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
|
{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
module Phi.Widget ( Display
, Widget(..)
, WidgetClass(..)
, WidgetState(..)
, separator
, createWidgetState
, layoutWidgets
, renderWidgets
, handleMessageWidgets
) where
import Control.Concurrent
import Control.Monad
import Data.Traversable
import qualified Graphics.X11.Xlib
import Graphics.Rendering.Cairo
import Phi.Phi
type Display = MVar Graphics.X11.Xlib.Display
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
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
|