]> Git — Sourcephile - haskell/symantic.git/blob - symantic-document/Language/Symantic/Document/Sym.hs
Fix writeSGR on/off.
[haskell/symantic.git] / symantic-document / Language / Symantic / Document / Sym.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 module Language.Symantic.Document.Sym where
3
4 import Data.Bool
5 import Data.Char (Char)
6 import Data.Eq (Eq(..))
7 import Data.Foldable (Foldable(..))
8 import Data.Function ((.), ($))
9 import Data.Functor (Functor(..))
10 import Data.Int (Int)
11 import Data.Ord (Ord(..), Ordering(..))
12 import Data.Semigroup (Semigroup(..))
13 import Data.String (String, IsString)
14 import Prelude (Integer, toInteger, fromIntegral, Num(..), undefined, Integral, Real, Enum)
15 import Text.Show (Show)
16 import qualified Data.List as List
17 import qualified Data.Text as Text
18 import qualified Data.Text.Lazy as TL
19
20 -- * Type 'Nat'
21 newtype Nat = Nat Integer
22 deriving (Eq, Ord, Show, Integral, Real, Enum)
23 unLength :: Nat -> Integer
24 unLength (Nat i) = i
25 instance Num Nat where
26 fromInteger i | 0 <= i = Nat i
27 | otherwise = undefined
28 abs = Nat . abs . unLength
29 signum = signum . signum
30 Nat x + Nat y = Nat (x + y)
31 Nat x * Nat y = Nat (x * y)
32 Nat x - Nat y | y <= x = Nat (x - y)
33 | otherwise = undefined
34
35 -- ** Type 'Column'
36 type Column = Nat
37
38 -- ** Type 'Indent'
39 type Indent = Column
40
41 -- * Class 'Lengthable'
42 class Lengthable a where
43 length :: a -> Nat
44 instance Lengthable Char where
45 length _ = Nat 1
46 instance Lengthable [a] where
47 length = Nat . fromIntegral . List.length
48 instance Lengthable Text.Text where
49 length = Nat . fromIntegral . Text.length
50 instance Lengthable TL.Text where
51 length = Nat . fromIntegral . TL.length
52
53 -- * Class 'Textable'
54 class (IsString d, Semigroup d) => Textable d where
55 charH :: Char -- ^ XXX: MUST NOT be '\n'
56 -> d
57 stringH :: String -- ^ XXX: MUST NOT contain '\n'
58 -> d
59 textH :: Text.Text -- ^ XXX: MUST NOT contain '\n'
60 -> d
61 ltextH :: TL.Text -- ^ XXX: MUST NOT contain '\n'
62 -> d
63 replicate :: Int -> d -> d
64 integer :: Integer -> d
65 default replicate :: Textable (ReprOf d) => Trans d => Int -> d -> d
66 default integer :: Textable (ReprOf d) => Trans d => Integer -> d
67 default charH :: Textable (ReprOf d) => Trans d => Char -> d
68 default stringH :: Textable (ReprOf d) => Trans d => String -> d
69 default textH :: Textable (ReprOf d) => Trans d => Text.Text -> d
70 default ltextH :: Textable (ReprOf d) => Trans d => TL.Text -> d
71 charH = trans . charH
72 stringH = trans . stringH
73 textH = trans . textH
74 ltextH = trans . ltextH
75 replicate = trans1 . replicate
76 integer = trans . integer
77
78 empty :: d
79 newline :: d
80 space :: d
81 -- | @x '<+>' y = x '<>' 'space' '<>' y@
82 (<+>) :: d -> d -> d
83 -- | @x '</>' y = x '<>' 'newline' '<>' y@
84 (</>) :: d -> d -> d
85 int :: Int -> d
86 char :: Char -> d
87 string :: String -> d
88 text :: Text.Text -> d
89 ltext :: TL.Text -> d
90 catH :: Foldable f => f d -> d
91 catV :: Foldable f => f d -> d
92 foldrWith :: Foldable f => (d -> d -> d) -> f d -> d
93 foldWith :: Foldable f => (d -> d) -> f d -> d
94 intercalate :: Foldable f => d -> f d -> d
95 between :: d -> d -> d -> d
96
97 newline = "\n"
98 space = char ' '
99 x <+> y = x <> space <> y
100 x </> y = x <> newline <> y
101 int = integer . toInteger
102 char = \case '\n' -> newline; c -> charH c
103 string = catV . fmap stringH . lines
104 text = catV . fmap textH . Text.lines
105 ltext = catV . fmap ltextH . TL.lines
106 catH = foldr (<>) empty
107 catV = foldrWith (\x y -> x<>newline<>y)
108 foldrWith f ds = if null ds then empty else foldr1 f ds
109 foldWith f = foldrWith $ \a acc -> a <> f acc
110 intercalate sep = foldrWith (\x y -> x<>sep<>y)
111 between o c d = o<>d<>c
112 -- default catH :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
113 -- default catV :: Textable (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d
114 -- catH l = trans (catH (fmap unTrans l))
115 -- catV l = trans (catV (fmap unTrans l))
116
117 -- * Class 'Alignable'
118 class Textable d => Alignable d where
119 -- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
120 align :: d -> d
121 -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
122 hang :: Indent -> d -> d
123 hang ind = align . incrIndent ind
124 -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
125 incrIndent :: Indent -> d -> d
126 -- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
127 withIndent :: Indent -> d -> d
128 -- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.
129 --
130 -- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.
131 withNewline :: d -> d -> d
132 newlineWithoutIndent :: d
133 newlineWithIndent :: d
134 -- | @('column' f)@ return @f@ applied to the current 'Column'.
135 column :: (Column -> d) -> d
136 -- | @('endToEndWidth' d f)@ return @d@ concatenated to
137 -- @f@ applied to the difference between the end 'Column' and start 'Column' of @d@.
138 --
139 -- Note that @f@ is given the end-to-end width,
140 -- which is not necessarily the maximal width.
141 endToEndWidth :: d -> (Column -> d) -> d
142 endToEndWidth d f = column $ \(Nat c1) -> (d <>) $ column $ \(Nat c2) -> f $ Nat $ c2 - c1
143
144 -- | @'spaces' ind = 'replicate' ind 'space'@
145 spaces :: Indent -> d
146 spaces (Nat i) = replicate (fromIntegral i) space
147
148 -- | @('fill' ind d)@ return @d@ then as many 'space's as needed
149 -- so that the whole is @ind@ 'Column's wide.
150 fill :: Indent -> d -> d
151 fill (Nat m) d =
152 endToEndWidth d $ \(Nat w) ->
153 case w`compare`m of
154 LT -> spaces $ Nat $ m - w
155 _ -> empty
156
157 -- | @('breakableFill' ind f d)@ return @f@ then as many 'space's as needed
158 -- so that the whole is @ind@ 'Column's wide,
159 -- then, if @f@ is not wider than @ind@, appends @d@,
160 -- otherwise appends a 'newline' and @d@,
161 -- with an 'Indent' level set to the start 'Column' of @f@ plus @ind@.
162 breakableFill :: Indent -> d -> d -> d
163 breakableFill (Nat m) f d =
164 column $ \(Nat c) ->
165 endToEndWidth f $ \(Nat w) ->
166 case w`compare`m of
167 LT -> spaces (Nat $ m - w) <> d
168 EQ -> d
169 GT -> withIndent (Nat $ c + m) (newline <> d)
170
171 -- * Class 'Wrapable'
172 class (Textable d, Alignable d) => Wrapable d where
173 -- | @('ifWrap' onWrap onNoWrap)@
174 -- return @onWrap@ if @onNoWrap@ leads to a 'Column'
175 -- greater or equal to the one sets with 'withWrapColumn',
176 -- otherwise return @onNoWrap@.
177 ifWrap :: d -> d -> d
178 -- | @('breakpoint' onNoBreak onBreak d)@
179 -- return @onNoBreak@ then @d@ if they fit,
180 -- @onBreak@ otherwise.
181 breakpoint :: d -> d -> d -> d
182 -- | @('breakableEmpty' d)@ return @d@ if it fits, 'newline' then @d@ otherwise.
183 breakableEmpty :: d -> d
184 breakableEmpty = breakpoint empty newline
185 -- | @x '><' y = x '<>' 'breakableEmpty' y@
186 (><) :: d -> d -> d
187 x >< y = x <> breakableEmpty y
188 -- | @('breakableSpace' d)@ return 'space' then @d@ it they fit,
189 -- 'newline' then @d@ otherwise.
190 breakableSpace :: d -> d
191 breakableSpace = breakpoint space newline
192 -- | @x '>+<' y = x '<>' 'breakableSpace' y@
193 (>+<) :: d -> d -> d
194 x >+< y = x <> breakableSpace y
195 -- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'
196 -- between items of @ds@.
197 breakableSpaces :: Foldable f => f d -> d
198 breakableSpaces = foldWith breakableSpace
199 -- | @'withWrapColumn' col d@ set the 'Column' triggering wrapping to @col@ within @d@.
200 withWrapColumn :: Column -> d -> d
201 -- | @('intercalateHorV' sep ds)@
202 -- return @ds@ with @sep@ intercalated if the whole fits,
203 -- otherwise return 'align' of @ds@ with 'newline' and @sep@ intercalated.
204 intercalateHorV :: Foldable f => d -> f d -> d
205 intercalateHorV sep xs =
206 ifWrap
207 (align $ foldWith ((newline <> sep) <>) xs)
208 (foldWith (sep <>) xs)
209
210 -- * Class 'Colorable'
211 class Colorable d where
212 -- | @('colorable' f)@ return @f@ applied to whether colors are activated or not.
213 colorable :: (Bool -> d) -> d
214 -- | @('withColor' b d)@ whether to active colors or not within @d@.
215 withColorable :: Bool -> d -> d
216
217 reverse :: d -> d
218
219 -- Foreground colors
220 -- Dull
221 black :: d -> d
222 red :: d -> d
223 green :: d -> d
224 yellow :: d -> d
225 blue :: d -> d
226 magenta :: d -> d
227 cyan :: d -> d
228 white :: d -> d
229
230 -- Vivid
231 blacker :: d -> d
232 redder :: d -> d
233 greener :: d -> d
234 yellower :: d -> d
235 bluer :: d -> d
236 magentaer :: d -> d
237 cyaner :: d -> d
238 whiter :: d -> d
239
240 -- Background colors
241 -- Dull
242 onBlack :: d -> d
243 onRed :: d -> d
244 onGreen :: d -> d
245 onYellow :: d -> d
246 onBlue :: d -> d
247 onMagenta :: d -> d
248 onCyan :: d -> d
249 onWhite :: d -> d
250
251 -- Vivid
252 onBlacker :: d -> d
253 onRedder :: d -> d
254 onGreener :: d -> d
255 onYellower :: d -> d
256 onBluer :: d -> d
257 onMagentaer :: d -> d
258 onCyaner :: d -> d
259 onWhiter :: d -> d
260
261 default reverse :: Colorable (ReprOf d) => Trans d => d -> d
262 default black :: Colorable (ReprOf d) => Trans d => d -> d
263 default red :: Colorable (ReprOf d) => Trans d => d -> d
264 default green :: Colorable (ReprOf d) => Trans d => d -> d
265 default yellow :: Colorable (ReprOf d) => Trans d => d -> d
266 default blue :: Colorable (ReprOf d) => Trans d => d -> d
267 default magenta :: Colorable (ReprOf d) => Trans d => d -> d
268 default cyan :: Colorable (ReprOf d) => Trans d => d -> d
269 default white :: Colorable (ReprOf d) => Trans d => d -> d
270 default blacker :: Colorable (ReprOf d) => Trans d => d -> d
271 default redder :: Colorable (ReprOf d) => Trans d => d -> d
272 default greener :: Colorable (ReprOf d) => Trans d => d -> d
273 default yellower :: Colorable (ReprOf d) => Trans d => d -> d
274 default bluer :: Colorable (ReprOf d) => Trans d => d -> d
275 default magentaer :: Colorable (ReprOf d) => Trans d => d -> d
276 default cyaner :: Colorable (ReprOf d) => Trans d => d -> d
277 default whiter :: Colorable (ReprOf d) => Trans d => d -> d
278 default onBlack :: Colorable (ReprOf d) => Trans d => d -> d
279 default onRed :: Colorable (ReprOf d) => Trans d => d -> d
280 default onGreen :: Colorable (ReprOf d) => Trans d => d -> d
281 default onYellow :: Colorable (ReprOf d) => Trans d => d -> d
282 default onBlue :: Colorable (ReprOf d) => Trans d => d -> d
283 default onMagenta :: Colorable (ReprOf d) => Trans d => d -> d
284 default onCyan :: Colorable (ReprOf d) => Trans d => d -> d
285 default onWhite :: Colorable (ReprOf d) => Trans d => d -> d
286 default onBlacker :: Colorable (ReprOf d) => Trans d => d -> d
287 default onRedder :: Colorable (ReprOf d) => Trans d => d -> d
288 default onGreener :: Colorable (ReprOf d) => Trans d => d -> d
289 default onYellower :: Colorable (ReprOf d) => Trans d => d -> d
290 default onBluer :: Colorable (ReprOf d) => Trans d => d -> d
291 default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d
292 default onCyaner :: Colorable (ReprOf d) => Trans d => d -> d
293 default onWhiter :: Colorable (ReprOf d) => Trans d => d -> d
294
295 reverse = trans1 reverse
296 black = trans1 black
297 red = trans1 red
298 green = trans1 green
299 yellow = trans1 yellow
300 blue = trans1 blue
301 magenta = trans1 magenta
302 cyan = trans1 cyan
303 white = trans1 white
304 blacker = trans1 blacker
305 redder = trans1 redder
306 greener = trans1 greener
307 yellower = trans1 yellower
308 bluer = trans1 bluer
309 magentaer = trans1 magentaer
310 cyaner = trans1 cyaner
311 whiter = trans1 whiter
312 onBlack = trans1 onBlack
313 onRed = trans1 onRed
314 onGreen = trans1 onGreen
315 onYellow = trans1 onYellow
316 onBlue = trans1 onBlue
317 onMagenta = trans1 onMagenta
318 onCyan = trans1 onCyan
319 onWhite = trans1 onWhite
320 onBlacker = trans1 onBlacker
321 onRedder = trans1 onRedder
322 onGreener = trans1 onGreener
323 onYellower = trans1 onYellower
324 onBluer = trans1 onBluer
325 onMagentaer = trans1 onMagentaer
326 onCyaner = trans1 onCyaner
327 onWhiter = trans1 onWhiter
328
329 -- * Class 'Decorable'
330 class Decorable d where
331 -- | @('decorable' f)@ return @f@ applied to whether decorations are activated or not.
332 decorable :: (Bool -> d) -> d
333 -- | @('withColor' b d)@ whether to active decorations or not within @d@.
334 withDecorable :: Bool -> d -> d
335
336 bold :: d -> d
337 underline :: d -> d
338 italic :: d -> d
339 default bold :: Decorable (ReprOf d) => Trans d => d -> d
340 default underline :: Decorable (ReprOf d) => Trans d => d -> d
341 default italic :: Decorable (ReprOf d) => Trans d => d -> d
342 bold = trans1 bold
343 underline = trans1 underline
344 italic = trans1 italic
345
346 -- * Class 'Trans'
347 class Trans tr where
348 -- | Return the underlying @tr@ of the transformer.
349 type ReprOf tr :: *
350
351 -- | Lift a tr to the transformer's.
352 trans :: ReprOf tr -> tr
353 -- | Unlift a tr from the transformer's.
354 unTrans :: tr -> ReprOf tr
355
356 -- | Identity transformation for a unary symantic method.
357 trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)
358 trans1 f = trans . f . unTrans
359
360 -- | Identity transformation for a binary symantic method.
361 trans2
362 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)
363 -> (tr -> tr -> tr)
364 trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))
365
366 -- | Identity transformation for a ternary symantic method.
367 trans3
368 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)
369 -> (tr -> tr -> tr -> tr)
370 trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))
371
372 -- | Break a 'String' into lines while preserving all empty lines.
373 lines :: String -> [String]
374 lines cs =
375 case List.break (== '\n') cs of
376 (chunk, _:rest) -> chunk : lines rest
377 (chunk, []) -> [chunk]