symantic-document 0.1.2.20180831 → 1.0.0.20190614

raw patch · 12 files changed

+1342/−1210 lines, 12 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Language/Symantic/Document.hs +0/−4
• Language/Symantic/Document/Sym.hs +0/−454
• Language/Symantic/Document/Term.hs +0/−186
• Language/Symantic/Document/Term/Dimension.hs +0/−198
• Language/Symantic/Document/Term/IO.hs +0/−183
• Symantic/Document.hs +8/−0
• Symantic/Document/API.hs +484/−0
• Symantic/Document/AnsiText.hs +211/−0
• Symantic/Document/Plain.hs +447/−0
• stack.yaml +1/−1
• symantic-document.cabal +10/−8
• test/HUnit.hs +181/−176

@@ -1,4 +0,0 @@-module Language.Symantic.Document- ( module Language.Symantic.Document.Sym- ) where-import Language.Symantic.Document.Sym

@@ -1,454 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Language.Symantic.Document.Sym where--import Data.Bool-import Data.Char (Char)-import Data.Eq (Eq(..))-import Data.Foldable (Foldable, foldr, foldr1)-import Data.Function ((.), ($))-import Data.Functor (Functor(..))-import Data.Int (Int)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..), Ordering(..))-import Data.Semigroup (Semigroup(..))-import Data.String (String, IsString)-import Prelude (Integer, fromIntegral, Num(..), pred, undefined, Integral, Real, Enum)-import Text.Show (Show(..))-import qualified Data.Foldable as Foldable-import qualified Data.List as List-import qualified Data.Text as Text-import qualified Data.Text.Lazy as TL---- * Type 'Nat'-newtype Nat = Nat { unNat :: Integer }- deriving (Eq, Ord, Show, Integral, Real, Enum)-unLength :: Nat -> Integer-unLength (Nat i) = i-instance Num Nat where-	fromInteger i | 0 <= i    = Nat i-	              | otherwise = undefined-	abs = Nat . abs . unLength-	signum = signum . signum-	Nat x + Nat y = Nat (x + y)-	Nat x * Nat y = Nat (x * y)-	Nat x - Nat y | x >= y    = Nat (x - y)-	              | otherwise = undefined---- * Class 'Lengthable'-class Lengthable a where-	length :: a -> Nat-instance Lengthable Char where-	length _ = Nat 1-instance Lengthable [a] where-	length = Nat . fromIntegral . List.length-instance Lengthable Text.Text where-	length = Nat . fromIntegral . Text.length-instance Lengthable TL.Text where-	length = Nat . fromIntegral . TL.length---- * Class 'Splitable'-class Monoid a => Splitable a where-	null  :: a -> Bool-	tail  :: a -> a-	break :: (Char -> Bool) -> a -> (a, a)-	lines :: a -> [a]-	lines = splitOnChar (== '\n')-	words :: a -> [a]-	words = splitOnChar (== ' ')-	splitOnChar :: (Char -> Bool) -> a -> [a]-	splitOnChar c a =-		if null a then []-		else let (l,a') = break c a in-			l : if null a' then []-				else let a'' = tail a' in-					if null a'' then [mempty] else splitOnChar c a''-instance Splitable String where-	null  = List.null-	tail  = List.tail-	break = List.break-instance Splitable Text.Text where-	null  = Text.null-	tail  = Text.tail-	break = Text.break-instance Splitable TL.Text where-	null  = TL.null-	tail  = TL.tail-	break = TL.break---- * Type 'Column'-type Column = Nat---- ** Type 'Indent'-type Indent = Column---- * Class 'Textable'-class (IsString d, Semigroup d) => Textable d where-	empty     :: d-	charH     :: Char -- ^ XXX: MUST NOT be '\n'-	          -> d-	stringH   :: String -- ^ XXX: MUST NOT contain '\n'-	          -> d-	textH     :: Text.Text -- ^ XXX: MUST NOT contain '\n'-	          -> d-	ltextH    :: TL.Text -- ^ XXX: MUST NOT contain '\n'-	          -> d-	default empty     :: Textable (ReprOf d) => Trans d => d-	default charH     :: Textable (ReprOf d) => Trans d => Char -> d-	default stringH   :: Textable (ReprOf d) => Trans d => String -> d-	default textH     :: Textable (ReprOf d) => Trans d => Text.Text -> d-	default ltextH    :: Textable (ReprOf d) => Trans d => TL.Text -> d-	empty     = trans empty-	charH     = trans . charH-	stringH   = trans . stringH-	textH     = trans . textH-	ltextH    = trans . ltextH-	-	newline     :: d-	space       :: d-	-- | @x '<+>' y = x '<>' 'space' '<>' y@-	(<+>)       :: d -> d -> d-	-- | @x '</>' y = x '<>' 'newline' '<>' y@-	(</>)       :: d -> d -> d-	int         :: Int -> d-	integer     :: Integer -> d-	char        :: Char    -> d-	string      :: String  -> d-	text        :: Text.Text  -> d-	ltext       :: TL.Text -> d-	catH        :: Foldable f => f d -> d-	catV        :: Foldable f => f d -> d-	unwords     :: Foldable f => f d -> d-	unlines     :: Foldable f => f d -> d-	foldrWith   :: Foldable f => (d -> d -> d) -> f d -> d-	foldWith    :: Foldable f => (d -> d) -> f d -> d-	intercalate :: Foldable f => d -> f d -> d-	between     :: d -> d -> d -> d-	replicate   :: Int -> d -> d-	-	newline = "\n"-	space   = char ' '-	x <+> y = x <> space <> y-	x </> y = x <> newline <> y-	int     = stringH . show-	integer = stringH . show-	char    = \case '\n' -> newline; c -> charH c-	string  = catV . fmap stringH . lines-	text    = catV . fmap textH   . lines-	ltext   = catV . fmap ltextH  . lines-	catH    = foldr (<>) empty-	catV    = foldrWith (\x y -> x<>newline<>y)-	unwords = foldr (<>) space-	unlines = foldr (\x y -> x<>newline<>y) empty-	foldrWith f ds  = if Foldable.null ds then empty else foldr1 f ds-	foldWith  f     = foldrWith $ \a acc -> a <> f acc-	intercalate sep = foldrWith (\x y -> x<>sep<>y)-	between o c d = o<>d<>c-	replicate cnt t | cnt <= 0  = empty-	                | otherwise = t <> replicate (pred cnt) t---- * Class 'Indentable'-class Textable d => Indentable d where-	-- | @('align' d)@ make @d@ uses current 'Column' as 'Indent' level.-	align :: d -> d-	default align :: Indentable (ReprOf d) => Trans d => d -> d-	align = trans1 align-	-- | @('incrIndent' ind d)@ make @d@ uses current 'Indent' plus @ind@ as 'Indent' level.-	incrIndent :: Indent -> d -> d-	default incrIndent :: Indentable (ReprOf d) => Trans d => Indent -> d -> d-	incrIndent = trans1 . incrIndent-	-- | @('withIndent' ind d)@ make @d@ uses @ind@ as 'Indent' level.-	withIndent :: Indent -> d -> d-	default withIndent :: Indentable (ReprOf d) => Trans d => Indent -> d -> d-	withIndent = trans1 . withIndent-	-- | @('withNewline' nl d)@ make @d@ uses @nl@ as 'newline'.-	---	-- Useful values for @nl@ are: 'empty', 'newlineWithIndent', 'newlineWithoutIndent'.-	withNewline          :: d -> d -> d-	newlineWithoutIndent :: d-	newlineWithIndent    :: d-	default withNewline          :: Indentable (ReprOf d) => Trans d => d -> d -> d-	default newlineWithoutIndent :: Indentable (ReprOf d) => Trans d => d-	default newlineWithIndent    :: Indentable (ReprOf d) => Trans d => d-	withNewline          = trans2 withNewline-	newlineWithoutIndent = trans newlineWithoutIndent-	newlineWithIndent    = trans newlineWithIndent-	-- | @('column' f)@ write @f@ applied to the current 'Column'.-	column :: (Column -> d) -> d-	default column :: Indentable (ReprOf d) => Trans d => (Column -> d) -> d-	column f = trans $ column (unTrans . f)-	-- | @('indent' f)@ write @f@ applied to the current 'Indent'.-	indent :: (Indent -> d) -> d-	default indent :: Indentable (ReprOf d) => Trans d => (Indent -> d) -> d-	indent f = trans $ indent (unTrans . f)-	-	-- | @('hang' ind d)@ make @d@ uses current 'Column' plus @ind@ as 'Indent' level.-	hang :: Indent -> d -> d-	hang ind = align . incrIndent ind-	-	-- | @('endToEndWidth' d f)@ write @d@ then-	-- @f@ applied to the absolute value of the difference between-	-- the end 'Column' and start 'Column' of @d@.-	---	-- Note that @f@ is given the end-to-end width,-	-- which is not necessarily the maximal width.-	endToEndWidth :: d -> (Column -> d) -> d-	endToEndWidth d f =-		column $ \c1 ->-			(d <>) $-			column $ \c2 ->-			f $ if c2 - c1 >= 0-				then c2 - c1-				else c1 - c2-	-	-- | @'spaces' ind = 'replicate' ind 'space'@-	spaces :: Indent -> d-	spaces i = replicate (fromIntegral i) space-	-	-- | @('fill' ind d)@ write @d@,-	-- then if @d@ is not wider than @ind@,-	-- write the difference with 'spaces'.-	fill :: Indent -> d -> d-	fill m d =-		endToEndWidth d $ \w ->-			case w`compare`m of-			 LT -> spaces $ m - w-			 _  -> empty-	-	-- | @('breakableFill' ind d)@ write @d@,-	-- then if @d@ is not wider than @ind@, write the difference with 'spaces'-	-- otherwise write a 'newline' indented to to the start 'Column' of @d@ plus @ind@.-	breakableFill :: Indent -> d -> d-	breakableFill m d =-		column $ \c ->-		endToEndWidth d $ \w ->-			case w`compare`m of-			 LT -> spaces (m - w)-			 EQ -> empty-			 GT -> withIndent (c + m) newline---- * Class 'Breakable'-class (Textable d, Indentable d) => Breakable d where-	-- | @('breakable' f)@ write @f@ applied to whether breaks are activated or not.-	breakable :: (Maybe Column -> d) -> d-	default breakable :: Breakable (ReprOf d) => Trans d => (Maybe Column -> d) -> d-	breakable f = trans $ breakable (unTrans . f)-	-- | @('withBreakable' b d)@ whether to active breaks or not within @d@.-	withBreakable :: Maybe Column -> d -> d-	default withBreakable :: Breakable (ReprOf d) => Trans d => Maybe Column -> d -> d-	withBreakable = trans1 . withBreakable-	-	-- | @('ifBreak' onWrap onNoWrap)@-	-- write @onWrap@ if @onNoWrap@ leads to a 'Column'-	-- greater or equal to the one sets with 'withBreakable',-	-- otherwise write @onNoWrap@.-	ifBreak :: d -> d -> d-	default ifBreak :: Breakable (ReprOf d) => Trans d => d -> d -> d-	ifBreak = trans2 ifBreak-	-- | @('breakpoint' onNoBreak onBreak d)@-	-- write @onNoBreak@ then @d@ if they fit,-	-- @onBreak@ otherwise.-	breakpoint :: d -> d -> d -> d-	default breakpoint :: Breakable (ReprOf d) => Trans d => d -> d -> d -> d-	breakpoint = trans3 breakpoint-	-	-- | @('breakableEmpty' d)@ write @d@ if it fits, 'newline' then @d@ otherwise.-	breakableEmpty :: d -> d-	breakableEmpty = breakpoint empty newline-	-	-- | @x '><' y = x '<>' 'breakableEmpty' y@-	(><) :: d -> d -> d-	x >< y = x <> breakableEmpty y-	-	-- | @('breakableSpace' d)@ write 'space' then @d@ it they fit,-	-- 'newline' then @d@ otherwise.-	breakableSpace :: d -> d-	breakableSpace = breakpoint space newline-	-	-- | @x '>+<' y = x '<>' 'breakableSpace' y@-	(>+<) :: d -> d -> d-	x >+< y = x <> breakableSpace y-	-	-- | @'breakableSpaces' ds@ intercalate a 'breakableSpace'-	-- between items of @ds@.-	breakableSpaces :: Foldable f => f d -> d-	breakableSpaces = foldWith breakableSpace-	-	-- | @('intercalateHorV' sep ds)@-	-- write @ds@ with @sep@ intercalated if the whole fits,-	-- otherwise write 'align' of @ds@ with 'newline' and @sep@ intercalated.-	intercalateHorV :: Foldable f => d -> f d -> d-	intercalateHorV sep xs =-		ifBreak-		 (align $ foldWith ((newline <> sep) <>) xs)-		 (foldWith (sep <>) xs)---- * Class 'Colorable'-class Colorable d where-	-- | @('colorable' f)@ write @f@ applied to whether colors are activated or not.-	colorable :: (Bool -> d) -> d-	default colorable :: Colorable (ReprOf d) => Trans d => (Bool -> d) -> d-	colorable f = trans $ colorable (unTrans . f)-	-- | @('withColor' b d)@ whether to active colors or not within @d@.-	withColorable :: Bool -> d -> d-	default withColorable :: Colorable (ReprOf d) => Trans d => Bool -> d -> d-	withColorable = trans1 . withColorable-	-	reverse :: d -> d-	-	-- Foreground colors-	-- Dull-	black   :: d -> d-	red     :: d -> d-	green   :: d -> d-	yellow  :: d -> d-	blue    :: d -> d-	magenta :: d -> d-	cyan    :: d -> d-	white   :: d -> d-	-	-- Vivid-	blacker   :: d -> d-	redder    :: d -> d-	greener   :: d -> d-	yellower  :: d -> d-	bluer     :: d -> d-	magentaer :: d -> d-	cyaner    :: d -> d-	whiter    :: d -> d-	-	-- Background colors-	-- Dull-	onBlack   :: d -> d-	onRed     :: d -> d-	onGreen   :: d -> d-	onYellow  :: d -> d-	onBlue    :: d -> d-	onMagenta :: d -> d-	onCyan    :: d -> d-	onWhite   :: d -> d-	-	-- Vivid-	onBlacker   :: d -> d-	onRedder    :: d -> d-	onGreener   :: d -> d-	onYellower  :: d -> d-	onBluer     :: d -> d-	onMagentaer :: d -> d-	onCyaner    :: d -> d-	onWhiter    :: d -> d-	-	default reverse     :: Colorable (ReprOf d) => Trans d => d -> d-	default black       :: Colorable (ReprOf d) => Trans d => d -> d-	default red         :: Colorable (ReprOf d) => Trans d => d -> d-	default green       :: Colorable (ReprOf d) => Trans d => d -> d-	default yellow      :: Colorable (ReprOf d) => Trans d => d -> d-	default blue        :: Colorable (ReprOf d) => Trans d => d -> d-	default magenta     :: Colorable (ReprOf d) => Trans d => d -> d-	default cyan        :: Colorable (ReprOf d) => Trans d => d -> d-	default white       :: Colorable (ReprOf d) => Trans d => d -> d-	default blacker     :: Colorable (ReprOf d) => Trans d => d -> d-	default redder      :: Colorable (ReprOf d) => Trans d => d -> d-	default greener     :: Colorable (ReprOf d) => Trans d => d -> d-	default yellower    :: Colorable (ReprOf d) => Trans d => d -> d-	default bluer       :: Colorable (ReprOf d) => Trans d => d -> d-	default magentaer   :: Colorable (ReprOf d) => Trans d => d -> d-	default cyaner      :: Colorable (ReprOf d) => Trans d => d -> d-	default whiter      :: Colorable (ReprOf d) => Trans d => d -> d-	default onBlack     :: Colorable (ReprOf d) => Trans d => d -> d-	default onRed       :: Colorable (ReprOf d) => Trans d => d -> d-	default onGreen     :: Colorable (ReprOf d) => Trans d => d -> d-	default onYellow    :: Colorable (ReprOf d) => Trans d => d -> d-	default onBlue      :: Colorable (ReprOf d) => Trans d => d -> d-	default onMagenta   :: Colorable (ReprOf d) => Trans d => d -> d-	default onCyan      :: Colorable (ReprOf d) => Trans d => d -> d-	default onWhite     :: Colorable (ReprOf d) => Trans d => d -> d-	default onBlacker   :: Colorable (ReprOf d) => Trans d => d -> d-	default onRedder    :: Colorable (ReprOf d) => Trans d => d -> d-	default onGreener   :: Colorable (ReprOf d) => Trans d => d -> d-	default onYellower  :: Colorable (ReprOf d) => Trans d => d -> d-	default onBluer     :: Colorable (ReprOf d) => Trans d => d -> d-	default onMagentaer :: Colorable (ReprOf d) => Trans d => d -> d-	default onCyaner    :: Colorable (ReprOf d) => Trans d => d -> d-	default onWhiter    :: Colorable (ReprOf d) => Trans d => d -> d-	-	reverse     = trans1 reverse-	black       = trans1 black-	red         = trans1 red-	green       = trans1 green-	yellow      = trans1 yellow-	blue        = trans1 blue-	magenta     = trans1 magenta-	cyan        = trans1 cyan-	white       = trans1 white-	blacker     = trans1 blacker-	redder      = trans1 redder-	greener     = trans1 greener-	yellower    = trans1 yellower-	bluer       = trans1 bluer-	magentaer   = trans1 magentaer-	cyaner      = trans1 cyaner-	whiter      = trans1 whiter-	onBlack     = trans1 onBlack-	onRed       = trans1 onRed-	onGreen     = trans1 onGreen-	onYellow    = trans1 onYellow-	onBlue      = trans1 onBlue-	onMagenta   = trans1 onMagenta-	onCyan      = trans1 onCyan-	onWhite     = trans1 onWhite-	onBlacker   = trans1 onBlacker-	onRedder    = trans1 onRedder-	onGreener   = trans1 onGreener-	onYellower  = trans1 onYellower-	onBluer     = trans1 onBluer-	onMagentaer = trans1 onMagentaer-	onCyaner    = trans1 onCyaner-	onWhiter    = trans1 onWhiter---- * Class 'Decorable'-class Decorable d where-	-- | @('decorable' f)@ write @f@ applied to whether decorations are activated or not.-	decorable :: (Bool -> d) -> d-	default decorable :: Decorable (ReprOf d) => Trans d => (Bool -> d) -> d-	decorable f = trans $ decorable (unTrans . f)-	-- | @('withColor' b d)@ whether to active decorations or not within @d@.-	withDecorable :: Bool -> d -> d-	default withDecorable :: Decorable (ReprOf d) => Trans d => Bool -> d -> d-	withDecorable = trans1 . withDecorable-	-	bold      :: d -> d-	underline :: d -> d-	italic    :: d -> d-	default bold      :: Decorable (ReprOf d) => Trans d => d -> d-	default underline :: Decorable (ReprOf d) => Trans d => d -> d-	default italic    :: Decorable (ReprOf d) => Trans d => d -> d-	bold      = trans1 bold-	underline = trans1 underline-	italic    = trans1 italic---- * Class 'Trans'-class Trans tr where-	-- | Return the underlying @tr@ of the transformer.-	type ReprOf tr :: *-	-	-- | Lift a tr to the transformer's.-	trans :: ReprOf tr -> tr-	-- | Unlift a tr from the transformer's.-	unTrans :: tr -> ReprOf tr-	-	-- | Identity transformation for a unary symantic method.-	trans1 :: (ReprOf tr -> ReprOf tr) -> (tr -> tr)-	trans1 f = trans . f . unTrans-	-	-- | Identity transformation for a binary symantic method.-	trans2-	 :: (ReprOf tr -> ReprOf tr -> ReprOf tr)-	 -> (tr -> tr -> tr)-	trans2 f t1 t2 = trans (f (unTrans t1) (unTrans t2))-	-	-- | Identity transformation for a ternary symantic method.-	trans3-	 :: (ReprOf tr -> ReprOf tr -> ReprOf tr -> ReprOf tr)-	 -> (tr -> tr -> tr -> tr)-	trans3 f t1 t2 t3 = trans (f (unTrans t1) (unTrans t2) (unTrans t3))

@@ -1,186 +0,0 @@-module Language.Symantic.Document.Term- ( module Language.Symantic.Document.Sym- , module Language.Symantic.Document.Term- ) where--import Control.Applicative (Applicative(..))-import Data.Bool-import Data.Function (($), (.), id)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import GHC.Exts (IsList(..))-import Prelude (pred, fromIntegral, Num(..))-import System.Console.ANSI-import qualified Data.List as List-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB--import Language.Symantic.Document.Sym---- * Type 'Reader'-data Reader- =   Reader- {   reader_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.- ,   reader_newline   :: Term            -- ^ How to display 'newline'.- ,   reader_sgr       :: ![SGR]          -- ^ Active ANSI codes.- ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break, or 'Nothing'- ,   reader_colorable :: !Bool           -- ^ Whether colors are activated or not.- ,   reader_decorable :: !Bool           -- ^ Whether decorations are activated or not.- }---- | Default 'Reader'.-defReader :: Reader-defReader = Reader- { reader_indent    = 0- , reader_newline   = newlineWithIndent- , reader_sgr       = []- , reader_breakable = Nothing- , reader_colorable = True- , reader_decorable = True- }---- * Type 'State'-type State = Column---- | Default 'State'.-defState :: State-defState = 0---- * Type 'Term'-newtype Term- =      Term- {    unTerm :: Reader ->-                State  ->-                (State -> TLB.Builder -> TLB.Builder) -> -- normal continuation-                (State -> TLB.Builder -> TLB.Builder) -> -- should-break continuation-                TLB.Builder }---- | Render a 'Term' into a 'TL.Text'.-textTerm :: Term -> TL.Text-textTerm = TLB.toLazyText . runTerm---- | Render a 'Term' into a 'TLB.Builder'.-runTerm :: Term -> TLB.Builder-runTerm (Term t) = t defReader defState oko oko-	where oko _st = id--instance IsList Term where-	type Item Term = Term-	fromList = mconcat-	toList   = pure-instance Semigroup Term where-	x <> y = Term $ \ro st ok ko ->-		unTerm x ro st-		 (\sx tx -> unTerm y ro sx-			 (\sy ty -> ok sy (tx<>ty))-			 (\sy ty -> ko sy (tx<>ty)))-		 (\sx tx -> unTerm y ro sx-			 (\sy ty -> ko sy (tx<>ty))-			 (\sy ty -> ko sy (tx<>ty)))-instance Monoid Term where-	mempty  = empty-	mappend = (<>)-instance IsString Term where-	fromString = string--writeH :: Column -> TLB.Builder -> Term-writeH len t =-	Term $ \ro st ok ko ->-		let newCol = st + len in-		(case reader_breakable ro of-		 Just breakCol | breakCol < newCol -> ko-		 _ -> ok)-		newCol t--instance Textable Term where-	empty     = Term $ \_ro st ok _ko -> ok st mempty-	charH   t = writeH (Nat 1) (TLB.singleton t)-	stringH t = writeH (length t) (fromString t)-	textH   t = writeH (length t) (TLB.fromText t)-	ltextH  t = writeH (length t) (TLB.fromLazyText t)-	replicate cnt t | cnt <= 0  = empty-	                | otherwise = t <> replicate (pred cnt) t-	newline = Term $ \ro -> unTerm (reader_newline ro) ro-instance Indentable Term where-	align t = Term $ \ro st -> unTerm t ro{reader_indent=st} st-	withNewline nl  t = Term $ \ro -> unTerm t ro{reader_newline=nl}-	withIndent  ind t = Term $ \ro -> unTerm t ro{reader_indent=ind}-	incrIndent  ind t = Term $ \ro -> unTerm t ro{reader_indent=reader_indent ro + ind}-	column f = Term $ \ro st -> unTerm (f st) ro st-	indent f = Term $ \ro -> unTerm (f (reader_indent ro)) ro-	newlineWithoutIndent = Term $ \_ro _st ok _ko ->-		ok 0 $ TLB.singleton '\n'-	newlineWithIndent = Term $ \ro _st ok _ko ->-		ok (reader_indent ro) $-			TLB.singleton '\n' <>-			fromString (List.replicate (fromIntegral $ reader_indent ro) ' ')-instance Breakable Term where-	breakable f       = Term $ \ro -> unTerm (f (reader_breakable ro)) ro-	withBreakable b t = Term $ \ro -> unTerm t ro{reader_breakable=b}-	ifBreak y x = Term $ \ro st ok ko ->-		unTerm x ro st ok $-		case reader_breakable ro of-		 Nothing -> ko-		 Just{} -> (\_sx _tx -> unTerm y ro st ok ko)-	breakpoint onNoBreak onBreak t = Term $ \ro st ok ko ->-		unTerm (onNoBreak <> t) ro st ok $-		case reader_breakable ro of-		 Nothing -> ko-		 Just{}  -> (\_sp _tp -> unTerm (onBreak <> t) ro st ok ko)--writeSGR :: (Reader -> Bool) -> SGR -> Term -> Term-writeSGR isOn s (Term t) =-	Term $ \ro ->-		if isOn ro-		then unTerm (o <> m <> c) ro-		else t ro-	where-	o = Term $ \_ro st ok _ko -> ok st $ fromString $ setSGRCode [s]-	m = Term $ \ro -> t ro{reader_sgr=s:reader_sgr ro}-	c = Term $ \ro st ok _ko -> ok st $ fromString $ setSGRCode $ Reset:List.reverse (reader_sgr ro)--instance Colorable Term where-	colorable f       = Term $ \ro -> unTerm (f (reader_colorable ro)) ro-	withColorable b t = Term $ \ro -> unTerm t ro{reader_colorable=b}-	reverse     = writeSGR reader_colorable $ SetSwapForegroundBackground True-	black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black-	red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red-	green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green-	yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow-	blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue-	magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta-	cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan-	white       = writeSGR reader_colorable $ SetColor Foreground Dull  White-	blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black-	redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red-	greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green-	yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow-	bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue-	magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta-	cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan-	whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White-	onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black-	onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red-	onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green-	onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow-	onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue-	onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta-	onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan-	onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White-	onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black-	onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red-	onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green-	onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow-	onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue-	onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta-	onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan-	onWhiter    = writeSGR reader_colorable $ SetColor Background Vivid White-instance Decorable Term where-	decorable f       = Term $ \ro -> unTerm (f (reader_decorable ro)) ro-	withDecorable b t = Term $ \ro -> unTerm t ro{reader_decorable=b}-	bold      = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity-	underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline-	italic    = writeSGR reader_decorable $ SetItalicized True

@@ -1,198 +0,0 @@-module Language.Symantic.Document.Term.Dimension- ( module Language.Symantic.Document.Sym- , module Language.Symantic.Document.Term.Dimension- ) where--import Control.Applicative (Applicative(..))-import Data.Bool-import Data.Eq (Eq(..))-import Data.Function (($), (.), id)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import GHC.Exts (IsList(..))-import Prelude ((+))-import Text.Show (Show(..))--import Language.Symantic.Document.Sym---- * Type 'Dim'-data Dim- =   Dim- {   dim_width       :: Nat -- ^ Maximun line length.- ,   dim_height      :: Nat -- ^ Number of newlines.- ,   dim_width_first :: Nat -- ^ Nat of the first line.- ,   dim_width_last  :: Nat -- ^ Nat of the last line.- } deriving (Eq, Show)-instance Semigroup Dim where-	Dim{dim_width=wx, dim_height=hx, dim_width_first=wfx, dim_width_last=wlx} <>-	 Dim{dim_width=wy, dim_height=hy, dim_width_first=wfy, dim_width_last=wly} =-		let h = hx + hy in-		case (hx, hy) of-		 (0, 0) -> let w = wx  + wy  in Dim w h w w-		 (0, _) -> let v = wx  + wfy in Dim (max v wy) h v wly-		 (_, 0) -> let v = wlx + wy in Dim (max v wx) h wfx v-		 _      -> Dim (max wx wy) h wfx wly-instance Monoid Dim where-	mempty  = Dim 0 0 0 0-	mappend = (<>)---- * Type 'Reader'-data Reader- =   Reader- {   reader_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.- ,   reader_newline   :: Dimension       -- ^ How to display 'newline'.- ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break, or 'Nothing'- ,   reader_colorable :: !Bool           -- ^ Whether colors are activated or not.- ,   reader_decorable :: !Bool           -- ^ Whether decorations are activated or not.- }---- | Default 'Reader'.-defReader :: Reader-defReader = Reader- { reader_indent    = 0- , reader_newline   = newlineWithIndent- , reader_breakable = Nothing- , reader_colorable = True- , reader_decorable = True- }---- * Type 'State'-type State = Column--defState :: State-defState = 0---- * Type 'Dimension'-newtype Dimension- =      Dimension- {    unDimension :: Reader ->-                     State  ->-                     (State -> Dim -> Dim) -> -- normal continuation-                     (State -> Dim -> Dim) -> -- should-break continuation-                     Dim }--dim :: Dimension -> Dim-dim (Dimension p) = p defReader defState oko oko-	where oko _st = id--instance IsList Dimension where-	type Item Dimension = Dimension-	fromList = mconcat-	toList   = pure-instance Semigroup Dimension where-	x <> y = Dimension $ \ro st ok ko ->-		unDimension x ro st-		 (\sx tx -> unDimension y ro sx-			 (\sy ty -> ok sy (tx<>ty))-			 (\sy ty -> ko sy (tx<>ty)))-		 (\sx tx -> unDimension y ro sx-			 (\sy ty -> ko sy (tx<>ty))-			 (\sy ty -> ko sy (tx<>ty)))-instance Monoid Dimension where-	mempty  = empty-	mappend = (<>)-instance IsString Dimension where-	fromString = string--writeH :: Column -> Dimension-writeH len =-	Dimension $ \ro col ok ko ->-		let newCol = col + len in-		(case reader_breakable ro of-		 Just breakCol | breakCol < newCol -> ko-		 _ -> ok)-		newCol Dim-		 { dim_width       = len-		 , dim_height      = 0-		 , dim_width_last  = len-		 , dim_width_first = len-		 }--instance Textable Dimension where-	empty     = Dimension $ \_ro st ok _ko -> ok st mempty-	charH   _ = writeH 1-	stringH   = writeH . length-	textH     = writeH . length-	ltextH    = writeH . length-	newline   = Dimension $ \ro -> unDimension (reader_newline ro) ro-instance Indentable Dimension where-	align p = Dimension $ \ro st -> unDimension p ro{reader_indent=st} st-	withNewline nl  p = Dimension $ \ro -> unDimension p ro{reader_newline=nl}-	withIndent  ind p = Dimension $ \ro -> unDimension p ro{reader_indent=ind}-	incrIndent  ind p = Dimension $ \ro -> unDimension p ro{reader_indent=reader_indent ro + ind}-	column f = Dimension $ \ro st -> unDimension (f st) ro st-	indent f = Dimension $ \ro -> unDimension (f (reader_indent ro)) ro-	newlineWithoutIndent = Dimension $ \_ro _st ok _ko ->-		ok 0 Dim-		 { dim_width       = 0-		 , dim_height      = 1-		 , dim_width_first = 0-		 , dim_width_last  = 0-		 }-	newlineWithIndent = Dimension $ \ro _st ok _ko ->-		let ind = reader_indent ro in-		ok ind Dim-		 { dim_width       = ind-		 , dim_height      = 1-		 , dim_width_first = 0-		 , dim_width_last  = ind-		 }--instance Breakable Dimension where-	breakable f = Dimension $ \ro -> unDimension (f (reader_breakable ro)) ro-	withBreakable col p = Dimension $ \ro -> unDimension p ro{reader_breakable=col}-	ifBreak y x = Dimension $ \ro st ok ko ->-		unDimension x ro st ok $-		case reader_breakable ro of-		 Nothing -> ko-		 Just{} -> (\_sx _tx -> unDimension y ro st ok ko)-	breakpoint onNoBreak onBreak t = Dimension $ \ro st ok ko ->-		unDimension (onNoBreak <> t) ro st ok $-		case reader_breakable ro of-		 Nothing -> ko-		 Just{} -> (\_sp _tp -> unDimension (onBreak <> t) ro st ok ko)-instance Colorable Dimension where-	colorable f       = Dimension $ \ro -> unDimension (f (reader_colorable ro)) ro-	withColorable b t = Dimension $ \ro -> unDimension t ro{reader_colorable=b}-	reverse     = id-	black       = id-	red         = id-	green       = id-	yellow      = id-	blue        = id-	magenta     = id-	cyan        = id-	white       = id-	blacker     = id-	redder      = id-	greener     = id-	yellower    = id-	bluer       = id-	magentaer   = id-	cyaner      = id-	whiter      = id-	onBlack     = id-	onRed       = id-	onGreen     = id-	onYellow    = id-	onBlue      = id-	onMagenta   = id-	onCyan      = id-	onWhite     = id-	onBlacker   = id-	onRedder    = id-	onGreener   = id-	onYellower  = id-	onBluer     = id-	onMagentaer = id-	onCyaner    = id-	onWhiter    = id-instance Decorable Dimension where-	decorable f       = Dimension $ \ro -> unDimension (f (reader_decorable ro)) ro-	withDecorable b t = Dimension $ \ro -> unDimension t ro{reader_decorable=b}-	bold      = id-	underline = id-	italic    = id

@@ -1,183 +0,0 @@-module Language.Symantic.Document.Term.IO- ( module Language.Symantic.Document.Sym- , module Language.Symantic.Document.Term.IO- ) where--import Control.Applicative (Applicative(..))-import Data.Bool-import Data.Function (($), id)-import Data.Maybe (Maybe(..))-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import GHC.Exts (IsList(..))-import Prelude (fromIntegral, Num(..))-import System.Console.ANSI-import System.IO (IO)-import qualified Data.List as List-import qualified Data.Text.IO as Text-import qualified Data.Text.Lazy.IO as TL-import qualified System.IO as IO--import Language.Symantic.Document.Sym---- * Type 'Reader'-data Reader- =   Reader- {   reader_indent    :: !Indent         -- ^ Current indentation level, used by 'newline'.- ,   reader_newline   :: TermIO          -- ^ How to display 'newline'.- ,   reader_sgr       :: ![SGR]          -- ^ Active ANSI codes.- ,   reader_handle    :: !IO.Handle      -- ^ Where to write.- ,   reader_breakable :: !(Maybe Column) -- ^ 'Column' after which to break.- ,   reader_colorable :: !Bool           -- ^ Whether colors are activated or not.- ,   reader_decorable :: !Bool           -- ^ Whether decorations are activated or not.- }---- | Default 'Reader'.-defReader :: Reader-defReader = Reader- { reader_indent      = 0- , reader_newline     = newlineWithIndent- , reader_sgr         = []- , reader_handle      = IO.stdout- , reader_breakable   = Nothing- , reader_colorable   = True- , reader_decorable   = True- }---- * Type 'State'-type State = Column---- | Default 'State'.-defState :: State-defState = 0---- * Type 'TermIO'-newtype TermIO- =      TermIO- {    unTermIO :: Reader -> State ->-                  (State -> IO () -> IO ()) -> -- normal continuation-                  (State -> IO () -> IO ()) -> -- should-break continuation-                  IO () }---- | Write a 'TermIO'.-runTermIO :: IO.Handle -> TermIO -> IO ()-runTermIO h (TermIO t) = t defReader{reader_handle=h} defState oko oko-	where oko _st = id--instance IsList TermIO where-	type Item TermIO = TermIO-	fromList = mconcat-	toList   = pure-instance Semigroup TermIO where-	x <> y = TermIO $ \ro st ok ko ->-		unTermIO x ro st-		 (\sx tx -> unTermIO y ro sx-			 (\sy ty -> ok sy (tx<>ty))-			 (\sy ty -> ko sy (tx<>ty)))-		 (\sx tx -> unTermIO y ro sx-			 (\sy ty -> ko sy (tx<>ty))-			 (\sy ty -> ko sy (tx<>ty)))-instance Monoid TermIO where-	mempty  = empty-	mappend = (<>)-instance IsString TermIO where-	fromString = string--writeH :: Column -> (IO.Handle -> IO ()) -> TermIO-writeH len t =-	TermIO $ \ro st ok ko ->-		let newCol = st + len in-		(case reader_breakable ro of-		 Just breakCol | breakCol < newCol -> ko-		 _ -> ok)-		newCol (t (reader_handle ro))--instance Textable TermIO where-	empty     = TermIO $ \_ro st ok _ko -> ok st mempty-	charH   t = writeH 1 (`IO.hPutChar` t)-	stringH t = writeH (length t) (`IO.hPutStr` t)-	textH   t = writeH (length t) (`Text.hPutStr` t)-	ltextH  t = writeH (length t) (`TL.hPutStr` t)-	newline   = TermIO $ \ro -> unTermIO (reader_newline ro) ro-instance Indentable TermIO where-	align t = TermIO $ \ro st -> unTermIO t ro{reader_indent=st} st-	withNewline nl  t = TermIO $ \ro -> unTermIO t ro{reader_newline=nl}-	withIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=ind}-	incrIndent  ind t = TermIO $ \ro -> unTermIO t ro{reader_indent=reader_indent ro + ind}-	column f = TermIO $ \ro st -> unTermIO (f st) ro st-	indent f = TermIO $ \ro -> unTermIO (f (reader_indent ro)) ro-	newlineWithoutIndent = TermIO $ \ro _st ok _ko ->-		ok 0 $ IO.hPutChar (reader_handle ro) '\n'-	newlineWithIndent = TermIO $ \ro@Reader{reader_handle=h} _st ok _ko ->-		ok (reader_indent ro) $ do-			IO.hPutChar h '\n'-			IO.hPutStr h $ List.replicate (fromIntegral $ reader_indent ro) ' '-instance Breakable TermIO where-	breakable f       = TermIO $ \ro -> unTermIO (f (reader_breakable ro)) ro-	withBreakable b t = TermIO $ \ro -> unTermIO t ro{reader_breakable=b}-	ifBreak y x = TermIO $ \ro st ok ko ->-		unTermIO x ro st ok $-		case reader_breakable ro of-		 Nothing -> ko-		 Just{} -> (\_sx _tx -> unTermIO y ro st ok ko)-	breakpoint onNoBreak onBreak t = TermIO $ \ro st ok ko ->-		unTermIO (onNoBreak <> t) ro st ok $-		case reader_breakable ro of-		 Nothing -> ko-		 Just{} -> (\_sp _tp -> unTermIO (onBreak <> t) ro st ok ko)--writeSGR :: (Reader -> Bool) -> SGR -> TermIO -> TermIO-writeSGR isOn s (TermIO t) =-	TermIO $ \ro ->-		if isOn ro-		then unTermIO (o <> m <> c) ro-		else t ro-	where-	o = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) [s]-	m = TermIO $ \ro -> t ro{reader_sgr=s:reader_sgr ro}-	c = TermIO $ \ro st ok _ko -> ok st $ hSetSGR (reader_handle ro) $ Reset:List.reverse (reader_sgr ro)--instance Colorable TermIO where-	colorable f       = TermIO $ \ro -> unTermIO (f (reader_colorable ro)) ro-	withColorable b t = TermIO $ \ro -> unTermIO t ro{reader_colorable=b}-	reverse     = writeSGR reader_colorable $ SetSwapForegroundBackground True-	black       = writeSGR reader_colorable $ SetColor Foreground Dull  Black-	red         = writeSGR reader_colorable $ SetColor Foreground Dull  Red-	green       = writeSGR reader_colorable $ SetColor Foreground Dull  Green-	yellow      = writeSGR reader_colorable $ SetColor Foreground Dull  Yellow-	blue        = writeSGR reader_colorable $ SetColor Foreground Dull  Blue-	magenta     = writeSGR reader_colorable $ SetColor Foreground Dull  Magenta-	cyan        = writeSGR reader_colorable $ SetColor Foreground Dull  Cyan-	white       = writeSGR reader_colorable $ SetColor Foreground Dull  White-	blacker     = writeSGR reader_colorable $ SetColor Foreground Vivid Black-	redder      = writeSGR reader_colorable $ SetColor Foreground Vivid Red-	greener     = writeSGR reader_colorable $ SetColor Foreground Vivid Green-	yellower    = writeSGR reader_colorable $ SetColor Foreground Vivid Yellow-	bluer       = writeSGR reader_colorable $ SetColor Foreground Vivid Blue-	magentaer   = writeSGR reader_colorable $ SetColor Foreground Vivid Magenta-	cyaner      = writeSGR reader_colorable $ SetColor Foreground Vivid Cyan-	whiter      = writeSGR reader_colorable $ SetColor Foreground Vivid White-	onBlack     = writeSGR reader_colorable $ SetColor Background Dull  Black-	onRed       = writeSGR reader_colorable $ SetColor Background Dull  Red-	onGreen     = writeSGR reader_colorable $ SetColor Background Dull  Green-	onYellow    = writeSGR reader_colorable $ SetColor Background Dull  Yellow-	onBlue      = writeSGR reader_colorable $ SetColor Background Dull  Blue-	onMagenta   = writeSGR reader_colorable $ SetColor Background Dull  Magenta-	onCyan      = writeSGR reader_colorable $ SetColor Background Dull  Cyan-	onWhite     = writeSGR reader_colorable $ SetColor Background Dull  White-	onBlacker   = writeSGR reader_colorable $ SetColor Background Vivid Black-	onRedder    = writeSGR reader_colorable $ SetColor Background Vivid Red-	onGreener   = writeSGR reader_colorable $ SetColor Background Vivid Green-	onYellower  = writeSGR reader_colorable $ SetColor Background Vivid Yellow-	onBluer     = writeSGR reader_colorable $ SetColor Background Vivid Blue-	onMagentaer = writeSGR reader_colorable $ SetColor Background Vivid Magenta-	onCyaner    = writeSGR reader_colorable $ SetColor Background Vivid Cyan-	onWhiter    = writeSGR reader_colorable $ SetColor Background Vivid White-instance Decorable TermIO where-	decorable f       = TermIO $ \ro -> unTermIO (f (reader_decorable ro)) ro-	withDecorable b t = TermIO $ \ro -> unTermIO t ro{reader_decorable=b}-	bold      = writeSGR reader_decorable $ SetConsoleIntensity BoldIntensity-	underline = writeSGR reader_decorable $ SetUnderlining SingleUnderline-	italic    = writeSGR reader_decorable $ SetItalicized True

