]> Git — Sourcephile - haskell/symantic-document.git/blob - Symantic/Document/Plain.hs
plain: fix flushing in align and ul/ol
[haskell/symantic-document.git] / Symantic / Document / Plain.hs
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE NoMonomorphismRestriction #-}
3 {-# LANGUAGE UndecidableInstances #-}
4 module Symantic.Document.Plain where
5
6 import Data.Bool
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
26
27 import Symantic.Document.API
28
29 -- * Type 'Plain'
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
36 { unPlain ::
37 {-curr-}PlainInh ->
38 {-curr-}PlainState d ->
39 {-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
40 PlainFit d
41 -- NOTE: equivalent to:
42 -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
43 }
44 instance (Show d, Monoid d) => Show (Plain d) where
45 show = show . runPlain
46
47 runPlain :: Monoid d => Plain d -> d
48 runPlain x =
49 unPlain x
50 defPlainInh
51 defPlainState
52 {-k-}(\(px,_sx) fits _overflow ->
53 -- NOTE: if px fits, then appending mempty fits
54 fits (px mempty) )
55 {-fits-}id
56 {-overflow-}id
57
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'
63 -- must be written.
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'.
69 } deriving (Show)
70
71 defPlainState :: PlainState d
72 defPlainState = PlainState
73 { plainState_buffer = mempty
74 , plainState_bufferStart = 0
75 , plainState_bufferWidth = 0
76 , plainState_removableIndent = 0
77 }
78
79 -- ** Type 'PlainInh'
80 data PlainInh = PlainInh
81 { plainInh_width :: !(Maybe Column)
82 , plainInh_justify :: !Bool
83 , plainInh_indent :: !Width
84 } deriving (Show)
85
86 defPlainInh :: PlainInh
87 defPlainInh = PlainInh
88 { plainInh_width = Nothing
89 , plainInh_justify = False
90 , plainInh_indent = 0
91 }
92
93 -- ** Type 'PlainFit'
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) ->
100 d
101
102 -- ** Type 'PlainChunk'
103 data PlainChunk d
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
112 showsPrec p x =
113 showParen (p>10) $
114 case x of
115 PlainChunk_Ignored d ->
116 showString "Z " .
117 showsPrec 11 d
118 PlainChunk_Word (Word d) ->
119 showString "W " .
120 showsPrec 11 d
121 PlainChunk_Spaces s ->
122 showString "S " .
123 showsPrec 11 s
124 instance Lengthable d => Lengthable (PlainChunk d) where
125 width = \case
126 PlainChunk_Ignored{} -> 0
127 PlainChunk_Word d -> width d
128 PlainChunk_Spaces s -> s
129 nullWidth = \case
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)
135
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
141
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) ->
146 k (px.py,sy)
147 instance Monoid d => Monoid (Plain d) where
148 mempty = Plain $ \_inh st k -> k (id,st)
149 mappend = (<>)
150 instance Spaceable d => Spaceable (Plain d) where
151 newline = Plain $ \inh st k ->
152 k(\next ->
153 (if plainInh_justify inh then joinLine inh st else mempty) <>
154 newline<>spaces (plainInh_indent inh)<>next
155 , st
156 { plainState_bufferStart = plainInh_indent inh
157 , plainState_bufferWidth = 0
158 , plainState_buffer = mempty
159 }
160 )
161 space = spaces 1
162 spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
163 let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
164 if plainInh_justify inh
165 then
166 let newState =
167 case plainState_buffer of
168 PlainChunk_Spaces s:bs -> st
169 { plainState_buffer = PlainChunk_Spaces (s+n):bs
170 }
171 _ -> st
172 { plainState_buffer = PlainChunk_Spaces n:plainState_buffer
173 , plainState_bufferWidth = plainState_bufferWidth + 1
174 }
175 in
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
180 else
181 let newState = st
182 { plainState_bufferWidth = plainState_bufferWidth + n
183 } in
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
192 if wordWidth <= 0
193 then k (id,st) fits overflow
194 else
195 let newBufferWidth = plainState_bufferWidth + wordWidth in
196 let newWidth = plainState_bufferStart + newBufferWidth in
197 if plainInh_justify inh
198 then
199 let newState = st
200 { plainState_buffer =
201 PlainChunk_Word (Word (from s)) :
202 plainState_buffer
203 , plainState_bufferWidth = newBufferWidth
204 } in
205 case plainInh_width inh of
206 Just maxWidth | maxWidth < newWidth ->
207 overflow $ k (id, newState) fits overflow
208 _ -> k (id, newState) fits overflow
209 else
210 let newState = st
211 { plainState_bufferWidth = newBufferWidth
212 } in
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
219 from =
220 mconcat .
221 List.intersperse breakspace .
222 (from <$>) .
223 words .
224 unLine
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
239 unPlain
240 (if w<=m
241 then spaces (m`minusNatural`w)
242 else mempty)
243 inh1 st1
244 in
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
252 unPlain
253 (case w`compare`m of
254 LT -> spaces (m`minusNatural`w)
255 EQ -> mempty
256 GT -> setIndent (col0 + m) newline)
257 inh1 st1
258 in
259 unPlain (p <> p1) inh0 st0
260 instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
261 ul ds =
262 catV $
263 (<$> ds) $ \d ->
264 from (Word '-')<>space<>flushLine<>align d<>flushLine
265 ol ds =
266 catV $ snd $
267 Fold.foldr
268 (\d (i, acc) ->
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}
274
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 ->
278 ok
279 ( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
280 , st
281 { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
282 , plainState_bufferWidth = 0
283 , plainState_buffer = mempty
284 }
285 )
286
287 collapseSpaces :: PlainChunk d -> PlainChunk d
288 collapseSpaces = \case
289 PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
290 x -> x
291
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
297 k
298 ( id
299 , st
300 { plainState_removableIndent = newlineInd
301 }
302 )
303 fits
304 {-overflow-}(\_r ->
305 unPlain newline inh st k
306 fits
307 {-overflow-}(
308 if plainState_removableIndent st < newlineInd
309 then overflow
310 else fits
311 )
312 )
313 breakspace = Plain $ \inh st k fits overflow ->
314 let newlineInd = plainInh_indent inh in
315 k
316 ( if plainInh_justify inh then id else (space <>)
317 , st
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
326 }
327 )
328 fits
329 {-overflow-}(\_r ->
330 unPlain newline inh st k
331 fits
332 {-overflow-}(
333 if plainState_removableIndent st < newlineInd
334 then overflow
335 else fits
336 )
337 )
338 breakalt x y = Plain $ \inh st k fits overflow ->
339 unPlain x inh st k fits
340 {-overflow-}(\_r ->
341 unPlain y inh st k fits overflow
342 )
343 -- String
344 instance (From (Word String) d, Spaceable d) =>
345 From String (Plain d) where
346 from =
347 mconcat .
348 List.intersperse newline .
349 (from <$>) .
350 lines
351 instance (From (Word String) d, Spaceable d) =>
352 IsString (Plain d) where
353 fromString = from
354 -- Text
355 instance (From (Word Text) d, Spaceable d) =>
356 From Text (Plain d) where
357 from =
358 mconcat .
359 List.intersperse newline .
360 (from <$>) .
361 lines
362 instance (From (Word TL.Text) d, Spaceable d) =>
363 From TL.Text (Plain d) where
364 from =
365 mconcat .
366 List.intersperse newline .
367 (from <$>) .
368 lines
369 -- Char
370 instance (From (Word Char) d, Spaceable d) =>
371 From Char (Plain d) where
372 from ' ' = breakspace
373 from '\n' = newline
374 from c = from (Word c)
375
376
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)
382
383 joinLine ::
384 Spaceable d =>
385 PlainInh -> PlainState d -> d
386 joinLine PlainInh{..} PlainState{..} =
387 case plainInh_width of
388 Nothing -> joinPlainLine $ List.reverse plainState_buffer
389 Just maxWidth ->
390 if maxWidth < plainState_bufferStart
391 || maxWidth < plainInh_indent
392 then joinPlainLine $ List.reverse plainState_buffer
393 else
394 let superfluousSpaces = Fold.foldr
395 (\c acc ->
396 acc + case c of
397 PlainChunk_Ignored{} -> 0
398 PlainChunk_Word{} -> 0
399 PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
400 0 plainState_buffer in
401 let minBufferWidth =
402 -- NOTE: cap the spaces at 1,
403 -- to let justifyWidth decide where to add spaces.
404 plainState_bufferWidth`minusNatural`superfluousSpaces in
405 let justifyWidth =
406 -- NOTE: when minBufferWidth is not breakable,
407 -- the width of justification can be wider than
408 -- what remains to reach maxWidth.
409 max minBufferWidth $
410 maxWidth`minusNatural`plainState_bufferStart
411 in
412 let wordCount = countWords plainState_buffer in
413 unLine $ padPlainLineInits justifyWidth $
414 (minBufferWidth,wordCount,List.reverse plainState_buffer)
415
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
420 where
421 go inWord acc = \case
422 [] -> acc
423 PlainChunk_Word{}:xs ->
424 if inWord
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
431
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)@.
436 --
437 -- A simple implementation of 'justifyPadding' could be:
438 -- @
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
443 -- where
444 -- (q,r) = a`divMod`b
445 -- m = 'min' (b-r) r
446 -- @
447 justifyPadding :: Natural -> Natural -> [Natural]
448 justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
449 where
450 (q,r) = a`quotRemNatural`b
451
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)
455
456 padPlainLineInits ::
457 Spaceable d =>
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.
463 || wordCount <= 1
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
468 else
469 -- Share the missing spaces as evenly as possible
470 -- between the words of the line.
471 padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
472
473 -- | Just concat 'PlainChunk's with no justification.
474 joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
475 joinPlainLine = mconcat . (runPlainChunk <$>)
476
477 -- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
478 padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
479 padPlainLine = go
480 where
481 go (w:ws) lls@(l:ls) =
482 case w of
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 []
486 go [] _ls = mempty