plain: fix flushing in align and ul/ol
authorJulien Moutinho <julm@autogeree.net>
Thu, 27 Jun 2019 14:34:57 +0000 (14:34 +0000)
committerJulien Moutinho <julm@autogeree.net>
Thu, 27 Jun 2019 14:35:19 +0000 (14:35 +0000)
Symantic/Document/API.hs
Symantic/Document/AnsiText.hs
Symantic/Document/Plain.hs
symantic-document.cabal
test/HUnit.hs

index d9c6ba18afbad255bdc06a7cdc0b631e73715e04..c0b9408af7b4fce145dc6e5a0fa95f72c2c9e1b0 100644 (file)
@@ -16,7 +16,7 @@ import Data.Ord (Ord(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (String, IsString(..))
 import Data.Text (Text)
-import Data.Tuple (snd)
+import Data.Traversable (Traversable)
 import Numeric.Natural (Natural)
 import Prelude (Integer, fromIntegral, pred)
 import System.Console.ANSI (SGR, setSGRCode)
@@ -154,7 +154,7 @@ class Monoid d => Spaceable d where
        unwords = intercalate space . (unWord <$>)
        -- | Like 'unlines' but without the trailing 'newline'.
        catLines :: Foldable f => Functor f => f (Line d) -> d
-       catLines = intercalate newline . (unLine <$>)
+       catLines = catV . (unLine <$>)
        -- | @x '<+>' y = x '<>' 'space' '<>' y@
        (<+>) :: d -> d -> d
        -- | @x '</>' y = x '<>' 'newline' '<>' y@
@@ -168,17 +168,17 @@ class Monoid d => Spaceable d where
 infixr 6 <+>
 infixr 6 </>
 instance Spaceable String where
-       newline    = "\n"
-       space      = " "
-       spaces n   = List.replicate (fromIntegral n) ' '
+       newline  = "\n"
+       space    = " "
+       spaces n = List.replicate (fromIntegral n) ' '
 instance Spaceable Text where
-       newline    = "\n"
-       space      = " "
-       spaces n   = Text.replicate (fromIntegral n) " "
+       newline  = "\n"
+       space    = " "
+       spaces n = Text.replicate (fromIntegral n) " "
 instance Spaceable TLB.Builder where
-       newline    = TLB.singleton '\n'
-       space      = TLB.singleton ' '
-       spaces     = TLB.fromText . spaces
+       newline  = TLB.singleton '\n'
+       space    = TLB.singleton ' '
+       spaces   = TLB.fromText . spaces
 
 intercalate :: (Foldable f, Monoid d) => d -> f d -> d
 intercalate sep ds = if Fold.null ds then mempty else Fold.foldr1 (\x y -> x<>sep<>y) ds
@@ -440,30 +440,18 @@ class Spaceable d => Indentable d where
        setIndent  = noTrans1 . setIndent
        fill       = noTrans1 . fill
        breakfill  = noTrans1 . breakfill
-       
-       ul ::
-        From (Word Char) d =>
-        Foldable f =>
-        Functor f =>
-        f d -> d
-       ul ds =
-               catV $
-                       (<$> ds) $ \d ->
-                               (from (Word '-')<>space) <> align d
-       
-       ol ::
-        From Natural d =>
-        From (Word Char) d =>
-        From (Line String) d =>
-        Foldable f =>
-        Functor f =>
-        f d -> d
-       ol ds =
-               catV $ snd $
-                       Fold.foldr
-                        (\d (i, acc) ->
-                               (pred i, (from i<>from (Word '.')<>space <> align d) : acc)
-                        ) (Fold.length ds, []) ds
+
+class Listable d where
+       ul :: Traversable f => f d -> d
+       ol :: Traversable f => f d -> d
+       default ul ::
+        Listable (UnTrans d) => Trans d =>
+        Traversable f => f d -> d
+       default ol ::
+        Listable (UnTrans d) => Trans d =>
+        Traversable f => f d -> d
+       ul ds = noTrans $ ul $ unTrans <$> ds
+       ol ds = noTrans $ ol $ unTrans <$> ds
 
 -- * Class 'Wrappable'
 class Wrappable d where
index 3f23e621a6aeb501d15ca5b1e531e5c497d78251..153d280ad61be3d16ab778bf25c1065d9b9662ed 100644 (file)
@@ -2,7 +2,7 @@
 module Symantic.Document.AnsiText where
 
 import Control.Applicative (Applicative(..), liftA2)
-import Control.Monad (Monad(..))
+import Control.Monad (Monad(..), sequence)
 import Control.Monad.Trans.Reader
 import Data.Bool
 import Data.Char (Char)
@@ -13,6 +13,7 @@ import Data.Semigroup (Semigroup(..))
 import Data.String (String, IsString(..))
 import Data.Text (Text)
 import System.Console.ANSI
+import Text.Show (Show(..))
 import qualified Data.List as List
 import qualified Data.Text.Lazy as TL
 
@@ -20,6 +21,8 @@ import Symantic.Document.API
 
 -- * Type 'AnsiText'
 newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }
+instance Show d => Show (AnsiText d) where
+       show (AnsiText d) = show $ runReader d []
 
 ansiText :: AnsiText d -> AnsiText d
 ansiText = id
@@ -95,12 +98,15 @@ instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where
        italic    = ansiTextSGR $ SetItalicized True
 instance Justifiable d => Justifiable (AnsiText d) where
        justify (AnsiText d) = AnsiText $ justify <$> d
-instance (Indentable d, From Char d) => Indentable (AnsiText d) where
+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
+instance Listable d => Listable (AnsiText d) where
+       ul ds = AnsiText $ (ul <$>) $ sequence $ unAnsiText <$> ds
+       ol ds = AnsiText $ (ol <$>) $ sequence $ unAnsiText <$> ds
 instance Wrappable d => Wrappable (AnsiText d) where
        setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
        breakpoint = AnsiText $ return breakpoint
@@ -118,6 +124,7 @@ ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
 -- * Type 'PlainText'
 -- | Drop 'Colorable16' and 'Decorable'.
 newtype PlainText d = PlainText { unPlainText :: d }
+ deriving (Show)
 
 plainText :: PlainText d -> PlainText d
 plainText = id
@@ -199,6 +206,9 @@ instance Indentable d => Indentable (PlainText d) where
        fill w (PlainText d)       = PlainText $ fill w d
        breakfill w (PlainText d)  = PlainText $ breakfill w d
        align (PlainText d)        = PlainText $ align d
+instance Listable d => Listable (PlainText d) where
+       ul ds = PlainText $ ul $ unPlainText <$> ds
+       ol ds = PlainText $ ol $ unPlainText <$> ds
 instance Wrappable d => Wrappable (PlainText d) where
        setWidth w (PlainText d) = PlainText $ setWidth w d
        breakpoint = PlainText breakpoint
index b081486d141905eeb586e0a46971fc69e240ce87..a863ec912d40f40dc428e93417ceda28d6ec9297 100644 (file)
@@ -1,11 +1,11 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 {-# LANGUAGE UndecidableInstances #-}
 module Symantic.Document.Plain where
 
 import Data.Bool
 import Data.Char (Char)
 import Data.Eq (Eq(..))
-import Data.Foldable (foldr)
 import Data.Function (($), (.), id)
 import Data.Functor ((<$>))
 import Data.Maybe (Maybe(..))
@@ -14,11 +14,13 @@ import Data.Ord (Ord(..), Ordering(..))
 import Data.Semigroup (Semigroup(..))
 import Data.String (String, IsString(..))
 import Data.Text (Text)
+import Data.Tuple (snd)
 import GHC.Natural (minusNatural,quotRemNatural)
 import Numeric.Natural (Natural)
-import Prelude (fromIntegral, Num(..))
+import Prelude (fromIntegral, Num(..), pred)
 import System.Console.ANSI
 import Text.Show (Show(..), showString, showParen)
+import qualified Data.Foldable as Fold
 import qualified Data.List as List
 import qualified Data.Text.Lazy as TL
 
@@ -39,6 +41,8 @@ newtype Plain d = Plain
      -- NOTE: equivalent to:
      -- ReaderT PlainInh (StateT (PlainState d) (Cont (PlainFit d))) (d->d)
  }
+instance (Show d, Monoid d) => Show (Plain d) where
+       show = show . runPlain
 
 runPlain :: Monoid d => Plain d -> d
 runPlain x =
@@ -219,7 +223,7 @@ instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>
                words .
                unLine
 instance Spaceable d => Indentable (Plain d) where
-       align p = Plain $ \inh st ->
+       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 ->
@@ -253,23 +257,38 @@ instance Spaceable d => Indentable (Plain d) where
                         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
+       ol ds =
+               catV $ snd $
+                       Fold.foldr
+                        (\d (i, acc) ->
+                               (pred i, (from i<>from (Word '.')<>space<>flushLine<>align d<>flushLine) : acc)
+                        ) (Fold.length ds, []) ds
 instance Spaceable d => Justifiable (Plain d) where
        justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh ->
                unPlain p inh{plainInh_justify=True}
-               where
-               flushLine :: Plain d
-               flushLine = Plain $ \_inh st@PlainState{..} ok ->
-                       ok
-                        ( (joinPlainLine (collapseSpaces <$> List.reverse plainState_buffer) <>)
-                        , st
-                                { plainState_bufferStart = plainState_bufferStart + plainState_bufferWidth
-                                , plainState_bufferWidth = 0
-                                , plainState_buffer      = mempty
-                                }
-                        )
-               collapseSpaces = \case
-                PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
-                x -> x
+
+-- | Commit 'plainState_buffer' upto there, so that it won't be justified.
+flushLine :: Spaceable d => Plain d
+flushLine = Plain $ \_inh st ok ->
+       ok
+        ( (joinPlainLine (collapseSpaces <$> List.reverse (plainState_buffer st)) <>)
+        , st
+                { plainState_bufferStart = plainState_bufferStart st + plainState_bufferWidth st
+                , plainState_bufferWidth = 0
+                , plainState_buffer      = mempty
+                }
+        )
+
+collapseSpaces :: PlainChunk d -> PlainChunk d
+collapseSpaces = \case
+ PlainChunk_Spaces s -> PlainChunk_Spaces (if s > 0 then 1 else 0)
+ x -> x
+
 instance Spaceable d => Wrappable (Plain d) where
        setWidth w p = Plain $ \inh ->
                unPlain p inh{plainInh_width=w}
@@ -297,9 +316,11 @@ instance Spaceable d => Wrappable (Plain d) where
                 ( if plainInh_justify inh then id else (space <>)
                 , st
                         { plainState_buffer =
-                               case plainState_buffer st of
-                                PlainChunk_Spaces s:bs -> PlainChunk_Spaces (s+1):bs
-                                bs -> PlainChunk_Spaces 1:bs
+                               if plainInh_justify inh
+                               then case plainState_buffer st of
+                                        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
                         }
@@ -370,29 +391,30 @@ joinLine PlainInh{..} PlainState{..} =
                || maxWidth < plainInh_indent
                then joinPlainLine $ List.reverse plainState_buffer
                else
+                       let superfluousSpaces = Fold.foldr
+                                (\c acc ->
+                                       acc + case c of
+                                        PlainChunk_Ignored{} -> 0
+                                        PlainChunk_Word{} -> 0
+                                        PlainChunk_Spaces s -> s`minusNatural`(min 1 s))
+                                0 plainState_buffer in
+                       let minBufferWidth =
+                               -- NOTE: cap the spaces at 1,
+                               -- to let justifyWidth decide where to add spaces.
+                               plainState_bufferWidth`minusNatural`superfluousSpaces in
+                       let justifyWidth =
+                               -- NOTE: when minBufferWidth is not breakable,
+                               -- the width of justification can be wider than
+                               -- what remains to reach maxWidth.
+                               max minBufferWidth $
+                                       maxWidth`minusNatural`plainState_bufferStart
+                       in
                        let wordCount = countWords plainState_buffer in
-                       let bufferWidth =
-                               -- NOTE: compress all separated spaces into a single one.
-                               if wordCount == 0
-                               then 0
-                               else
-                                       let spaceWidth = foldr
-                                                (\c acc ->
-                                                       acc + case c of
-                                                        PlainChunk_Ignored{} -> 0
-                                                        PlainChunk_Word{} -> 0
-                                                        PlainChunk_Spaces s -> s)
-                                                0 plainState_buffer in
-                                       (plainState_bufferWidth`minusNatural`spaceWidth) +
-                                       (wordCount`minusNatural`1) in
-                       let adjustedWidth =
-                               max bufferWidth $
-                                       min
-                                       (maxWidth`minusNatural`plainState_bufferStart)
-                                       (maxWidth`minusNatural`plainInh_indent) in
-                       unLine $ padPlainLineInits adjustedWidth $
-                        (bufferWidth,wordCount,List.reverse plainState_buffer)
+                       unLine $ padPlainLineInits justifyWidth $
+                        (minBufferWidth,wordCount,List.reverse plainState_buffer)
 
+-- | @('countWords' ps)@ returns the number of words in @(ps)@
+-- clearly separated by spaces.
 countWords :: [PlainChunk d] -> Natural
 countWords = go False 0
  where
@@ -434,23 +456,25 @@ justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'
 padPlainLineInits ::
  Spaceable d =>
  Width -> (Natural, Natural, [PlainChunk d]) -> Line d
-padPlainLineInits bufferWidth (lineWidth,wordCount,line) = Line $
-       if bufferWidth <= lineWidth
-               -- The gathered line reached or overreached the bufferWidth,
+padPlainLineInits maxWidth (lineWidth,wordCount,line) = Line $
+       if maxWidth <= lineWidth
+               -- The gathered line reached or overreached the maxWidth,
                -- hence no padding id needed.
        || wordCount <= 1
-               -- The case bufferWidth <= lineWidth && wordCount == 1
-               -- can happen if first word's length is < bufferWidth
-               -- but second word's len is >= bufferWidth.
+               -- 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
        else
                -- Share the missing spaces as evenly as possible
                -- between the words of the line.
-               padPlainLine line $ justifyPadding (bufferWidth-lineWidth) (wordCount-1)
+               padPlainLine line $ justifyPadding (maxWidth-lineWidth) (wordCount-1)
 
+-- | Just concat 'PlainChunk's with no justification.
 joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d
 joinPlainLine = mconcat . (runPlainChunk <$>)
 
+-- | Interleave 'PlainChunk's with 'Width's from 'justifyPadding'.
 padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d
 padPlainLine = go
        where
index ba5c0bfdfce697b1d3d3bf78fdc03b0e6a7b7b02..bc7550efbcb592fccf6433705bfc837c4384a6fe 100644 (file)
@@ -2,7 +2,7 @@ name: symantic-document
 -- PVP:  +-+------- breaking API changes
 --       | | +----- non-breaking API additions
 --       | | | +--- code changes with no API change
-version: 1.2.1.20190625
+version: 1.2.2.20190627
 category: Text
 synopsis: Document symantics.
 description: Symantics for generating documents.
index cd2612cde18591e8694ba85bba9bf8df6f293645..4535b8039030442597b40e0468f04279e094d341 100644 (file)
@@ -105,8 +105,9 @@ hunitPlain = testList "Plain"
  , 10 `maxWidth` nestedAlign 10 ==> "1\n 2\n  3\n   4\n    5\n     6\n      7\n       8\n        9\n         10"
  -- justify justifies
  , 10 `maxWidth` justify "1 2 3 4 5 6" ==> "1 2  3 4 5\n6"
- -- justify compress spaces
+ -- justify compresses spaces
  , 10 `maxWidth` justify "1 2 3 4  5 6" ==> "1 2  3 4 5\n6"
+ , 10 `maxWidth` justify " 1 2 3 4 5 6 7 8 9" ==> " 1 2 3 4 5\n6 7 8 9"
  -- justify respects concatenating words
  , 10 `maxWidth` justify (setWidth (Just 11) ("1 2 3"<>"4 5 6 7")) ==> "1 2  34 5 6\n7"
  -- justify flushes the buffer before
@@ -116,6 +117,58 @@ hunitPlain = testList "Plain"
  , 10 `maxWidth` justify ("a b\n" <> nestedAlign 2) ==> "a        b\n1 2"
  , 10 `maxWidth` justify (bold ("12 34 56 78 "<> underline "90" <> " 123 456  789"))
    ==> "\ESC[1m12  34  56\n78 \ESC[4m90\ESC[0;1m  123\n456 789\ESC[0m"
+ -- align flushes the buffer
+ , 10 `maxWidth` justify (ul ["1 2 3 4 5 6 7 8 9"])
+   ==> "- 1 2  3 4\n\
+       \  5 6  7 8\n\
+       \  9"
+ -- ul/ol is mempty when no item
+ , ul [] ==> ""
+ , ol [] ==> ""
+ -- ul flushes the buffer
+ , 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in ul [i, i])
+   ==> "- 1 2  3 4\n\
+       \  5 6  7 8\n\
+       \  9\n\
+       \- 1 2  3 4\n\
+       \  5 6  7 8\n\
+       \  9"
+ , 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in
+   ul [ul [i, i], ul [i, i]])
+   ==> "- - 1 2  3\n\
+       \    4 5  6\n\
+       \    7 8 9\n\
+       \  - 1 2  3\n\
+       \    4 5  6\n\
+       \    7 8 9\n\
+       \- - 1 2  3\n\
+       \    4 5  6\n\
+       \    7 8 9\n\
+       \  - 1 2  3\n\
+       \    4 5  6\n\
+       \    7 8 9"
+ , 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in
+   ol [ol [i, i], ol [i, i]])
+   ==> "1. 1. 1  2\n\
+       \      3  4\n\
+       \      5  6\n\
+       \      7  8\n\
+       \      9\n\
+       \   2. 1  2\n\
+       \      3  4\n\
+       \      5  6\n\
+       \      7  8\n\
+       \      9\n\
+       \2. 1. 1  2\n\
+       \      3  4\n\
+       \      5  6\n\
+       \      7  8\n\
+       \      9\n\
+       \   2. 1  2\n\
+       \      3  4\n\
+       \      5  6\n\
+       \      7  8\n\
+       \      9"
  -- breakspace backtracking is bounded by the removable indentation
  -- (hence it can actually wrap a few words in reasonable time).
  , 80 `maxWidth`
@@ -265,3 +318,5 @@ listHorV ds =
 
 fun :: IsString d => Indentable d => Wrappable d => d -> d
 fun d = "function(" <> incrIndent 2 (breakalt d (newline<>d<>newline)) <> ")"
+
+t1 = 10 `maxWidth` justify (let i = "1 2 3 4 5 6 7 8 9" in ol [ol [i, i], ol [i, i]])