summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjulm <>2019-07-10 17:44:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-07-10 17:44:00 (GMT)
commitd0c0989b95bc9cbf4fb3ae7dd1faac773ca97b34 (patch)
tree4fa9f80fbf5cae56d928ee45459a593a4685cb92
parenta4ac392e84c225c9025ebf37f6bdcfe2abab06ec (diff)
version 1.4.0.201907101.4.0.20190710
-rw-r--r--Symantic/Document/API.hs40
-rw-r--r--Symantic/Document/AnsiText.hs31
-rw-r--r--Symantic/Document/Plain.hs330
-rw-r--r--symantic-document.cabal2
-rw-r--r--test/HUnit.hs28
5 files changed, 260 insertions, 171 deletions
diff --git a/Symantic/Document/API.hs b/Symantic/Document/API.hs
index c0b9408..b2b2df0 100644
--- a/Symantic/Document/API.hs
+++ b/Symantic/Document/API.hs
@@ -413,33 +413,34 @@ xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")
class Spaceable d => Indentable d where
-- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.
align :: d -> d
- -- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
- incrIndent :: Indent -> d -> d
- -- | @('setIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.
- setIndent :: Indent -> d -> d
- -- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.
+ -- | @('setIndent' p ind d)@ make @d@ uses @ind@ as 'Indent' level.
+ -- Using @p@ as 'Indent' text.
+ setIndent :: d -> Indent -> d -> d
+ -- | @('incrIndent' p ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.
+ -- Appending @p@ to the current 'Indent' text.
+ incrIndent :: d -> Indent -> d -> d
hang :: Indent -> d -> d
- hang ind = align . incrIndent ind
+ hang ind = align . incrIndent (spaces ind) ind
-- | @('fill' w d)@ write @d@,
-- then if @d@ is not wider than @w@,
-- write the difference with 'spaces'.
fill :: Width -> d -> d
- -- | @('breakfill' w d)@ write @d@,
+ -- | @('fillOrBreak' w d)@ write @d@,
-- then if @d@ is not wider than @w@, write the difference with 'spaces'
-- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @w@.
- breakfill :: Width -> d -> d
+ fillOrBreak :: Width -> d -> d
- default align :: Indentable (UnTrans d) => Trans d => d -> d
- default incrIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
- default setIndent :: Indentable (UnTrans d) => Trans d => Indent -> d -> d
- default fill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
- default breakfill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
+ default align :: Indentable (UnTrans d) => Trans d => d -> d
+ default incrIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
+ default setIndent :: Indentable (UnTrans d) => Trans d => d -> Indent -> d -> d
+ default fill :: Indentable (UnTrans d) => Trans d => Width -> d -> d
+ default fillOrBreak :: Indentable (UnTrans d) => Trans d => Width -> d -> d
- align = noTrans1 align
- incrIndent = noTrans1 . incrIndent
- setIndent = noTrans1 . setIndent
- fill = noTrans1 . fill
- breakfill = noTrans1 . breakfill
+ align = noTrans1 align
+ setIndent p i = noTrans . setIndent (unTrans p) i . unTrans
+ incrIndent p i = noTrans . incrIndent (unTrans p) i . unTrans
+ fill = noTrans1 . fill
+ fillOrBreak = noTrans1 . fillOrBreak
class Listable d where
ul :: Traversable f => f d -> d
@@ -460,12 +461,15 @@ class Wrappable d where
breakpoint :: d
breakspace :: d
breakalt :: d -> d -> d
+ endline :: d
default breakpoint :: Wrappable (UnTrans d) => Trans d => d
default breakspace :: Wrappable (UnTrans d) => Trans d => d
default breakalt :: Wrappable (UnTrans d) => Trans d => d -> d -> d
+ default endline :: Wrappable (UnTrans d) => Trans d => d
breakpoint = noTrans breakpoint
breakspace = noTrans breakspace
breakalt = noTrans2 breakalt
+ endline = noTrans endline
-- * Class 'Justifiable'
class Justifiable d where
diff --git a/Symantic/Document/AnsiText.hs b/Symantic/Document/AnsiText.hs
index 153d280..7da647d 100644
--- a/Symantic/Document/AnsiText.hs
+++ b/Symantic/Document/AnsiText.hs
@@ -8,6 +8,7 @@ import Data.Bool
import Data.Char (Char)
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
+import Data.Functor.Identity (Identity(..))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
@@ -99,11 +100,19 @@ instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where
instance Justifiable d => Justifiable (AnsiText d) where
justify (AnsiText d) = AnsiText $ justify <$> d
instance Indentable d => Indentable (AnsiText d) where
- setIndent i (AnsiText d) = AnsiText $ setIndent i <$> d
- incrIndent i (AnsiText d) = AnsiText $ incrIndent i <$> d
- fill w (AnsiText d) = AnsiText $ fill w <$> d
- breakfill w (AnsiText d) = AnsiText $ breakfill w <$> d
- align (AnsiText d) = AnsiText $ align <$> d
+ align (AnsiText d) = AnsiText $ align <$> d
+ setIndent p i (AnsiText d) = AnsiText $ ReaderT $ \inh ->
+ Identity $
+ setIndent
+ (unAnsiText p`runReader`inh) i
+ (runReader d inh)
+ incrIndent p i (AnsiText d) = AnsiText $ ReaderT $ \inh ->
+ Identity $
+ incrIndent
+ (unAnsiText p`runReader`inh) i
+ (runReader d inh)
+ fill w (AnsiText d) = AnsiText $ fill w <$> d
+ fillOrBreak w (AnsiText d) = AnsiText $ fillOrBreak w <$> d
instance Listable d => Listable (AnsiText d) where
ul ds = AnsiText $ (ul <$>) $ sequence $ unAnsiText <$> ds
ol ds = AnsiText $ (ol <$>) $ sequence $ unAnsiText <$> ds
@@ -111,6 +120,7 @@ instance Wrappable d => Wrappable (AnsiText d) where
setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
breakpoint = AnsiText $ return breakpoint
breakspace = AnsiText $ return breakspace
+ endline = AnsiText $ return endline
breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
ansiTextSGR ::
@@ -201,11 +211,11 @@ instance Semigroup d => Decorable (PlainText d) where
instance Justifiable d => Justifiable (PlainText d) where
justify (PlainText d) = PlainText $ justify d
instance Indentable d => Indentable (PlainText d) where
- setIndent i (PlainText d) = PlainText $ setIndent i d
- incrIndent i (PlainText d) = PlainText $ incrIndent i d
- fill w (PlainText d) = PlainText $ fill w d
- breakfill w (PlainText d) = PlainText $ breakfill w d
- align (PlainText d) = PlainText $ align d
+ align (PlainText d) = PlainText $ align d
+ setIndent p i (PlainText d) = PlainText $ setIndent (runPlainText p) i d
+ incrIndent p i (PlainText d) = PlainText $ incrIndent (runPlainText p) i d
+ fill w (PlainText d) = PlainText $ fill w d
+ fillOrBreak w (PlainText d) = PlainText $ fillOrBreak w d
instance Listable d => Listable (PlainText d) where
ul ds = PlainText $ ul $ unPlainText <$> ds
ol ds = PlainText $ ol $ unPlainText <$> ds
@@ -213,6 +223,7 @@ instance Wrappable d => Wrappable (PlainText d) where
setWidth w (PlainText d) = PlainText $ setWidth w d
breakpoint = PlainText breakpoint
breakspace = PlainText breakspace
+ endline = PlainText endline
breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y
plainTextSGR ::
diff --git a/Symantic/Document/Plain.hs b/Symantic/Document/Plain.hs
index 498a51e..c2c5231 100644
--- a/Symantic/Document/Plain.hs
+++ b/Symantic/Document/Plain.hs
@@ -3,6 +3,7 @@
{-# LANGUAGE UndecidableInstances #-}
module Symantic.Document.Plain where
+import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
@@ -15,7 +16,7 @@ import Data.Semigroup (Semigroup(..))
import Data.String (String, IsString(..))
import Data.Text (Text)
import Data.Tuple (snd)
-import GHC.Natural (minusNatural,quotRemNatural)
+import GHC.Natural (minusNatural,minusNaturalMaybe,quotRemNatural)
import Numeric.Natural (Natural)
import Prelude (fromIntegral, Num(..), pred)
import System.Console.ANSI
@@ -34,17 +35,17 @@ import Symantic.Document.API
-- Prepending is done using continuation, like in a difference list.
newtype Plain d = Plain
{ unPlain ::
- {-curr-}PlainInh ->
+ {-curr-}PlainInh d ->
{-curr-}PlainState d ->
{-ok-}( ({-prepend-}(d->d), {-new-}PlainState d) -> PlainFit d) ->
PlainFit d
-- NOTE: equivalent to:
-- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
}
-instance (Show d, Monoid d) => Show (Plain d) where
+instance (Show d, Spaceable d) => Show (Plain d) where
show = show . runPlain
-runPlain :: Monoid d => Plain d -> d
+runPlain :: Spaceable d => Plain d -> d
runPlain x =
unPlain x
defPlainInh
@@ -63,31 +64,34 @@ data PlainState d = PlainState
-- must be written.
, plainState_bufferWidth :: !Width
-- ^ The 'Width' of the 'plainState_buffer' so far.
- , plainState_removableIndent :: !Indent
+ , plainState_breakIndent :: !Indent
-- ^ The amount of 'Indent' added by 'breakspace'
- -- that can be removed by breaking the 'space' into a 'newlineJustifying'.
+ -- that can be reached by breaking the 'space'
+ -- into a 'newlineJustifyingPlain'.
} deriving (Show)
defPlainState :: PlainState d
defPlainState = PlainState
- { plainState_buffer = mempty
- , plainState_bufferStart = 0
- , plainState_bufferWidth = 0
- , plainState_removableIndent = 0
+ { plainState_buffer = mempty
+ , plainState_bufferStart = 0
+ , plainState_bufferWidth = 0
+ , plainState_breakIndent = 0
}
-- ** Type 'PlainInh'
-data PlainInh = PlainInh
- { plainInh_width :: !(Maybe Column)
- , plainInh_justify :: !Bool
- , plainInh_indent :: !Width
- } deriving (Show)
+data PlainInh d = PlainInh
+ { plainInh_width :: !(Maybe Column)
+ , plainInh_justify :: !Bool
+ , plainInh_indent :: !Indent
+ , plainInh_indenting :: !(Plain d)
+ }
-defPlainInh :: PlainInh
+defPlainInh :: Spaceable d => PlainInh d
defPlainInh = PlainInh
- { plainInh_width = Nothing
- , plainInh_justify = False
- , plainInh_indent = 0
+ { plainInh_width = Nothing
+ , plainInh_justify = False
+ , plainInh_indent = 0
+ , plainInh_indenting = mempty
}
-- ** Type 'PlainFit'
@@ -101,11 +105,11 @@ type PlainFit d = {-fits-}(d -> d) ->
-- ** Type 'PlainChunk'
data PlainChunk d
- = PlainChunk_Ignored d
+ = PlainChunk_Ignored !d
-- ^ Ignored by the justification but kept in place.
-- Used for instance to put ANSI sequences.
- | PlainChunk_Word (Word d)
- | PlainChunk_Spaces Width
+ | PlainChunk_Word !(Word d)
+ | PlainChunk_Spaces !Width
-- ^ 'spaces' preserved to be interleaved
-- correctly with 'PlainChunk_Ignored'.
instance Show d => Show (PlainChunk d) where
@@ -148,35 +152,57 @@ instance Monoid d => Monoid (Plain d) where
mempty = Plain $ \_inh st k -> k (id,st)
mappend = (<>)
instance Spaceable d => Spaceable (Plain d) where
- -- | The default 'newline' does not justify
- -- 'plainState_buffer', for that use 'newlineJustifying'.
- newline = Plain $ \inh st k ->
- k(\next ->
- (if plainInh_justify inh
- then joinPlainLine $ List.reverse $ plainState_buffer st
- else mempty) <>
- newline<>spaces (plainInh_indent inh)<>next
- , st
- { plainState_bufferStart = plainInh_indent inh
+ -- | The default 'newline' does not justify 'plainState_buffer',
+ -- for that use 'newlineJustifyingPlain'.
+ newline = Plain $ \inh st ->
+ unPlain
+ ( newlinePlain
+ <> indentPlain
+ <> propagatePlain (plainState_breakIndent st)
+ <> flushlinePlain
+ ) inh st
+ where
+ indentPlain = Plain $ \inh ->
+ unPlain
+ (plainInh_indenting inh)
+ inh{plainInh_justify=False}
+ newlinePlain = Plain $ \inh st k ->
+ k (\next ->
+ (if plainInh_justify inh
+ then joinLinePlainChunk $ List.reverse $ plainState_buffer st
+ else mempty
+ )<>newline<>next
+ , st
+ { plainState_bufferStart = 0
, plainState_bufferWidth = 0
, plainState_buffer = mempty
- }
- )
+ })
+ propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
+ k (id,st1)
+ fits
+ {-overflow-}(
+ -- NOTE: the text after this newline overflows,
+ -- so propagate the overflow before this 'newline',
+ -- if and only if there is a 'breakspace' before this 'newline'
+ -- whose replacement by a 'newline' indents to a lower indent
+ -- than this 'newline''s indent.
+ -- Otherwise there is no point in propagating the overflow.
+ if breakIndent < plainInh_indent inh
+ then overflow
+ else fits
+ )
space = spaces 1
spaces n = Plain $ \inh st@PlainState{..} k fits overflow ->
let newWidth = plainState_bufferStart + plainState_bufferWidth + n in
if plainInh_justify inh
then
- let newState =
- case plainState_buffer of
- PlainChunk_Spaces s:bs -> st
- { plainState_buffer = PlainChunk_Spaces (s+n):bs
- }
- _ -> st
- { plainState_buffer = PlainChunk_Spaces n:plainState_buffer
- , plainState_bufferWidth = plainState_bufferWidth + 1
- }
- in
+ let newState = st
+ { plainState_buffer =
+ case plainState_buffer of
+ PlainChunk_Spaces s:buf -> PlainChunk_Spaces (s+n):buf
+ buf -> PlainChunk_Spaces n:buf
+ , plainState_bufferWidth = plainState_bufferWidth + n
+ } in
case plainInh_width inh of
Just maxWidth | maxWidth < newWidth ->
overflow $ k (id{-(d<>)-}, newState) fits overflow
@@ -227,59 +253,70 @@ instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
words .
unLine
instance Spaceable d => Indentable (Plain d) where
- align p = (flushLine <>) $ Plain $ \inh st ->
- let currInd = plainState_bufferStart st + plainState_bufferWidth st in
- unPlain p inh{plainInh_indent=currInd} st
- incrIndent i p = Plain $ \inh ->
- unPlain p inh{plainInh_indent = plainInh_indent inh + i}
- setIndent i p = Plain $ \inh ->
- unPlain p inh{plainInh_indent=i}
+ align p = (flushlinePlain <>) $ Plain $ \inh st ->
+ let col = plainState_bufferStart st + plainState_bufferWidth st in
+ unPlain p inh
+ { plainInh_indent = col
+ , plainInh_indenting =
+ if plainInh_indent inh <= col
+ then
+ plainInh_indenting inh <>
+ spaces (col`minusNatural`plainInh_indent inh)
+ else spaces col
+ } st
+ setIndent d i p = Plain $ \inh ->
+ unPlain p inh
+ { plainInh_indent = i
+ , plainInh_indenting = d
+ }
+ incrIndent d i p = Plain $ \inh ->
+ unPlain p inh
+ { plainInh_indent = plainInh_indent inh + i
+ , plainInh_indenting = plainInh_indenting inh <> d
+ }
+
fill m p = Plain $ \inh0 st0 ->
- let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
+ let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
let p1 = Plain $ \inh1 st1 ->
- let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
- let w | col0 <= col1 = col1`minusNatural`col0
- | otherwise = col0`minusNatural`col1 in
+ let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
unPlain
- (if w<=m
- then spaces (m`minusNatural`w)
+ (if col <= maxCol
+ then spaces (maxCol`minusNatural`col)
else mempty)
inh1 st1
in
unPlain (p <> p1) inh0 st0
- breakfill m p = Plain $ \inh0 st0 ->
- let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 in
+ fillOrBreak m p = Plain $ \inh0 st0 ->
+ let maxCol = plainState_bufferStart st0 + plainState_bufferWidth st0 + m in
let p1 = Plain $ \inh1 st1 ->
- let col1 = plainState_bufferStart st1 + plainState_bufferWidth st1 in
- let w | col0 <= col1 = col1`minusNatural`col0
- | otherwise = col0`minusNatural`col1 in
+ let col = plainState_bufferStart st1 + plainState_bufferWidth st1 in
unPlain
- (case w`compare`m of
- LT -> spaces (m`minusNatural`w)
+ (case col`compare`maxCol of
+ LT -> spaces (maxCol`minusNatural`col)
EQ -> mempty
- GT -> setIndent (col0 + m) newline)
- inh1 st1
+ GT -> incrIndent (spaces m) m newline
+ ) inh1 st1
in
unPlain (p <> p1) inh0 st0
instance (Spaceable d, From (Word Char) d, From (Word String) d) => Listable (Plain d) where
ul ds =
catV $
(<$> ds) $ \d ->
- from (Word '-')<>space<>flushLine<>align d<>flushLine
+ from (Word '-')<>space<>flushlinePlain<>align d<>flushlinePlain
ol ds =
catV $ snd $
Fold.foldr
(\d (i, acc) ->
- (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
+ (pred i, (from i<>from (Word '.')<>space<>flushlinePlain<>align d<>flushlinePlain) : acc)
) (Fold.length ds, []) ds
instance Spaceable d => Justifiable (Plain d) where
- justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
+ justify p = (\x -> flushlinePlain <> x <> flushlinePlain) $ Plain $ \inh ->
unPlain p inh{plainInh_justify=True}
-- | Commit 'plainState_buffer' upto there, so that it won't be justified.
-flushLine :: Spaceable d => Plain d
-flushLine = Plain $ \_inh st k ->
- k( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
+flushlinePlain :: Spaceable d => Plain d
+flushlinePlain = Plain $ \_inh st k ->
+ k( (joinLinePlainChunk (collapsePlainChunkSpaces <$> List.reverse (plainState_buffer st)) <>)
, st
{ plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
, plainState_bufferWidth = 0
@@ -287,8 +324,8 @@ flushLine = Plain $ \_inh st k ->
}
)
-collapseSpaces :: PlainChunk d -> PlainChunk d
-collapseSpaces = \case
+collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d
+collapsePlainChunkSpaces = \case
PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
x -> x
@@ -296,27 +333,11 @@ instance Spaceable d => Wrappable (Plain d) where
setWidth w p = Plain $ \inh ->
unPlain p inh{plainInh_width=w}
breakpoint = Plain $ \inh st k fits overflow ->
- let newlineInd = plainInh_indent inh in
- k
- ( id
- , st
- { plainState_removableIndent = newlineInd
- }
- )
+ k(id, st {plainState_breakIndent = plainInh_indent inh})
fits
- {-overflow-}(\_r ->
- unPlain newlineJustifying inh st k
- fits
- {-overflow-}(
- if plainState_removableIndent st < newlineInd
- then overflow
- else fits
- )
- )
+ {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
breakspace = Plain $ \inh st k fits overflow ->
- let newlineInd = plainInh_indent inh in
- k
- ( if plainInh_justify inh then id else (space <>)
+ k( if plainInh_justify inh then id else (space <>)
, st
{ plainState_buffer =
if plainInh_justify inh
@@ -324,38 +345,72 @@ instance Spaceable d => Wrappable (Plain d) where
PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
bs -> PlainChunk_Spaces 1:bs
else plainState_buffer st
- , plainState_bufferWidth = plainState_bufferWidth st + 1
- , plainState_removableIndent = newlineInd
+ , plainState_bufferWidth = plainState_bufferWidth st + 1
+ , plainState_breakIndent = plainInh_indent inh
}
)
fits
- {-overflow-}(\_r ->
- unPlain newlineJustifying inh st k
- fits
- {-overflow-}(
- if plainState_removableIndent st < newlineInd
- then overflow
- else fits
- )
- )
+ {-overflow-}(\_r -> unPlain newlineJustifyingPlain inh st k fits overflow)
breakalt x y = Plain $ \inh st k fits overflow ->
- unPlain x inh st k fits
- {-overflow-}(\_r ->
- unPlain y inh st k fits overflow
- )
+ -- NOTE: breakalt must be y if and only if x does not fit,
+ -- hence the use of dummyK to limit the test
+ -- to overflows raised within x, and drop those raised after x.
+ unPlain x inh st dummyK
+ {-fits-} (\_r -> unPlain x inh st k fits overflow)
+ {-overflow-}(\_r -> unPlain y inh st k fits overflow)
+ where
+ dummyK (px,_sx) fits _overflow =
+ -- NOTE: if px fits, then appending mempty fits
+ fits (px mempty)
+ endline = Plain $ \inh st k fits _overflow ->
+ let col = plainState_bufferStart st + plainState_bufferWidth st in
+ case plainInh_width inh >>= (`minusNaturalMaybe` col) of
+ Nothing -> k (id, st) fits fits
+ Just w ->
+ let newState = st
+ { plainState_bufferWidth = plainState_bufferWidth st + w
+ } in
+ k (id,newState) fits fits
-- | Like 'newline', but justify 'plainState_buffer' before.
-newlineJustifying :: Spaceable d => Plain d
-newlineJustifying = Plain $ \inh st k ->
- k(\next ->
- (if plainInh_justify inh then joinLine inh st else mempty) <>
- newline<>spaces (plainInh_indent inh)<>next
- , st
- { plainState_bufferStart = plainInh_indent inh
+newlineJustifyingPlain :: Spaceable d => Plain d
+newlineJustifyingPlain = Plain $ \inh st ->
+ unPlain
+ ( newlinePlain
+ <> indentPlain
+ <> propagatePlain (plainState_breakIndent st)
+ <> flushlinePlain
+ ) inh st
+ where
+ indentPlain = Plain $ \inh ->
+ unPlain
+ (plainInh_indenting inh)
+ inh{plainInh_justify=False}
+ newlinePlain = Plain $ \inh st k ->
+ k (\next ->
+ (if plainInh_justify inh
+ then justifyLinePlain inh st
+ else mempty
+ )<>newline<>next
+ , st
+ { plainState_bufferStart = 0
, plainState_bufferWidth = 0
, plainState_buffer = mempty
- }
- )
+ })
+ propagatePlain breakIndent = Plain $ \inh st1 k fits overflow ->
+ k (id,st1)
+ fits
+ {-overflow-}(
+ -- NOTE: the text after this newline overflows,
+ -- so propagate the overflow before this 'newline',
+ -- if and only if there is a 'breakspace' before this 'newline'
+ -- whose replacement by a 'newline' indents to a lower indent
+ -- than this 'newline''s indent.
+ -- Otherwise there is no point in propagating the overflow.
+ if breakIndent < plainInh_indent inh
+ then overflow
+ else fits
+ )
-- String
instance (From (Word String) d, Spaceable d) =>
@@ -390,23 +445,22 @@ instance (From (Word Char) d, Spaceable d) =>
from '\n' = newline
from c = from (Word c)
-
instance (From [SGR] d, Semigroup d) => From [SGR] (Plain d) where
from sgr = Plain $ \inh st k ->
if plainInh_justify inh
then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
else k ((from sgr <>), st)
-joinLine ::
+justifyLinePlain ::
Spaceable d =>
- PlainInh -> PlainState d -> d
-joinLine PlainInh{..} PlainState{..} =
- case plainInh_width of
- Nothing -> joinPlainLine $ List.reverse plainState_buffer
+ PlainInh d -> PlainState d -> d
+justifyLinePlain inh PlainState{..} =
+ case plainInh_width inh of
+ Nothing -> joinLinePlainChunk $ List.reverse plainState_buffer
Just maxWidth ->
if maxWidth < plainState_bufferStart
- || maxWidth < plainInh_indent
- then joinPlainLine $ List.reverse plainState_buffer
+ || maxWidth < plainInh_indent inh
+ then joinLinePlainChunk $ List.reverse plainState_buffer
else
let superfluousSpaces = Fold.foldr
(\c acc ->
@@ -426,14 +480,14 @@ joinLine PlainInh{..} PlainState{..} =
max minBufferWidth $
maxWidth`minusNatural`plainState_bufferStart
in
- let wordCount = countWords plainState_buffer in
- unLine $ padPlainLineInits justifyWidth $
+ let wordCount = countWordsPlain plainState_buffer in
+ unLine $ padLinePlainChunkInits justifyWidth $
(minBufferWidth,wordCount,List.reverse plainState_buffer)
--- | @('countWords' ps)@ returns the number of words in @(ps)@
+-- | @('countWordsPlain' ps)@ returns the number of words in @(ps)@
-- clearly separated by spaces.
-countWords :: [PlainChunk d] -> Natural
-countWords = go False 0
+countWordsPlain :: [PlainChunk d] -> Natural
+countWordsPlain = go False 0
where
go inWord acc = \case
[] -> acc
@@ -470,10 +524,10 @@ justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
go rr 0 = List.replicate (fromIntegral rr) (q+1) -- when min (b-r) r == r
go rr bmr = q:(q+1) : go (rr`minusNatural`1) (bmr`minusNatural`1)
-padPlainLineInits ::
+padLinePlainChunkInits ::
Spaceable d =>
Width -> (Natural, Natural, [PlainChunk d]) -> Line d
-padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
+padLinePlainChunkInits maxWidth (lineWidth,wordCount,line) = Line $
if maxWidth <= lineWidth
-- The gathered line reached or overreached the maxWidth,
-- hence no padding id needed.
@@ -481,19 +535,19 @@ padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
-- The case maxWidth <= lineWidth && wordCount == 1
-- can happen if first word's length is < maxWidth
-- but second word's len is >= maxWidth.
- then joinPlainLine line
+ then joinLinePlainChunk line
else
-- Share the missing spaces as evenly as possible
-- between the words of the line.
- padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
+ padLinePlainChunk line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
-- | Just concat 'PlainChunk's with no justification.
-joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
-joinPlainLine = mconcat . (runPlainChunk <$>)
+joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
+joinLinePlainChunk = mconcat . (runPlainChunk <$>)
-- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
-padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
-padPlainLine = go
+padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
+padLinePlainChunk = go
where
go (w:ws) lls@(l:ls) =
case w of
diff --git a/symantic-document.cabal b/symantic-document.cabal
index cad6d20..c626d39 100644
--- a/symantic-document.cabal
+++ b/symantic-document.cabal
@@ -2,7 +2,7 @@ name: symantic-document
-- PVP: +-+------- breaking API changes
-- | | +----- non-breaking API additions
-- | | | +--- code changes with no API change
-version: 1.2.3.20190628
+version: 1.4.0.20190710
category: Text
synopsis: Document symantics.
description: Symantics for generating documents.
diff --git a/test/HUnit.hs b/test/HUnit.hs
index b43d997..ba68245 100644
--- a/test/HUnit.hs
+++ b/test/HUnit.hs
@@ -75,17 +75,17 @@ hunitPlain = testList "Plain"
, ("abcdefghi","Doc") ])
==> "let abcdef :: Doc\n abcde :: Int -> Doc -> Doc\n abcdefghi :: Doc"
, "let " <> align (catV $
- (\(name, typ) -> breakfill 6 name <> " ::" <+> typ)
+ (\(name, typ) -> fillOrBreak 6 name <> " ::" <+> typ)
<$> [ ("abcdef","Doc")
, ("abcde","Int -> Doc -> Doc")
, ("abcdefghi","Doc") ])
==> "let abcdef :: Doc\n abcde :: Int -> Doc -> Doc\n abcdefghi\n :: Doc"
, "let " <> align (catV $
- (\(name, typ) -> breakfill 6 name <> " ::" <+> typ)
+ (\(name, typ) -> fillOrBreak 6 name <> " ::" <+> typ)
<$> [("abcdefghi","Doc ->\nDoc")])
==> "let abcdefghi\n :: Doc ->\n Doc"
, "let " <> align (catV $
- (\(name, typ) -> breakfill 6 name <> align (" ::" <+> typ))
+ (\(name, typ) -> fillOrBreak 6 name <> align (" ::" <+> typ))
<$> [("abcdefghi","Doc ->\nDoc")])
==> "let abcdefghi\n :: Doc ->\n Doc"
, 10 `maxWidth` "1 2 3 4 5 6 7 8 9 10 11 12 13 14 15" ==> "1 2 3 4 5\n6 7 8 9 10\n11 12 13\n14 15"
@@ -171,6 +171,26 @@ hunitPlain = testList "Plain"
\ 5 6\n\
\ 7 8\n\
\ 9"
+ -- endline breakspaces
+ , 10 `maxWidth` ("a"<>endline<>" b") ==> "a\nb"
+ -- endline does no justify
+ , 10 `maxWidth` justify ("a b"<>endline<>" c") ==> "a b\nc"
+ -- endline works overflowed
+ , 10 `maxWidth` justify ("abcdefghijk"<>endline<>" a") ==> "abcdefghijk\na"
+ -- endline prints no nothing
+ , 10 `maxWidth` justify ("12345678"<>endline<>"90ab"<>align (" cdefghijk cdefghijk"))
+ ==> "1234567890ab\n\
+ \ cdefghijk\n\
+ \ cdefghijk"
+ -- newline stops overflow
+ , 10 `maxWidth` breakalt "fits" "over"<>"\n"<>"12345678901"
+ ==> "fits\n\
+ \12345678901"
+ -- breakalt triggers only if its first argument overflows,
+ -- not if what's next overflows.
+ , 10 `maxWidth` spaces 2<>align(breakalt "fits" "over"<>newline<>"12345678901")
+ ==> " fits\n\
+ \ 12345678901"
-- breakspace backtracking is bounded by the removable indentation
-- (hence it can actually wrap a few words in reasonable time).
, 80 `maxWidth`
@@ -319,5 +339,5 @@ listHorV ds =
<> newline <> "]")
fun :: IsString d => Indentable d => Wrappable d => d -> d
-fun d = "function(" <> incrIndent 2 (breakalt d (newline<>d<>newline)) <> ")"
+fun d = "function(" <> incrIndent (spaces 2) 2 (breakalt d (newline<>d<>newline)) <> ")"