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 'newline'.
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 newline = Plain $ \inh st k ->
153 (if plainInh_justify inh then joinLine inh st else mempty) <>
154 newline<>spaces (plainInh_indent inh)<>next
156 { plainState_bufferStart = plainInh_indent inh
157 , plainState_bufferWidth = 0
158 , plainState_buffer = mempty
162 spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
163 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
164 if plainInh_justify inh
167 case plainState_buffer of
168 PlainChunk_Spaces s:bs -> st
169 { plainState_buffer = PlainChunk_Spaces (s+n):bs
172 { plainState_buffer = PlainChunk_Spaces n:plainState_buffer
173 , plainState_bufferWidth = plainState_bufferWidth + 1
176 case plainInh_width inh of
177 Just maxWidth | maxWidth < newWidth ->
178 overflow $ k (id{-(d<>)-}, newState) fits overflow
179 _ -> k (id{-(d<>)-}, newState) fits overflow
182 { plainState_bufferWidth = plainState_bufferWidth + n
184 case plainInh_width inh of
185 Just maxWidth | maxWidth < newWidth ->
186 overflow $ k ((spaces n <>), newState) fits fits
187 _ -> k ((spaces n <>), newState) fits overflow
188 instance (From (Word s) d, Semigroup d, Lengthable s) =>
189 From (Word s) (Plain d) where
190 from s = Plain $ \inh st@PlainState{..} k fits overflow ->
191 let wordWidth = width s in
193 then k (id,st) fits overflow
195 let newBufferWidth = plainState_bufferWidth + wordWidth in
196 let newWidth = plainState_bufferStart + newBufferWidth in
197 if plainInh_justify inh
200 { plainState_buffer =
201 PlainChunk_Word (Word (from s)) :
203 , plainState_bufferWidth = newBufferWidth
205 case plainInh_width inh of
206 Just maxWidth | maxWidth < newWidth ->
207 overflow $ k (id, newState) fits overflow
208 _ -> k (id, newState) fits overflow
211 { plainState_bufferWidth = newBufferWidth
213 case plainInh_width inh of
214 Just maxWidth | maxWidth < newWidth ->
215 overflow $ k ((from s <>), newState) fits fits
216 _ -> k ((from s <>), newState) fits overflow
217 instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
218 From (Line s) (Plain d) where
221 List.intersperse breakspace .
225 instance Spaceable d => Indentable (Plain d) where
226 align p = (flushLine <>) $ Plain $ \inh st ->
227 let currInd = plainState_bufferStart st + plainState_bufferWidth st in
228 unPlain p inh{plainInh_indent=currInd} st
229 incrIndent i p = Plain $ \inh ->
230 unPlain p inh{plainInh_indent = plainInh_indent inh + i}
231 setIndent i p = Plain $ \inh ->
232 unPlain p inh{plainInh_indent=i}
233 fill m p = Plain $ \inh0 st0 ->
234 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
235 let p1 = Plain $ \inh1 st1 ->
236 let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
237 let w | col0 <= col1 = col1`minusNatural`col0
238 | otherwise = col0`minusNatural`col1 in
241 then spaces (m`minusNatural`w)
245 unPlain (p <> p1) inh0 st0
246 breakfill m p = Plain $ \inh0 st0 ->
247 let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
248 let p1 = Plain $ \inh1 st1 ->
249 let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
250 let w | col0 <= col1 = col1`minusNatural`col0
251 | otherwise = col0`minusNatural`col1 in
254 LT -> spaces (m`minusNatural`w)
256 GT -> setIndent (col0 + m) newline)
259 unPlain (p <> p1) inh0 st0
260 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
264 from (Word '-')<>space<>flushLine<>align d<>flushLine
269 (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
270 ) (Fold.length ds, []) ds
271 instance Spaceable d => Justifiable (Plain d) where
272 justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
273 unPlain p inh{plainInh_justify=True}
275 -- | Commit 'plainState_buffer' upto there, so that it won't be justified.
276 flushLine :: Spaceable d => Plain d
277 flushLine = Plain $ \_inh st ok ->
279 ( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
281 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
282 , plainState_bufferWidth = 0
283 , plainState_buffer = mempty
287 collapseSpaces :: PlainChunk d -> PlainChunk d
288 collapseSpaces = \case
289 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
292 instance Spaceable d => Wrappable (Plain d) where
293 setWidth w p = Plain $ \inh ->
294 unPlain p inh{plainInh_width=w}
295 breakpoint = Plain $ \inh st k fits overflow ->
296 let newlineInd = plainInh_indent inh in
300 { plainState_removableIndent = newlineInd
305 unPlain newline inh st k
308 if plainState_removableIndent st < newlineInd
313 breakspace = Plain $ \inh st k fits overflow ->
314 let newlineInd = plainInh_indent inh in
316 ( if plainInh_justify inh then id else (space <>)
318 { plainState_buffer =
319 if plainInh_justify inh
320 then case plainState_buffer st of
321 PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
322 bs -> PlainChunk_Spaces 1:bs
323 else plainState_buffer st
324 , plainState_bufferWidth = plainState_bufferWidth st + 1
325 , plainState_removableIndent = newlineInd
330 unPlain newline inh st k
333 if plainState_removableIndent st < newlineInd
338 breakalt x y = Plain $ \inh st k fits overflow ->
339 unPlain x inh st k fits
341 unPlain y inh st k fits overflow
344 instance (From (Word String) d, Spaceable d) =>
345 From String (Plain d) where
348 List.intersperse newline .
351 instance (From (Word String) d, Spaceable d) =>
352 IsString (Plain d) where
355 instance (From (Word Text) d, Spaceable d) =>
356 From Text (Plain d) where
359 List.intersperse newline .
362 instance (From (Word TL.Text) d, Spaceable d) =>
363 From TL.Text (Plain d) where
366 List.intersperse newline .
370 instance (From (Word Char) d, Spaceable d) =>
371 From Char (Plain d) where
372 from ' ' = breakspace
374 from c = from (Word c)
377 instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
378 from sgr = Plain $ \inh st k ->
379 if plainInh_justify inh
380 then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
381 else k ((from sgr <>), st)
385 PlainInh -> PlainState d -> d
386 joinLine PlainInh{..} PlainState{..} =
387 case plainInh_width of
388 Nothing -> joinPlainLine $ List.reverse plainState_buffer
390 if maxWidth < plainState_bufferStart
391 || maxWidth < plainInh_indent
392 then joinPlainLine $ List.reverse plainState_buffer
394 let superfluousSpaces = Fold.foldr
397 PlainChunk_Ignored{} -> 0
398 PlainChunk_Word{} -> 0
399 PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
400 0 plainState_buffer in
402 -- NOTE: cap the spaces at 1,
403 -- to let justifyWidth decide where to add spaces.
404 plainState_bufferWidth`minusNatural`superfluousSpaces in
406 -- NOTE: when minBufferWidth is not breakable,
407 -- the width of justification can be wider than
408 -- what remains to reach maxWidth.
410 maxWidth`minusNatural`plainState_bufferStart
412 let wordCount = countWords plainState_buffer in
413 unLine $ padPlainLineInits justifyWidth $
414 (minBufferWidth,wordCount,List.reverse plainState_buffer)
416 -- | @('countWords' ps)@ returns the number of words in @(ps)@
417 -- clearly separated by spaces.
418 countWords :: [PlainChunk d] -> Natural
419 countWords = go False 0
421 go inWord acc = \case
423 PlainChunk_Word{}:xs ->
425 then go inWord acc xs
426 else go True (acc+1) xs
427 PlainChunk_Spaces s:xs
428 | s == 0 -> go inWord acc xs
429 | otherwise -> go False acc xs
430 PlainChunk_Ignored{}:xs -> go inWord acc xs
432 -- | @('justifyPadding' a b)@ returns the padding lengths
433 -- to reach @(a)@ in @(b)@ pads,
434 -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@
435 -- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.
437 -- A simple implementation of 'justifyPadding' could be:
439 -- 'justifyPadding' a b =
440 -- 'join' ('List.replicate' m [q,q'+'1])
441 -- <> ('List.replicate' (r'-'m) (q'+'1)
442 -- <> ('List.replicate' ((b'-'r)'-'m) q
444 -- (q,r) = a`divMod`b
447 justifyPadding :: Natural -> Natural -> [Natural]
448 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
450 (q,r) = a`quotRemNatural`b
452 go 0 bmr = List.replicate (fromIntegral bmr) q -- when min (b-r) r == b-r
453 go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
454 go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
458 Width -> (Natural, Natural, [PlainChunk d]) -> Line d
459 padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
460 if maxWidth <= lineWidth
461 -- The gathered line reached or overreached the maxWidth,
462 -- hence no padding id needed.
464 -- The case maxWidth <= lineWidth && wordCount == 1
465 -- can happen if first word's length is < maxWidth
466 -- but second word's len is >= maxWidth.
467 then joinPlainLine line
469 -- Share the missing spaces as evenly as possible
470 -- between the words of the line.
471 padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
473 -- | Just concat 'PlainChunk's with no justification.
474 joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
475 joinPlainLine = mconcat . (runPlainChunk <$>)
477 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
478 padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
481 go (w:ws) lls@(l:ls) =
483 PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls
484 _ -> runPlainChunk w <> go ws lls
485 go (w:ws) [] = runPlainChunk w <> go ws []