symantic-document 1.0.0.20190614 → 1.2.2.20190627

raw patch · 5 files changed

+422/−248 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Symantic/Document/API.hs +113/−99
• Symantic/Document/AnsiText.hs +48/−38
• Symantic/Document/Plain.hs +143/−104
• symantic-document.cabal +3/−3
• test/HUnit.hs +115/−4

@@ -6,7 +6,7 @@ import Data.Bool import Data.Char (Char) import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldr, foldr1, null)+import Data.Foldable (Foldable) import Data.Function ((.), ($), id, const) import Data.Functor (Functor(..), (<$>)) import Data.Int (Int)@@ -16,10 +16,12 @@ import Data.Semigroup (Semigroup(..)) import Data.String (String, IsString(..)) import Data.Text (Text)+import Data.Traversable (Traversable) import Numeric.Natural (Natural) import Prelude (Integer, fromIntegral, pred) import System.Console.ANSI (SGR, setSGRCode) import Text.Show (Show(..))+import qualified Data.Foldable as Fold import qualified Data.List as List import qualified Data.Text as Text import qualified Data.Text.Lazy as TL@@ -41,97 +43,97 @@  deriving (Eq,Show,Semigroup) unWord :: Word d -> d unWord (Word d) = d-instance DocFrom [SGR] d => DocFrom [SGR] (Word d) where-	docFrom = Word . docFrom+instance From [SGR] d => From [SGR] (Word d) where+	from = Word . from --- * Class 'DocFrom'-class DocFrom a d where-	docFrom :: a -> d-	default docFrom :: DocFrom String d => Show a => a -> d-	docFrom = docFrom . show-instance DocFrom (Line String) d => DocFrom Int d where-	docFrom = docFrom . Line . show-instance DocFrom (Line String) d => DocFrom Integer d where-	docFrom = docFrom . Line . show-instance DocFrom (Line String) d => DocFrom Natural d where-	docFrom = docFrom . Line . show+-- * Class 'From'+class From a d where+	from :: a -> d+	default from :: From String d => Show a => a -> d+	from = from . show+instance From (Line String) d => From Int d where+	from = from . Line . show+instance From (Line String) d => From Integer d where+	from = from . Line . show+instance From (Line String) d => From Natural d where+	from = from . Line . show  -- String-instance DocFrom Char String where-	docFrom = pure-instance DocFrom String String where-	docFrom = id-instance DocFrom Text String where-	docFrom = Text.unpack-instance DocFrom TL.Text String where-	docFrom = TL.unpack-instance DocFrom d String => DocFrom (Line d) String where-	docFrom = docFrom . unLine-instance DocFrom d String => DocFrom (Word d) String where-	docFrom = docFrom . unWord-instance DocFrom [SGR] String where-	docFrom = setSGRCode+instance From Char String where+	from = pure+instance From String String where+	from = id+instance From Text String where+	from = Text.unpack+instance From TL.Text String where+	from = TL.unpack+instance From d String => From (Line d) String where+	from = from . unLine+instance From d String => From (Word d) String where+	from = from . unWord+instance From [SGR] String where+	from = setSGRCode  -- Text-instance DocFrom Char Text where-	docFrom = Text.singleton-instance DocFrom String Text where-	docFrom = Text.pack-instance DocFrom Text Text where-	docFrom = id-instance DocFrom TL.Text Text where-	docFrom = TL.toStrict-instance DocFrom d Text => DocFrom (Line d) Text where-	docFrom = docFrom . unLine-instance DocFrom d Text => DocFrom (Word d) Text where-	docFrom = docFrom . unWord-instance DocFrom [SGR] Text where-	docFrom = docFrom . setSGRCode+instance From Char Text where+	from = Text.singleton+instance From String Text where+	from = Text.pack+instance From Text Text where+	from = id+instance From TL.Text Text where+	from = TL.toStrict+instance From d Text => From (Line d) Text where+	from = from . unLine+instance From d Text => From (Word d) Text where+	from = from . unWord+instance From [SGR] Text where+	from = from . setSGRCode  -- TLB.Builder-instance DocFrom Char TLB.Builder where-	docFrom = TLB.singleton-instance DocFrom String TLB.Builder where-	docFrom = fromString-instance DocFrom Text TLB.Builder where-	docFrom = TLB.fromText-instance DocFrom TL.Text TLB.Builder where-	docFrom = TLB.fromLazyText-instance DocFrom TLB.Builder TLB.Builder where-	docFrom = id-instance DocFrom d TLB.Builder => DocFrom (Line d) TLB.Builder where-	docFrom = docFrom . unLine-instance DocFrom d TLB.Builder => DocFrom (Word d) TLB.Builder where-	docFrom = docFrom . unWord-instance DocFrom [SGR] TLB.Builder where-	docFrom = docFrom . setSGRCode+instance From Char TLB.Builder where+	from = TLB.singleton+instance From String TLB.Builder where+	from = fromString+instance From Text TLB.Builder where+	from = TLB.fromText+instance From TL.Text TLB.Builder where+	from = TLB.fromLazyText+instance From TLB.Builder TLB.Builder where+	from = id+instance From d TLB.Builder => From (Line d) TLB.Builder where+	from = from . unLine+instance From d TLB.Builder => From (Word d) TLB.Builder where+	from = from . unWord+instance From [SGR] TLB.Builder where+	from = from . setSGRCode  runTextBuilder :: TLB.Builder -> TL.Text runTextBuilder = TLB.toLazyText  -- * Class 'Lengthable' class Lengthable d where-	length :: d -> Column-	nullLength :: d -> Bool-	nullLength d = length d == 0+	width :: d -> Column+	nullWidth :: d -> Bool+	nullWidth d = width d == 0 instance Lengthable Char where-	length _ = 1-	nullLength = const False+	width _ = 1+	nullWidth = const False instance Lengthable String where-	length = fromIntegral . List.length-	nullLength = null+	width = fromIntegral . List.length+	nullWidth = Fold.null instance Lengthable Text.Text where-	length = fromIntegral . Text.length-	nullLength = Text.null+	width = fromIntegral . Text.length+	nullWidth = Text.null instance Lengthable TL.Text where-	length = fromIntegral . TL.length-	nullLength = TL.null+	width = fromIntegral . TL.length+	nullWidth = TL.null instance Lengthable d => Lengthable (Line d) where-	length = fromIntegral . length . unLine-	nullLength = nullLength . unLine+	width = fromIntegral . width . unLine+	nullWidth = nullWidth . unLine instance Lengthable d => Lengthable (Word d) where-	length = fromIntegral . length . unWord-	nullLength = nullLength . unWord+	width = fromIntegral . width . unWord+	nullWidth = nullWidth . unWord  -- * Class 'Spaceable' class Monoid d => Spaceable d where@@ -147,12 +149,12 @@ 	default spaces :: Monoid d => Column -> d 	spaces i = replicate (fromIntegral i) space 	unlines :: Foldable f => f (Line d) -> d-	unlines = foldr (\(Line x) acc -> x<>newline<>acc) mempty+	unlines = Fold.foldr (\(Line x) acc -> x<>newline<>acc) mempty 	unwords :: Foldable f => Functor f => f (Word d) -> d 	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@@@ -161,25 +163,25 @@ 	x </> y = x <> newline <> y 	catH :: Foldable f => f d -> d 	catV :: Foldable f => f d -> d-	catH = foldr (<>) mempty+	catH = Fold.foldr (<>) mempty 	catV = intercalate newline 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 null ds then mempty else foldr1 (\x y -> x<>sep<>y) ds+intercalate sep ds = if Fold.null ds then mempty else Fold.foldr1 (\x y -> x<>sep<>y) ds  replicate :: Monoid d => Int -> d -> d replicate cnt t | cnt <= 0  = mempty@@ -187,14 +189,14 @@  between :: Semigroup d => d -> d -> d -> d between o c d = o<>d<>c-parens :: Semigroup d => DocFrom (Word Char) d => d -> d-parens = between (docFrom (Word '(')) (docFrom (Word ')'))-braces :: Semigroup d => DocFrom (Word Char) d => d -> d-braces = between (docFrom (Word '{')) (docFrom (Word '}'))-brackets :: Semigroup d => DocFrom (Word Char) d => d -> d-brackets = between (docFrom (Word '[')) (docFrom (Word ']'))-angles :: Semigroup d => DocFrom (Word Char) d => d -> d-angles = between (docFrom (Word '<')) (docFrom (Word '>'))+parens :: Semigroup d => From (Word Char) d => d -> d+parens = between (from (Word '(')) (from (Word ')'))+braces :: Semigroup d => From (Word Char) d => d -> d+braces = between (from (Word '{')) (from (Word '}'))+brackets :: Semigroup d => From (Word Char) d => d -> d+brackets = between (from (Word '[')) (from (Word ']'))+angles :: Semigroup d => From (Word Char) d => d -> d+angles = between (from (Word '<')) (from (Word '>'))  -- * Class 'Splitable' class (Lengthable d, Monoid d) => Splitable d where@@ -213,18 +215,18 @@ 	 	splitOnChar :: (Char -> Bool) -> d -> [d] 	splitOnChar f d0 =-		if nullLength d0 then [] else go d0+		if nullWidth d0 then [] else go d0 		where 		go d = 			let (l,r) = f`break`d in 			l : case tail r of 			 Nothing -> []-			 Just rt | nullLength rt -> [mempty]+			 Just rt | nullWidth rt -> [mempty] 			         | otherwise -> go rt 	splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d] 	splitOnCharNoEmpty f d = 		let (l,r) = f`break`d in-		(if nullLength l then [] else [l]) <>+		(if nullWidth l then [] else [l]) <> 		case tail r of 		 Nothing -> [] 		 Just rt -> splitOnCharNoEmpty f rt@@ -404,8 +406,8 @@ 	onWhiter    = xmlSGR "onWhiter"  -- | For debugging purposes.-xmlSGR :: Semigroup d => DocFrom String d => String -> d -> d-xmlSGR newSGR s = docFrom ("<"<>newSGR<>">")<>s<>docFrom ("</"<>newSGR<>">")+xmlSGR :: Semigroup d => From String d => String -> d -> d+xmlSGR newSGR s = from ("<"<>newSGR<>">")<>s<>from ("</"<>newSGR<>">")  -- * Class 'Indentable' class Spaceable d => Indentable d where@@ -438,6 +440,18 @@ 	setIndent  = noTrans1 . setIndent 	fill       = noTrans1 . fill 	breakfill  = noTrans1 . breakfill++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

