180 lines
6.2 KiB
Haskell
180 lines
6.2 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
|
|
|
|
module Phi.Widget ( Display(..)
|
|
, withDisplay
|
|
, getAtoms
|
|
, getScreenWindows
|
|
, getScreens
|
|
, unionArea
|
|
, SurfaceSlice(..)
|
|
, Widget(..)
|
|
, CompoundWidget
|
|
, (<~>)
|
|
, IOCache
|
|
, RenderCache
|
|
, createIOCache
|
|
, createRenderCache
|
|
, renderCached
|
|
, Separator
|
|
, separator
|
|
) where
|
|
|
|
import Control.Arrow
|
|
import Control.Arrow.Transformer
|
|
import Control.CacheArrow
|
|
import Control.Concurrent.MVar
|
|
import Control.Monad
|
|
import Control.Monad.State.Strict hiding (lift)
|
|
import Control.Monad.IO.Class
|
|
|
|
import Data.Maybe
|
|
|
|
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 w, Eq w, Eq s) => Widget w s c | w -> s, w -> c where
|
|
initWidget :: w -> Phi -> Display -> IO s
|
|
|
|
initCache :: w -> c
|
|
|
|
minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
|
|
|
|
weight :: w -> Float
|
|
weight _ = 0
|
|
|
|
layout :: w -> s -> Int -> Int -> Xlib.Rectangle -> s
|
|
layout _ priv _ _ _ = priv
|
|
|
|
render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
|
|
|
|
handleMessage :: w -> s -> Message -> s
|
|
handleMessage _ priv _ = priv
|
|
|
|
type IOCache = CacheArrow (Kleisli IO)
|
|
type RenderCache w s = IOCache (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
|
|
|
|
createIOCache :: Eq a => (a -> IO b) -> IOCache a b
|
|
createIOCache = lift . Kleisli
|
|
|
|
createRenderCache :: (w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
|
|
-> CacheArrow (Kleisli IO) (w, s, Int, Int, Int, Int, Xlib.Rectangle) Surface
|
|
createRenderCache f = lift . Kleisli $ \(widget, state, x, y, w, h, screen) -> do
|
|
surface <- createImageSurface FormatARGB32 w h
|
|
renderWith surface $ do
|
|
setOperator OperatorClear
|
|
paint
|
|
setOperator OperatorOver
|
|
f widget state x y w h screen
|
|
return surface
|
|
|
|
renderCached :: (Eq w, Eq s) => w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT (RenderCache w s) IO [(Bool, SurfaceSlice)]
|
|
renderCached widget state x y w h screen = do
|
|
cache <- get
|
|
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (widget, state, x, y, w, h, screen)
|
|
put cache'
|
|
return [(updated, SurfaceSlice 0 surf)]
|
|
|
|
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)
|
|
|
|
initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b)
|
|
|
|
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
|
|
CompoundCache ca cb <- get
|
|
(surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen
|
|
(surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen
|
|
put $ CompoundCache ca' cb'
|
|
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 () (RenderCache Separator ()) where
|
|
initWidget _ _ _ = return ()
|
|
initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do
|
|
setOperator OperatorClear
|
|
paint
|
|
|
|
minSize (Separator s _) _ _ _ = s
|
|
weight (Separator _ w) = w
|
|
render = renderCached
|
|
|
|
|
|
separator :: Int -> Float -> Separator
|
|
separator = Separator
|