1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Symantic.Document.Plain where
7 import Data.Char (Char)
8 import Data.Eq (Eq(..))
9 import Data.Function (($), (.), id)
10 import Data.Functor ((<$>))
11 import Data.Maybe (Maybe(..))
12 import Data.Monoid (Monoid(..))
13 import Data.Ord (Ord(..), Ordering(..))
14 import Data.Semigroup (Semigroup(..))
15 import Data.String (String, IsString(..))
16 import Data.Text (Text)
17 import Data.Tuple (snd)
18 import GHC.Natural (minusNatural,quotRemNatural)
19 import Numeric.Natural (Natural)
20 import Prelude (fromIntegral, Num(..), pred)
21 import System.Console.ANSI
22 import Text.Show (Show(..), showString, showParen)
23 import qualified Data.Foldable as Fold
24 import qualified Data.List as List
25 import qualified Data.Text.Lazy as TL
27 import Symantic.Document.API
30 -- | Church encoded for performance concerns.
31 -- Kind like 'ParsecT' in @megaparsec@ but a little bit different
32 -- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly
33 -- when in the left hand side of ('<>').
34 -- Prepending is done using continuation, like in a difference list.
35 newtype Plain d = Plain
38 {-curr-}PlainState d ->
39 {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
41 -- NOTE: equivalent to:
42 -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
44 instance (Show d, Monoid d) => Show (Plain d) where
45 show = show . runPlain
47 runPlain :: Monoid d => Plain d -> d
52 {-k-}(\(px,_sx) fits _overflow ->
53 -- NOTE: if px fits, then appending mempty fits
58 -- ** Type 'PlainState'
59 data PlainState d = PlainState
60 { plainState_buffer :: ![PlainChunk d]
61 , plainState_bufferStart :: !Column
62 -- ^ The 'Column' from which the 'plainState_buffer'
64 , plainState_bufferWidth :: !Width
65 -- ^ The 'Width' of the 'plainState_buffer' so far.
66 , plainState_removableIndent :: !Indent
67 -- ^ The amount of 'Indent' added by 'breakspace'
68 -- that can be removed by breaking the 'space' into a 'newlineJustifying'.
71 defPlainState :: PlainState d
72 defPlainState = PlainState
73 { plainState_buffer = mempty
74 , plainState_bufferStart = 0
75 , plainState_bufferWidth = 0
76 , plainState_removableIndent = 0
80 data PlainInh = PlainInh
81 { plainInh_width :: !(Maybe Column)
82 , plainInh_justify :: !Bool
83 , plainInh_indent :: !Width
86 defPlainInh :: PlainInh
87 defPlainInh = PlainInh
88 { plainInh_width = Nothing
89 , plainInh_justify = False
94 -- | Double continuation to qualify the returned document
95 -- as fitting or overflowing the given 'plainInh_width'.
96 -- It's like @('Bool',d)@ in a normal style
97 -- (a non continuation-passing-style).
98 type PlainFit d = {-fits-}(d -> d) ->
99 {-overflow-}(d -> d) ->
102 -- ** Type 'PlainChunk'
104 = PlainChunk_Ignored d
105 -- ^ Ignored by the justification but kept in place.
106 -- Used for instance to put ANSI sequences.
107 | PlainChunk_Word (Word d)
108 | PlainChunk_Spaces Width
109 -- ^ 'spaces' preserved to be interleaved
110 -- correctly with 'PlainChunk_Ignored'.
111 instance Show d => Show (PlainChunk d) where
115 PlainChunk_Ignored d ->
118 PlainChunk_Word (Word d) ->
121 PlainChunk_Spaces s ->
124 instance Lengthable d => Lengthable (PlainChunk d) where
126 PlainChunk_Ignored{} -> 0
127 PlainChunk_Word d -> width d
128 PlainChunk_Spaces s -> s
130 PlainChunk_Ignored{} -> True
131 PlainChunk_Word d -> nullWidth d
132 PlainChunk_Spaces s -> s == 0
133 instance From [SGR] d => From [SGR] (PlainChunk d) where
134 from sgr = PlainChunk_Ignored (from sgr)
136 runPlainChunk :: Spaceable d => PlainChunk d -> d
137 runPlainChunk = \case
138 PlainChunk_Ignored d -> d
139 PlainChunk_Word (Word d) -> d
140 PlainChunk_Spaces s -> spaces s
142 instance Semigroup d => Semigroup (Plain d) where
143 Plain x <> Plain y = Plain $ \inh st k ->
144 x inh st $ \(px,sx) ->
145 y inh sx $ \(py,sy) ->
147 instance Monoid d => Monoid (Plain d) where
148 mempty = Plain $ \_inh st k -> k (id,st)
150 instance Spaceable d => Spaceable (Plain d) where
151 -- | The default 'newline' does not justify
152 -- 'plainState_buffer', for that use 'newlineJustifying'.
153 newline = Plain $ \inh st k ->
155 (if plainInh_justify inh
156 then joinPlainLine $ List.reverse $ plainState_buffer st
158 newline<>spaces (plainInh_indent inh)<>next
160 { plainState_bufferStart = plainInh_indent inh
161 , plainState_bufferWidth = 0
162 , plainState_buffer = mempty
166 spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
167 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
168 if plainInh_justify inh
171 case plainState_buffer of
172 PlainChunk_Spaces s:bs -> st
173 { plainState_buffer = PlainChunk_Spaces (s+n):bs
176 { plainState_buffer = PlainChunk_Spaces n:plainState_buffer
177 , plainState_bufferWidth = plainState_bufferWidth + 1
180 case plainInh_width inh of
181 Just maxWidth | maxWidth < newWidth ->
182 overflow $ k (id{-(d<>)-}, newState) fits overflow
183 _ -> k (id{-(d<>)-}, newState) fits overflow
186 { plainState_bufferWidth = plainState_bufferWidth + n
188 case plainInh_width inh of
189 Just maxWidth | maxWidth < newWidth ->
190 overflow $ k ((spaces n <>), newState) fits fits
191 _ -> k ((spaces n <>), newState) fits overflow
192 instance (From (Word s) d, Semigroup d, Lengthable s) =>
193 From (Word s) (Plain d) where
194 from s = Plain $ \inh st@PlainState{..} k fits overflow ->
195 let wordWidth = width s in
197 then k (id,st) fits overflow
199 let newBufferWidth = plainState_bufferWidth + wordWidth in
200 let newWidth = plainState_bufferStart + newBufferWidth in
201 if plainInh_justify inh
204 { plainState_buffer =
205 PlainChunk_Word (Word (from s)) :
207 , plainState_bufferWidth = newBufferWidth
209 case plainInh_width inh of
210 Just maxWidth | maxWidth < newWidth ->
211 overflow $ k (id, newState) fits overflow
212 _ -> k (id, newState) fits overflow
215 { plainState_bufferWidth = newBufferWidth
217 case plainInh_width inh of
218 Just maxWidth | maxWidth < newWidth ->
219 overflow $ k ((from s <>), newState) fits fits
220 _ -> k ((from s <>), newState) fits overflow
221 instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
222 From (Line s) (Plain d) where
225 List.intersperse breakspace .
229 instance Spaceable d => Indentable (Plain d) where
230 align p = (flushLine <>) $ Plain $ \inh st ->
231 let currInd = plainState_bufferStart st + plainState_bufferWidth st in
232 unPlain p inh{plainInh_indent=currInd} st
233 incrIndent i p = Plain $ \inh ->
234 unPlain p inh{plainInh_indent = plainInh_indent inh + i}
235 setIndent i p = Plain $ \inh ->
236 unPlain p inh{plainInh_indent=i}
237 fill m p = Plain $ \inh0 st0 ->
238 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
239 let p1 = Plain $ \inh1 st1 ->
240 let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
241 let w | col0 <= col1 = col1`minusNatural`col0
242 | otherwise = col0`minusNatural`col1 in
245 then spaces (m`minusNatural`w)
249 unPlain (p <> p1) inh0 st0
250 breakfill m p = Plain $ \inh0 st0 ->
251 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
252 let p1 = Plain $ \inh1 st1 ->
253 let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
254 let w | col0 <= col1 = col1`minusNatural`col0
255 | otherwise = col0`minusNatural`col1 in
258 LT -> spaces (m`minusNatural`w)
260 GT -> setIndent (col0 + m) newline)
263 unPlain (p <> p1) inh0 st0
264 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
268 from (Word '-')<>space<>flushLine<>align d<>flushLine
273 (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
274 ) (Fold.length ds, []) ds
275 instance Spaceable d => Justifiable (Plain d) where
276 justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
277 unPlain p inh{plainInh_justify=True}
279 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
280 flushLine :: Spaceable d => Plain d
281 flushLine = Plain $ \_inh st k ->
282 k( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
284 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
285 , plainState_bufferWidth = 0
286 , plainState_buffer = mempty
290 collapseSpaces :: PlainChunk d -> PlainChunk d
291 collapseSpaces = \case
292 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
295 instance Spaceable d => Wrappable (Plain d) where
296 setWidth w p = Plain $ \inh ->
297 unPlain p inh{plainInh_width=w}
298 breakpoint = Plain $ \inh st k fits overflow ->
299 let newlineInd = plainInh_indent inh in
303 { plainState_removableIndent = newlineInd
308 unPlain newlineJustifying inh st k
311 if plainState_removableIndent st < newlineInd
316 breakspace = Plain $ \inh st k fits overflow ->
317 let newlineInd = plainInh_indent inh in
319 ( if plainInh_justify inh then id else (space <>)
321 { plainState_buffer =
322 if plainInh_justify inh
323 then case plainState_buffer st of
324 PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
325 bs -> PlainChunk_Spaces 1:bs
326 else plainState_buffer st
327 , plainState_bufferWidth = plainState_bufferWidth st + 1
328 , plainState_removableIndent = newlineInd
333 unPlain newlineJustifying inh st k
336 if plainState_removableIndent st < newlineInd
341 breakalt x y = Plain $ \inh st k fits overflow ->
342 unPlain x inh st k fits
344 unPlain y inh st k fits overflow
347 -- | Like 'newline', but justify 'plainState_buffer' before.
348 newlineJustifying :: Spaceable d => Plain d
349 newlineJustifying = Plain $ \inh st k ->
351 (if plainInh_justify inh then joinLine inh st else mempty) <>
352 newline<>spaces (plainInh_indent inh)<>next
354 { plainState_bufferStart = plainInh_indent inh
355 , plainState_bufferWidth = 0
356 , plainState_buffer = mempty
361 instance (From (Word String) d, Spaceable d) =>
362 From String (Plain d) where
365 List.intersperse newline .
368 instance (From (Word String) d, Spaceable d) =>
369 IsString (Plain d) where
372 instance (From (Word Text) d, Spaceable d) =>
373 From Text (Plain d) where
376 List.intersperse newline .
379 instance (From (Word TL.Text) d, Spaceable d) =>
380 From TL.Text (Plain d) where
383 List.intersperse newline .
387 instance (From (Word Char) d, Spaceable d) =>
388 From Char (Plain d) where
389 from ' ' = breakspace
391 from c = from (Word c)
394 instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
395 from sgr = Plain $ \inh st k ->
396 if plainInh_justify inh
397 then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
398 else k ((from sgr <>), st)
402 PlainInh -> PlainState d -> d
403 joinLine PlainInh{..} PlainState{..} =
404 case plainInh_width of
405 Nothing -> joinPlainLine $ List.reverse plainState_buffer
407 if maxWidth < plainState_bufferStart
408 || maxWidth < plainInh_indent
409 then joinPlainLine $ List.reverse plainState_buffer
411 let superfluousSpaces = Fold.foldr
414 PlainChunk_Ignored{} -> 0
415 PlainChunk_Word{} -> 0
416 PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
417 0 plainState_buffer in
419 -- NOTE: cap the spaces at 1,
420 -- to let justifyWidth decide where to add spaces.
421 plainState_bufferWidth`minusNatural`superfluousSpaces in
423 -- NOTE: when minBufferWidth is not breakable,
424 -- the width of justification can be wider than
425 -- what remains to reach maxWidth.
427 maxWidth`minusNatural`plainState_bufferStart
429 let wordCount = countWords plainState_buffer in
430 unLine $ padPlainLineInits justifyWidth $
431 (minBufferWidth,wordCount,List.reverse plainState_buffer)
433 -- | @('countWords' ps)@ returns the number of words in @(ps)@
434 -- clearly separated by spaces.
435 countWords :: [PlainChunk d] -> Natural
436 countWords = go False 0
438 go inWord acc = \case
440 PlainChunk_Word{}:xs ->
442 then go inWord acc xs
443 else go True (acc+1) xs
444 PlainChunk_Spaces s:xs
445 | s == 0 -> go inWord acc xs
446 | otherwise -> go False acc xs
447 PlainChunk_Ignored{}:xs -> go inWord acc xs
449 -- | @('justifyPadding' a b)@ returns the padding lengths
450 -- to reach @(a)@ in @(b)@ pads,
451 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
452 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
454 -- A simple implementation of 'justifyPadding' could be:
456 -- 'justifyPadding' a b =
457 -- 'join' ('List.replicate' m [q,q'+'1])
458 -- <> ('List.replicate' (r'-'m) (q'+'1)
459 -- <> ('List.replicate' ((b'-'r)'-'m) q
461 -- (q,r) = a`divMod`b
464 justifyPadding :: Natural -> Natural -> [Natural]
465 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
467 (q,r) = a`quotRemNatural`b
469 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
470 go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
471 go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
475 Width -> (Natural, Natural, [PlainChunk d]) -> Line d
476 padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
477 if maxWidth <= lineWidth
478 -- The gathered line reached or overreached the maxWidth,
479 -- hence no padding id needed.
481 -- The case maxWidth <= lineWidth && wordCount == 1
482 -- can happen if first word's length is < maxWidth
483 -- but second word's len is >= maxWidth.
484 then joinPlainLine line
486 -- Share the missing spaces as evenly as possible
487 -- between the words of the line.
488 padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
490 -- | Just concat 'PlainChunk's with no justification.
491 joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
492 joinPlainLine = mconcat . (runPlainChunk <$>)
494 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
495 padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
498 go (w:ws) lls@(l:ls) =
500 PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
501 _ -> runPlainChunk w <> go ws lls
502 go (w:ws) [] = runPlainChunk w <> go ws []