@@ -0,0 +1,8 @@+module Symantic.Document+ ( module Symantic.Document.API+ , module Symantic.Document.Plain+ , module Symantic.Document.AnsiText+ ) where+import Symantic.Document.API+import Symantic.Document.Plain+import Symantic.Document.AnsiText

@@ -0,0 +1,484 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+module Symantic.Document.API where++import Control.Applicative (Applicative(..))+import Data.Bool+import Data.Char (Char)+import Data.Eq (Eq(..))+import Data.Foldable (Foldable, foldr, foldr1, null)+import Data.Function ((.), ($), id, const)+import Data.Functor (Functor(..), (<$>))+import Data.Int (Int)+import Data.Maybe (Maybe(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Data.Text (Text)+import Numeric.Natural (Natural)+import Prelude (Integer, fromIntegral, pred)+import System.Console.ANSI (SGR, setSGRCode)+import Text.Show (Show(..))+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB++-- * Helper types+type Column = Natural+type Indent = Column+type Width = Natural++-- ** Type 'Line'+newtype Line d = Line d+ deriving (Eq,Show)+unLine :: Line d -> d+unLine (Line d) = d++-- ** Type 'Word'+newtype Word d = Word d+ deriving (Eq,Show,Semigroup)+unWord :: Word d -> d+unWord (Word d) = d+instance DocFrom [SGR] d => DocFrom [SGR] (Word d) where+	docFrom = Word . docFrom++-- * 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++-- 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++-- 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++-- 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++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+instance Lengthable Char where+	length _ = 1+	nullLength = const False+instance Lengthable String where+	length = fromIntegral . List.length+	nullLength = null+instance Lengthable Text.Text where+	length = fromIntegral . Text.length+	nullLength = Text.null+instance Lengthable TL.Text where+	length = fromIntegral . TL.length+	nullLength = TL.null+instance Lengthable d => Lengthable (Line d) where+	length = fromIntegral . length . unLine+	nullLength = nullLength . unLine+instance Lengthable d => Lengthable (Word d) where+	length = fromIntegral . length . unWord+	nullLength = nullLength . unWord++-- * Class 'Spaceable'+class Monoid d => Spaceable d where+	newline :: d+	space   :: d+	default newline :: Spaceable (UnTrans d) => Trans d => d+	default space   :: Spaceable (UnTrans d) => Trans d => d+	newline = noTrans newline+	space   = noTrans space+	+	-- | @'spaces' ind = 'replicate' ind 'space'@+	spaces :: Column -> d+	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+	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 <$>)+	-- | @x '<+>' y = x '<>' 'space' '<>' y@+	(<+>) :: d -> d -> d+	-- | @x '</>' y = x '<>' 'newline' '<>' y@+	(</>) :: d -> d -> d+	x <+> y = x <> space <> y+	x </> y = x <> newline <> y+	catH :: Foldable f => f d -> d+	catV :: Foldable f => f d -> d+	catH = foldr (<>) mempty+	catV = intercalate newline+infixr 6 <+>+infixr 6 </>+instance Spaceable String where+	newline    = "\n"+	space      = " "+	spaces n   = List.replicate (fromIntegral n) ' '+instance Spaceable Text where+	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++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++replicate :: Monoid d => Int -> d -> d+replicate cnt t | cnt <= 0  = mempty+                | otherwise = t `mappend` replicate (pred cnt) t++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 '>'))++-- * Class 'Splitable'+class (Lengthable d, Monoid d) => Splitable d where+	tail  :: d -> Maybe d+	break :: (Char -> Bool) -> d -> (d, d)+	span :: (Char -> Bool) -> d -> (d, d)+	span f = break (not . f)+	lines :: d -> [Line d]+	words :: d -> [Word d]+	linesNoEmpty :: d -> [Line d]+	wordsNoEmpty :: d -> [Word d]+	lines = (Line <$>) . splitOnChar (== '\n')+	words = (Word <$>) . splitOnChar (== ' ')+	linesNoEmpty = (Line <$>) . splitOnCharNoEmpty (== '\n')+	wordsNoEmpty = (Word <$>) . splitOnCharNoEmpty (== ' ')+	+	splitOnChar :: (Char -> Bool) -> d -> [d]+	splitOnChar f d0 =+		if nullLength 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]+			         | otherwise -> go rt+	splitOnCharNoEmpty :: (Char -> Bool) -> d -> [d]+	splitOnCharNoEmpty f d =+		let (l,r) = f`break`d in+		(if nullLength l then [] else [l]) <>+		case tail r of+		 Nothing -> []+		 Just rt -> splitOnCharNoEmpty f rt+instance Splitable String where+	tail [] = Nothing+	tail s = Just $ List.tail s+	break = List.break+instance Splitable Text.Text where+	tail "" = Nothing+	tail s = Just $ Text.tail s+	break = Text.break+instance Splitable TL.Text where+	tail "" = Nothing+	tail s = Just $ TL.tail s+	break = TL.break++-- * Class 'Decorable'+class Decorable d where+	bold      :: d -> d+	underline :: d -> d+	italic    :: d -> d+	default bold      :: Decorable (UnTrans d) => Trans d => d -> d+	default underline :: Decorable (UnTrans d) => Trans d => d -> d+	default italic    :: Decorable (UnTrans d) => Trans d => d -> d+	bold      = noTrans1 bold+	underline = noTrans1 underline+	italic    = noTrans1 italic++-- * Class 'Colorable16'+class Colorable16 d where+	reverse :: d -> d+	+	-- Foreground colors+	-- Dull+	black   :: d -> d+	red     :: d -> d+	green   :: d -> d+	yellow  :: d -> d+	blue    :: d -> d+	magenta :: d -> d+	cyan    :: d -> d+	white   :: d -> d+	+	-- Vivid+	blacker   :: d -> d+	redder    :: d -> d+	greener   :: d -> d+	yellower  :: d -> d+	bluer     :: d -> d+	magentaer :: d -> d+	cyaner    :: d -> d+	whiter    :: d -> d+	+	-- Background colors+	-- Dull+	onBlack   :: d -> d+	onRed     :: d -> d+	onGreen   :: d -> d+	onYellow  :: d -> d+	onBlue    :: d -> d+	onMagenta :: d -> d+	onCyan    :: d -> d+	onWhite   :: d -> d+	+	-- Vivid+	onBlacker   :: d -> d+	onRedder    :: d -> d+	onGreener   :: d -> d+	onYellower  :: d -> d+	onBluer     :: d -> d+	onMagentaer :: d -> d+	onCyaner    :: d -> d+	onWhiter    :: d -> d+	+	default reverse     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default black       :: Colorable16 (UnTrans d) => Trans d => d -> d+	default red         :: Colorable16 (UnTrans d) => Trans d => d -> d+	default green       :: Colorable16 (UnTrans d) => Trans d => d -> d+	default yellow      :: Colorable16 (UnTrans d) => Trans d => d -> d+	default blue        :: Colorable16 (UnTrans d) => Trans d => d -> d+	default magenta     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default cyan        :: Colorable16 (UnTrans d) => Trans d => d -> d+	default white       :: Colorable16 (UnTrans d) => Trans d => d -> d+	default blacker     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default redder      :: Colorable16 (UnTrans d) => Trans d => d -> d+	default greener     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default yellower    :: Colorable16 (UnTrans d) => Trans d => d -> d+	default bluer       :: Colorable16 (UnTrans d) => Trans d => d -> d+	default magentaer   :: Colorable16 (UnTrans d) => Trans d => d -> d+	default cyaner      :: Colorable16 (UnTrans d) => Trans d => d -> d+	default whiter      :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onBlack     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onRed       :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onGreen     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onYellow    :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onBlue      :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onMagenta   :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onCyan      :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onWhite     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onBlacker   :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onRedder    :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onGreener   :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onYellower  :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onBluer     :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onMagentaer :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onCyaner    :: Colorable16 (UnTrans d) => Trans d => d -> d+	default onWhiter    :: Colorable16 (UnTrans d) => Trans d => d -> d+	+	reverse     = noTrans1 reverse+	black       = noTrans1 black+	red         = noTrans1 red+	green       = noTrans1 green+	yellow      = noTrans1 yellow+	blue        = noTrans1 blue+	magenta     = noTrans1 magenta+	cyan        = noTrans1 cyan+	white       = noTrans1 white+	blacker     = noTrans1 blacker+	redder      = noTrans1 redder+	greener     = noTrans1 greener+	yellower    = noTrans1 yellower+	bluer       = noTrans1 bluer+	magentaer   = noTrans1 magentaer+	cyaner      = noTrans1 cyaner+	whiter      = noTrans1 whiter+	onBlack     = noTrans1 onBlack+	onRed       = noTrans1 onRed+	onGreen     = noTrans1 onGreen+	onYellow    = noTrans1 onYellow+	onBlue      = noTrans1 onBlue+	onMagenta   = noTrans1 onMagenta+	onCyan      = noTrans1 onCyan+	onWhite     = noTrans1 onWhite+	onBlacker   = noTrans1 onBlacker+	onRedder    = noTrans1 onRedder+	onGreener   = noTrans1 onGreener+	onYellower  = noTrans1 onYellower+	onBluer     = noTrans1 onBluer+	onMagentaer = noTrans1 onMagentaer+	onCyaner    = noTrans1 onCyaner+	onWhiter    = noTrans1 onWhiter++-- | For debugging purposes.+instance Colorable16 String where+	reverse     = xmlSGR "reverse"+	black       = xmlSGR "black"+	red         = xmlSGR "red"+	green       = xmlSGR "green"+	yellow      = xmlSGR "yellow"+	blue        = xmlSGR "blue"+	magenta     = xmlSGR "magenta"+	cyan        = xmlSGR "cyan"+	white       = xmlSGR "white"+	blacker     = xmlSGR "blacker"+	redder      = xmlSGR "redder"+	greener     = xmlSGR "greener"+	yellower    = xmlSGR "yellower"+	bluer       = xmlSGR "bluer"+	magentaer   = xmlSGR "magentaer"+	cyaner      = xmlSGR "cyaner"+	whiter      = xmlSGR "whiter"+	onBlack     = xmlSGR "onBlack"+	onRed       = xmlSGR "onRed"+	onGreen     = xmlSGR "onGreen"+	onYellow    = xmlSGR "onYellow"+	onBlue      = xmlSGR "onBlue"+	onMagenta   = xmlSGR "onMagenta"+	onCyan      = xmlSGR "onCyan"+	onWhite     = xmlSGR "onWhite"+	onBlacker   = xmlSGR "onBlacker"+	onRedder    = xmlSGR "onRedder"+	onGreener   = xmlSGR "onGreener"+	onYellower  = xmlSGR "onYellower"+	onBluer     = xmlSGR "onBluer"+	onMagentaer = xmlSGR "onMagentaer"+	onCyaner    = xmlSGR "onCyaner"+	onWhiter    = xmlSGR "onWhiter"++-- | For debugging purposes.+xmlSGR :: Semigroup d => DocFrom String d => String -> d -> d+xmlSGR newSGR s = docFrom ("<"<>newSGR<>">")<>s<>docFrom ("</"<>newSGR<>">")++-- * Class 'Indentable'+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.+	hang :: Indent -> d -> d+	hang ind = align . incrIndent 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@,+	-- 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+	+	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+	+	align      = noTrans1 align+	incrIndent = noTrans1 . incrIndent+	setIndent  = noTrans1 . setIndent+	fill       = noTrans1 . fill+	breakfill  = noTrans1 . breakfill++-- * Class 'Wrappable'+class Wrappable d where+	setWidth :: Maybe Width -> d -> d+	-- getWidth :: (Maybe Width -> d) -> d+	breakpoint :: d+	breakspace :: d+	breakalt   :: d -> d -> 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+	breakpoint = noTrans breakpoint+	breakspace = noTrans breakspace+	breakalt   = noTrans2 breakalt++-- * Class 'Justifiable'+class Justifiable d where+	justify :: d -> d++-- * Class 'Trans'+class Trans repr where+	-- | Return the underlying @repr@ of the transformer.+	type UnTrans repr :: *+	+	-- | Lift a repr to the transformer's.+	noTrans :: UnTrans repr -> repr+	-- | Unlift a repr from the transformer's.+	unTrans :: repr -> UnTrans repr+	+	-- | Identity transformation for a unary symantic method.+	noTrans1 :: (UnTrans repr -> UnTrans repr) -> (repr -> repr)+	noTrans1 f = noTrans . f . unTrans+	+	-- | Identity transformation for a binary symantic method.+	noTrans2+	 :: (UnTrans repr -> UnTrans repr -> UnTrans repr)+	 -> (repr -> repr -> repr)+	noTrans2 f a b = noTrans (f (unTrans a) (unTrans b))+	+	-- | Identity transformation for a ternary symantic method.+	noTrans3+	 :: (UnTrans repr -> UnTrans repr -> UnTrans repr -> UnTrans repr)+	 -> (repr -> repr -> repr -> repr)+	noTrans3 f a b c = noTrans (f (unTrans a) (unTrans b) (unTrans c))

