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
201
202
203
204
205
206
|
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiWayIf #-}
{-# 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),
Block,
Flex (..),
lit,
fill,
litShrink,
pollUi,
Env (..),
Ui',
layOutUi,
renderUi,
renderUi',
)
where
import Control.DeepSeq
import Control.Monad.Reader
import Control.Monad.State (evalStateT, get, modify)
import Data.Default
import Data.Map qualified as M
import Data.Maybe
import Data.Sensor qualified as S
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
data Ui a = Ui [a]
deriving
( Eq,
Functor,
Foldable,
Traversable,
Show,
Generic,
NFData
)
data Block a
= Lit Flex a
deriving (Eq, Functor, Show, Generic, NFData)
data Flex = Flex
{ canGrow :: Bool,
canShrink :: Bool
}
deriving (Eq, Show, Generic, NFData)
lit :: (P.Pretty a) => a -> Block P.Doc
lit = Lit (Flex False False) . P.pretty
litShrink :: (P.Pretty a) => a -> Block P.Doc
litShrink = Lit (Flex False True) . P.pretty
fill :: Block P.Doc
fill = Lit (Flex True False) (P.pretty "")
pollUi :: Ui (S.Sensor () (Block P.Doc)) -> S.Sensor () (Ui (Block P.Doc))
pollUi (Ui sfs) = Ui <$> S.concatS sfs
layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui'
layOutUi env (Ui bs) = shrinkText env =<< layOut env (Ui' (concatMap go bs))
where
go (Lit flex (P.Lit color string)) =
[ C
{ rect = def,
..
}
]
go (Lit flex (P.Col docs)) =
-- TODO bug `P.Col` needs container support in `C`
concatMap (go . Lit flex) 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 _ [] = []
expa 0 cs = cs
expa rwidth (c@C {flex = Flex False False} : cs) = c : expa rwidth cs
expa rwidth (c@C {flex = Flex {..}} : cs) =
if
| rwidth > 0 && canGrow ->
c {rect = c.rect {width = c.rect.width + rwidth}}
: map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
| rwidth < 0 && canShrink ->
c {rect = c.rect {width = c.rect.width + rwidth}}
: map (\c -> c {rect = c.rect {left = c.rect.left + rwidth}}) cs
| otherwise -> c : expa rwidth cs
shrinkText :: Env -> Ui' -> IO Ui'
shrinkText Env {..} (Ui' cs) = Ui' <$> mapM go cs
where
go C {..} = do
string' <- fit rect.width string
pure C {string = string', ..}
fit _ "" = pure ""
fit rwidth string = do
glyphInfo <- X.xftTextExtents dpy fnt string
let width = X.xglyphinfo_xOff glyphInfo
if width <= rwidth
then pure string
else fit' rwidth (init string)
fit' _ "" = pure ""
fit' rwidth string = do
glyphInfo <- X.xftTextExtents dpy fnt (string ++ "…")
let width = X.xglyphinfo_xOff glyphInfo
if width <= rwidth
then pure (string ++ "…")
else fit' rwidth (init string)
extents :: Env -> C -> IO Rect
extents Env {..} (C {..}) = do
glyphInfo <- X.xftTextExtents dpy fnt string
ascent <- X.xftfont_ascent fnt
pure
( Rect
{ top = X.xglyphinfo_y glyphInfo,
left = X.xglyphinfo_x glyphInfo,
width = X.xglyphinfo_xOff glyphInfo,
height = ascent
}
)
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, Generic, NFData)
data C = C
{ rect :: Rect,
flex :: Flex,
color :: Maybe (P.Intensity, P.Color),
string :: String
}
deriving (Show, Eq, Generic, NFData)
data Rect = Rect
{ top :: Int,
left :: Int,
width :: Int,
height :: Int
}
deriving (Generic, Default, Show, Eq, NFData)
io :: (MonadIO m) => IO a -> m a
io = liftIO
|
