diff options
Diffstat (limited to 'lib/Phi/Widget.hs')
| -rw-r--r-- | lib/Phi/Widget.hs | 86 |
1 files changed, 52 insertions, 34 deletions
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 48c0b6c..e4a1e6a 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, FlexibleContexts, MultiParamTypeClasses, FunctionalDependencies #-} module Phi.Widget ( Display(..) , withDisplay @@ -16,11 +16,14 @@ module Phi.Widget ( Display(..) , handleMessageWidgets ) where +import Control.Arrow +import Control.Arrow.Transformer +import Control.CacheArrow import Control.Concurrent.MVar import Control.Monad import Control.Monad.IO.Class -import Data.Traversable +import Data.Traversable hiding (forM) import qualified Graphics.X11.Xlib as Xlib import Graphics.Rendering.Cairo @@ -64,35 +67,50 @@ unionArea a b = fromIntegral $ uw*uh by2 = by1 + fromIntegral bh -class Show a => WidgetClass a where - type WidgetData a :: * +class (Show a, Eq a, Eq d) => WidgetClass a d | a -> d where + initWidget :: a -> Phi -> Display -> IO d - initWidget :: a -> Phi -> Display -> IO (WidgetData a) - - minSize :: a -> WidgetData a -> Int -> Xlib.Rectangle -> Int + minSize :: a -> d -> Int -> Xlib.Rectangle -> Int weight :: a -> Float weight _ = 0 - layout :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> WidgetData a + layout :: a -> d -> Int -> Int -> Xlib.Rectangle -> d layout _ priv _ _ _ = priv - render :: a -> WidgetData a -> Int -> Int -> Xlib.Rectangle -> Render () + render :: a -> d -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render () - handleMessage :: a -> WidgetData a -> Message -> WidgetData a + handleMessage :: a -> d -> Message -> d handleMessage _ priv _ = priv -data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => Widget !a +data Widget = forall a d. WidgetClass a d => Widget !a deriving instance Show Widget -data WidgetState = forall a. (WidgetClass a, Show (WidgetData a)) => WidgetState { stateWidget :: !a - , stateX :: !Int - , stateY :: !Int - , stateWidth :: !Int - , stateHeight :: !Int - , statePrivateData :: !(WidgetData a) - } -deriving instance Show WidgetState +instance Eq Widget where + _ == _ = False + +data WidgetState = forall a d. WidgetClass a d => + WidgetState { stateWidget :: !a + , stateX :: !Int + , stateY :: !Int + , stateWidth :: !Int + , stateHeight :: !Int + , statePrivateData :: !d + , stateRender :: !(CacheArrow (Kleisli IO) (a, d, Int, Int, Int, Int, Xlib.Rectangle) Surface) + } + +instance Eq WidgetState where + _ == _ = False + +createStateRender :: WidgetClass 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 createWidgetState :: Phi -> Display -> Widget -> IO WidgetState createWidgetState phi disp (Widget w) = do @@ -103,6 +121,7 @@ createWidgetState phi disp (Widget w) = do , stateWidth = 0 , stateHeight = 0 , statePrivateData = priv + , stateRender = createStateRender } layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> [WidgetState] @@ -118,40 +137,39 @@ layoutWidgets widgets x y width height screen = snd $ mapAccumL layoutWidgetAndX in (wX + stateWidth lw, lw) layoutWidget wX state = case state of - WidgetState {stateWidget = w, statePrivateData = priv} -> + WidgetState {stateWidget = w, statePrivateData = priv, stateRender = render} -> let wWidth = floor $ (fromIntegral $ minSize w priv height screen) + (fromIntegral surplus)*(nneg $ weight w)/wsum priv' = layout w priv wWidth height screen - in WidgetState w wX y wWidth height priv' + in WidgetState w wX y wWidth height priv' render nneg :: (Num a, Ord a) => a -> a nneg x = max 0 x -renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Render () -renderWidgets widgets screen = forM_ widgets $ \WidgetState { stateWidget = widget - , stateX = x - , stateY = y - , stateWidth = w - , stateHeight = h - , statePrivateData = priv } -> do +renderWidgets :: [WidgetState] -> Xlib.Rectangle -> Int -> Int -> Render [WidgetState] +renderWidgets widgets screen winX winY = forM widgets $ \(WidgetState widget x y w h priv render) -> do + (surface, render') <- liftIO $ runKleisli (runCache render) (widget, priv, winX+x, winY+y, w, h, screen) + save translate (fromIntegral x) (fromIntegral y) - render widget priv w h screen + withPatternForSurface surface setSource + paint restore + + return $ WidgetState widget x y w h priv render' handleMessageWidgets :: Message -> [WidgetState] -> [WidgetState] handleMessageWidgets message = map handleMessageWidget where - handleMessageWidget (WidgetState w x y width height priv) = WidgetState w x y width height $ handleMessage w priv message + handleMessageWidget (WidgetState w x y width height priv render) = WidgetState w x y width height (handleMessage w priv message) render -data Separator = Separator Int Float deriving Show +data Separator = Separator Int Float deriving (Show, Eq) -instance WidgetClass Separator where - type WidgetData Separator = () +instance WidgetClass Separator () where initWidget _ _ _ = return () minSize (Separator s _) _ _ _ = s weight (Separator _ w) = w - render _ _ _ _ _ = return () + render _ _ _ _ _ _ _ = return () separator :: Int -> Float -> Widget separator s w = Widget $ Separator s w |