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
|
{-# 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),
Block,
lit,
fill,
pollUi,
Env (..),
Ui',
layOutUi,
renderUi,
renderUi',
)
where
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)
data Block a
= Lit a
| Fill
deriving (Eq, Functor, Show)
lit :: (P.Pretty a) => a -> Block P.Doc
lit = Lit . P.pretty
fill :: Block a
fill = Fill
pollUi ::
Ui (S.Sensor (S.SensorT IO) () (Block P.Doc)) ->
S.Sensor (S.SensorT IO) () (Ui (Block P.Doc))
pollUi = sequence
layOutUi :: Env -> Ui (Block P.Doc) -> IO Ui'
layOutUi env (Ui bs) = layOut env (Ui' (concatMap go bs))
where
go (Lit 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
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)
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
|
