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
|
{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
module Phi.Widget ( Display(..)
, withDisplay
, getAtoms
, Widget(..)
, WidgetClass(..)
, WidgetState(..)
, separator
, createWidgetState
, layoutWidgets
, renderWidgets
, handleMessageWidgets
) where
import Control.Concurrent.MVar
import Control.Monad
import Control.Monad.IO.Class
import Data.Traversable
import qualified Graphics.X11.Xlib
import Graphics.Rendering.Cairo
import Phi.Phi
import Phi.X11.Atoms
data Display = Display (MVar Graphics.X11.Xlib.Display) Atoms
withDisplay :: MonadIO m => Display -> (Graphics.X11.Xlib.Display -> m a) -> m a
withDisplay (Display dispvar _) f = do
disp <- liftIO $ takeMVar dispvar
a <- f disp
liftIO $ putMVar dispvar disp
return a
getAtoms :: Display -> Atoms
getAtoms (Display _ atoms) = atoms
class Show a => WidgetClass a where
type WidgetData a :: *
initWidget :: a -> Phi -> Display -> IO (WidgetData a)
minSize :: a -> Int
weight :: a -> Float
weight _ = 0
layout :: a -> WidgetData a -> Int -> Int -> WidgetData a
layout _ priv _ _ = priv
render :: a -> WidgetData a -> Int -> Int -> Render ()
handleMessage :: a -> WidgetData a -> Message -> WidgetData a
handleMessage _ priv _ = priv
data Widget = forall a. (WidgetClass a, Show (WidgetData a)) => 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
createWidgetState :: Phi -> Display -> Widget -> IO WidgetState
createWidgetState phi disp (Widget w) = do
phi' <- dupPhi phi
priv <- initWidget w phi' disp
return WidgetState { stateWidget = w
, stateX = 0
, stateY = 0
, stateWidth = 0
, stateHeight = 0
, statePrivateData = priv
}
layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> [WidgetState]
layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets
where
sizesum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . minSize $ w) widgets
wsum = let wsum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . weight $ w) widgets
in if wsum > 0 then wsum else 1
surplus = width - sizesum
layoutWidgetAndX wX state = let lw = layoutWidget wX state
in (wX + stateWidth lw, lw)
layoutWidget wX state = case state of
WidgetState {stateWidget = w, statePrivateData = priv} ->
let wWidth = floor $ (fromIntegral $ minSize w) + (fromIntegral surplus)*(nneg $ weight w)/wsum
priv' = layout w priv wWidth height
in WidgetState w wX y wWidth height priv'
nneg :: (Num a, Ord a) => a -> a
nneg x = max 0 x
renderWidgets :: [WidgetState] -> Render ()
renderWidgets widgets = forM_ widgets $ \WidgetState { stateWidget = widget
, stateX = x
, stateY = y
, stateWidth = w
, stateHeight = h
, statePrivateData = priv } -> do
save
translate (fromIntegral x) (fromIntegral y)
render widget priv w h
restore
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
data Separator = Separator Int Float deriving Show
instance WidgetClass Separator where
type WidgetData Separator = ()
initWidget _ _ _ = return ()
minSize (Separator s _) = s
weight (Separator _ w) = w
render _ _ _ _ = return ()
separator :: Int -> Float -> Widget
separator s w = Widget $ Separator s w
|
