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
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoFieldSelectors #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Ui
( Ui (Ui),
lit,
fill,
sens,
initUi,
pollUi,
Env (..),
Ui',
layOutUi,
renderUi,
renderUi',
)
where
import Control.Concurrent.STM
import Control.Monad.Identity
import Control.Monad.Reader
import Control.Monad.State (evalStateT, get, modify)
import Data.Default
import Data.Dynamic
import Data.Map qualified as M
import Data.Maybe
import GHC.Generics (Generic)
import Graphics.X11 qualified as X
import Graphics.X11.Xft qualified as X
import Graphics.X11.Xrender qualified as X
import Pretty qualified as P
import Sensor hiding (io)
data Ui f a = Ui [Block f a]
instance Eq (Ui Identity P.Doc) where
Ui bs == Ui bs' = bs == bs'
data Block f a
= Lit P.Doc
| Fill
| forall o. (Typeable o) => Sens (o -> a) (f o)
instance Eq (Block Identity P.Doc) where
(Lit doc) == (Lit doc') = doc == doc'
Fill == Fill = True
Sens toOut (Identity x) == Sens toOut' (Identity x') = toOut x == toOut' x'
_ == _ = False
lit :: (P.Pretty a) => a -> Block f P.Doc
lit = Lit . P.pretty
fill :: Block f a
fill = Fill
sens :: (P.Pretty o, Typeable o) => f o -> Block f P.Doc
sens = Sens P.pretty
initUi ::
Ui Sensor P.Doc ->
SensorM (Ui TVar P.Doc)
initUi (Ui bs) = Ui <$> mapM go bs
where
go (Lit s) = pure (Lit s)
go Fill = pure Fill
go (Sens toOut s) = Sens toOut <$> poll s
pollUi ::
Ui TVar P.Doc ->
STM (Ui Identity P.Doc)
pollUi (Ui bs) = Ui <$> mapM go bs
where
go (Lit s) = pure (Lit s)
go Fill = pure Fill
go (Sens toOut vT) = Sens toOut . Identity <$> readTVar vT
layOutUi ::
Env ->
Ui Identity P.Doc ->
IO Ui'
layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
where
go (Lit doc) = go' doc
go (Sens toOut (runIdentity -> toOut -> doc)) = go' doc
go Fill =
[ C
{ rect = def,
fill = True,
color = Nothing,
string = ""
}
]
go' (P.Lit color string) =
[ C
{ rect = def,
fill = False,
..
}
]
go' (P.Col docs) =
concatMap go' docs
layOut :: Env -> Ui' -> IO Ui'
layOut env@Env {..} (Ui' cs) = do
cs' <- evalStateT (mapM pack cs) 0
let rwidth = wwidth - sum (map (.rect.width) cs')
pure (Ui' (expa rwidth cs'))
where
pack c = do
rect <- io (extents env c)
left <- get <* modify (+ rect.width)
pure c {rect = rect {left = left}}
expa rwidth (c@C {fill = True} : cs) =
do
c {rect = c.rect {width = c.rect.width + rwidth}}
: map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
expa rwidth (c : cs) = c : expa rwidth cs
expa _ [] = []
extents :: Env -> C -> IO Rect
extents Env {..} (C {..}) = do
glyphInfo <- X.xftTextExtents dpy fnt string
pure
( Rect
{ top = 0,
left = 0,
width = X.xglyphinfo_xOff glyphInfo,
height = X.xglyphinfo_height glyphInfo
}
)
data Env = Env
{ dpy :: X.Display,
pixm :: X.Pixmap,
gc :: X.GC,
wwidth :: Int,
wheight :: Int,
vis :: X.Visual,
cmap :: X.Colormap,
fnt :: X.XftFont,
drw :: X.XftDraw
}
type Colors = M.Map (P.Intensity, P.Color) X.XftColor
renderUi :: Env -> Colors -> Ui' -> IO ()
renderUi Env {..} colors (Ui' cs) = do
let bg = colors M.! (P.Dull, P.Black)
X.xftDrawRect drw bg 0 0 wwidth wheight
let h = maximum (map (.rect.height) cs)
mapM_ (go h) cs
where
go h (C {..}) = do
let fg = colors M.! fromMaybe (P.Dull, P.White) color
liftIO (X.xftDrawString drw fg fnt rect.left h string)
renderUi' :: Env -> Colors -> Ui' -> Ui' -> IO ()
renderUi' env@Env {..} colors (Ui' cs') ui@(Ui' cs)
| length cs' /= length cs = renderUi env colors ui
| otherwise = do
let h = maximum (map (.rect.height) cs)
cs'' = catMaybes (zipWith (\c' c -> if c /= c' then Just c else Nothing) cs' cs)
mapM_ (go h) cs''
where
go h (C {..}) = io do
let bg = colors M.! (P.Dull, P.Black)
let fg = colors M.! (fromMaybe (P.Dull, P.White) color)
X.xftDrawRect drw bg rect.left 0 rect.width wheight
X.xftDrawString drw fg fnt rect.left h string
data Ui' = Ui' [C] deriving (Show)
data C = C
{ rect :: Rect,
fill :: Bool,
color :: Maybe (P.Intensity, P.Color),
string :: String
}
deriving (Show, Eq)
data Rect = Rect
{ top :: Int,
left :: Int,
width :: Int,
height :: Int
}
deriving (Generic, Default, Show, Eq)
io :: (MonadIO m) => IO a -> m a
io = liftIO
|