@@ -0,0 +1,211 @@+{-# LANGUAGE UndecidableInstances #-}+module Symantic.Document.AnsiText where++import Control.Applicative (Applicative(..), liftA2)+import Control.Monad (Monad(..))+import Control.Monad.Trans.Reader+import Data.Bool+import Data.Char (Char)+import Data.Function (($), (.), id)+import Data.Functor ((<$>))+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Data.Text (Text)+import System.Console.ANSI+import qualified Data.List as List+import qualified Data.Text.Lazy as TL++import Symantic.Document.API++-- * Type 'AnsiText'+newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }++ansiText :: AnsiText d -> AnsiText d+ansiText = id++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 Semigroup d => Semigroup (AnsiText d) where+	AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y+instance Monoid d => Monoid (AnsiText d) where+	mempty = AnsiText (return mempty)+	mappend = (<>)+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+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+	reverse     = ansiTextSGR $ SetSwapForegroundBackground True+	black       = ansiTextSGR $ SetColor Foreground Dull  Black+	red         = ansiTextSGR $ SetColor Foreground Dull  Red+	green       = ansiTextSGR $ SetColor Foreground Dull  Green+	yellow      = ansiTextSGR $ SetColor Foreground Dull  Yellow+	blue        = ansiTextSGR $ SetColor Foreground Dull  Blue+	magenta     = ansiTextSGR $ SetColor Foreground Dull  Magenta+	cyan        = ansiTextSGR $ SetColor Foreground Dull  Cyan+	white       = ansiTextSGR $ SetColor Foreground Dull  White+	blacker     = ansiTextSGR $ SetColor Foreground Vivid Black+	redder      = ansiTextSGR $ SetColor Foreground Vivid Red+	greener     = ansiTextSGR $ SetColor Foreground Vivid Green+	yellower    = ansiTextSGR $ SetColor Foreground Vivid Yellow+	bluer       = ansiTextSGR $ SetColor Foreground Vivid Blue+	magentaer   = ansiTextSGR $ SetColor Foreground Vivid Magenta+	cyaner      = ansiTextSGR $ SetColor Foreground Vivid Cyan+	whiter      = ansiTextSGR $ SetColor Foreground Vivid White+	onBlack     = ansiTextSGR $ SetColor Background Dull  Black+	onRed       = ansiTextSGR $ SetColor Background Dull  Red+	onGreen     = ansiTextSGR $ SetColor Background Dull  Green+	onYellow    = ansiTextSGR $ SetColor Background Dull  Yellow+	onBlue      = ansiTextSGR $ SetColor Background Dull  Blue+	onMagenta   = ansiTextSGR $ SetColor Background Dull  Magenta+	onCyan      = ansiTextSGR $ SetColor Background Dull  Cyan+	onWhite     = ansiTextSGR $ SetColor Background Dull  White+	onBlacker   = ansiTextSGR $ SetColor Background Vivid Black+	onRedder    = ansiTextSGR $ SetColor Background Vivid Red+	onGreener   = ansiTextSGR $ SetColor Background Vivid Green+	onYellower  = ansiTextSGR $ SetColor Background Vivid Yellow+	onBluer     = ansiTextSGR $ SetColor Background Vivid Blue+	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+	bold      = ansiTextSGR $ SetConsoleIntensity BoldIntensity+	underline = ansiTextSGR $ SetUnderlining SingleUnderline+	italic    = ansiTextSGR $ SetItalicized True+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+instance Wrappable d => Wrappable (AnsiText d) where+	setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d+	breakpoint = AnsiText $ return breakpoint+	breakspace = AnsiText $ return breakspace+	breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y++ansiTextSGR ::+ Semigroup d => DocFrom [SGR] d =>+ SGR -> AnsiText d -> AnsiText d+ansiTextSGR newSGR (AnsiText d) = AnsiText $ do+	oldSGR <- ask+	(\m -> docFrom [newSGR] <> m <> docFrom (Reset:List.reverse oldSGR))+	 <$> local (newSGR :) d++-- * Type 'PlainText'+-- | Drop 'Colorable16' and 'Decorable'.+newtype PlainText d = PlainText { unPlainText :: d }++plainText :: PlainText d -> PlainText d+plainText = id++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 Semigroup d => Semigroup (PlainText d) where+	PlainText x <> PlainText y = PlainText $ (<>) x y+instance Monoid d => Monoid (PlainText d) where+	mempty = PlainText mempty+	mappend = (<>)+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+instance Spaceable d => Spaceable (PlainText d) where+	newline = PlainText $ newline+	space   = PlainText $ space+	spaces  = PlainText . spaces+instance Semigroup d => Colorable16 (PlainText d) where+	reverse     = plainTextSGR+	black       = plainTextSGR+	red         = plainTextSGR+	green       = plainTextSGR+	yellow      = plainTextSGR+	blue        = plainTextSGR+	magenta     = plainTextSGR+	cyan        = plainTextSGR+	white       = plainTextSGR+	blacker     = plainTextSGR+	redder      = plainTextSGR+	greener     = plainTextSGR+	yellower    = plainTextSGR+	bluer       = plainTextSGR+	magentaer   = plainTextSGR+	cyaner      = plainTextSGR+	whiter      = plainTextSGR+	onBlack     = plainTextSGR+	onRed       = plainTextSGR+	onGreen     = plainTextSGR+	onYellow    = plainTextSGR+	onBlue      = plainTextSGR+	onMagenta   = plainTextSGR+	onCyan      = plainTextSGR+	onWhite     = plainTextSGR+	onBlacker   = plainTextSGR+	onRedder    = plainTextSGR+	onGreener   = plainTextSGR+	onYellower  = plainTextSGR+	onBluer     = plainTextSGR+	onMagentaer = plainTextSGR+	onCyaner    = plainTextSGR+	onWhiter    = plainTextSGR+instance (Semigroup d, DocFrom [SGR] d) => Decorable (PlainText d) where+	bold      = plainTextSGR+	underline = plainTextSGR+	italic    = plainTextSGR+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+instance Wrappable d => Wrappable (PlainText d) where+	setWidth w (PlainText d) = PlainText $ setWidth w d+	breakpoint = PlainText breakpoint+	breakspace = PlainText breakspace+	breakalt (PlainText x) (PlainText y) = PlainText $ breakalt x y++plainTextSGR ::+ Semigroup d =>+ PlainText d -> PlainText d+plainTextSGR (PlainText d) = PlainText d

@@ -0,0 +1,447 @@+{-# LANGUAGE OverloadedStrings #-}+{-# 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(..))+import Data.Monoid (Monoid(..))+import Data.Ord (Ord(..), Ordering(..))+import Data.Semigroup (Semigroup(..))+import Data.String (String, IsString(..))+import Data.Text (Text)+import GHC.Natural (minusNatural,quotRemNatural)+import Numeric.Natural (Natural)+import Prelude (fromIntegral, Num(..))+import System.Console.ANSI+import Text.Show (Show(..), showString, showParen)+import qualified Data.List as List+import qualified Data.Text.Lazy as TL++import Symantic.Document.API++-- * Type 'Plain'+-- | Church encoded for performance concerns.+-- Kind like 'ParsecT' in @megaparsec@ but a little bit different+-- due to the use of 'PlainFit' for implementing 'breakingSpace' correctly+-- when in the left hand side of ('<>').+-- Prepending is done using continuation, like in a difference list.+newtype Plain d = Plain+ { unPlain ::+     {-curr-}PlainInh ->+     {-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)+ }++runPlain :: Monoid d => Plain d -> d+runPlain x =+	unPlain x+	 defPlainInh+	 defPlainState+	 {-k-}(\(px,_sx) fits _overflow ->+		-- NOTE: if px fits, then appending mempty fits+		fits (px mempty) )+	 {-fits-}id+	 {-overflow-}id++-- ** Type 'PlainState'+data PlainState d = PlainState+ { plainState_buffer          :: ![PlainChunk d]+ , plainState_bufferStart     :: !Column+ , plainState_bufferWidth     :: !Width+ , plainState_removableIndent :: !Indent+   -- ^ The amount of 'Indent' added by 'breakspace'+   -- that can be removed by breaking the 'space' into a 'newline'.+ } deriving (Show)++defPlainState :: PlainState d+defPlainState = PlainState+ { plainState_buffer          = mempty+ , plainState_bufferStart     = 0+ , plainState_bufferWidth     = 0+ , plainState_removableIndent = 0+ }++-- ** Type 'PlainInh'+data PlainInh = PlainInh+ { plainInh_width   :: !(Maybe Column)+ , plainInh_justify :: !Bool+ , plainInh_indent  :: !Width+ } deriving (Show)++defPlainInh :: PlainInh+defPlainInh = PlainInh+ { plainInh_width   = Nothing+ , plainInh_justify = False+ , plainInh_indent  = 0+ }++-- ** Type 'PlainFit'+-- | Double continuation to qualify the returned document+-- as fitting or overflowing the given 'plainInh_width'.+-- It's like @('Bool',d)@ in a normal style+-- (a non continuation-passing-style).+type PlainFit d = {-fits-}(d -> d) ->+                  {-overflow-}(d -> d) ->+                  d++-- ** Type 'PlainChunk'+data PlainChunk 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+     -- ^ 'spaces' preserved to be interleaved+     -- correctly with 'PlainChunk_Ignored'.+instance Show d => Show (PlainChunk d) where+	showsPrec p x =+		showParen (p>10) $+		case x of+		 PlainChunk_Ignored d ->+			showString "Z " .+			showsPrec 11 d+		 PlainChunk_Word (Word d) ->+			showString "W " .+			showsPrec 11 d+		 PlainChunk_Spaces s ->+			showString "S " .+			showsPrec 11 s+instance Lengthable d => Lengthable (PlainChunk d) where+	length = \case+	 PlainChunk_Ignored{} -> 0+	 PlainChunk_Word d -> length d+	 PlainChunk_Spaces s -> s+	nullLength = \case+	 PlainChunk_Ignored{} -> True+	 PlainChunk_Word d -> nullLength d+	 PlainChunk_Spaces s -> s == 0+instance DocFrom [SGR] d => DocFrom [SGR] (PlainChunk d) where+	docFrom sgr = PlainChunk_Ignored (docFrom sgr)++runPlainChunk :: Spaceable d => PlainChunk d -> d+runPlainChunk = \case+ PlainChunk_Ignored d -> d+ PlainChunk_Word (Word d) -> d+ PlainChunk_Spaces s -> spaces s++instance Semigroup d => Semigroup (Plain d) where+	Plain x <> Plain y = Plain $ \inh st k ->+		x inh st $ \(px,sx) ->+			y inh sx $ \(py,sy) ->+				k (px.py,sy)+instance Monoid d => Monoid (Plain d) where+	mempty = Plain $ \_inh st k -> k (id,st)+	mappend = (<>)+instance (Spaceable d) => Spaceable (Plain d) where+	newline = 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+			 , plainState_bufferWidth      = 0+			 , plainState_buffer           = mempty+			 }+		 )+	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+			case plainInh_width inh of+			 Just width | width < newWidth ->+				overflow $ k (id{-(d<>)-}, newState) fits overflow+			 _ -> k (id{-(d<>)-}, newState) fits overflow+		else+			let newState = st+				 { plainState_bufferWidth = plainState_bufferWidth + n+				 } in+			case plainInh_width inh of+			 Just width | width < 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+		then k (id,st) fits overflow+		else+			let newBufferWidth = plainState_bufferWidth + wordLen in+			let newWidth = plainState_bufferStart + newBufferWidth in+			if plainInh_justify inh+			then+				let newState = st+					 { plainState_buffer =+						PlainChunk_Word (Word (docFrom s)) :+						plainState_buffer+					 , plainState_bufferWidth = newBufferWidth+					 } in+				case plainInh_width inh of+				 Just width | width < newWidth ->+					overflow $ k (id, newState) fits overflow+				 _ -> k (id, newState) fits overflow+			else+				let newState = st+					 { 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 =+		mconcat .+		List.intersperse breakspace .+		(docFrom <$>) .+		words .+		unLine+instance Spaceable d => Indentable (Plain d) where+	align p = 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}+	fill m p = Plain $ \inh0 st0 ->+		let col0 = plainState_bufferStart st0 + plainState_bufferWidth st0 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+			unPlain+			 (if w<=m+				then spaces (m`minusNatural`w)+				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+		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+			unPlain+			 (case w`compare`m of+				 LT -> spaces (m`minusNatural`w)+				 EQ -> mempty+				 GT -> setIndent (col0 + m) newline)+			 inh1 st1+		in+		unPlain (p <> p1) inh0 st0+instance Spaceable d => Justifiable (Plain d) where+	justify p = (<> flushLastLine) $ 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+	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+			 }+		 )+		 fits+		 {-overflow-}(\_r ->+			unPlain newline inh st k+			 fits+			 {-overflow-}(+				if plainState_removableIndent st < newlineInd+				then overflow+				else fits+			 )+		 )+	breakspace = Plain $ \inh st k fits overflow ->+		let newlineInd = plainInh_indent inh in+		k+		 ( 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+			 , plainState_bufferWidth      = plainState_bufferWidth st + 1+			 , plainState_removableIndent  = newlineInd+			 }+		 )+		 fits+		 {-overflow-}(\_r ->+			unPlain newline inh st k+			 fits+			 {-overflow-}(+				if plainState_removableIndent st < newlineInd+				then overflow+				else fits+			 )+		 )+	breakalt x y = Plain $ \inh st k fits overflow ->+		unPlain x inh st k fits+		 {-overflow-}(\_r ->+			unPlain y inh st k fits overflow+		 )+-- String+instance (DocFrom (Word String) d, Spaceable d) =>+         DocFrom String (Plain d) where+	docFrom =+		mconcat .+		List.intersperse newline .+		(docFrom <$>) .+		lines+instance (DocFrom (Word String) d, Spaceable d) =>+         IsString (Plain d) where+	fromString = docFrom+-- Text+instance (DocFrom (Word Text) d, Spaceable d) =>+         DocFrom Text (Plain d) where+	docFrom =+		mconcat .+		List.intersperse newline .+		(docFrom <$>) .+		lines+instance (DocFrom (Word TL.Text) d, Spaceable d) =>+         DocFrom TL.Text (Plain d) where+	docFrom =+		mconcat .+		List.intersperse newline .+		(docFrom <$>) .+		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 (DocFrom [SGR] d, Semigroup d) => DocFrom [SGR] (Plain d) where+	docFrom 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)++joinLine ::+ Spaceable d =>+ PlainInh -> PlainState d -> d+joinLine PlainInh{..} PlainState{..} =+	case plainInh_width of+	 Nothing -> joinPlainLine $ List.reverse plainState_buffer+	 Just width ->+		if width < plainState_bufferStart+		|| width < 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)++-- | @('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)@+-- where @(q+1)@ and @(q)@ are the two padding lengths used and @(m = min (b-r) r)@.+--+-- A simple implementation of 'justifyPadding' could be:+-- @+-- 'justifyPadding' a b =+--   'join' ('List.replicate' m [q,q'+'1])+--   <> ('List.replicate' (r'-'m) (q'+'1)+--   <> ('List.replicate' ((b'-'r)'-'m) q+--   where+--   (q,r) = a`divMod`b+--   m = 'min' (b-r) r+-- @+justifyPadding :: Natural -> Natural -> [Natural]+justifyPadding a b = go r (b-r) -- NOTE: r >= 0 && b-r >= 0 due to 'divMod'+	where+	(q,r) = a`quotRemNatural`b+	+	go 0  bmr = List.replicate (fromIntegral bmr) q    -- when min (b-r) r == b-r+	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 ::+ 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,+		-- 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.+	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)++joinPlainLine :: Monoid d => Spaceable d => [PlainChunk d] -> d+joinPlainLine = mconcat . (runPlainChunk <$>)++padPlainLine :: Spaceable d => [PlainChunk d] -> [Width] -> d+padPlainLine = go+	where+	go (w:ws) lls@(l:ls) =+		case w of+		 PlainChunk_Spaces _s -> spaces (fromIntegral (l+1)) <> go ws ls+		 _ -> runPlainChunk w <> go ws lls+	go (w:ws) [] = runPlainChunk w <> go ws []+	go [] _ls = mempty

@@ -1,3 +1,3 @@-resolver: lts-12.8+resolver: lts-13.19 packages: - '.'

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.1.2.20180831+version: 1.0.0.20190614 category: Text synopsis: Document symantics. description: Symantics for generating documents.@@ -16,8 +16,8 @@ -- homepage:  build-type: Simple-cabal-version: >= 1.10-tested-with: GHC==8.4.3+cabal-version: >= 1.24+tested-with: GHC==8.4.4 extra-source-files:   stack.yaml extra-tmp-files:@@ -28,11 +28,10 @@  Library   exposed-modules:-    Language.Symantic.Document-    Language.Symantic.Document.Sym-    Language.Symantic.Document.Term-    Language.Symantic.Document.Term.Dimension-    Language.Symantic.Document.Term.IO+    Symantic.Document+    Symantic.Document.API+    Symantic.Document.AnsiText+    Symantic.Document.Plain   default-language: Haskell2010   default-extensions:     DataKinds@@ -44,9 +43,11 @@     NamedFieldPuns     NoImplicitPrelude     OverloadedStrings+    RecordWildCards     ScopedTypeVariables     StandaloneDeriving     TupleSections+    TypeApplications     TypeFamilies     TypeOperators   ghc-options:@@ -77,6 +78,7 @@     NoImplicitPrelude     NoMonomorphismRestriction     OverloadedStrings+    RecordWildCards     ScopedTypeVariables     TupleSections     TypeApplications

@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedLists #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE OverloadedStrings #-} module HUnit where  import Test.Tasty@@ -13,194 +12,200 @@ import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Semigroup (Semigroup(..))-import Data.String (String)+import Data.String (String, IsString(..))+import Prelude ((+)) import Text.Show (Show(..)) import qualified Data.List as List-import qualified Data.Text.Lazy as TL -import qualified Language.Symantic.Document.Term as Doc-import qualified Language.Symantic.Document.Term.Dimension as Dim-import Language.Symantic.Document.Term ((<+>))+import Symantic.Document.API+import Symantic.Document.Plain+import Symantic.Document.AnsiText  -- * Tests hunits :: TestTree hunits = testGroup "HUnit" $- [ hunitsTerm- , hunitsTermDimension+ [ hunitPlain  ] +hunitPlain :: TestTree+hunitPlain = testList "Plain"+ [ newline ==> "\n"+ , "hello\nworld" ==> "hello\nworld"+ , 10`maxWidth` breakpoints ["hello", "world"] ==> "helloworld"+ ,  9`maxWidth` breakpoints ["hello", "world"] ==> "hello\nworld"+ ,  6`maxWidth` breakpoints ["he", "ll", "o!"] ==> "hello!"+ ,  6`maxWidth` breakpoints ["he", "ll", "o!", "wo", "rl", "d!"] ==> "hello!\nworld!"+ ,  5`maxWidth` breakpoints ["hello", "world"] ==> "hello\nworld"+ ,  5`maxWidth` breakpoints ["he", "llo", "world"] ==> "hello\nworld"+ ,  5`maxWidth` breakpoints ["he", "ll", "o!"] ==> "hell\no!"+ ,  4`maxWidth` breakpoints ["hello", "world"] ==> "hello\nworld"+ ,  4`maxWidth` breakpoints ["he", "ll", "o!"] ==> "hell\no!"+ ,  4`maxWidth` breakpoints ["he", "llo", "world"] ==> "he\nllo\nworld"+ ,  4`maxWidth` breakpoints ["he", "llo", "w", "orld"] ==> "he\nllow\norld"+ ,  4`maxWidth` breakpoints ["he", "ll", "o!", "wo", "rl", "d!"] ==> "hell\no!wo\nrld!"+ ,  3`maxWidth` breakpoints ["hello", "world"] ==> "hello\nworld"+ ,  3`maxWidth` breakpoints ["he", "ll"] ==> "he\nll"+ ,  3`maxWidth` breakpoints ["he", "ll", "o!"] ==> "he\nll\no!"+ ,  1`maxWidth` breakpoints ["he", "ll", "o!"] ==> "he\nll\no!"+ ,  4`maxWidth` mconcat ["__", align $ breakpoints ["he", "ll", "o!", "wo", "rl", "d!"]]+    ==> "__he\n  ll\n  o!\n  wo\n  rl\n  d!"+ ,  6`maxWidth` mconcat ["__", align $ breakpoints ["he", "ll", "o!", "wo", "rl", "d!"]]+    ==> "__hell\n  o!wo\n  rld!"+ , 16`maxWidth` mconcat ["__", listHorV ["hello", "world"]] ==> "__[hello, world]"+ ,  4`maxWidth` mconcat ["__", listHorV ["hello", "world"]] ==> "__[ hello\n  , world\n  ]"+ , 11`maxWidth` breakspaces ["hello", "world"] ==> "hello world"+ , 10`maxWidth` breakspaces ["hello", "world"] ==> "hello\nworld"+ ,  6`maxWidth` breakspaces ["hel", "lo", "wo", "rld"] ==> "hel lo\nwo rld"+ ,  6`maxWidth` breakspaces ["hel", "lo", "wo", "rld", "HEL", "LO", "WO", "RLD"] ==> "hel lo\nwo rld\nHEL LO\nWO RLD"+ ,  5`maxWidth` breakspaces ["hello", "world"] ==> "hello\nworld"+ , 19`maxWidth` fun (fun $ fun $ fun $ fun $ listHorV ["abcdefg", "abcdefg"])+   ==> "function(function(\n    function(\n      function(\n        function(\n          [ abcdefg\n          , abcdefg\n          ]\n          )\n        )\n      )\n    ))"+ , 19`maxWidth` fun (fun $ fun $ fun $ fun $ listHorV ["abcdefgh", "abcdefgh"])+   ==> "function(\n  function(\n    function(\n      function(\n        function(\n          [ abcdefgh\n          , abcdefgh\n          ]\n          )\n        )\n      )\n    )\n  )"+ , 7`maxWidth` ("hello"<>breakspace<>"world") ==> "hello\nworld"+ , 7`maxWidth` ("hello "<>"world") ==> "hello\nworld"+ , "  "<> "hello\nworld\n!" ==> "  hello\nworld\n!"+ , "__"<>align "hello\nworld\n!" ==> "__hello\n  world\n  !"+ , hang 2 "hello\nworld\n!" ==> "hello\n  world\n  !"+ , hang 2 "hello\nworld\n!"<>"\nhello\n!" ==> "hello\n  world\n  !\nhello\n!"+ , "let " <> align (catV $+             (\(name, typ) -> fill 6 name <+> "::" <+> typ)+             <$> [ ("abcdef","Doc")+                 , ("abcde","Int -> Doc -> Doc")+                 , ("abcdefghi","Doc") ])+   ==> "let abcdef :: Doc\n    abcde  :: Int -> Doc -> Doc\n    abcdefghi :: Doc"+ , "let " <> align (catV $+             (\(name, typ) -> breakfill 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)+             <$> [("abcdefghi","Doc ->\nDoc")])+   ==> "let abcdefghi\n           :: Doc ->\n    Doc"+ , "let " <> align (catV $+             (\(name, typ) -> breakfill 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"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34 5")                 ==> "a b 12 34\n      5"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align "")       ==> "a b 12 34"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " ")      ==> "a b 12 34 "+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 5")     ==> "a b 12 34\n         5"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 56")    ==> "a b 12\n      34\n        56"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 567")   ==> "a b\n12 34 567"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 5678")  ==> "a b\n12 34 5678"+ , 10 `maxWidth` "a b "<>"12"<>align (" 34" <> align " 56789") ==> "a b\n12 34\n     56789"+ , 10 `maxWidth` ("1234567890" <> " ") <> "1" ==> "1234567890\n1"+ , 10 `maxWidth` nestedAlign  6 ==> "1 2 3 4 5\n         6"+ , 10 `maxWidth` nestedAlign  7 ==> "1 2 3 4\n       5\n        6\n         7"+ , 10 `maxWidth` nestedAlign  8 ==> "1 2 3\n     4\n      5\n       6\n        7\n         8"+ , 10 `maxWidth` nestedAlign  9 ==> "1 2\n   3\n    4\n     5\n      6\n       7\n        8\n         9"+ , 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+ , 10 `maxWidth` justify "1 2 3 4  5 6" ==> "1 2  3 4 5\n6"+ -- 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"+ -- breakspace backtracking is bounded by the removable indentation+ -- (hence it can actually justify 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,\+  \ 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\nconsectetur consequat. Nam congue semper tellus. Sed erat dolor, dapibus\+  \ sit\namet, venenatis ornare, ultrices ut, nisi. Aliquam ante. Suspendisse\+  \ scelerisque\ndui nec velit. Duis augue augue, gravida euismod, vulputate ac,\+  \ facilisis id,\nsem. Morbi in orci. Nulla purus lacus, pulvinar vel, malesuada\+  \ ac, mattis nec,\nquam. Nam molestie scelerisque quam. Nullam feugiat cursus\+  \ lacus.orem ipsum\ndolor sit amet, consectetur adipiscing elit. Donec libero\+  \ risus, commodo vitae,\npharetra 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. Aliquam\+  \ ante. Suspendisse scelerisque\ndui nec velit. Duis augue augue, gravida\+  \ euismod, vulputate ac, facilisis id,\nsem. Morbi in orci. Nulla purus lacus,\+  \ pulvinar vel, malesuada ac, mattis nec,\nquam. Nam molestie scelerisque quam.\+  \ Nullam feugiat cursus lacus.orem ipsum\ndolor sit amet, consectetur adipiscing\+  \ elit. Donec libero risus, commodo vitae,\npharetra 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. Aliquam ante. Suspendisse scelerisque\ndui nec velit. Duis augue\+  \ augue, gravida euismod, vulputate ac, facilisis id,\nsem. Morbi in orci. Nulla\+  \ purus lacus, pulvinar vel, malesuada ac, mattis nec,\nquam. Nam molestie\+  \ scelerisque quam. Nullam feugiat cursus lacus.orem ipsum\ndolor sit amet,\+  \ consectetur adipiscing elit. Donec libero risus, commodo vitae,\npharetra\+  \ 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."+ ]+	where+	(==>) :: IsString d => d ~ String => AnsiText (Plain d) -> d -> Assertion; infix 0 ==>+	p ==> exp = got @?= exp+		where got = runPlain $ runAnsiText p+ testList :: String -> [Assertion] -> TestTree testList n as = testGroup n $ List.zipWith testCase (show <$> [1::Int ..]) as -testMessage :: TL.Text -> String-testMessage msg =-	foldMap esc $ TL.unpack $-	if 42 < TL.length msg then excerpt else msg-	where-	excerpt = TL.take 42 msg <> "…"-	esc = \case-	 '\n' -> "\\n"-	 c -> [c]--hunitsTerm :: TestTree-hunitsTerm = testGroup "Term"- [ testList "Textable"-   [ Doc.newline ==> "\n"-   , Doc.stringH "hello" ==> "hello"-   , "hello" ==> "hello"-   , Doc.catV @_ @[] ["hello", "world"] ==> "hello\nworld"-   ]- , testList "Indentable"-   [ "hello\nworld" ==> "hello\nworld"-   , "  "<> "hello\nworld\n!" ==> "  hello\nworld\n!"-   , "__"<>Doc.align "hello\nworld\n!" ==> "__hello\n  world\n  !"-   , Doc.hang 2 "hello\nworld\n!" ==> "hello\n  world\n  !"-   , Doc.hang 2 "hello\nworld\n!"<>"\nhello\n!" ==> "hello\n  world\n  !\nhello\n!"-   , "let " <> Doc.align (Doc.catV $-               (\(name, typ) -> Doc.fill 6 (Doc.stringH name) <+> "::" <+> Doc.stringH typ)-               `List.map` [ ("abcdef","Doc")-                          , ("abcde","Int -> Doc -> Doc")-                          , ("abcdefghi","Doc") ])-     ==> "let abcdef :: Doc\n    abcde  :: Int -> Doc -> Doc\n    abcdefghi :: Doc"-   , "let " <> Doc.align (Doc.catV $-               (\(name, typ) -> Doc.breakableFill 6 (Doc.stringH name) <> " ::" <+> Doc.stringH typ)-               `List.map` [ ("abcdef","Doc")-                          , ("abcde","Int -> Doc -> Doc")-                          , ("abcdefghi","Doc") ])-     ==> "let abcdef :: Doc\n    abcde  :: Int -> Doc -> Doc\n    abcdefghi\n           :: Doc"-   , "let " <> Doc.align (Doc.catV $-               (\(name, typ) -> Doc.breakableFill 6 (Doc.stringH name) <> " ::" <+> typ)-               `List.map` [("abcdefghi","Doc ->\nDoc")])-     ==> "let abcdefghi\n           :: Doc ->\n    Doc"-   , "let " <> Doc.align (Doc.catV $-               (\(name, typ) -> Doc.breakableFill 6 (Doc.stringH name) <> Doc.align (" ::" <+> typ))-               `List.map` [("abcdefghi","Doc ->\nDoc")])-     ==> "let abcdefghi\n           :: Doc ->\n          Doc"-   ]- , testList "Breakable"-   [ 10`wc` be ["hello", "world"] ==> "helloworld"-   ,  9`wc` be ["hello", "world"] ==> "hello\nworld"-   ,  6`wc` be ["he", "ll", "o!"] ==> "hello!"-   ,  6`wc` be ["he", "ll", "o!", "wo", "rl", "d!"] ==> "hello!\nworld!"-   ,  5`wc` be ["hello", "world"] ==> "hello\nworld"-   ,  5`wc` be ["he", "llo", "world"] ==> "hello\nworld"-   ,  5`wc` be ["he", "ll", "o!"] ==> "hell\no!"-   ,  4`wc` be ["hello", "world"] ==> "hello\nworld"-   ,  4`wc` be ["he", "ll", "o!"] ==> "hell\no!"-   ,  4`wc` be ["he", "llo", "world"] ==> "he\nllo\nworld"-   ,  4`wc` be ["he", "llo", "w", "orld"] ==> "he\nllow\norld"-   ,  4`wc` be ["he", "ll", "o!", "wo", "rl", "d!"] ==> "hell\no!wo\nrld!"-   ,  3`wc` be ["hello", "world"] ==> "hello\nworld"-   ,  3`wc` be ["he", "ll"] ==> "he\nll"-   ,  3`wc` be ["he", "ll", "o!"] ==> "he\nll\no!"-   ,  1`wc` be ["he", "ll", "o!"] ==> "he\nll\no!"-   ,  4`wc` ["__", Doc.align $ be ["he", "ll", "o!", "wo", "rl", "d!"]] ==> "__he\n  ll\n  o!\n  wo\n  rl\n  d!"-   ,  6`wc` ["__", Doc.align $ be ["he", "ll", "o!", "wo", "rl", "d!"]] ==> "__hell\n  o!wo\n  rld!"-   , 16`wc` ["__", listHorV ["hello", "world"]] ==> "__[hello, world]"-   ,  4`wc` ["__", listHorV ["hello", "world"]] ==> "__[ hello\n  , world\n  ]"-   , 11`wc` bs ["hello", "world"] ==> "hello world"-   , 10`wc` bs ["hello", "world"] ==> "hello\nworld"-   ,  6`wc` bs ["hel", "lo", "wo", "rld"] ==> "hel lo\nwo rld"-   ,  6`wc` bs ["hel", "lo", "wo", "rld", "HEL", "LO", "WO", "RLD"] ==> "hel lo\nwo rld\nHEL LO\nWO RLD"-   ,  5`wc` bs ["hello", "world"] ==> "hello\nworld"-   , 19`wc` fun (fun $ fun $ fun $ fun $ listHorV ["abcdefg", "abcdefg"])-     ==> "function(function(\n    function(\n      function(\n        function(\n          [ abcdefg\n          , abcdefg\n          ]\n          )\n        )\n      )\n    ))"-   , 19`wc` fun (fun $ fun $ fun $ fun $ listHorV ["abcdefgh", "abcdefgh"])-     ==> "function(\n  function(\n    function(\n      function(\n        function(\n          [ abcdefgh\n          , abcdefgh\n          ]\n          )\n        )\n      )\n    )\n  )"-   ]- ]-	where-	(==>) :: Doc.Term -> TL.Text -> Assertion; infix 0 ==>-	p ==> expected = got @?= expected-		where got = Doc.textTerm p+breakpoints :: Wrappable d => Monoid d => [d] -> d+breakpoints = intercalate breakpoint -hunitsTermDimension :: TestTree-hunitsTermDimension = testGroup "Term.Dimension"- [ testList "Textable"-   [ Doc.newline ==> mempty-       {   Dim.dim_width       = 0-       ,   Dim.dim_height      = 1-       ,   Dim.dim_width_first = 0-       ,   Dim.dim_width_last  = 0-       }-   , Doc.newline <> Doc.newline ==> mempty-       { Dim.dim_height        = 2-       }-   , Doc.space ==> Dim.Dim 1 0 1 1-   , Doc.newline <> Doc.space ==> mempty-       {   Dim.dim_width       = 1-       ,   Dim.dim_height      = 1-       ,   Dim.dim_width_first = 0-       ,   Dim.dim_width_last  = 1-       }-   , Doc.stringH "hello" ==> mempty-       {   Dim.dim_width       = 5-       ,   Dim.dim_height      = 0-       ,   Dim.dim_width_first = 5-       ,   Dim.dim_width_last  = 5-       }-   , "hello" ==> mempty-       {   Dim.dim_width       = 5-       ,   Dim.dim_height      = 0-       ,   Dim.dim_width_first = 5-       ,   Dim.dim_width_last  = 5-       }-   , Doc.newline <> "hello" ==> mempty-       {   Dim.dim_width       = 5-       ,   Dim.dim_height      = 1-       ,   Dim.dim_width_first = 0-       ,   Dim.dim_width_last  = 5-       }-   , "hel" <> Doc.newline ==> mempty-       {   Dim.dim_width       = 3-       ,   Dim.dim_height      = 1-       ,   Dim.dim_width_first = 3-       ,   Dim.dim_width_last  = 0-       }-   , ("hel" <> Doc.newline) <> "lo" ==> mempty-       {   Dim.dim_width       = 3-       ,   Dim.dim_height      = 1-       ,   Dim.dim_width_first = 3-       ,   Dim.dim_width_last  = 2-       }-   , Doc.catV @_ @[] ["hello", "world"] ==> mempty-       {   Dim.dim_width       = 5-       ,   Dim.dim_height      = 1-       ,   Dim.dim_width_first = 5-       ,   Dim.dim_width_last  = 5-       }-   , "hel\nlo" <> Doc.empty ==> Dim.Dim 3 1 3 2-   , "hel\nlo " ==> Dim.Dim 3 1 3 3-   , "lo" ==> Dim.Dim 2 0 2 2-   , Doc.charH 'X' ==> Dim.Dim 1 0 1 1-   , "lo"<>Doc.charH 'X' ==> Dim.Dim 3 0 3 3-   , "lo"<>Doc.charH ' ' ==> Dim.Dim 3 0 3 3-   , "lo"<>Doc.space ==> Dim.Dim 3 0 3 3-   , (Doc.newline<>"lo")<>Doc.space ==> Dim.Dim 3 1 0 3-   , (("hel"<>Doc.newline)<>"lo")<>Doc.space ==> Dim.Dim 3 1 3 3-   , "hel\nlo" <> Doc.space ==> Dim.Dim 3 1 3 3-   , (Dim.Dim 2 0 2 2 <> Dim.Dim 1 0 1 1) @?= Dim.Dim 3 0 3 3-   ]- ]-	where-	(==>) :: Dim.Dimension -> Dim.Dim -> Assertion; infix 0 ==>-	p ==> expected = got @?= expected-		where got = Dim.dim p+breakspaces :: Wrappable d => Monoid d => [d] -> d+breakspaces = intercalate breakspace -be :: Doc.Breakable d => [d] -> d-be = Doc.foldWith Doc.breakableEmpty-bs :: Doc.Breakable d => [d] -> d-bs = Doc.foldWith Doc.breakableSpace-wc :: Doc.Breakable d => Doc.Column -> d -> d-wc = Doc.withBreakable . Just+infix 1 `maxWidth`+maxWidth :: Wrappable d => Width -> d -> d+maxWidth = setWidth . Just -fun :: (Doc.Indentable d, Doc.Breakable d) => d -> d-fun x = "function(" <> Doc.incrIndent 2 (Doc.ifBreak (Doc.newline<>x<>Doc.newline) x) <> ")"+nestedAlign ::+ DocFrom (Line String) d =>+ Spaceable d => Indentable d => Wrappable d =>+ Int -> d+nestedAlign n = go 1+	where+	go i =+		docFrom (Line (show i)) <>+		(if n <= i then mempty+		else align (breakspace <> go (i+1))) -listHorV :: (Doc.Indentable d, Doc.Breakable d) => [d] -> d+listHorV :: IsString d => Indentable d => Wrappable d => [d] -> d listHorV [] = "[]"-listHorV [x] = "["<>x<>"]"-listHorV xs =-	Doc.ifBreak-	 (Doc.align $ "[ " <> foldr1 (\a acc -> a <> Doc.newline <> ", " <> acc) xs <> Doc.newline <> "]")-	 ("[" <> Doc.intercalate ", " xs <> "]")+listHorV [d] = "["<>d<>"]"+listHorV ds =+	breakalt+	 ("[" <> intercalate ("," <> space) ds <> "]")+	 (align $ "[" <> space+		 <> foldr1 (\a acc -> a <> newline <> "," <> space <> acc) ds+		 <> newline <> "]")++fun :: IsString d => Indentable d => Wrappable d => d -> d+fun d = "function(" <> incrIndent 2 (breakalt d (newline<>d<>newline)) <> ")"