From 4d519acbd48fa400f09e4705251a0dbf45c6876e Mon Sep 17 00:00:00 2001 From: Matthias Schiffer Date: Thu, 8 Sep 2011 19:15:23 +0200 Subject: Core is independent of X11 now --- lib/Phi/Widget.hs | 86 +++++++++++++++++++++++-------------------------------- 1 file changed, 36 insertions(+), 50 deletions(-) (limited to 'lib/Phi/Widget.hs') diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index a598887..3687630 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,10 +1,7 @@ -{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-} -module Phi.Widget ( XEvent(..) +module Phi.Widget ( Rectangle(..) , Display(..) - , withDisplay - , getAtoms - , XMessage(..) , unionArea , SurfaceSlice(..) , Widget(..) @@ -23,7 +20,6 @@ module Phi.Widget ( XEvent(..) 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 @@ -31,67 +27,57 @@ import Control.Monad.IO.Class import Data.Maybe import Data.Typeable -import Graphics.XHB import Graphics.Rendering.Cairo import Phi.Phi import Phi.X11.Atoms -data Display = Display !Connection !Atoms +data Rectangle = Rectangle { rect_x :: !Int + , rect_y :: !Int + , rect_width :: !Int + , rect_height :: !Int + } deriving (Show, Eq) -newtype XEvent = XEvent SomeEvent deriving Typeable +class Display d where + type Window d :: * -instance Show XEvent where - show _ = "XEvent (..)" - -withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a -withDisplay (Display conn _) f = f conn - -getAtoms :: Display -> Atoms -getAtoms (Display _ atoms) = atoms - -data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable) - - -unionArea :: RECTANGLE -> RECTANGLE -> Int +unionArea :: Rectangle -> Rectangle -> Int unionArea a b = uw*uh where - uw = max 0 $ (min ax2 bx2) - fromIntegral (max ax1 bx1) - uh = max 0 $ (min ay2 by2) - fromIntegral (max ay1 by1) + uw = max 0 $ (min ax2 bx2) - (max ax1 bx1) + uh = max 0 $ (min ay2 by2) - (max ay1 by1) - MkRECTANGLE ax1 ay1 aw ah = a - MkRECTANGLE bx1 by1 bw bh = b + Rectangle ax1 ay1 aw ah = a + Rectangle bx1 by1 bw bh = b - ax2 = fromIntegral ax1 + fromIntegral aw - ay2 = fromIntegral ay1 + fromIntegral ah + ax2 = ax1 + aw + ay2 = ay1 + ah - bx2 = fromIntegral bx1 + fromIntegral bw - by2 = fromIntegral by1 + fromIntegral bh + bx2 = bx1 + bw + by2 = by1 + bh data SurfaceSlice = SurfaceSlice !Int !Surface -class Eq s => Widget w s c | w -> s, w -> c where - initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s +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 + minSize :: w -> s -> Int -> Rectangle -> Int weight :: w -> Float weight _ = 0 - render :: w -> s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT c IO [(Bool, SurfaceSlice)] + render :: w -> s -> Int -> Int -> Int -> Int -> Rectangle -> StateT c IO [(Bool, SurfaceSlice)] handleMessage :: w -> s -> Message -> s handleMessage _ priv _ = priv -deriving instance Eq RECTANGLE - type IOCache = CacheArrow (Kleisli IO) -type RenderCache s = IOCache (s, Int, Int, Int, Int, RECTANGLE) Surface +type RenderCache s = IOCache (s, Int, Int, Int, Int, Rectangle) Surface createIOCache :: Eq a => (a -> IO b) -> IOCache a b createIOCache = lift . Kleisli @@ -103,8 +89,8 @@ runIOCache a = do put cache' return b -createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ()) - -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface +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 @@ -114,22 +100,22 @@ createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do 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 :: 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 = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b +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 = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb -deriving instance Eq (CompoundState a sa ca b sb cb) +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 = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb +data CompoundCache a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => 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 +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) @@ -154,15 +140,15 @@ instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) handleMessage (CompoundWidget a b) (CompoundState sa sb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) -weight' :: (Widget a sa ca) => a -> Float +weight' :: (Widget a sa ca d) => a -> Float weight' = max 0 . weight -(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb +(<~>) :: (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 = Separator !Int !Float deriving (Show, Eq) +data Separator d = Separator !Int !Float deriving (Show, Eq) -instance Widget Separator () (RenderCache ()) where +instance Display d => Widget (Separator d) () (RenderCache ()) d where initWidget _ _ _ _ = return () initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do setOperator OperatorClear @@ -173,5 +159,5 @@ instance Widget Separator () (RenderCache ()) where render _ = renderCached -separator :: Int -> Float -> Separator +separator :: Int -> Float -> Separator d separator = Separator -- cgit v1.2.3