@@ -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.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 @@  -- * 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@@ -27,20 +30,20 @@ runAnsiText :: AnsiText d -> d runAnsiText (AnsiText d) = (`runReader` []) d -instance DocFrom Char d => DocFrom Char (AnsiText d) where-	docFrom = AnsiText . return . docFrom-instance DocFrom String d => DocFrom String (AnsiText d) where-	docFrom = AnsiText . return . docFrom-instance DocFrom Text d => DocFrom Text (AnsiText d) where-	docFrom = AnsiText . return . docFrom-instance DocFrom TL.Text d => DocFrom TL.Text (AnsiText d) where-	docFrom = AnsiText . return . docFrom-instance DocFrom s (AnsiText d) => DocFrom (Line s) (AnsiText d) where-	docFrom = docFrom . unLine-instance DocFrom s (AnsiText d) => DocFrom (Word s) (AnsiText d) where-	docFrom = docFrom . unWord-instance DocFrom String d => IsString (AnsiText d) where-	fromString = docFrom+instance From Char d => From Char (AnsiText d) where+	from = AnsiText . return . from+instance From String d => From String (AnsiText d) where+	from = AnsiText . return . from+instance From Text d => From Text (AnsiText d) where+	from = AnsiText . return . from+instance From TL.Text d => From TL.Text (AnsiText d) where+	from = AnsiText . return . from+instance From s (AnsiText d) => From (Line s) (AnsiText d) where+	from = from . unLine+instance From s (AnsiText d) => From (Word s) (AnsiText d) where+	from = from . unWord+instance From String d => IsString (AnsiText d) where+	fromString = from instance Semigroup d => Semigroup (AnsiText d) where 	AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y instance Monoid d => Monoid (AnsiText d) where@@ -49,13 +52,13 @@ instance Lengthable d => Lengthable (AnsiText d) where 	-- NOTE: AnsiText's Reader can be run with an empty value 	-- because all 'SGR' are ignored anyway.-	length (AnsiText ds) = length $ runReader ds mempty-	nullLength (AnsiText ds) = nullLength $ runReader ds mempty+	width (AnsiText ds) = width $ runReader ds mempty+	nullWidth (AnsiText ds) = nullWidth $ runReader ds mempty instance Spaceable d => Spaceable (AnsiText d) where 	newline = AnsiText $ return newline 	space   = AnsiText $ return space 	spaces  = AnsiText . return . spaces-instance (Semigroup d, DocFrom [SGR] d) => Colorable16 (AnsiText d) where+instance (Semigroup d, From [SGR] d) => Colorable16 (AnsiText d) where 	reverse     = ansiTextSGR $ SetSwapForegroundBackground True 	black       = ansiTextSGR $ SetColor Foreground Dull  Black 	red         = ansiTextSGR $ SetColor Foreground Dull  Red@@ -89,7 +92,7 @@ 	onMagentaer = ansiTextSGR $ SetColor Background Vivid Magenta 	onCyaner    = ansiTextSGR $ SetColor Background Vivid Cyan 	onWhiter    = ansiTextSGR $ SetColor Background Vivid White-instance (Semigroup d, DocFrom [SGR] d) => Decorable (AnsiText d) where+instance (Semigroup d, From [SGR] d) => Decorable (AnsiText d) where 	bold      = ansiTextSGR $ SetConsoleIntensity BoldIntensity 	underline = ansiTextSGR $ SetUnderlining SingleUnderline 	italic    = ansiTextSGR $ SetItalicized True@@ -101,6 +104,9 @@ 	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@@ -108,16 +114,17 @@ 	breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y  ansiTextSGR ::- Semigroup d => DocFrom [SGR] d =>+ Semigroup d => From [SGR] d =>  SGR -> AnsiText d -> AnsiText d ansiTextSGR newSGR (AnsiText d) = AnsiText $ do 	oldSGR <- ask-	(\m -> docFrom [newSGR] <> m <> docFrom (Reset:List.reverse oldSGR))+	(\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR)) 	 <$> local (newSGR :) d  -- * Type 'PlainText' -- | Drop 'Colorable16' and 'Decorable'. newtype PlainText d = PlainText { unPlainText :: d }+ deriving (Show)  plainText :: PlainText d -> PlainText d plainText = id@@ -125,20 +132,20 @@ runPlainText :: PlainText d -> d runPlainText (PlainText d) = d -instance DocFrom Char d => DocFrom Char (PlainText d) where-	docFrom = PlainText . docFrom-instance DocFrom String d => DocFrom String (PlainText d) where-	docFrom = PlainText . docFrom-instance DocFrom Text d => DocFrom Text (PlainText d) where-	docFrom = PlainText . docFrom-instance DocFrom TL.Text d => DocFrom TL.Text (PlainText d) where-	docFrom = PlainText . docFrom-instance DocFrom s (PlainText d) => DocFrom (Line s) (PlainText d) where-	docFrom = docFrom . unLine-instance DocFrom s (PlainText d) => DocFrom (Word s) (PlainText d) where-	docFrom = docFrom . unWord-instance DocFrom String d => IsString (PlainText d) where-	fromString = docFrom+instance From Char d => From Char (PlainText d) where+	from = PlainText . from+instance From String d => From String (PlainText d) where+	from = PlainText . from+instance From Text d => From Text (PlainText d) where+	from = PlainText . from+instance From TL.Text d => From TL.Text (PlainText d) where+	from = PlainText . from+instance From s (PlainText d) => From (Line s) (PlainText d) where+	from = from . unLine+instance From s (PlainText d) => From (Word s) (PlainText d) where+	from = from . unWord+instance From String d => IsString (PlainText d) where+	fromString = from instance Semigroup d => Semigroup (PlainText d) where 	PlainText x <> PlainText y = PlainText $ (<>) x y instance Monoid d => Monoid (PlainText d) where@@ -147,8 +154,8 @@ instance Lengthable d => Lengthable (PlainText d) where 	-- NOTE: PlainText's Reader can be run with an empty value 	-- because all 'SGR' are ignored anyway.-	length (PlainText ds) = length ds-	nullLength (PlainText ds) = nullLength ds+	width (PlainText ds) = width ds+	nullWidth (PlainText ds) = nullWidth ds instance Spaceable d => Spaceable (PlainText d) where 	newline = PlainText $ newline 	space   = PlainText $ space@@ -187,7 +194,7 @@ 	onMagentaer = plainTextSGR 	onCyaner    = plainTextSGR 	onWhiter    = plainTextSGR-instance (Semigroup d, DocFrom [SGR] d) => Decorable (PlainText d) where+instance Semigroup d => Decorable (PlainText d) where 	bold      = plainTextSGR 	underline = plainTextSGR 	italic    = plainTextSGR@@ -199,6 +206,9 @@ 	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

