163 lines
5.4 KiB
Haskell
163 lines
5.4 KiB
Haskell
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
|
|
|
|
module Phi.Widget ( Rectangle(..)
|
|
, Display(..)
|
|
, unionArea
|
|
, SurfaceSlice(..)
|
|
, Widget(..)
|
|
, CompoundWidget
|
|
, (<~>)
|
|
, IOCache
|
|
, RenderCache
|
|
, createIOCache
|
|
, runIOCache
|
|
, createRenderCache
|
|
, renderCached
|
|
, Separator
|
|
, separator
|
|
) where
|
|
|
|
import Control.Arrow
|
|
import Control.Arrow.Transformer
|
|
import Control.CacheArrow
|
|
import Control.Monad
|
|
import Control.Monad.State.Strict hiding (lift)
|
|
import Control.Monad.IO.Class
|
|
|
|
import Data.Maybe
|
|
import Data.Typeable
|
|
|
|
import Graphics.Rendering.Cairo
|
|
|
|
import Phi.Phi
|
|
import Phi.X11.Atoms
|
|
|
|
|
|
data Rectangle = Rectangle { rect_x :: !Int
|
|
, rect_y :: !Int
|
|
, rect_width :: !Int
|
|
, rect_height :: !Int
|
|
} deriving (Show, Eq)
|
|
|
|
class Display d where
|
|
type Window d :: *
|
|
|
|
|
|
unionArea :: Rectangle -> Rectangle -> Int
|
|
unionArea a b = uw*uh
|
|
where
|
|
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
|
|
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
|
|
|
|
Rectangle ax1 ay1 aw ah = a
|
|
Rectangle bx1 by1 bw bh = b
|
|
|
|
ax2 = ax1 + aw
|
|
ay2 = ay1 + ah
|
|
|
|
bx2 = bx1 + bw
|
|
by2 = by1 + bh
|
|
|
|
|
|
data SurfaceSlice = SurfaceSlice !Int !Surface
|
|
|
|
class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where
|
|
initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s
|
|
|
|
initCache :: w -> c
|
|
|
|
minSize :: w -> s -> Int -> Rectangle -> Int
|
|
|
|
weight :: w -> Float
|
|
weight _ = 0
|
|
|
|
render :: w -> s -> Int -> Int -> Int -> Int -> Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
|
|
|
|
handleMessage :: w -> s -> Message -> s
|
|
handleMessage _ priv _ = priv
|
|
|
|
type IOCache = CacheArrow (Kleisli IO)
|
|
type RenderCache s = IOCache (s, Int, Int, Int, Int, Rectangle) Surface
|
|
|
|
createIOCache :: Eq a => (a -> IO b) -> IOCache a b
|
|
createIOCache = lift . Kleisli
|
|
|
|
runIOCache :: Eq a => a -> StateT (IOCache a b) IO b
|
|
runIOCache a = do
|
|
cache <- get
|
|
(b, cache') <- liftIO $ runKleisli (runCache cache) a
|
|
put cache'
|
|
return b
|
|
|
|
createRenderCache :: (s -> Int -> Int -> Int -> Int -> Rectangle -> Render ())
|
|
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Rectangle) Surface
|
|
createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
|
|
surface <- createImageSurface FormatARGB32 w h
|
|
renderWith surface $ do
|
|
setOperator OperatorClear
|
|
paint
|
|
setOperator OperatorOver
|
|
f state x y w h screen
|
|
return surface
|
|
|
|
renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> Rectangle -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)]
|
|
renderCached state x y w h screen = do
|
|
cache <- get
|
|
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen)
|
|
put cache'
|
|
return [(updated, SurfaceSlice 0 surf)]
|
|
|
|
data CompoundWidget a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundWidget !a !b
|
|
|
|
data CompoundState a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundState !sa !sb
|
|
deriving instance Eq (CompoundState a sa ca b sb cb d)
|
|
|
|
data CompoundCache a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundCache !ca !cb
|
|
|
|
|
|
instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a sa ca b sb cb d) (CompoundCache a sa ca b sb cb d) d where
|
|
initWidget (CompoundWidget a b) phi disp screens = liftM2 CompoundState (initWidget a phi disp screens) (initWidget b phi disp screens)
|
|
|
|
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
|
|
|
|
render c@(CompoundWidget a b) s@(CompoundState sa sb) x y w h screen = do
|
|
let sizesum = minSize c s h screen
|
|
wsum = let wsum = weight c
|
|
in if wsum > 0 then wsum else 1
|
|
surplus = w - sizesum
|
|
xb = floor $ (fromIntegral $ minSize a sa h screen) + (fromIntegral surplus)*(weight' a)/wsum
|
|
|
|
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) message = CompoundState (handleMessage a sa message) (handleMessage b sb message)
|
|
|
|
weight' :: (Widget a sa ca d) => a -> Float
|
|
weight' = max 0 . weight
|
|
|
|
(<~>) :: (Widget a sa ca d, Widget b sb cb d) => a -> b -> CompoundWidget a sa ca b sb cb d
|
|
a <~> b = CompoundWidget a b
|
|
|
|
data Separator d = Separator !Int !Float deriving (Show, Eq)
|
|
|
|
instance Display d => Widget (Separator d) () (RenderCache ()) d where
|
|
initWidget _ _ _ _ = return ()
|
|
initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do
|
|
setOperator OperatorClear
|
|
paint
|
|
|
|
minSize (Separator s _) _ _ _ = s
|
|
weight (Separator _ w) = w
|
|
render _ = renderCached
|
|
|
|
|
|
separator :: Int -> Float -> Separator d
|
|
separator = Separator
|