1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Symantic.Document.Plain where
6 import Control.Monad (Monad(..))
8 import Data.Char (Char)
9 import Data.Eq (Eq(..))
10 import Data.Function (($), (.), id)
11 import Data.Functor ((<$>))
12 import Data.Maybe (Maybe(..))
13 import Data.Monoid (Monoid(..))
14 import Data.Ord (Ord(..), Ordering(..))
15 import Data.Semigroup (Semigroup(..))
16 import Data.String (String, IsString(..))
17 import Data.Text (Text)
18 import Data.Tuple (snd)
19 import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
20 import Numeric.Natural (Natural)
21 import Prelude (fromIntegral, Num(..), pred)
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.Text.Lazy as TL
28 import Symantic.Document.API
31 -- | Church encoded for performance concerns.
32 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
33 -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
34 -- when in the left hand side of ('<>').
35 -- Prepending is done using continuation, like in a difference list.
36 newtype Plain d = Plain
39 {-curr-}PlainState d ->
40 {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
42 -- NOTE: equivalent to:
43 -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
45 instance (Show d, Spaceable d) => Show (Plain d) where
46 show = show . runPlain
48 runPlain :: Spaceable d => Plain d -> d
53 {-k-}(\(px,_sx) fits _overflow ->
54 -- NOTE: if px fits, then appending mempty fits
59 -- ** Type 'PlainState'
60 data PlainState d = PlainState
61 { plainState_buffer :: ![PlainChunk d]
62 , plainState_bufferStart :: !Column
63 -- ^ The 'Column' from which the 'plainState_buffer'
65 , plainState_bufferWidth :: !Width
66 -- ^ The 'Width' of the 'plainState_buffer' so far.
67 , plainState_breakIndent :: !Indent
68 -- ^ The amount of 'Indent' added by 'breakspace'
69 -- that can be reached by breaking the 'space'
70 -- into a 'newlineJustifyingPlain'.
73 defPlainState :: PlainState d
74 defPlainState = PlainState
75 { plainState_buffer = mempty
76 , plainState_bufferStart = 0
77 , plainState_bufferWidth = 0
78 , plainState_breakIndent = 0
82 data PlainInh d = PlainInh
83 { plainInh_width :: !(Maybe Column)
84 , plainInh_justify :: !Bool
85 , plainInh_indent :: !Indent
86 , plainInh_indenting :: !(Plain d)
87 , plainInh_sgr :: ![SGR]
90 defPlainInh :: Spaceable d => PlainInh d
91 defPlainInh = PlainInh
92 { plainInh_width = Nothing
93 , plainInh_justify = False
95 , plainInh_indenting = mempty
100 -- | Double continuation to qualify the returned document
101 -- as fitting or overflowing the given 'plainInh_width'.
102 -- It's like @('Bool',d)@ in a normal style
103 -- (a non continuation-passing-style).
104 type PlainFit d = {-fits-}(d -> d) ->
105 {-overflow-}(d -> d) ->
108 -- ** Type 'PlainChunk'
110 = PlainChunk_Ignored !d
111 -- ^ Ignored by the justification but kept in place.
112 -- Used for instance to put ANSI sequences.
113 | PlainChunk_Word !(Word d)
114 | PlainChunk_Spaces !Width
115 -- ^ 'spaces' preserved to be interleaved
116 -- correctly with 'PlainChunk_Ignored'.
117 instance Show d => Show (PlainChunk d) where
121 PlainChunk_Ignored d ->
124 PlainChunk_Word (Word d) ->
127 PlainChunk_Spaces s ->
130 instance Lengthable d => Lengthable (PlainChunk d) where
132 PlainChunk_Ignored{} -> 0
133 PlainChunk_Word d -> width d
134 PlainChunk_Spaces s -> s
136 PlainChunk_Ignored{} -> True
137 PlainChunk_Word d -> nullWidth d
138 PlainChunk_Spaces s -> s == 0
139 instance From [SGR] d => From [SGR] (PlainChunk d) where
140 from sgr = PlainChunk_Ignored (from sgr)
142 runPlainChunk :: Spaceable d => PlainChunk d -> d
143 runPlainChunk = \case
144 PlainChunk_Ignored d -> d
145 PlainChunk_Word (Word d) -> d
146 PlainChunk_Spaces s -> spaces s
148 instance Semigroup d => Semigroup (Plain d) where
149 Plain x <> Plain y = Plain $ \inh st k ->
150 x inh st $ \(px,sx) ->
151 y inh sx $ \(py,sy) ->
153 instance Monoid d => Monoid (Plain d) where
154 mempty = Plain $ \_inh st k -> k (id,st)
156 instance Spaceable d => Spaceable (Plain d) where
157 -- | The default 'newline' does not justify 'plainState_buffer',
158 -- for that use 'newlineJustifyingPlain'.
159 newline = Plain $ \inh st ->
163 <> propagatePlain (plainState_breakIndent st)
167 indentPlain = Plain $ \inh ->
169 (plainInh_indenting inh)
170 inh{plainInh_justify=False}
171 newlinePlain = Plain $ \inh st k ->
173 (if plainInh_justify inh
174 then joinLinePlainChunk $ List.reverse $ plainState_buffer st
178 { plainState_bufferStart = 0
179 , plainState_bufferWidth = 0
180 , plainState_buffer = mempty
182 propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
186 -- NOTE: the text after this newline overflows,
187 -- so propagate the overflow before this 'newline',
188 -- if and only if there is a 'breakspace' before this 'newline'
189 -- whose replacement by a 'newline' indents to a lower indent
190 -- than this 'newline''s indent.
191 -- Otherwise there is no point in propagating the overflow.
192 if breakIndent < plainInh_indent inh
197 spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
198 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
199 if plainInh_justify inh
202 { plainState_buffer =
203 case plainState_buffer of
204 PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
205 buf -> PlainChunk_Spaces n:buf
206 , plainState_bufferWidth = plainState_bufferWidth + n
208 case plainInh_width inh of
209 Just maxWidth | maxWidth < newWidth ->
210 overflow $ k (id{-(d<>)-}, newState) fits overflow
211 _ -> k (id{-(d<>)-}, newState) fits overflow
214 { plainState_bufferWidth = plainState_bufferWidth + n
216 case plainInh_width inh of
217 Just maxWidth | maxWidth < newWidth ->
218 overflow $ k ((spaces n <>), newState) fits fits
219 _ -> k ((spaces n <>), newState) fits overflow
220 instance (From (Word s) d, Semigroup d, Lengthable s) =>
221 From (Word s) (Plain d) where
222 from s = Plain $ \inh st@PlainState{..} k fits overflow ->
223 let wordWidth = width s in
225 then k (id,st) fits overflow
227 let newBufferWidth = plainState_bufferWidth + wordWidth in
228 let newWidth = plainState_bufferStart + newBufferWidth in
229 if plainInh_justify inh
232 { plainState_buffer =
233 PlainChunk_Word (Word (from s)) :
235 , plainState_bufferWidth = newBufferWidth
237 case plainInh_width inh of
238 Just maxWidth | maxWidth < newWidth ->
239 overflow $ k (id, newState) fits overflow
240 _ -> k (id, newState) fits overflow
243 { plainState_bufferWidth = newBufferWidth
245 case plainInh_width inh of
246 Just maxWidth | maxWidth < newWidth ->
247 overflow $ k ((from s <>), newState) fits fits
248 _ -> k ((from s <>), newState) fits overflow
249 instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
250 From (Line s) (Plain d) where
253 List.intersperse breakspace .
257 instance Spaceable d => Indentable (Plain d) where
258 align p = (flushlinePlain <>) $ Plain $ \inh st ->
259 let col = plainState_bufferStart st + plainState_bufferWidth st in
261 { plainInh_indent = col
262 , plainInh_indenting =
263 if plainInh_indent inh <= col
265 plainInh_indenting inh <>
266 spaces (col`minusNatural`plainInh_indent inh)
269 setIndent d i p = Plain $ \inh ->
271 { plainInh_indent = i
272 , plainInh_indenting = d
274 incrIndent d i p = Plain $ \inh ->
276 { plainInh_indent = plainInh_indent inh + i
277 , plainInh_indenting = plainInh_indenting inh <> d
280 fill m p = Plain $ \inh0 st0 ->
281 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
282 let p1 = Plain $ \inh1 st1 ->
283 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
286 then spaces (maxCol`minusNatural`col)
290 unPlain (p <> p1) inh0 st0
291 fillOrBreak m p = Plain $ \inh0 st0 ->
292 let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
293 let p1 = Plain $ \inh1 st1 ->
294 let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
296 (case col`compare`maxCol of
297 LT -> spaces (maxCol`minusNatural`col)
299 GT -> incrIndent (spaces m) m newline
302 unPlain (p <> p1) inh0 st0
303 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
307 from (Word '-')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}
312 (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d{-<>flushlinePlain-}) : acc)
313 ) (Fold.length ds, []) ds
314 instance Spaceable d => Justifiable (Plain d) where
315 justify p = (\x -> flushlinePlain <> x <> flushlinePlain) $ Plain $ \inh ->
316 unPlain p inh{plainInh_justify=True}
318 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
319 flushlinePlain :: Spaceable d => Plain d
320 flushlinePlain = Plain $ \_inh st k ->
321 k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
323 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
324 , plainState_bufferWidth = 0
325 , plainState_buffer = mempty
329 collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d
330 collapsePlainChunkSpaces = \case
331 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
334 instance Spaceable d => Wrappable (Plain d) where
335 setWidth w p = Plain $ \inh ->
336 unPlain p inh{plainInh_width=w}
337 breakpoint = Plain $ \inh st k fits overflow ->
338 k(id, st {plainState_breakIndent = plainInh_indent inh})
340 {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
341 breakspace = Plain $ \inh st k fits overflow ->
342 k( if plainInh_justify inh then id else (space <>)
344 { plainState_buffer =
345 if plainInh_justify inh
346 then case plainState_buffer st of
347 PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
348 bs -> PlainChunk_Spaces 1:bs
349 else plainState_buffer st
350 , plainState_bufferWidth = plainState_bufferWidth st + 1
351 , plainState_breakIndent = plainInh_indent inh
355 {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
356 breakalt x y = Plain $ \inh st k fits overflow ->
357 -- NOTE: breakalt must be y if and only if x does not fit,
358 -- hence the use of dummyK to limit the test
359 -- to overflows raised within x, and drop those raised after x.
360 unPlain x inh st dummyK
361 {-fits-} (\_r -> unPlain x inh st k fits overflow)
362 {-overflow-}(\_r -> unPlain y inh st k fits overflow)
364 dummyK (px,_sx) fits _overflow =
365 -- NOTE: if px fits, then appending mempty fits
367 endline = Plain $ \inh st k fits _overflow ->
368 let col = plainState_bufferStart st + plainState_bufferWidth st in
369 case plainInh_width inh >>= (`minusNaturalMaybe` col) of
370 Nothing -> k (id, st) fits fits
373 { plainState_bufferWidth = plainState_bufferWidth st + w
375 k (id,newState) fits fits
377 -- | Like 'newline', but justify 'plainState_buffer' before.
378 newlineJustifyingPlain :: Spaceable d => Plain d
379 newlineJustifyingPlain = Plain $ \inh st ->
383 <> propagatePlain (plainState_breakIndent st)
387 indentPlain = Plain $ \inh ->
389 (plainInh_indenting inh)
390 inh{plainInh_justify=False}
391 newlinePlain = Plain $ \inh st k ->
393 (if plainInh_justify inh
394 then justifyLinePlain inh st
398 { plainState_bufferStart = 0
399 , plainState_bufferWidth = 0
400 , plainState_buffer = mempty
402 propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
406 -- NOTE: the text after this newline overflows,
407 -- so propagate the overflow before this 'newline',
408 -- if and only if there is a 'breakspace' before this 'newline'
409 -- whose replacement by a 'newline' indents to a lower indent
410 -- than this 'newline''s indent.
411 -- Otherwise there is no point in propagating the overflow.
412 if breakIndent < plainInh_indent inh
418 instance (From (Word String) d, Spaceable d) =>
419 From String (Plain d) where
422 List.intersperse newline .
425 instance (From (Word String) d, Spaceable d) =>
426 IsString (Plain d) where
429 instance (From (Word Text) d, Spaceable d) =>
430 From Text (Plain d) where
433 List.intersperse newline .
436 instance (From (Word TL.Text) d, Spaceable d) =>
437 From TL.Text (Plain d) where
440 List.intersperse newline .
444 instance (From (Word Char) d, Spaceable d) =>
445 From Char (Plain d) where
446 from ' ' = breakspace
448 from c = from (Word c)
450 instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
451 from sgr = Plain $ \inh st k ->
452 if plainInh_justify inh
453 then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
454 else k ((from sgr <>), st)
459 PlainInh d -> PlainState d -> d
460 justifyLinePlain inh PlainState{..} =
461 case plainInh_width inh of
462 Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
464 if maxWidth < plainState_bufferStart
465 || maxWidth < plainInh_indent inh
466 then joinLinePlainChunk $ List.reverse plainState_buffer
468 let superfluousSpaces = Fold.foldr
471 PlainChunk_Ignored{} -> 0
472 PlainChunk_Word{} -> 0
473 PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
474 0 plainState_buffer in
476 -- NOTE: cap the spaces at 1,
477 -- to let justifyWidth decide where to add spaces.
478 plainState_bufferWidth`minusNatural`superfluousSpaces in
480 -- NOTE: when minBufferWidth is not breakable,
481 -- the width of justification can be wider than
482 -- what remains to reach maxWidth.
484 maxWidth`minusNatural`plainState_bufferStart
486 let wordCount = countWordsPlain plainState_buffer in
487 unLine $ padLinePlainChunkInits justifyWidth $
488 (minBufferWidth,wordCount,List.reverse plainState_buffer)
490 -- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
491 -- clearly separated by spaces.
492 countWordsPlain :: [PlainChunk d] -> Natural
493 countWordsPlain = go False 0
495 go inWord acc = \case
497 PlainChunk_Word{}:xs ->
499 then go inWord acc xs
500 else go True (acc+1) xs
501 PlainChunk_Spaces s:xs
502 | s == 0 -> go inWord acc xs
503 | otherwise -> go False acc xs
504 PlainChunk_Ignored{}:xs -> go inWord acc xs
506 -- | @('justifyPadding' a b)@ returns the padding lengths
507 -- to reach @(a)@ in @(b)@ pads,
508 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
509 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
511 -- A simple implementation of 'justifyPadding' could be:
513 -- 'justifyPadding' a b =
514 -- 'join' ('List.replicate' m [q,q'+'1])
515 -- <> ('List.replicate' (r'-'m) (q'+'1)
516 -- <> ('List.replicate' ((b'-'r)'-'m) q
518 -- (q,r) = a`divMod`b
521 justifyPadding :: Natural -> Natural -> [Natural]
522 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
524 (q,r) = a`quotRemNatural`b
526 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
527 go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
528 go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
530 padLinePlainChunkInits ::
532 Width -> (Natural, Natural, [PlainChunk d]) -> Line d
533 padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
534 if maxWidth <= lineWidth
535 -- The gathered line reached or overreached the maxWidth,
536 -- hence no padding id needed.
538 -- The case maxWidth <= lineWidth && wordCount == 1
539 -- can happen if first word's length is < maxWidth
540 -- but second word's len is >= maxWidth.
541 then joinLinePlainChunk line
543 -- Share the missing spaces as evenly as possible
544 -- between the words of the line.
545 padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
547 -- | Just concat 'PlainChunk's with no justification.
548 joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
549 joinLinePlainChunk = mconcat . (runPlainChunk <$>)
551 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
552 padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
553 padLinePlainChunk = go
555 go (w:ws) lls@(l:ls) =
557 PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
558 _ -> runPlainChunk w <> go ws lls
559 go (w:ws) [] = runPlainChunk w <> go ws []
563 instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where
564 reverse = plainSGR $ SetSwapForegroundBackground True
565 black = plainSGR $ SetColor Foreground Dull Black
566 red = plainSGR $ SetColor Foreground Dull Red
567 green = plainSGR $ SetColor Foreground Dull Green
568 yellow = plainSGR $ SetColor Foreground Dull Yellow
569 blue = plainSGR $ SetColor Foreground Dull Blue
570 magenta = plainSGR $ SetColor Foreground Dull Magenta
571 cyan = plainSGR $ SetColor Foreground Dull Cyan
572 white = plainSGR $ SetColor Foreground Dull White
573 blacker = plainSGR $ SetColor Foreground Vivid Black
574 redder = plainSGR $ SetColor Foreground Vivid Red
575 greener = plainSGR $ SetColor Foreground Vivid Green
576 yellower = plainSGR $ SetColor Foreground Vivid Yellow
577 bluer = plainSGR $ SetColor Foreground Vivid Blue
578 magentaer = plainSGR $ SetColor Foreground Vivid Magenta
579 cyaner = plainSGR $ SetColor Foreground Vivid Cyan
580 whiter = plainSGR $ SetColor Foreground Vivid White
581 onBlack = plainSGR $ SetColor Background Dull Black
582 onRed = plainSGR $ SetColor Background Dull Red
583 onGreen = plainSGR $ SetColor Background Dull Green
584 onYellow = plainSGR $ SetColor Background Dull Yellow
585 onBlue = plainSGR $ SetColor Background Dull Blue
586 onMagenta = plainSGR $ SetColor Background Dull Magenta
587 onCyan = plainSGR $ SetColor Background Dull Cyan
588 onWhite = plainSGR $ SetColor Background Dull White
589 onBlacker = plainSGR $ SetColor Background Vivid Black
590 onRedder = plainSGR $ SetColor Background Vivid Red
591 onGreener = plainSGR $ SetColor Background Vivid Green
592 onYellower = plainSGR $ SetColor Background Vivid Yellow
593 onBluer = plainSGR $ SetColor Background Vivid Blue
594 onMagentaer = plainSGR $ SetColor Background Vivid Magenta
595 onCyaner = plainSGR $ SetColor Background Vivid Cyan
596 onWhiter = plainSGR $ SetColor Background Vivid White
597 instance (Semigroup d, From [SGR] d) => Decorable (Plain d) where
598 bold = plainSGR $ SetConsoleIntensity BoldIntensity
599 underline = plainSGR $ SetUnderlining SingleUnderline
600 italic = plainSGR $ SetItalicized True
605 SGR -> Plain d -> Plain d
606 plainSGR newSGR p = before <> middle <> after
608 before = Plain $ \inh st k ->
609 let d = from [newSGR] in
610 if plainInh_justify inh
612 { plainState_buffer =
613 PlainChunk_Ignored d :
617 middle = Plain $ \inh ->
618 unPlain p inh{plainInh_sgr=newSGR:plainInh_sgr inh}
619 after = Plain $ \inh st k ->
620 let d = from $ Reset : List.reverse (plainInh_sgr inh) in
621 if plainInh_justify inh
623 { plainState_buffer =
624 PlainChunk_Ignored d :