154 lines
5.1 KiB
Haskell
154 lines
5.1 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-}
|
|
|
|
module Phi.Widget ( Display(..)
|
|
, withDisplay
|
|
, getAtoms
|
|
, getScreenWindows
|
|
, getScreens
|
|
, unionArea
|
|
, SurfaceSlice(..)
|
|
, Widget(..)
|
|
, CompoundWidget
|
|
, (<~>)
|
|
, Separator
|
|
, separator
|
|
) where
|
|
|
|
import Control.Arrow
|
|
import Control.Arrow.Transformer
|
|
import Control.CacheArrow
|
|
import Control.Concurrent.MVar
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class
|
|
|
|
import qualified Graphics.X11.Xlib as Xlib
|
|
import Graphics.Rendering.Cairo
|
|
|
|
import Phi.Phi
|
|
import Phi.X11.Atoms
|
|
|
|
|
|
data Display = Display !(MVar Xlib.Display) !Atoms ![(Xlib.Rectangle, Xlib.Window)]
|
|
|
|
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
|
|
withDisplay (Display dispvar _ _) f = do
|
|
disp <- liftIO $ takeMVar dispvar
|
|
a <- f disp
|
|
liftIO $ putMVar dispvar disp
|
|
return a
|
|
|
|
getAtoms :: Display -> Atoms
|
|
getAtoms (Display _ atoms _) = atoms
|
|
|
|
getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)]
|
|
getScreenWindows (Display _ _ screenWindows) = screenWindows
|
|
|
|
getScreens :: Display -> [Xlib.Rectangle]
|
|
getScreens = map fst . getScreenWindows
|
|
|
|
|
|
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
|
|
unionArea a b = fromIntegral $ uw*uh
|
|
where
|
|
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
|
|
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
|
|
|
|
Xlib.Rectangle ax1 ay1 aw ah = a
|
|
Xlib.Rectangle bx1 by1 bw bh = b
|
|
|
|
ax2 = ax1 + fromIntegral aw
|
|
ay2 = ay1 + fromIntegral ah
|
|
|
|
bx2 = bx1 + fromIntegral bw
|
|
by2 = by1 + fromIntegral bh
|
|
|
|
|
|
data SurfaceSlice = SurfaceSlice !Int !Surface
|
|
|
|
class (Show a, Eq a, Eq s) => Widget a s c | a -> s, a -> c where
|
|
initWidget :: a -> Phi -> Display -> IO s
|
|
|
|
minSize :: a -> s -> Int -> Xlib.Rectangle -> Int
|
|
|
|
weight :: a -> Float
|
|
weight _ = 0
|
|
|
|
layout :: a -> s -> Int -> Int -> Xlib.Rectangle -> s
|
|
layout _ priv _ _ _ = priv
|
|
|
|
render :: a -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> IO [(Bool, SurfaceSlice)]
|
|
|
|
handleMessage :: a -> s -> Message -> s
|
|
handleMessage _ priv _ = priv
|
|
|
|
{-createStateRender :: Widget a d => CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface
|
|
createStateRender = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
|
|
surface <- createImageSurface FormatARGB32 w h
|
|
renderWith surface $ do
|
|
setOperator OperatorClear
|
|
paint
|
|
setOperator OperatorOver
|
|
render widget state x y w h screen
|
|
return surface-}
|
|
|
|
data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
|
|
deriving instance Eq (CompoundWidget a sa ca b sb cb)
|
|
deriving instance Show (CompoundWidget a sa ca b sb cb)
|
|
|
|
data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int
|
|
deriving instance Eq (CompoundState a sa ca b sb cb)
|
|
|
|
data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb
|
|
|
|
|
|
instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
|
|
initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0)
|
|
|
|
minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen
|
|
|
|
weight (CompoundWidget a b) = weight' a + weight' b
|
|
|
|
layout c@(CompoundWidget a b) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb
|
|
where
|
|
sizesum = minSize c s height screen
|
|
wsum = let wsum = weight c
|
|
in if wsum > 0 then wsum else 1
|
|
|
|
surplus = width - sizesum
|
|
|
|
(xb, sa') = layoutWidget a sa
|
|
(_, sb') = layoutWidget b sb
|
|
|
|
layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum
|
|
in (wWidth, layout w s wWidth height screen)
|
|
|
|
render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do
|
|
surfacea <- render a sa x y xb h screen
|
|
surfaceb <- render b sb (x+xb) y (w-xb) h screen
|
|
return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb
|
|
|
|
handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb
|
|
|
|
weight' :: (Widget a sa ca) => a -> Float
|
|
weight' = max 0 . weight
|
|
|
|
(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb
|
|
a <~> b = CompoundWidget a b
|
|
|
|
data Separator = Separator !Int !Float deriving (Show, Eq)
|
|
|
|
instance Widget Separator () () where
|
|
initWidget _ _ _ = return ()
|
|
|
|
minSize (Separator s _) _ _ _ = s
|
|
weight (Separator _ w) = w
|
|
render _ _ _ _ width height _ = do
|
|
surface <- createImageSurface FormatARGB32 width height
|
|
renderWith surface $ do
|
|
setOperator OperatorClear
|
|
paint
|
|
return [(True, SurfaceSlice 0 surface)]
|
|
|
|
|
|
separator :: Int -> Float -> Separator
|
|
separator = Separator
|