1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widget ( XEvent(..)
, Display(..)
, withDisplay
, getAtoms
, XMessage(..)
, 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.Concurrent.MVar
import Control.Monad
import Control.Monad.State.Strict hiding (lift)
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
import Debug.Trace
data Display = Display !Connection !Atoms
newtype XEvent = XEvent SomeEvent deriving Typeable
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 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)
MkRECTANGLE ax1 ay1 aw ah = a
MkRECTANGLE bx1 by1 bw bh = b
ax2 = fromIntegral ax1 + fromIntegral aw
ay2 = fromIntegral ay1 + fromIntegral ah
bx2 = fromIntegral bx1 + fromIntegral bw
by2 = fromIntegral by1 + fromIntegral 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
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
deriving instance Eq RECTANGLE
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 = (Widget a sa ca, Widget b sb cb) => 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 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 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) => 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 ()) 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
|
