symantic-document 1.2.3.20190628 → 1.4.0.20190710
raw patch · 5 files changed
+260/−171 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Symantic.Document.API: breakfill :: (Indentable d, Indentable (UnTrans d)) => Trans d => Width -> d -> d
- Symantic.Document.Plain: [plainState_removableIndent] :: PlainState d -> !Indent
- Symantic.Document.Plain: collapseSpaces :: PlainChunk d -> PlainChunk d
- Symantic.Document.Plain: countWords :: [PlainChunk d] -> Natural
- Symantic.Document.Plain: flushLine :: Spaceable d => Plain d
- Symantic.Document.Plain: instance (GHC.Show.Show d, GHC.Base.Monoid d) => GHC.Show.Show (Symantic.Document.Plain.Plain d)
- Symantic.Document.Plain: instance GHC.Show.Show Symantic.Document.Plain.PlainInh
- Symantic.Document.Plain: joinLine :: Spaceable d => PlainInh -> PlainState d -> d
- Symantic.Document.Plain: joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
- Symantic.Document.Plain: newlineJustifying :: Spaceable d => Plain d
- Symantic.Document.Plain: padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
- Symantic.Document.Plain: padPlainLineInits :: Spaceable d => Width -> (Natural, Natural, [PlainChunk d]) -> Line d
+ Symantic.Document.API: endline :: (Wrappable d, Wrappable (UnTrans d)) => Trans d => d
+ Symantic.Document.API: fillOrBreak :: (Indentable d, Indentable (UnTrans d)) => Trans d => Width -> d -> d
+ Symantic.Document.Plain: [plainInh_indenting] :: PlainInh d -> !Plain d
+ Symantic.Document.Plain: [plainState_breakIndent] :: PlainState d -> !Indent
+ Symantic.Document.Plain: collapsePlainChunkSpaces :: PlainChunk d -> PlainChunk d
+ Symantic.Document.Plain: countWordsPlain :: [PlainChunk d] -> Natural
+ Symantic.Document.Plain: flushlinePlain :: Spaceable d => Plain d
+ Symantic.Document.Plain: instance (GHC.Show.Show d, Symantic.Document.API.Spaceable d) => GHC.Show.Show (Symantic.Document.Plain.Plain d)
+ Symantic.Document.Plain: joinLinePlainChunk :: Monoid d => Spaceable d => [PlainChunk d] -> d
+ Symantic.Document.Plain: justifyLinePlain :: Spaceable d => PlainInh d -> PlainState d -> d
+ Symantic.Document.Plain: newlineJustifyingPlain :: Spaceable d => Plain d
+ Symantic.Document.Plain: padLinePlainChunk :: Spaceable d => [PlainChunk d] -> [Width] -> d
+ Symantic.Document.Plain: padLinePlainChunkInits :: Spaceable d => Width -> (Natural, Natural, [PlainChunk d]) -> Line d
- Symantic.Document.API: incrIndent :: (Indentable d, Indentable (UnTrans d)) => Trans d => Indent -> d -> d
+ Symantic.Document.API: incrIndent :: (Indentable d, Indentable (UnTrans d)) => Trans d => d -> Indent -> d -> d
- Symantic.Document.API: setIndent :: (Indentable d, Indentable (UnTrans d)) => Trans d => Indent -> d -> d
+ Symantic.Document.API: setIndent :: (Indentable d, Indentable (UnTrans d)) => Trans d => d -> Indent -> d -> d
- Symantic.Document.Plain: Plain :: (PlainInh -> PlainState d -> ((d -> d, PlainState d) -> PlainFit d) -> PlainFit d) -> Plain d
+ Symantic.Document.Plain: Plain :: (PlainInh d -> PlainState d -> ((d -> d, PlainState d) -> PlainFit d) -> PlainFit d) -> Plain d
- Symantic.Document.Plain: PlainChunk_Ignored :: d -> PlainChunk d
+ Symantic.Document.Plain: PlainChunk_Ignored :: !d -> PlainChunk d
- Symantic.Document.Plain: PlainChunk_Spaces :: Width -> PlainChunk d
+ Symantic.Document.Plain: PlainChunk_Spaces :: !Width -> PlainChunk d
- Symantic.Document.Plain: PlainChunk_Word :: Word d -> PlainChunk d
+ Symantic.Document.Plain: PlainChunk_Word :: !Word d -> PlainChunk d
- Symantic.Document.Plain: PlainInh :: !Maybe Column -> !Bool -> !Width -> PlainInh
+ Symantic.Document.Plain: PlainInh :: !Maybe Column -> !Bool -> !Indent -> !Plain d -> PlainInh d
- Symantic.Document.Plain: [plainInh_indent] :: PlainInh -> !Width
+ Symantic.Document.Plain: [plainInh_indent] :: PlainInh d -> !Indent
- Symantic.Document.Plain: [plainInh_justify] :: PlainInh -> !Bool
+ Symantic.Document.Plain: [plainInh_justify] :: PlainInh d -> !Bool
- Symantic.Document.Plain: [plainInh_width] :: PlainInh -> !Maybe Column
+ Symantic.Document.Plain: [plainInh_width] :: PlainInh d -> !Maybe Column
- Symantic.Document.Plain: [unPlain] :: Plain d -> PlainInh -> PlainState d -> ((d -> d, PlainState d) -> PlainFit d) -> PlainFit d
+ Symantic.Document.Plain: [unPlain] :: Plain d -> PlainInh d -> PlainState d -> ((d -> d, PlainState d) -> PlainFit d) -> PlainFit d
- Symantic.Document.Plain: data PlainInh
+ Symantic.Document.Plain: data PlainInh d
- Symantic.Document.Plain: defPlainInh :: PlainInh
+ Symantic.Document.Plain: defPlainInh :: Spaceable d => PlainInh d
- Symantic.Document.Plain: runPlain :: Monoid d => Plain d -> d
+ Symantic.Document.Plain: runPlain :: Spaceable d => Plain d -> d
Files
- Symantic/Document/API.hs +22/−18
- Symantic/Document/AnsiText.hs +21/−10
- Symantic/Document/Plain.hs +192/−138
- symantic-document.cabal +1/−1
- test/HUnit.hs +24/−4
Symantic/Document/API.hs view
@@ -413,33 +413,34 @@ 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 @@ 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
Symantic/Document/AnsiText.hs view
@@ -8,6 +8,7 @@ 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 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 @@ 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 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 @@ 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 ::
Symantic/Document/Plain.hs view
@@ -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.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 @@ -- 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 @@ -- 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 '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 @@ 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 @@ 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 @@ } ) -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 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ -- 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
symantic-document.cabal view
@@ -2,7 +2,7 @@ -- 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.
test/HUnit.hs view
@@ -75,17 +75,17 @@ , ("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 @@ \ 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 @@ <> 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)) <> ")"