]> Git — Sourcephile - haskell/symantic-plaintext.git/blob - src/Symantic/Plaintext/Writer.hs
wip
[haskell/symantic-plaintext.git] / src / Symantic / Plaintext / Writer.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE UndecidableInstances #-}
3 {-# LANGUAGE NoMonomorphismRestriction #-}
4
5 module Symantic.Plaintext.Writer where
6
7 import Control.Monad (Monad (..))
8 import Data.Bool
9 import Data.Char (Char)
10 import Data.Eq (Eq (..))
11 import Data.Foldable qualified as Fold
12 import Data.Function (id, ($), (.))
13 import Data.Functor ((<$>))
14 import Data.Int (Int)
15 import Data.Kind (Type)
16 import Data.List qualified as List
17 import Data.Maybe (Maybe (..))
18 import Data.Monoid (Monoid (..))
19 import Data.Ord (Ord (..), Ordering (..))
20 import Data.Semigroup (Semigroup (..))
21 import Data.String (IsString (..), String)
22 import Data.Text qualified as T
23 import Data.Text.Lazy qualified as TL
24 import Data.Tuple qualified as Tuple
25 import GHC.Natural (minusNatural, minusNaturalMaybe, quotRemNatural)
26 import Numeric.Natural (Natural)
27 import System.Console.ANSI hiding (SGR)
28 import Text.Show (Show (..), showParen, showString)
29 import Prelude (Num (..), error, fromIntegral, pred)
30
31 --import qualified Data.Text.Lazy.Builder as TLB
32
33 import Symantic.Plaintext.Classes hiding (char)
34 import Symantic.Plaintext.Output
35
36 -- * Type 'Writer'
37
38 {- | Church encoded for performance concerns.
39 Kinda like 'ParsecT' in @megaparsec@ but a little bit different
40 due to the use of 'WriterFit' for implementing 'breakingSpace' correctly
41 when in the left hand side of ('<.>').
42 Prepending is done using continuation, like in a difference list.
43 -}
44 newtype Writer (o :: Type) a = Writer
45 { unWriter ::
46 a ->
47 {-curr-} WriterInh o ->
48 {-curr-} WriterState o ->
49 {-ok-} (({-prepend-} (o -> o {-new-}), WriterState o) -> WriterFit o) ->
50 WriterFit o
51 -- NOTE: equivalent to:
52 -- ReaderT WriterInh (StateT (WriterState o) (Cont (WriterFit o))) (o->o)
53 }
54
55 runWriter :: Monoid o => Writer o a -> a -> o
56 runWriter x a =
57 unWriter
58 x
59 a
60 defWriterInh
61 defWriterState
62 {-k-} ( \(px, _sx) fits _overflow ->
63 -- NOTE: if px fits, then appending mempty fits
64 fits (px mempty)
65 )
66 {-fits-} id
67 {-overflow-} id
68
69 instance Semigroup o => ProductFunctor (Writer o) where
70 x <.> y = Writer $ \(a, b) inh st k ->
71 unWriter x a inh st $ \(px, sx) ->
72 unWriter y b inh sx $ \(py, sy) ->
73 k (px . py, sy)
74 x .> y = Writer $ \b inh st k ->
75 unWriter x () inh st $ \(px, sx) ->
76 unWriter y b inh sx $ \(py, sy) ->
77 k (px . py, sy)
78 x <. y = Writer $ \a inh st k ->
79 unWriter x a inh st $ \(px, sx) ->
80 unWriter y () inh sx $ \(py, sy) ->
81 k (px . py, sy)
82 instance Emptyable (Writer o) where
83 empty = Writer $ \_a _inh st k -> k (id, st)
84 instance Outputable o => Repeatable (Writer o) where
85 many0 item = Writer $ \as ->
86 unWriter (concat ((`void` item) <$> as)) ()
87 many1 item = Writer $ \case
88 [] -> error "many1"
89 as -> unWriter (concat ((`void` item) <$> as)) ()
90
91 -- String
92 instance (Convertible String o, Outputable o) => IsString (Writer o ()) where
93 fromString = convert
94 instance (Convertible String o, Outputable o) => Convertible String (Writer o ()) where
95 convert =
96 concat
97 . List.intersperse newline
98 . ( concat
99 . List.intersperse breakspace
100 . (wordWriter <$>)
101 . words
102 <$>
103 )
104 . lines
105 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Convertible T.Text (Writer o ()) where
106 convert =
107 concat
108 . List.intersperse newline
109 . ( concat
110 . List.intersperse breakspace
111 . (wordWriter <$>)
112 . words
113 <$>
114 )
115 . lines
116 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Convertible TL.Text (Writer o ()) where
117 convert =
118 concat
119 . List.intersperse newline
120 . ( concat
121 . List.intersperse breakspace
122 . (wordWriter <$>)
123 . words
124 <$>
125 )
126 . lines
127
128 instance (Convertible String o, Outputable o) => Inferable Int (Writer o) where
129 infer = showWordWriter
130 instance (Convertible String o, Outputable o) => Inferable Natural (Writer o) where
131 infer = showWordWriter
132 instance (Convertible String o, Outputable o) => Inferable (Word String) (Writer o) where
133 infer = Writer $ ($ ()) . unWriter . wordWriter
134 instance (Convertible String o, Outputable o) => Inferable String (Writer o) where
135 infer = Writer $ ($ ()) . unWriter . fromString
136 instance (Convertible T.Text o, Convertible Char o, Outputable o) => Inferable T.Text (Writer o) where
137 infer = Writer $ ($ ()) . unWriter . convert
138 instance (Convertible TL.Text o, Convertible Char o, Outputable o) => Inferable TL.Text (Writer o) where
139 infer = Writer $ ($ ()) . unWriter . convert
140 instance Outputable o => Inferable Char (Writer o) where
141 infer = Writer $ \case
142 '\n' -> unWriter newline ()
143 ' ' -> unWriter breakspace ()
144 c -> unWriter (wordWriter (Word c)) ()
145 instance Outputable o => Inferable (Word Char) (Writer o) where
146 infer = Writer $ \c -> unWriter (wordWriter c) ()
147 showWordWriter ::
148 Show a =>
149 Convertible String o =>
150 Outputable o =>
151 Inferable a (Writer o) =>
152 Writer o a
153 showWordWriter =
154 Writer $
155 ($ ()) . unWriter . wordWriter
156 . Word
157 . show
158
159 -- ** Type 'WriterState'
160 data WriterState o = WriterState
161 { plainState_buffer :: ![WriterChunk o]
162 , -- | The 'Column' from which the 'plainState_buffer'
163 -- must be written.
164 plainState_bufferStart :: !Column
165 , -- | The 'Width' of the 'plainState_buffer' so far.
166 plainState_bufferWidth :: !Width
167 , -- | The amount of 'Indent' added by 'breakspace'
168 -- that can be reached by breaking the 'space'
169 -- into a 'newlineJustifyingWriter'.
170 plainState_breakIndent :: !Indent
171 }
172 deriving (Show)
173
174 defWriterState :: WriterState o
175 defWriterState =
176 WriterState
177 { plainState_buffer = mempty
178 , plainState_bufferStart = 0
179 , plainState_bufferWidth = 0
180 , plainState_breakIndent = 0
181 }
182
183 -- ** Type 'WriterInh'
184 data WriterInh o = WriterInh
185 { plainInh_width :: !(Maybe Column)
186 , plainInh_justify :: !Bool
187 , plainInh_indent :: !Indent
188 , plainInh_indenting :: !(Writer o ())
189 , plainInh_sgr :: ![SGR]
190 }
191
192 defWriterInh :: Monoid o => WriterInh o
193 defWriterInh =
194 WriterInh
195 { plainInh_width = Nothing
196 , plainInh_justify = False
197 , plainInh_indent = 0
198 , plainInh_indenting = empty
199 , plainInh_sgr = []
200 }
201
202 -- ** Type 'WriterFit'
203
204 {- | Double continuation to qualify the returned document
205 as fitting or overflowing the given 'plainInh_width'.
206 It's like @('Bool',o)@ in a normal style
207 (a non continuation-passing-style).
208 -}
209 type WriterFit o =
210 {-fits-} (o -> o) ->
211 {-overflow-} (o -> o) ->
212 o
213
214 -- ** Type 'WriterChunk'
215 data WriterChunk o
216 = -- | Ignored by the justification but kept in place.
217 -- Used for instance to put ANSI sequences.
218 WriterChunk_Ignored !o
219 | WriterChunk_Word !(Word o)
220 | -- | 'spaces' preserved to be interleaved
221 -- correctly with 'WriterChunk_Ignored'.
222 WriterChunk_Spaces !Width
223 instance Show o => Show (WriterChunk o) where
224 showsPrec p x =
225 showParen (p > 10) $
226 case x of
227 WriterChunk_Ignored o ->
228 showString "Z "
229 . showsPrec 11 o
230 WriterChunk_Word (Word o) ->
231 showString "W "
232 . showsPrec 11 o
233 WriterChunk_Spaces s ->
234 showString "S "
235 . showsPrec 11 s
236 instance Lengthable o => Lengthable (WriterChunk o) where
237 length = \case
238 WriterChunk_Ignored{} -> 0
239 WriterChunk_Word o -> length o
240 WriterChunk_Spaces s -> s
241 isEmpty = \case
242 WriterChunk_Ignored{} -> True
243 WriterChunk_Word o -> isEmpty o
244 WriterChunk_Spaces s -> s == 0
245
246 --instance From [SGR] o => From [SGR] (WriterChunk o) where
247 -- from sgr = WriterChunk_Ignored (from sgr)
248
249 runWriterChunk :: Outputable o => WriterChunk o -> o
250 runWriterChunk = \case
251 WriterChunk_Ignored o -> o
252 WriterChunk_Word (Word o) -> o
253 WriterChunk_Spaces s -> repeatedChar s ' '
254
255 instance Voidable (Writer o) where
256 void a p = Writer $ \() -> unWriter p a
257 instance (Convertible Char o, Outputable o) => Spaceable (Writer o) where
258 space = spaces 1
259 spaces n = Writer $ \() inh st@WriterState{..} k fits overflow ->
260 let newWidth = plainState_bufferStart + plainState_bufferWidth + n
261 in if plainInh_justify inh
262 then
263 let newState =
264 st
265 { plainState_buffer =
266 case plainState_buffer of
267 WriterChunk_Spaces s : buf -> WriterChunk_Spaces (s + n) : buf
268 buf -> WriterChunk_Spaces n : buf
269 , plainState_bufferWidth = plainState_bufferWidth + n
270 }
271 in case plainInh_width inh of
272 Just maxWidth
273 | maxWidth < newWidth ->
274 overflow $ k (id {-(o<>)-}, newState) fits overflow
275 _ -> k (id {-(o<>)-}, newState) fits overflow
276 else
277 let newState =
278 st
279 { plainState_bufferWidth = plainState_bufferWidth + n
280 }
281 in case plainInh_width inh of
282 Just maxWidth
283 | maxWidth < newWidth ->
284 overflow $ k ((repeatedChar n ' ' <>), newState) fits fits
285 _ -> k ((repeatedChar n ' ' <>), newState) fits overflow
286 instance (Outputable o) => Newlineable (Writer o) where
287 newline = Writer $ \() inh st ->
288 unWriter
289 ( newlineWriter
290 <. indentWriter
291 <. propagateWriter (plainState_breakIndent st)
292 <. flushlineWriter
293 )
294 ()
295 inh
296 st
297 where
298 indentWriter = Writer $ \() inh ->
299 unWriter
300 (plainInh_indenting inh)
301 ()
302 inh{plainInh_justify = False}
303 newlineWriter = Writer $ \() inh st k ->
304 k
305 ( \next ->
306 ( if plainInh_justify inh
307 then joinLineWriterChunk $ List.reverse $ plainState_buffer st
308 else mempty
309 )
310 <> nl
311 <> next
312 , st
313 { plainState_bufferStart = 0
314 , plainState_bufferWidth = 0
315 , plainState_buffer = mempty
316 }
317 )
318 propagateWriter breakIndent = Writer $ \() inh st k fits overflow ->
319 k
320 (id, st)
321 fits
322 {-overflow-} ( -- NOTE: the text after this newline overflows,
323 -- so propagate the overflow before this 'newline',
324 -- if and only if there is a 'breakspace' before this 'newline'
325 -- whose replacement by a 'newline' indents to a lower indent
326 -- than this 'newline''s indent.
327 -- Otherwise there is no point in propagating the overflow.
328 if breakIndent < plainInh_indent inh
329 then overflow
330 else fits
331 )
332
333 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
334 flushlineWriter :: Outputable o => Writer o ()
335 flushlineWriter = Writer $ \() _inh st k ->
336 k
337 ( (joinLineWriterChunk (collapseWriterChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
338 , st
339 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
340 , plainState_bufferWidth = 0
341 , plainState_buffer = mempty
342 }
343 )
344
345 -- | Just concat 'WriterChunk's with no justification.
346 joinLineWriterChunk :: Outputable o => [WriterChunk o] -> o
347 joinLineWriterChunk = mconcat . (runWriterChunk <$>)
348
349 collapseWriterChunkSpaces :: WriterChunk o -> WriterChunk o
350 collapseWriterChunkSpaces = \case
351 WriterChunk_Spaces s -> WriterChunk_Spaces (if s > 0 then 1 else 0)
352 x -> x
353
354 wordWriter ::
355 Lengthable i =>
356 Convertible i o =>
357 Outputable o =>
358 Word i ->
359 Writer o ()
360 wordWriter inp = Writer $ \() inh st@WriterState{..} k fits overflow ->
361 let wordWidth = length inp
362 in let out = convert inp
363 in if wordWidth <= 0
364 then k (id, st) fits overflow
365 else
366 let newBufferWidth = plainState_bufferWidth + wordWidth
367 in let newWidth = plainState_bufferStart + newBufferWidth
368 in if plainInh_justify inh
369 then
370 let newState =
371 st
372 { plainState_buffer = WriterChunk_Word out : plainState_buffer
373 , plainState_bufferWidth = newBufferWidth
374 }
375 in case plainInh_width inh of
376 Just maxWidth
377 | maxWidth < newWidth ->
378 overflow $ k (id, newState) fits overflow
379 _ -> k (id, newState) fits overflow
380 else
381 let newState =
382 st
383 { plainState_bufferWidth = newBufferWidth
384 }
385 in case plainInh_width inh of
386 Just maxWidth
387 | maxWidth < newWidth ->
388 overflow $ k ((unWord out <>), newState) fits fits
389 _ -> k ((unWord out <>), newState) fits overflow
390
391 instance (Convertible Char o, Outputable o) => Indentable (Writer o) where
392 align p = (flushlineWriter .>) $
393 Writer $ \a inh st ->
394 let col = plainState_bufferStart st + plainState_bufferWidth st
395 in unWriter
396 p
397 a
398 inh
399 { plainInh_indent = col
400 , plainInh_indenting =
401 if plainInh_indent inh <= col
402 then
403 plainInh_indenting inh
404 .> spaces (col `minusNatural` plainInh_indent inh)
405 else spaces col
406 }
407 st
408 setIndent o i p = Writer $ \a inh ->
409 unWriter
410 p
411 a
412 inh
413 { plainInh_indent = i
414 , plainInh_indenting = o
415 }
416 incrIndent o i p = Writer $ \a inh ->
417 unWriter
418 p
419 a
420 inh
421 { plainInh_indent = plainInh_indent inh + i
422 , plainInh_indenting = plainInh_indenting inh .> o
423 }
424 fill m p = Writer $ \a inh0 st0 ->
425 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m
426 in let p1 = Writer $ \() inh1 st1 ->
427 let col = plainState_bufferStart st1 + plainState_bufferWidth st1
428 in unWriter
429 ( if col <= maxCol
430 then spaces (maxCol `minusNatural` col)
431 else empty
432 )
433 ()
434 inh1
435 st1
436 in unWriter (p <. p1) a inh0 st0
437 fillOrBreak m p = Writer $ \a inh0 st0 ->
438 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m
439 in let p1 = Writer $ \() inh1 st1 ->
440 let col = plainState_bufferStart st1 + plainState_bufferWidth st1
441 in unWriter
442 ( case col `compare` maxCol of
443 LT -> spaces (maxCol `minusNatural` col)
444 EQ -> empty
445 GT -> incrIndent (spaces m) m newline
446 )
447 ()
448 inh1
449 st1
450 in unWriter (p <. p1) a inh0 st0
451 instance (Convertible Char o, Convertible String o, Outputable o) => Listable (Writer o) where
452 ul is =
453 catV $
454 (<$> is) $ \i ->
455 wordWriter (Word '-') .> space .> flushlineWriter
456 .> align i
457
458 -- .> flushlineWriter
459 ol is =
460 catV $
461 Tuple.snd $
462 Fold.foldr
463 ( \o (n, acc) ->
464 ( pred n
465 , ( wordWriter (Word (show n))
466 .> wordWriter (Word '.')
467 .> space
468 .> flushlineWriter
469 .> align o
470 -- .> flushlineWriter
471 ) :
472 acc
473 )
474 )
475 (Fold.length is, [])
476 is
477 unorderedList li =
478 intercalate_ newline $
479 wordWriter (Word '-') .> space .> flushlineWriter .> align li
480 orderedList li = Writer $ \as ->
481 unWriter
482 (intercalate_ newline item)
483 (List.zip [1 ..] as)
484 where
485 item = Writer $ \(i :: Natural, a) ->
486 ($ a) $
487 unWriter $
488 void i natural
489 .> wordWriter (Word '.')
490 .> space
491 .> flushlineWriter
492 .> align li
493 intercalate_ sep li = Writer $ \as ->
494 unWriter (concat (List.intersperse sep ((`void` li) <$> as))) ()
495 list_ opn sep cls li =
496 breakalt
497 (opn .> intercalate_ (sep .> space) li <. cls)
498 ( align $
499 opn .> space
500 .> intercalate_ (newline .> sep .> space) li
501 <. newline
502 <. cls
503 )
504 instance Outputable o => Justifiable (Writer o) where
505 justify p = (\x -> flushlineWriter .> x <. flushlineWriter) $
506 Writer $ \a inh ->
507 unWriter p a inh{plainInh_justify = True}
508 instance Outputable o => Wrappable (Writer o) where
509 setWidth w p = Writer $ \a inh ->
510 unWriter p a inh{plainInh_width = w}
511 breakpoint = Writer $ \() inh st k fits overflow ->
512 k
513 (id, st{plainState_breakIndent = plainInh_indent inh})
514 fits
515 {-overflow-} (\_r -> unWriter newlineJustifyingWriter () inh st k fits overflow)
516 breakspace = Writer $ \() inh st k fits overflow ->
517 k
518 ( if plainInh_justify inh then id else (char ' ' <>)
519 , st
520 { plainState_buffer =
521 if plainInh_justify inh
522 then case plainState_buffer st of
523 WriterChunk_Spaces s : bs -> WriterChunk_Spaces (s + 1) : bs
524 bs -> WriterChunk_Spaces 1 : bs
525 else plainState_buffer st
526 , plainState_bufferWidth = plainState_bufferWidth st + 1
527 , plainState_breakIndent = plainInh_indent inh
528 }
529 )
530 fits
531 {-overflow-} (\_r -> unWriter newlineJustifyingWriter () inh st k fits overflow)
532 breakalt x y = Writer $ \a inh st k fits overflow ->
533 -- NOTE: breakalt must be y if and only if x does not fit,
534 -- hence the use of dummyK to limit the test
535 -- to overflows raised within x, and drop those raised after x.
536 unWriter
537 x
538 a
539 inh
540 st
541 dummyK
542 {-fits-} (\_r -> unWriter x a inh st k fits overflow)
543 {-overflow-} (\_r -> unWriter y a inh st k fits overflow)
544 where
545 dummyK (px, _sx) fits _overflow =
546 -- NOTE: if px fits, then appending mempty fits
547 fits (px mempty)
548 endline = Writer $ \() inh st k fits _overflow ->
549 let col = plainState_bufferStart st + plainState_bufferWidth st
550 in case plainInh_width inh >>= (`minusNaturalMaybe` col) of
551 Nothing -> k (id, st) fits fits
552 Just w ->
553 let newState =
554 st
555 { plainState_bufferWidth = plainState_bufferWidth st + w
556 }
557 in k (id, newState) fits fits
558
559 -- | Like 'newline', but justify 'plainState_buffer' before.
560 newlineJustifyingWriter :: Outputable o => Writer o ()
561 newlineJustifyingWriter = Writer $ \() inh st ->
562 unWriter
563 ( newlineWriter
564 .> indentWriter
565 .> propagateWriter (plainState_breakIndent st)
566 <. flushlineWriter
567 )
568 ()
569 inh
570 st
571 where
572 indentWriter = Writer $ \a inh ->
573 unWriter
574 (plainInh_indenting inh)
575 a
576 inh{plainInh_justify = False}
577 newlineWriter = Writer $ \() inh st k ->
578 k
579 ( \next ->
580 ( if plainInh_justify inh
581 then justifyLineWriter inh st
582 else mempty
583 )
584 <> nl
585 <> next
586 , st
587 { plainState_bufferStart = 0
588 , plainState_bufferWidth = 0
589 , plainState_buffer = mempty
590 }
591 )
592 propagateWriter breakIndent = Writer $ \() inh st1 k fits overflow ->
593 k
594 (id, st1)
595 fits
596 {-overflow-} ( -- NOTE: the text after this newline overflows,
597 -- so propagate the overflow before this 'newline',
598 -- if and only if there is a 'breakspace' before this 'newline'
599 -- whose replacement by a 'newline' indents to a lower indent
600 -- than this 'newline''s indent.
601 -- Otherwise there is no point in propagating the overflow.
602 if breakIndent < plainInh_indent inh
603 then overflow
604 else fits
605 )
606
607 -- * Justifying
608 justifyLineWriter ::
609 Outputable o =>
610 WriterInh o ->
611 WriterState o ->
612 o
613 justifyLineWriter inh WriterState{..} =
614 case plainInh_width inh of
615 Nothing -> joinLineWriterChunk $ List.reverse plainState_buffer
616 Just maxWidth ->
617 if maxWidth < plainState_bufferStart
618 || maxWidth < plainInh_indent inh
619 then joinLineWriterChunk $ List.reverse plainState_buffer
620 else
621 let superfluousSpaces =
622 Fold.foldr
623 ( \c acc ->
624 acc + case c of
625 WriterChunk_Ignored{} -> 0
626 WriterChunk_Word{} -> 0
627 WriterChunk_Spaces s -> s `minusNatural` (min 1 s)
628 )
629 0
630 plainState_buffer
631 in let minBufferWidth =
632 -- NOTE: cap the spaces at 1,
633 -- to let justifyWidth decide where to add spaces.
634 plainState_bufferWidth `minusNatural` superfluousSpaces
635 in let justifyWidth =
636 -- NOTE: when minBufferWidth is not breakable,
637 -- the length of justification can be wider than
638 -- what remains to reach maxWidth.
639 max minBufferWidth $
640 maxWidth `minusNatural` plainState_bufferStart
641 in let wordCount = countWordsWriter plainState_buffer
642 in unLine $
643 padLineWriterChunkInits justifyWidth $
644 (minBufferWidth, wordCount, List.reverse plainState_buffer)
645
646 {- | @('countWordsWriter' ps)@ returns the number of words in @(ps)@
647 clearly separated by spaces.
648 -}
649 countWordsWriter :: [WriterChunk o] -> Natural
650 countWordsWriter = go False 0
651 where
652 go inWord acc = \case
653 [] -> acc
654 WriterChunk_Word{} : xs ->
655 if inWord
656 then go inWord acc xs
657 else go True (acc + 1) xs
658 WriterChunk_Spaces s : xs
659 | s == 0 -> go inWord acc xs
660 | otherwise -> go False acc xs
661 WriterChunk_Ignored{} : xs -> go inWord acc xs
662
663 {- | @('justifyPadding' a b)@ returns the padding lengths
664 to reach @(a)@ in @(b)@ pads,
665 using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
666 where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
667
668 A simple implementation of 'justifyPadding' could be:
669 @
670 'justifyPadding' a b =
671 'join' ('List.replicate' m [q,q'+'1])
672 <> ('List.replicate' (r'-'m) (q'+'1)
673 <> ('List.replicate' ((b'-'r)'-'m) q
674 where
675 (q,r) = a`divMod`b
676 m = 'min' (b-r) r
677 @
678 -}
679 justifyPadding :: Natural -> Natural -> [Natural]
680 justifyPadding a b = go r (b - r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
681 where
682 (q, r) = a `quotRemNatural` b
683 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
684 go rr 0 = List.replicate (fromIntegral rr) (q + 1) -- when min (b-r) r == r
685 go rr bmr = q : (q + 1) : go (rr `minusNatural` 1) (bmr `minusNatural` 1)
686
687 padLineWriterChunkInits ::
688 Outputable o =>
689 Width ->
690 (Natural, Natural, [WriterChunk o]) ->
691 Line o
692 padLineWriterChunkInits maxWidth (lineWidth, wordCount, line) =
693 Line $
694 if maxWidth <= lineWidth
695 -- The gathered line reached or overreached the maxWidth,
696 -- hence no padding is needed.
697 || wordCount <= 1
698 then -- The case maxWidth <= lineWidth && wordCount == 1
699 -- can happen if first word's length is < maxWidth
700 -- but second word's len is >= maxWidth.
701 joinLineWriterChunk line
702 else -- Share the missing spaces as evenly as possible
703 -- between the words of the line.
704 padLineWriterChunk line $ justifyPadding (maxWidth - lineWidth) (wordCount -1)
705
706 -- | Interleave 'WriterChunk's with 'Width's from 'justifyPadding'.
707 padLineWriterChunk :: Outputable o => [WriterChunk o] -> [Width] -> o
708 padLineWriterChunk = go
709 where
710 go (w : ws) lls@(l : ls) =
711 case w of
712 WriterChunk_Spaces _s -> repeatedChar (fromIntegral (l + 1)) ' ' <> go ws ls
713 _ -> runWriterChunk w <> go ws lls
714 go (w : ws) [] = runWriterChunk w <> go ws []
715 go [] _ls = mempty
716
717 sgrWriter :: Outputable o => [SGR] -> Writer o ()
718 sgrWriter sgr = Writer $ \() inh st k ->
719 if plainInh_justify inh
720 then
721 k
722 ( id
723 , st
724 { plainState_buffer =
725 WriterChunk_Ignored (fromString (setSGRCode sgr)) :
726 plainState_buffer st
727 }
728 )
729 else k ((fromString (setSGRCode sgr) <>), st)
730
731 instance Outputable o => Colorable16 (Writer o) where
732 reverse = plainSGR $ SetSwapForegroundBackground True
733 black = plainSGR $ SetColor Foreground Dull Black
734 red = plainSGR $ SetColor Foreground Dull Red
735 green = plainSGR $ SetColor Foreground Dull Green
736 yellow = plainSGR $ SetColor Foreground Dull Yellow
737 blue = plainSGR $ SetColor Foreground Dull Blue
738 magenta = plainSGR $ SetColor Foreground Dull Magenta
739 cyan = plainSGR $ SetColor Foreground Dull Cyan
740 white = plainSGR $ SetColor Foreground Dull White
741 blacker = plainSGR $ SetColor Foreground Vivid Black
742 redder = plainSGR $ SetColor Foreground Vivid Red
743 greener = plainSGR $ SetColor Foreground Vivid Green
744 yellower = plainSGR $ SetColor Foreground Vivid Yellow
745 bluer = plainSGR $ SetColor Foreground Vivid Blue
746 magentaer = plainSGR $ SetColor Foreground Vivid Magenta
747 cyaner = plainSGR $ SetColor Foreground Vivid Cyan
748 whiter = plainSGR $ SetColor Foreground Vivid White
749 onBlack = plainSGR $ SetColor Background Dull Black
750 onRed = plainSGR $ SetColor Background Dull Red
751 onGreen = plainSGR $ SetColor Background Dull Green
752 onYellow = plainSGR $ SetColor Background Dull Yellow
753 onBlue = plainSGR $ SetColor Background Dull Blue
754 onMagenta = plainSGR $ SetColor Background Dull Magenta
755 onCyan = plainSGR $ SetColor Background Dull Cyan
756 onWhite = plainSGR $ SetColor Background Dull White
757 onBlacker = plainSGR $ SetColor Background Vivid Black
758 onRedder = plainSGR $ SetColor Background Vivid Red
759 onGreener = plainSGR $ SetColor Background Vivid Green
760 onYellower = plainSGR $ SetColor Background Vivid Yellow
761 onBluer = plainSGR $ SetColor Background Vivid Blue
762 onMagentaer = plainSGR $ SetColor Background Vivid Magenta
763 onCyaner = plainSGR $ SetColor Background Vivid Cyan
764 onWhiter = plainSGR $ SetColor Background Vivid White
765 instance Outputable o => Decorable (Writer o) where
766 bold = plainSGR $ SetConsoleIntensity BoldIntensity
767 underline = plainSGR $ SetUnderlining SingleUnderline
768 italic = plainSGR $ SetItalicized True
769
770 plainSGR :: Outputable o => SGR -> Writer o a -> Writer o a
771 plainSGR newSGR p = before .> middle <. after
772 where
773 before = Writer $ \() inh st k ->
774 let o = fromString $ setSGRCode [newSGR]
775 in if plainInh_justify inh
776 then
777 k
778 ( id
779 , st
780 { plainState_buffer =
781 WriterChunk_Ignored o :
782 plainState_buffer st
783 }
784 )
785 else k ((o <>), st)
786 middle = Writer $ \a inh ->
787 unWriter p a inh{plainInh_sgr = newSGR : plainInh_sgr inh}
788 after = Writer $ \() inh st k ->
789 let o = fromString $ setSGRCode $ Reset : List.reverse (plainInh_sgr inh)
790 in if plainInh_justify inh
791 then
792 k
793 ( id
794 , st
795 { plainState_buffer =
796 WriterChunk_Ignored o :
797 plainState_buffer st
798 }
799 )
800 else k ((o <>), st)