summaryrefslogtreecommitdiffstats
path: root/lib/Phi/Widget.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi/Widget.hs')
-rw-r--r--lib/Phi/Widget.hs86
1 files changed, 36 insertions, 50 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-26 14:47:30 +0200