@@ -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.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 @@      -- 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 =@@ -55,7 +59,10 @@ data PlainState d = PlainState  { plainState_buffer          :: ![PlainChunk d]  , plainState_bufferStart     :: !Column+   -- ^ The 'Column' from which the 'plainState_buffer'+   -- must be written.  , plainState_bufferWidth     :: !Width+   -- ^ The 'Width' of the 'plainState_buffer' so far.  , plainState_removableIndent :: !Indent    -- ^ The amount of 'Indent' added by 'breakspace'    -- that can be removed by breaking the 'space' into a 'newline'.@@ -115,16 +122,16 @@ 			showString "S " . 			showsPrec 11 s instance Lengthable d => Lengthable (PlainChunk d) where-	length = \case+	width = \case 	 PlainChunk_Ignored{} -> 0-	 PlainChunk_Word d -> length d+	 PlainChunk_Word d -> width d 	 PlainChunk_Spaces s -> s-	nullLength = \case+	nullWidth = \case 	 PlainChunk_Ignored{} -> True-	 PlainChunk_Word d -> nullLength d+	 PlainChunk_Word d -> nullWidth d 	 PlainChunk_Spaces s -> s == 0-instance DocFrom [SGR] d => DocFrom [SGR] (PlainChunk d) where-	docFrom sgr = PlainChunk_Ignored (docFrom sgr)+instance From [SGR] d => From [SGR] (PlainChunk d) where+	from sgr = PlainChunk_Ignored (from sgr)  runPlainChunk :: Spaceable d => PlainChunk d -> d runPlainChunk = \case@@ -140,7 +147,7 @@ instance Monoid d => Monoid (Plain d) where 	mempty = Plain $ \_inh st k -> k (id,st) 	mappend = (<>)-instance (Spaceable d) => Spaceable (Plain d) where+instance Spaceable d => Spaceable (Plain d) where 	newline = Plain $ \inh st k -> 		k(\next -> 			(if plainInh_justify inh then joinLine inh st else mempty) <>@@ -167,7 +174,7 @@ 					 } 			in 			case plainInh_width inh of-			 Just width | width < newWidth ->+			 Just maxWidth | maxWidth < newWidth -> 				overflow $ k (id{-(d<>)-}, newState) fits overflow 			 _ -> k (id{-(d<>)-}, newState) fits overflow 		else@@ -175,27 +182,28 @@ 				 { plainState_bufferWidth = plainState_bufferWidth + n 				 } in 			case plainInh_width inh of-			 Just width | width < newWidth ->+			 Just maxWidth | maxWidth < newWidth -> 				overflow $ k ((spaces n <>), newState) fits fits 			 _ -> k ((spaces n <>), newState) fits overflow-instance (DocFrom (Word s) d, Semigroup d, Lengthable s) => DocFrom (Word s) (Plain d) where-	docFrom s = Plain $ \inh st@PlainState{..} k fits overflow ->-		let wordLen = length s in-		if wordLen <= 0+instance (From (Word s) d, Semigroup d, Lengthable s) =>+         From (Word s) (Plain d) where+	from s = Plain $ \inh st@PlainState{..} k fits overflow ->+		let wordWidth = width s in+		if wordWidth <= 0 		then k (id,st) fits overflow 		else-			let newBufferWidth = plainState_bufferWidth + wordLen in+			let newBufferWidth = plainState_bufferWidth + wordWidth in 			let newWidth = plainState_bufferStart + newBufferWidth in 			if plainInh_justify inh 			then 				let newState = st 					 { plainState_buffer =-						PlainChunk_Word (Word (docFrom s)) :+						PlainChunk_Word (Word (from s)) : 						plainState_buffer 					 , plainState_bufferWidth = newBufferWidth 					 } in 				case plainInh_width inh of-				 Just width | width < newWidth ->+				 Just maxWidth | maxWidth < newWidth -> 					overflow $ k (id, newState) fits overflow 				 _ -> k (id, newState) fits overflow 			else@@ -203,19 +211,19 @@ 					 { plainState_bufferWidth = newBufferWidth 					 } in 				case plainInh_width inh of-				 Just width | width < newWidth ->-					overflow $ k ((docFrom s <>), newState) fits fits-				 _ -> k ((docFrom s <>), newState) fits overflow-instance (DocFrom (Word s) d, Lengthable s, Spaceable d, Splitable s) =>-         DocFrom (Line s) (Plain d) where-	docFrom =+				 Just maxWidth | maxWidth < newWidth ->+					overflow $ k ((from s <>), newState) fits fits+				 _ -> k ((from s <>), newState) fits overflow+instance (From (Word s) d, Lengthable s, Spaceable d, Splitable s) =>+         From (Line s) (Plain d) where+	from = 		mconcat . 		List.intersperse breakspace .-		(docFrom <$>) .+		(from <$>) . 		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 ->@@ -249,24 +257,39 @@ 			 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 = (<> flushLastLine) $ Plain $ \inh ->+	justify p = (\x -> flushLine <> x <> flushLine) $ Plain $ \inh -> 		unPlain p inh{plainInh_justify=True}-		where-		flushLastLine :: Plain d-		flushLastLine = 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-instance (Spaceable d) => Wrappable (Plain d) where++-- | 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} 	breakpoint = Plain $ \inh st k fits overflow ->@@ -274,7 +297,7 @@ 		k 		 ( id 		 , st-			 { plainState_removableIndent  = newlineInd+			 { plainState_removableIndent = newlineInd 			 } 		 ) 		 fits@@ -293,9 +316,11 @@ 		 ( 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 			 }@@ -316,44 +341,44 @@ 			unPlain y inh st k fits overflow 		 ) -- String-instance (DocFrom (Word String) d, Spaceable d) =>-         DocFrom String (Plain d) where-	docFrom =+instance (From (Word String) d, Spaceable d) =>+         From String (Plain d) where+	from = 		mconcat . 		List.intersperse newline .-		(docFrom <$>) .+		(from <$>) . 		lines-instance (DocFrom (Word String) d, Spaceable d) =>+instance (From (Word String) d, Spaceable d) =>          IsString (Plain d) where-	fromString = docFrom+	fromString = from -- Text-instance (DocFrom (Word Text) d, Spaceable d) =>-         DocFrom Text (Plain d) where-	docFrom =+instance (From (Word Text) d, Spaceable d) =>+         From Text (Plain d) where+	from = 		mconcat . 		List.intersperse newline .-		(docFrom <$>) .+		(from <$>) . 		lines-instance (DocFrom (Word TL.Text) d, Spaceable d) =>-         DocFrom TL.Text (Plain d) where-	docFrom =+instance (From (Word TL.Text) d, Spaceable d) =>+         From TL.Text (Plain d) where+	from = 		mconcat . 		List.intersperse newline .-		(docFrom <$>) .+		(from <$>) . 		lines -- Char-instance (DocFrom (Word Char) d, Spaceable d) =>-         DocFrom Char (Plain d) where-	docFrom ' '  = breakspace-	docFrom '\n' = newline-	docFrom c    = docFrom (Word c)+instance (From (Word Char) d, Spaceable d) =>+         From Char (Plain d) where+	from ' '  = breakspace+	from '\n' = newline+	from c    = from (Word c)  -instance (DocFrom [SGR] d, Semigroup d) => DocFrom [SGR] (Plain d) where-	docFrom sgr = Plain $ \inh st k ->+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 (docFrom sgr) : plainState_buffer st})-		else k ((docFrom sgr <>), st)+		then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})+		else k ((from sgr <>), st)  joinLine ::  Spaceable d =>@@ -361,37 +386,49 @@ joinLine PlainInh{..} PlainState{..} = 	case plainInh_width of 	 Nothing -> joinPlainLine $ List.reverse plainState_buffer-	 Just width ->-		if width < plainState_bufferStart-		|| width < plainInh_indent+	 Just maxWidth ->+		if maxWidth < plainState_bufferStart+		|| maxWidth < plainInh_indent 		then joinPlainLine $ List.reverse plainState_buffer 		else-			let wordCount =-				foldr (\c acc -> acc + case c of-				 PlainChunk_Word{} -> 1-				 _ -> 0) 0 plainState_buffer in-			let bufferWidth =-				-- NOTE: compress all separated spaces into a single one.-				if wordCount == 0-				then 0-				else-					let spaceCount = foldr-						 (\c acc ->-							acc + case c of-							 PlainChunk_Ignored{} -> 0-							 PlainChunk_Word{} -> 0-							 PlainChunk_Spaces s -> s)-						 0 plainState_buffer in-					(plainState_bufferWidth`minusNatural`spaceCount) +-					(wordCount`minusNatural`1) in-			let adjustedWidth =-				max bufferWidth $-					min-					(width`minusNatural`plainState_bufferStart)-					(width`minusNatural`plainInh_indent) in-			unLine $ padPlainLineInits adjustedWidth-			 (bufferWidth,wordCount,List.reverse plainState_buffer)+			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+			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+	go inWord acc = \case+	 [] -> acc+	 PlainChunk_Word{}:xs ->+		if inWord+		then go inWord acc xs+		else go True (acc+1) xs+	 PlainChunk_Spaces s:xs+	  | s == 0    -> go inWord acc xs+	  | otherwise -> go False acc xs+	 PlainChunk_Ignored{}:xs -> go inWord acc xs+ -- | @('justifyPadding' a b)@ returns the padding lengths -- to reach @(a)@ in @(b)@ pads, -- using the formula: @(a '==' m'*'(q '+' q'+'1) '+' ('r'-'m)'*'(q'+'1) '+' (b'-'r'-'m)'*'q)@@@ -419,23 +456,25 @@ padPlainLineInits ::  Spaceable d =>  Width -> (Natural, Natural, [PlainChunk d]) -> Line d-padPlainLineInits width (lineLen,wordCount,line) = Line $-	if width <= lineLen-		-- The gathered line reached or overreached the width,+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 width <= lineLen && wordCount == 1-		-- can happen if first word's length is < width-		-- but second word's len is >= width.+		-- 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 (width-lineLen) (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

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 1.0.0.20190614+version: 1.2.2.20190627 category: Text synopsis: Document symantics. description: Symantics for generating documents.@@ -16,8 +16,8 @@ -- homepage:  build-type: Simple-cabal-version: >= 1.24-tested-with: GHC==8.4.4+cabal-version: 1.24+tested-with: GHC==8.6.4 extra-source-files:   stack.yaml extra-tmp-files:

@@ -105,15 +105,72 @@  , 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+ , 10 `maxWidth` "__" <> align (justify "1 2 3 4 5") ==> "__1 2  3 4\n  5"  -- justify does not overflow the alignment  , 10 `maxWidth` justify (nestedAlign 6) ==> "1 2 3 4 5\n         6"  , 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 justify a few words in reasonable time).+ -- (hence it can actually wrap a few words in reasonable time).  , 80 `maxWidth`   "Lorem ipsum dolor sit amet,  Nulla nec tortor. Donec id elit quis purus\   \ consectetur consequat. Nam congue semper tellus. Sed erat dolor,\@@ -167,6 +224,58 @@   \ mollis, posuere eu, pede. Nulla nec tortor. Donec id elit quis\   \ purus\nconsectetur consequat. Nam congue semper tellus. Sed erat dolor, dapibus\   \ sit\namet, venenatis ornare, ultrices ut, nisi."+ , 80 `maxWidth` justify+  "Lorem ipsum dolor sit amet,  Nulla nec tortor. Donec id elit quis purus\+  \ consectetur consequat. Nam congue semper tellus. Sed erat dolor,\+  \ dapibus sit amet, venenatis ornare, ultrices ut, nisi. Aliquam ante.\+  \ Suspendisse scelerisque dui nec velit. Duis augue augue, gravida euismod,\+  \ vulputate ac, facilisis id, sem. Morbi in orci. Nulla purus lacus,\+  \ pulvinar vel, malesuada ac, mattis nec, quam. Nam molestie scelerisque\+  \ quam. Nullam feugiat cursus lacus.orem ipsum dolor sit amet, consectetur\+  \ adipiscing elit. Donec libero risus, commodo vitae, pharetra mollis,\+  \ posuere eu, pede. Nulla nec tortor. Donec id elit quis purus consectetur\+  \ consequat. Nam congue semper tellus. Sed erat dolor, dapibus sit\+  \ amet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse\+  \ scelerisque dui nec velit. Duis augue augue, gravida euismod, vulputate ac,\+  \ facilisis id, sem. Morbi in orci. Nulla purus lacus, pulvinar vel,\+  \ malesuada ac, mattis nec, quam. Nam molestie scelerisque quam.\+  \ Nullam feugiat cursus lacus.orem ipsum dolor sit amet, consectetur\+  \ adipiscing elit. Donec libero risus, commodo vitae, pharetra mollis,\+  \ posuere eu, pede. Nulla nec tortor. Donec id elit quis purus consectetur\+  \ consequat. Nam congue semper tellus. Sed erat dolor, dapibus sit amet,\+  \ venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse\+  \ scelerisque dui nec velit. Duis augue augue, gravida euismod, vulputate ac,\+  \ facilisis id, sem. Morbi in orci. Nulla purus lacus, pulvinar vel,\+  \ malesuada ac, mattis nec, quam. Nam molestie scelerisque quam. Nullam\+  \ feugiat cursus lacus.orem ipsum dolor sit amet, consectetur adipiscing\+  \ elit. Donec libero risus, commodo vitae, pharetra mollis, posuere eu, pede.\+  \ Nulla nec tortor. Donec id elit quis purus consectetur consequat. Nam\+  \ congue semper tellus. Sed erat dolor, dapibus sit amet, venenatis ornare,\+  \ ultrices ut, nisi."+  ==> "Lorem ipsum  dolor sit  amet,  Nulla  nec  tortor.  Donec  id  elit  quis  purus\n\+  \consectetur consequat.  Nam congue  semper tellus.  Sed erat  dolor, dapibus sit\n\+  \amet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse scelerisque\n\+  \dui nec  velit. Duis  augue augue,  gravida euismod, vulputate ac, facilisis id,\n\+  \sem. Morbi  in orci.  Nulla purus lacus, pulvinar vel, malesuada ac, mattis nec,\n\+  \quam. Nam  molestie scelerisque  quam. Nullam  feugiat cursus  lacus.orem  ipsum\n\+  \dolor sit  amet, consectetur adipiscing elit. Donec libero risus, commodo vitae,\n\+  \pharetra mollis,  posuere eu,  pede. Nulla  nec tortor. Donec id elit quis purus\n\+  \consectetur consequat.  Nam congue  semper tellus.  Sed erat  dolor, dapibus sit\n\+  \amet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse scelerisque\n\+  \dui nec  velit. Duis  augue augue,  gravida euismod, vulputate ac, facilisis id,\n\+  \sem. Morbi  in orci.  Nulla purus lacus, pulvinar vel, malesuada ac, mattis nec,\n\+  \quam. Nam  molestie scelerisque  quam. Nullam  feugiat cursus  lacus.orem  ipsum\n\+  \dolor sit  amet, consectetur adipiscing elit. Donec libero risus, commodo vitae,\n\+  \pharetra mollis,  posuere eu,  pede. Nulla  nec tortor. Donec id elit quis purus\n\+  \consectetur consequat.  Nam congue  semper tellus.  Sed erat  dolor, dapibus sit\n\+  \amet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse scelerisque\n\+  \dui nec  velit. Duis  augue augue,  gravida euismod, vulputate ac, facilisis id,\n\+  \sem. Morbi  in orci.  Nulla purus lacus, pulvinar vel, malesuada ac, mattis nec,\n\+  \quam. Nam  molestie scelerisque  quam. Nullam  feugiat cursus  lacus.orem  ipsum\n\+  \dolor sit  amet, consectetur adipiscing elit. Donec libero risus, commodo vitae,\n\+  \pharetra mollis,  posuere eu,  pede. Nulla  nec tortor. Donec id elit quis purus\n\+  \consectetur consequat.  Nam congue  semper tellus.  Sed erat  dolor, dapibus sit\n\+  \amet, venenatis ornare, ultrices ut, nisi."                                         ] 	where 	(==>) :: IsString d => d ~ String => AnsiText (Plain d) -> d -> Assertion; infix 0 ==>@@ -187,13 +296,13 @@ maxWidth = setWidth . Just  nestedAlign ::- DocFrom (Line String) d =>+ From (Line String) d =>  Spaceable d => Indentable d => Wrappable d =>  Int -> d nestedAlign n = go 1 	where 	go i =-		docFrom (Line (show i)) <>+		from (Line (show i)) <> 		(if n <= i then mempty 		else align (breakspace <> go (i+1))) @@ -209,3 +318,5 @@  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]])