char-boxdrawing-1: src/Data/Char/BoxDrawing.hs
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Data.Char.BoxDrawing (
-- * Box border type
Drawing,
render,
lookup,
read,
overlay,
-- ** Box drawing styles
BoxDrawingStyle,
ascii,
unicode,
-- * Drawings
-- ** Base primitives
-- $primitives
up,
down,
left,
right,
-- ** Combinations
-- $combinations
horizontal,
vertical,
cornerTL,
cornerTR,
cornerBR,
cornerBL,
intersectFull,
intersectL,
intersectR,
intersectT,
intersectB,
-- ** Box drawing modifiers
-- $modifiers
heavy,
heavyHoriz,
heavyVert,
dashed2,
dashed3,
double,
doubleHoriz,
doubleVert,
rounded,
) where
import Data.Bits
import Data.Coerce
import Data.Maybe (fromMaybe)
import Data.Word (Word8)
import Text.Printf (printf)
import Prelude hiding (lookup, read)
--------------------------------------------------------------------------------
--
-- $primitives
--
-- Use the 'Semigroup' instance to combine box 'Drawing'.
up, left, right, down, cornerTL, cornerTR, cornerBR, cornerBL, horizontal, vertical, intersectL, intersectR, intersectT, intersectB, intersectFull :: Drawing
up = bb BUp
left = bb BLeft
right = bb BRight
down = bb BDown
-- $combinations
--
-- These are pre-made combinations of 'up', 'down', 'left', and 'right'.
cornerTL = bb BDown <> bb BRight
cornerTR = bb BDown <> bb BLeft
cornerBR = bb BUp <> bb BLeft
cornerBL = bb BUp <> bb BRight
horizontal = bb BLeft <> bb BRight
vertical = bb BUp <> bb BDown
intersectL = vertical <> right
intersectR = vertical <> left
intersectT = horizontal <> down
intersectB = horizontal <> up
intersectFull = horizontal <> vertical
-- $modifiers
--
-- Combine these using the 'Semigroup' instance with another 'Drawing' to set
-- its style, such as heavy, dashed, etc. - only relevant for the style
-- 'unicode' and has no effect for the style 'ascii'.
double, doubleHoriz, doubleVert, heavy, dashed2, dashed3, dashed4, rounded, heavyHoriz, heavyVert :: Drawing
double = style1 Double
doubleHoriz = style1 DoubleHoriz
doubleVert = style1 DoubleVert
heavy = style1 Heavy
heavyHoriz = style1 HeavyHoriz
heavyVert = style1 HeavyVert
dashed2 = style1 Dashed2
dashed3 = style1 Dashed3
dashed4 = style1 Dashed4
rounded = style1 Rounded
bb :: Drawing1 -> Drawing
bb = boxBorderBits
--------------------------------------------------------------------------------
-- | A border style such as ASCII or unicode. Describes how to turn a
-- 'Drawing' into an actual character for rendering, or to lookup a character
-- from a buffer into a 'Drawing' for combining different border characters
data BoxDrawingStyle = BoxDrawingStyle
{ render :: Drawing -> Char
-- ^ Render a 'Drawing' given the style
, lookup :: Char -> Maybe Drawing
-- ^ Lookup a character given the style
}
--------------------------------------------------------------------------------
-- Generated code by using TH and then copy-pasting it back with -ddump-splices
--
-- Hopefully, there are no bugs in this ever :)
--
-- | A basic box-drawing style that uses @|@, @+@, and @-@
ascii :: BoxDrawingStyle
ascii =
( \(run :: Word8 -> Char)
(runBack :: Char -> Maybe Word8) ->
BoxDrawingStyle (coerce run) (coerce runBack)
)
( \case
3 -> '|'
5 -> '+'
6 -> '+'
7 -> '+'
9 -> '+'
10 -> '+'
11 -> '+'
12 -> '-'
13 -> '+'
14 -> '+'
15 -> '+'
19 -> '|'
21 -> '+'
22 -> '+'
23 -> '+'
25 -> '+'
26 -> '+'
27 -> '+'
28 -> '-'
29 -> '+'
30 -> '+'
31 -> '+'
35 -> '|'
37 -> '+'
38 -> '+'
39 -> '+'
41 -> '+'
42 -> '+'
43 -> '+'
44 -> '-'
45 -> '+'
46 -> '+'
47 -> '+'
51 -> '|'
53 -> '+'
54 -> '+'
55 -> '+'
57 -> '+'
58 -> '+'
59 -> '+'
60 -> '-'
61 -> '+'
62 -> '+'
63 -> '+'
67 -> '|'
69 -> '+'
70 -> '+'
71 -> '+'
73 -> '+'
74 -> '+'
75 -> '+'
76 -> '-'
77 -> '+'
78 -> '+'
79 -> '+'
83 -> '|'
85 -> '+'
86 -> '+'
87 -> '+'
89 -> '+'
90 -> '+'
91 -> '+'
92 -> '-'
93 -> '+'
94 -> '+'
95 -> '+'
99 -> '|'
101 -> '+'
102 -> '+'
103 -> '+'
105 -> '+'
106 -> '+'
107 -> '+'
108 -> '-'
109 -> '+'
110 -> '+'
111 -> '+'
115 -> '|'
117 -> '+'
118 -> '+'
119 -> '+'
121 -> '+'
122 -> '+'
123 -> '+'
124 -> '-'
125 -> '+'
126 -> '+'
127 -> '+'
131 -> '|'
133 -> '+'
134 -> '+'
135 -> '+'
137 -> '+'
138 -> '+'
139 -> '+'
140 -> '-'
141 -> '+'
142 -> '+'
143 -> '+'
147 -> '|'
149 -> '+'
150 -> '+'
151 -> '+'
153 -> '+'
154 -> '+'
155 -> '+'
156 -> '-'
157 -> '+'
158 -> '+'
159 -> '+'
163 -> '|'
165 -> '+'
166 -> '+'
167 -> '+'
169 -> '+'
170 -> '+'
171 -> '+'
172 -> '-'
173 -> '+'
174 -> '+'
175 -> '+'
179 -> '|'
181 -> '+'
182 -> '+'
183 -> '+'
185 -> '+'
186 -> '+'
187 -> '+'
188 -> '-'
189 -> '+'
190 -> '+'
191 -> '+'
195 -> '|'
197 -> '+'
198 -> '+'
199 -> '+'
201 -> '+'
202 -> '+'
203 -> '+'
204 -> '-'
205 -> '+'
206 -> '+'
207 -> '+'
211 -> '|'
213 -> '+'
214 -> '+'
215 -> '+'
217 -> '+'
218 -> '+'
219 -> '+'
220 -> '-'
221 -> '+'
222 -> '+'
223 -> '+'
227 -> '|'
229 -> '+'
230 -> '+'
231 -> '+'
233 -> '+'
234 -> '+'
235 -> '+'
236 -> '-'
237 -> '+'
238 -> '+'
239 -> '+'
243 -> '|'
245 -> '+'
246 -> '+'
247 -> '+'
249 -> '+'
250 -> '+'
251 -> '+'
252 -> '-'
253 -> '+'
254 -> '+'
255 -> '+'
_ -> ' '
)
( \case
'+' -> Just 255
'-' -> Just 252
'|' -> Just 243
_ -> Nothing
)
-- | An advanced box-drawing style that supports all the drawing primitives
-- provided in this module
unicode :: BoxDrawingStyle
unicode =
( \(run :: Word8 -> Char)
(runBack :: Char -> Maybe Word8) ->
BoxDrawingStyle (coerce run) (coerce runBack)
)
( \case
1 -> '\9589'
2 -> '\9591'
3 -> '\9474'
4 -> '\9588'
5 -> '\9496'
6 -> '\9488'
7 -> '\9508'
8 -> '\9590'
9 -> '\9492'
10 -> '\9484'
11 -> '\9500'
12 -> '\9472'
13 -> '\9524'
14 -> '\9516'
15 -> '\9532'
17 -> '\9589'
18 -> '\9591'
19 -> '\9474'
20 -> '\9588'
21 -> '\9583'
22 -> '\9582'
23 -> '\9508'
24 -> '\9590'
25 -> '\9584'
26 -> '\9581'
27 -> '\9500'
28 -> '\9472'
29 -> '\9524'
30 -> '\9516'
31 -> '\9532'
33 -> '\9589'
34 -> '\9591'
35 -> '\9550'
36 -> '\9588'
37 -> '\9496'
38 -> '\9488'
39 -> '\9508'
40 -> '\9590'
41 -> '\9492'
42 -> '\9484'
43 -> '\9500'
44 -> '\9548'
45 -> '\9524'
46 -> '\9516'
47 -> '\9532'
49 -> '\9589'
50 -> '\9591'
51 -> '\9474'
52 -> '\9588'
53 -> '\9496'
54 -> '\9488'
55 -> '\9508'
56 -> '\9590'
57 -> '\9492'
58 -> '\9484'
59 -> '\9500'
60 -> '\9472'
61 -> '\9524'
62 -> '\9516'
63 -> '\9532'
65 -> '\9589'
66 -> '\9591'
67 -> '\9478'
68 -> '\9588'
69 -> '\9496'
70 -> '\9488'
71 -> '\9508'
72 -> '\9590'
73 -> '\9492'
74 -> '\9484'
75 -> '\9500'
76 -> '\9476'
77 -> '\9524'
78 -> '\9516'
79 -> '\9532'
81 -> '\9589'
82 -> '\9591'
83 -> '\9474'
84 -> '\9588'
85 -> '\9496'
86 -> '\9488'
87 -> '\9508'
88 -> '\9590'
89 -> '\9492'
90 -> '\9484'
91 -> '\9500'
92 -> '\9472'
93 -> '\9524'
94 -> '\9516'
95 -> '\9532'
97 -> '\9589'
98 -> '\9591'
99 -> '\9482'
100 -> '\9588'
101 -> '\9496'
102 -> '\9488'
103 -> '\9508'
104 -> '\9590'
105 -> '\9492'
106 -> '\9484'
107 -> '\9500'
108 -> '\9480'
109 -> '\9524'
110 -> '\9516'
111 -> '\9532'
113 -> '\9589'
114 -> '\9591'
115 -> '\9474'
116 -> '\9588'
117 -> '\9496'
118 -> '\9488'
119 -> '\9508'
120 -> '\9590'
121 -> '\9492'
122 -> '\9484'
123 -> '\9500'
124 -> '\9472'
125 -> '\9524'
126 -> '\9516'
127 -> '\9532'
129 -> '\9589'
130 -> '\9591'
131 -> '\9474'
132 -> '\9588'
133 -> '\9497'
134 -> '\9489'
135 -> '\9509'
136 -> '\9590'
137 -> '\9493'
138 -> '\9485'
139 -> '\9501'
140 -> '\9473'
141 -> '\9527'
142 -> '\9519'
143 -> '\9535'
145 -> '\9589'
146 -> '\9591'
147 -> '\9475'
148 -> '\9588'
149 -> '\9498'
150 -> '\9490'
151 -> '\9512'
152 -> '\9590'
153 -> '\9493'
154 -> '\9486'
155 -> '\9504'
156 -> '\9472'
157 -> '\9528'
158 -> '\9520'
159 -> '\9538'
161 -> '\9593'
162 -> '\9595'
163 -> '\9475'
164 -> '\9592'
165 -> '\9499'
166 -> '\9491'
167 -> '\9515'
168 -> '\9594'
169 -> '\9495'
170 -> '\9487'
171 -> '\9507'
172 -> '\9473'
173 -> '\9531'
174 -> '\9523'
175 -> '\9547'
177 -> '\9589'
178 -> '\9591'
179 -> '\9474'
180 -> '\9588'
181 -> '\9563'
182 -> '\9557'
183 -> '\9569'
184 -> '\9590'
185 -> '\9560'
186 -> '\9554'
187 -> '\9566'
188 -> '\9552'
189 -> '\9575'
190 -> '\9572'
191 -> '\9532'
193 -> '\9589'
194 -> '\9591'
195 -> '\9553'
196 -> '\9588'
197 -> '\9564'
198 -> '\9558'
199 -> '\9570'
200 -> '\9590'
201 -> '\9561'
202 -> '\9555'
203 -> '\9567'
204 -> '\9472'
205 -> '\9576'
206 -> '\9573'
207 -> '\9532'
209 -> '\9589'
210 -> '\9591'
211 -> '\9553'
212 -> '\9588'
213 -> '\9565'
214 -> '\9559'
215 -> '\9571'
216 -> '\9590'
217 -> '\9562'
218 -> '\9556'
219 -> '\9568'
220 -> '\9552'
221 -> '\9577'
222 -> '\9574'
223 -> '\9532'
225 -> '\9589'
226 -> '\9591'
227 -> '\9474'
228 -> '\9588'
229 -> '\9496'
230 -> '\9488'
231 -> '\9508'
232 -> '\9590'
233 -> '\9492'
234 -> '\9484'
235 -> '\9500'
236 -> '\9472'
237 -> '\9524'
238 -> '\9516'
239 -> '\9532'
241 -> '\9589'
242 -> '\9591'
243 -> '\9474'
244 -> '\9588'
245 -> '\9496'
246 -> '\9488'
247 -> '\9508'
248 -> '\9590'
249 -> '\9492'
250 -> '\9484'
251 -> '\9500'
252 -> '\9472'
253 -> '\9524'
254 -> '\9516'
255 -> '\9532'
_ -> ' '
)
( \case
'\9472' -> Just 252
'\9473' -> Just 172
'\9474' -> Just 243
'\9475' -> Just 163
'\9476' -> Just 76
'\9478' -> Just 67
'\9480' -> Just 108
'\9482' -> Just 99
'\9484' -> Just 250
'\9485' -> Just 138
'\9486' -> Just 154
'\9487' -> Just 170
'\9488' -> Just 246
'\9489' -> Just 134
'\9490' -> Just 150
'\9491' -> Just 166
'\9492' -> Just 249
'\9493' -> Just 153
'\9495' -> Just 169
'\9496' -> Just 245
'\9497' -> Just 133
'\9498' -> Just 149
'\9499' -> Just 165
'\9500' -> Just 251
'\9501' -> Just 139
'\9504' -> Just 155
'\9507' -> Just 171
'\9508' -> Just 247
'\9509' -> Just 135
'\9512' -> Just 151
'\9515' -> Just 167
'\9516' -> Just 254
'\9519' -> Just 142
'\9520' -> Just 158
'\9523' -> Just 174
'\9524' -> Just 253
'\9527' -> Just 141
'\9528' -> Just 157
'\9531' -> Just 173
'\9532' -> Just 255
'\9535' -> Just 143
'\9538' -> Just 159
'\9547' -> Just 175
'\9548' -> Just 44
'\9550' -> Just 35
'\9552' -> Just 220
'\9553' -> Just 211
'\9554' -> Just 186
'\9555' -> Just 202
'\9556' -> Just 218
'\9557' -> Just 182
'\9558' -> Just 198
'\9559' -> Just 214
'\9560' -> Just 185
'\9561' -> Just 201
'\9562' -> Just 217
'\9563' -> Just 181
'\9564' -> Just 197
'\9565' -> Just 213
'\9566' -> Just 187
'\9567' -> Just 203
'\9568' -> Just 219
'\9569' -> Just 183
'\9570' -> Just 199
'\9571' -> Just 215
'\9572' -> Just 190
'\9573' -> Just 206
'\9574' -> Just 222
'\9575' -> Just 189
'\9576' -> Just 205
'\9577' -> Just 221
'\9581' -> Just 26
'\9582' -> Just 22
'\9583' -> Just 21
'\9584' -> Just 25
'\9588' -> Just 244
'\9589' -> Just 241
'\9590' -> Just 248
'\9591' -> Just 242
'\9592' -> Just 164
'\9593' -> Just 161
'\9594' -> Just 168
'\9595' -> Just 162
_ -> Nothing
)
--------------------------------------------------------------------------------
-- | A box border which can be rendered to a terminal given a 'BoxDrawingStyle'
--
-- Use the 'Monoid' and 'Semigroup' instances to combine box borders.
--
-- The internal representation is just a 'Word8'; the least-significant four
-- bits specify the base directions of the box drawing (up, down, left, or
-- right), and the most-significant four bits specify the style (see 'rounded',
-- 'dashed2', etc) which has its own special logic for how styles can be
-- combined.
newtype Drawing = Drawing Word8
deriving newtype (Eq, Ord)
instance Semigroup Drawing where
(<>) a@(Drawing ab) b@(Drawing bb) =
Drawing ((ab .|. bb) .&. 0x0f) `setStyle1` (getStyle1 a <> getStyle1 b)
instance Monoid Drawing where
mempty = Drawing 0
-- | A single box border component
data Drawing1
= BUp
| BDown
| BLeft
| BRight
deriving stock (Show, Read, Eq, Ord, Enum, Bounded)
newtype StyleBits = StyleBits Word8
styleBits :: Drawing -> StyleBits
styleBits (Drawing fs) = StyleBits (fs `shiftR` 4)
setStyleBits :: Drawing -> StyleBits -> Drawing
setStyleBits (Drawing fs) (StyleBits s) = Drawing ((fs .&. 0x0f) .|. (s `shiftL` 4))
setStyle1 :: Drawing -> Style1 -> Drawing
setStyle1 b s = setStyleBits b (fromStyle1 s)
data Style1
= Light
| Rounded
| Dashed2
| Dashed2Heavy
| Dashed3
| Dashed3Heavy
| Dashed4
| Dashed4Heavy
| HeavyHoriz
| HeavyVert
| Heavy
| DoubleHoriz
| DoubleVert
| Double
deriving stock (Show, Eq, Ord, Enum, Bounded)
instance Monoid Style1 where
mempty = Light
instance Semigroup Style1 where
(<>) DoubleHoriz DoubleVert = Double
(<>) DoubleVert DoubleHoriz = Double
(<>) HeavyHoriz HeavyVert = Heavy
(<>) HeavyVert HeavyHoriz = Heavy
(<>) Heavy Dashed2 = Dashed2Heavy
(<>) Dashed2 Heavy = Dashed2Heavy
(<>) Heavy Dashed3 = Dashed3Heavy
(<>) Dashed3 Heavy = Dashed3Heavy
(<>) Heavy Dashed4 = Dashed4Heavy
(<>) Dashed4 Heavy = Dashed4Heavy
(<>) a b = max a b
style1 :: Style1 -> Drawing
style1 s = setStyleBits mempty (fromStyle1 s)
fromStyle1 :: Style1 -> StyleBits
fromStyle1 = StyleBits . toEnum . fromEnum
dropStyleBits :: Drawing -> Drawing
dropStyleBits (Drawing w) = Drawing (w .&. 0x0f)
getStyle1 :: Drawing -> Style1
getStyle1 (Drawing w)
| i >= 0 && i <= fromEnum (maxBound @Style1) = toEnum i
| otherwise = mempty
where
!i = fromIntegral (w `shiftR` 4)
getBorderBitField :: Drawing -> Word8
getBorderBitField (Drawing fs) = fs
bitsToDrawing :: Drawing -> [Drawing1]
bitsToDrawing (Drawing fs) = concat do
!b1 <- [minBound .. maxBound @Drawing1]
pure [b1 | testBit fs (fromEnum b1)]
boxBorderBits :: Drawing1 -> Drawing
boxBorderBits = Drawing . bit . fromEnum
-- | Given a box drawing style and a character, determine what 'Drawing' the
-- character is. On error, returns an empty 'Drawing'
read :: BoxDrawingStyle -> Char -> Drawing
read style ch = fromMaybe mempty (lookup style ch)
-- | Get the character that best represents visually overlaying the given box
-- drawing and a character.
overlay :: BoxDrawingStyle -> Drawing -> Char -> Char
overlay style next cur = render style (read style cur <> next)