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