symantic-document 0.0.0.20180213 → 0.1.2.20180831

raw patch · 13 files changed

+1164/−650 lines, 13 filesdep +containersdep +symantic-documentdep +tastyPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, symantic-document, tasty, tasty-hunit, transformers

API changes (from Hackage documentation)

Files

• Language/Symantic/Document.hs +0/−9
• Language/Symantic/Document/ANSI.hs +0/−162
• Language/Symantic/Document/Dim.hs +0/−102
• Language/Symantic/Document/Plain.hs +0/−149
• Language/Symantic/Document/Sym.hs +328/−107
• Language/Symantic/Document/Term.hs +186/−0
• Language/Symantic/Document/Term/Dimension.hs +198/−0
• Language/Symantic/Document/Term/IO.hs +183/−0
• Language/Symantic/Document/Valid.hs +0/−112
• stack.yaml +1/−1
• symantic-document.cabal +48/−8
• test/HUnit.hs +206/−0
• test/Main.hs +14/−0

@@ -1,13 +1,4 @@ module Language.Symantic.Document  ( module Language.Symantic.Document.Sym- , module Language.Symantic.Document.ANSI- , module Language.Symantic.Document.Dim- , module Language.Symantic.Document.Plain- , module Language.Symantic.Document.Valid  ) where- import Language.Symantic.Document.Sym-import Language.Symantic.Document.ANSI-import Language.Symantic.Document.Dim-import Language.Symantic.Document.Plain-import Language.Symantic.Document.Valid

@@ -1,162 +0,0 @@-module Language.Symantic.Document.ANSI where--import Control.Monad (Monad(..), replicateM_)-import Data.Bool (Bool(..))-import Data.Function (($), (.), const)-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import System.Console.ANSI-import System.IO (IO)-import Text.Show (Show(..))-import qualified Data.List as L-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB-import qualified Data.Text.Lazy.IO as TL-import qualified System.IO as IO--import Language.Symantic.Document.Sym---- * Type 'ANSI'-newtype ANSI = ANSI { unANSI :: [SGR] -> TLB.Builder }-instance IsString ANSI where-	fromString s = ANSI $ const t-		where t = fromString s--ansi :: ANSI -> TLB.Builder-ansi (ANSI d) = d []--pushSGR :: SGR -> ANSI -> ANSI-pushSGR c (ANSI d) = ANSI $ \cs ->-	fromString (setSGRCode [c]) <>-	d (c:cs) <>-	fromString (setSGRCode $ Reset:L.reverse cs)--instance Semigroup ANSI where-	ANSI x <> ANSI y = ANSI $ \c -> x c <> y c-instance Monoid ANSI where-	mempty  = empty-	mappend = (<>)-instance Doc_Text ANSI where-	replicate i d = ANSI $ TLB.fromLazyText . TL.replicate (int64OfInt i) . TLB.toLazyText . unANSI d-	int     = ANSI . const . fromString . show-	integer = ANSI . const . fromString . show-	char    = ANSI . const . TLB.singleton-	string  = ANSI . const . fromString-	text    = ANSI . const . TLB.fromText-	ltext   = ANSI . const . TLB.fromLazyText-	charH   = char-	stringH = string-	textH   = text-	ltextH  = ltext-instance Doc_Color ANSI where-	reverse     = pushSGR $ SetSwapForegroundBackground True-	black       = pushSGR $ SetColor Foreground Dull  Black-	red         = pushSGR $ SetColor Foreground Dull  Red-	green       = pushSGR $ SetColor Foreground Dull  Green-	yellow      = pushSGR $ SetColor Foreground Dull  Yellow-	blue        = pushSGR $ SetColor Foreground Dull  Blue-	magenta     = pushSGR $ SetColor Foreground Dull  Magenta-	cyan        = pushSGR $ SetColor Foreground Dull  Cyan-	white       = pushSGR $ SetColor Foreground Dull  White-	blacker     = pushSGR $ SetColor Foreground Vivid Black-	redder      = pushSGR $ SetColor Foreground Vivid Red-	greener     = pushSGR $ SetColor Foreground Vivid Green-	yellower    = pushSGR $ SetColor Foreground Vivid Yellow-	bluer       = pushSGR $ SetColor Foreground Vivid Blue-	magentaer   = pushSGR $ SetColor Foreground Vivid Magenta-	cyaner      = pushSGR $ SetColor Foreground Vivid Cyan-	whiter      = pushSGR $ SetColor Foreground Vivid White-	onBlack     = pushSGR $ SetColor Background Dull  Black-	onRed       = pushSGR $ SetColor Background Dull  Red-	onGreen     = pushSGR $ SetColor Background Dull  Green-	onYellow    = pushSGR $ SetColor Background Dull  Yellow-	onBlue      = pushSGR $ SetColor Background Dull  Blue-	onMagenta   = pushSGR $ SetColor Background Dull  Magenta-	onCyan      = pushSGR $ SetColor Background Dull  Cyan-	onWhite     = pushSGR $ SetColor Background Dull  White-	onBlacker   = pushSGR $ SetColor Background Vivid Black-	onRedder    = pushSGR $ SetColor Background Vivid Red-	onGreener   = pushSGR $ SetColor Background Vivid Green-	onYellower  = pushSGR $ SetColor Background Vivid Yellow-	onBluer     = pushSGR $ SetColor Background Vivid Blue-	onMagentaer = pushSGR $ SetColor Background Vivid Magenta-	onCyaner    = pushSGR $ SetColor Background Vivid Cyan-	onWhiter    = pushSGR $ SetColor Background Vivid White-instance Doc_Decoration ANSI where-	bold        = pushSGR $ SetConsoleIntensity BoldIntensity-	underline   = pushSGR $ SetUnderlining SingleUnderline-	italic      = pushSGR $ SetItalicized True---- * Type 'ANSI_IO'-newtype ANSI_IO = ANSI_IO { unANSI_IO :: [SGR] -> IO.Handle -> IO () }-instance IsString ANSI_IO where-	fromString s = ANSI_IO $ \_c h -> IO.hPutStr h t-		where t = fromString s--ansiIO :: ANSI_IO -> IO.Handle -> IO ()-ansiIO (ANSI_IO d) = d []--pushSGR_IO :: SGR -> ANSI_IO -> ANSI_IO-pushSGR_IO c (ANSI_IO d) = ANSI_IO $ \cs h -> do-	hSetSGR h [c]-	d (c:cs) h-	hSetSGR h $ Reset:L.reverse cs--instance Semigroup ANSI_IO where-	ANSI_IO x <> ANSI_IO y = ANSI_IO $ \c h -> do {x c h; y c h}-instance Monoid ANSI_IO where-	mempty  = empty-	mappend = (<>)-instance Doc_Text ANSI_IO where-	empty         = ANSI_IO $ \_ _ -> return ()-	replicate i d = ANSI_IO $ \c   -> replicateM_ i . unANSI_IO d c-	int       i   = ANSI_IO $ \_ h -> IO.hPutStr  h (show i)-	integer   i   = ANSI_IO $ \_ h -> IO.hPutStr  h (show i)-	char      x   = ANSI_IO $ \_ h -> IO.hPutChar h x-	string    x   = ANSI_IO $ \_ h -> IO.hPutStr  h x-	text      x   = ANSI_IO $ \_ h -> T.hPutStr   h x-	ltext     x   = ANSI_IO $ \_ h -> TL.hPutStr  h x-	charH         = char-	stringH       = string-	textH         = text-	ltextH        = ltext-instance Doc_Color ANSI_IO where-	reverse     = pushSGR_IO $ SetSwapForegroundBackground True-	black       = pushSGR_IO $ SetColor Foreground Dull  Black-	red         = pushSGR_IO $ SetColor Foreground Dull  Red-	green       = pushSGR_IO $ SetColor Foreground Dull  Green-	yellow      = pushSGR_IO $ SetColor Foreground Dull  Yellow-	blue        = pushSGR_IO $ SetColor Foreground Dull  Blue-	magenta     = pushSGR_IO $ SetColor Foreground Dull  Magenta-	cyan        = pushSGR_IO $ SetColor Foreground Dull  Cyan-	white       = pushSGR_IO $ SetColor Foreground Dull  White-	blacker     = pushSGR_IO $ SetColor Foreground Vivid Black-	redder      = pushSGR_IO $ SetColor Foreground Vivid Red-	greener     = pushSGR_IO $ SetColor Foreground Vivid Green-	yellower    = pushSGR_IO $ SetColor Foreground Vivid Yellow-	bluer       = pushSGR_IO $ SetColor Foreground Vivid Blue-	magentaer   = pushSGR_IO $ SetColor Foreground Vivid Magenta-	cyaner      = pushSGR_IO $ SetColor Foreground Vivid Cyan-	whiter      = pushSGR_IO $ SetColor Foreground Vivid White-	onBlack     = pushSGR_IO $ SetColor Background Dull  Black-	onRed       = pushSGR_IO $ SetColor Background Dull  Red-	onGreen     = pushSGR_IO $ SetColor Background Dull  Green-	onYellow    = pushSGR_IO $ SetColor Background Dull  Yellow-	onBlue      = pushSGR_IO $ SetColor Background Dull  Blue-	onMagenta   = pushSGR_IO $ SetColor Background Dull  Magenta-	onCyan      = pushSGR_IO $ SetColor Background Dull  Cyan-	onWhite     = pushSGR_IO $ SetColor Background Dull  White-	onBlacker   = pushSGR_IO $ SetColor Background Vivid Black-	onRedder    = pushSGR_IO $ SetColor Background Vivid Red-	onGreener   = pushSGR_IO $ SetColor Background Vivid Green-	onYellower  = pushSGR_IO $ SetColor Background Vivid Yellow-	onBluer     = pushSGR_IO $ SetColor Background Vivid Blue-	onMagentaer = pushSGR_IO $ SetColor Background Vivid Magenta-	onCyaner    = pushSGR_IO $ SetColor Background Vivid Cyan-	onWhiter    = pushSGR_IO $ SetColor Background Vivid White-instance Doc_Decoration ANSI_IO where-	bold        = pushSGR_IO $ SetConsoleIntensity BoldIntensity-	underline   = pushSGR_IO $ SetUnderlining SingleUnderline-	italic      = pushSGR_IO $ SetItalicized True

@@ -1,102 +0,0 @@-module Language.Symantic.Document.Dim where--import Data.Eq (Eq)-import Data.Foldable (Foldable(..))-import Data.Function (($), id)-import Data.Functor ((<$>))-import Data.Int (Int)-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import Prelude (max, Num(..), toInteger)-import Text.Show (Show(..))-import qualified Data.List as L-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import Language.Symantic.Document.Sym---- * Type 'Dim'-data Dim- =   Dim- { width       :: Int -- ^ Maximun line length.- , height      :: Int -- ^ Number of newlines.- , width_first :: Int -- ^ Length of the first line.- , width_last  :: Int -- ^ Length of the last line.- } deriving (Eq, Show)-instance IsString Dim where-	fromString [] = Dim 0 0 0 0-	fromString s =-		Dim-		 { width       = maximum ws-		 , height      = length ls-		 , width_first = if null ws then 0 else L.head ws-		 , width_last  = if null ws then 0 else L.last ws-		 }-		where-		ls = L.lines s-		ws = length <$> ls--dim :: Dim -> Dim-dim = id--instance Semigroup Dim where-	Dim wx hx wfx wlx <> Dim wy hy wfy 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 = wfx + wfy in Dim (max v (wx + wy)) h v wly-		 (_, 0) -> let v = wlx + wfy in Dim (max v (wx + wy)) h wfx v-		 _      -> Dim (max wx wy) h wfx wly-instance Monoid Dim where-	mempty  = empty-	mappend = (<>)-instance Doc_Text Dim where-	spaces    i   = Dim i 0 i i-	replicate i d = if i <= 0 then empty else d <> replicate (i - 1) d-	int       i   = fromString $ show i-	integer   i   = fromString $ show i-	charH     _c  = Dim 1 0 1 1-	stringH   t   = Dim l 0 l l where l = length t-	textH     t   = Dim l 0 l l where l = T.length t-	ltextH    t   = Dim l 0 l l where l = fromInteger $ toInteger $ TL.length t-	                                    -- XXX: conversion may overflow-instance Doc_Color Dim where-	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 Doc_Decoration Dim where-	bold        = id-	underline   = id-	italic      = id

@@ -1,149 +0,0 @@-module Language.Symantic.Document.Plain where--import Control.Monad (Monad(..), replicateM_)-import Data.Function (($), (.), id)-import Data.Monoid (Monoid(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import System.IO (IO)-import Text.Show (Show(..))-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TL-import qualified Data.Text.Lazy.Builder as TLB-import qualified System.IO as IO--import Language.Symantic.Document.Sym---- * Type 'Plain'-newtype Plain- =      Plain TLB.Builder- deriving (Show)-instance IsString Plain where-	fromString = Plain . fromString--plain :: Plain -> TLB.Builder-plain (Plain d) = d--instance Semigroup Plain where-	Plain x <> Plain y = Plain (x <> y)-instance Monoid Plain where-	mempty  = empty-	mappend = (<>)-instance Doc_Text Plain where-	int         = Plain . fromString . show-	integer     = Plain . fromString . show-	replicate i = Plain . TLB.fromLazyText . TL.replicate (int64OfInt i) . TLB.toLazyText . plain-	char        = Plain . TLB.singleton-	string      = Plain . fromString-	text        = Plain . TLB.fromText-	ltext       = Plain . TLB.fromLazyText-	charH       = char-	stringH     = string-	textH       = text-	ltextH      = ltext-instance Doc_Color Plain where-	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 Doc_Decoration Plain where-	bold        = id-	underline   = id-	italic      = id---- * Type 'PlainIO'-newtype PlainIO- =      PlainIO { unPlainH :: IO.Handle -> IO () }-instance IsString PlainIO where-	fromString s = PlainIO $ \h -> IO.hPutStr h t-		where t = fromString s--plainIO :: PlainIO -> IO.Handle -> IO ()-plainIO (PlainIO d) = d--instance Semigroup PlainIO where-	PlainIO x <> PlainIO y = PlainIO $ \h -> do {x h; y h}-instance Monoid PlainIO where-	mempty  = empty-	mappend = (<>)-instance Doc_Text PlainIO where-	empty         = PlainIO $ \_ -> return ()-	int     i     = PlainIO $ \h -> IO.hPutStr  h (show i)-	integer i     = PlainIO $ \h -> IO.hPutStr  h (show i)-	replicate i d = PlainIO $ replicateM_ i . plainIO d-	char    x     = PlainIO $ \h -> IO.hPutChar h x-	string  x     = PlainIO $ \h -> IO.hPutStr  h x-	text    x     = PlainIO $ \h -> T.hPutStr   h x-	ltext   x     = PlainIO $ \h -> TL.hPutStr  h x-	charH         = char-	stringH       = string-	textH         = text-	ltextH        = ltext-instance Doc_Color PlainIO where-	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 Doc_Decoration PlainIO where-	bold          = id-	underline     = id-	italic        = id

@@ -1,84 +1,299 @@-{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Language.Symantic.Document.Sym where +import Data.Bool import Data.Char (Char)-import Data.Foldable (Foldable(..))-import Data.Function ((.))+import Data.Eq (Eq(..))+import Data.Foldable (Foldable, foldr, foldr1)+import Data.Function ((.), ($)) import Data.Functor (Functor(..))-import Data.Int (Int, Int64)+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 Data.Text (Text)-import Prelude (Integer, fromInteger, toInteger)-import qualified Data.List as L-import qualified Data.Text as T+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 --- * Class 'Doc_Text'-class (IsString d, Semigroup d) => Doc_Text d where-	charH     :: Char    -> d -- ^ XXX: MUST NOT be '\n'-	stringH   :: String  -> d -- ^ XXX: MUST NOT contain '\n'-	textH     :: Text    -> d -- ^ XXX: MUST NOT contain '\n'-	ltextH    :: TL.Text -> d -- ^ XXX: MUST NOT contain '\n'-	replicate :: Int -> d -> d-	integer   :: Integer -> d-	default charH     :: Doc_Text (ReprOf d) => Trans d => Char -> d-	default stringH   :: Doc_Text (ReprOf d) => Trans d => String -> d-	default textH     :: Doc_Text (ReprOf d) => Trans d => Text -> d-	default ltextH    :: Doc_Text (ReprOf d) => Trans d => TL.Text -> d-	default replicate :: Doc_Text (ReprOf d) => Trans d => Int -> d -> d-	default integer   :: Doc_Text (ReprOf d) => Trans d => Integer -> d+-- * 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-	replicate = trans1 . replicate-	integer   = trans . integer 	-	empty     :: d-	eol       :: d-	space     :: d-	spaces    :: Int -> d-	int       :: Int -> d-	char      :: Char    -> d-	string    :: String  -> d-	text      :: Text    -> d-	ltext     :: TL.Text -> d-	catH      :: Foldable f => f d -> d-	catV      :: Foldable f => f d -> d-	paren     :: d -> d-	brace     :: d -> d-	bracket   :: d -> d-	bquote    :: d -> d-	dquote    :: d -> d-	fquote    :: d -> d-	squote    :: d -> d+	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 	-	empty     = ""-	eol       = "\n"-	space     = char ' '-	spaces i  = replicate i space-	int       = integer . toInteger-	char      = \case '\n' -> eol; c -> charH c-	string    = catV . fmap stringH . L.lines-	text      = catV . fmap textH   . T.lines-	ltext     = catV . fmap ltextH  . TL.lines-	catH      = foldr (<>) empty-	catV l    = if null l then empty else foldr1 (\a acc -> a <> eol <> acc) l-	paren   d = charH '('   <> d <> charH ')'-	brace   d = charH '{'   <> d <> charH '}'-	bracket d = charH '['   <> d <> charH ']'-	bquote  d = charH '`'   <> d <> charH '`'-	dquote  d = charH '\"'  <> d <> charH '\"'-	fquote  d =       "« "  <> d <>       " »"-	squote  d = charH '\''  <> d <> charH '\''-	-- default catH :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d-	-- default catV :: Doc_Text (ReprOf d) => Trans d => Foldable f => Functor f => f d -> d-	-- catH  l = trans (catH (fmap unTrans l))-	-- catV  l = trans (catV (fmap unTrans l))+	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 'Doc_Color'-class Doc_Color d where+-- * 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@@ -123,39 +338,39 @@ 	onCyaner    :: d -> d 	onWhiter    :: d -> d 	-	default reverse     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default black       :: Doc_Color (ReprOf d) => Trans d => d -> d-	default red         :: Doc_Color (ReprOf d) => Trans d => d -> d-	default green       :: Doc_Color (ReprOf d) => Trans d => d -> d-	default yellow      :: Doc_Color (ReprOf d) => Trans d => d -> d-	default blue        :: Doc_Color (ReprOf d) => Trans d => d -> d-	default magenta     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default cyan        :: Doc_Color (ReprOf d) => Trans d => d -> d-	default white       :: Doc_Color (ReprOf d) => Trans d => d -> d-	default blacker     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default redder      :: Doc_Color (ReprOf d) => Trans d => d -> d-	default greener     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default yellower    :: Doc_Color (ReprOf d) => Trans d => d -> d-	default bluer       :: Doc_Color (ReprOf d) => Trans d => d -> d-	default magentaer   :: Doc_Color (ReprOf d) => Trans d => d -> d-	default cyaner      :: Doc_Color (ReprOf d) => Trans d => d -> d-	default whiter      :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onBlack     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onRed       :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onGreen     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onYellow    :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onBlue      :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onMagenta   :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onCyan      :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onWhite     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onBlacker   :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onRedder    :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onGreener   :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onYellower  :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onBluer     :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onMagentaer :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onCyaner    :: Doc_Color (ReprOf d) => Trans d => d -> d-	default onWhiter    :: Doc_Color (ReprOf d) => Trans d => 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@@ -191,14 +406,23 @@ 	onCyaner    = trans1 onCyaner 	onWhiter    = trans1 onWhiter --- * Class 'Doc_Decoration'-class Doc_Decoration d where+-- * 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      :: Doc_Decoration (ReprOf d) => Trans d => d -> d-	default underline :: Doc_Decoration (ReprOf d) => Trans d => d -> d-	default italic    :: Doc_Decoration (ReprOf d) => Trans d => 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@@ -228,6 +452,3 @@ 	 :: (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))--int64OfInt :: Int -> Int64-int64OfInt = fromInteger . toInteger

@@ -0,0 +1,186 @@+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

@@ -0,0 +1,198 @@+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

@@ -0,0 +1,183 @@+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

@@ -1,112 +0,0 @@-module Language.Symantic.Document.Valid where--import Control.Applicative (Applicative(..))-import Control.Monad (Monad(..))-import Data.Eq (Eq(..))-import Data.Foldable (elem)-import Data.Function (($), (.), id)-import Data.Functor (Functor(..))-import Data.Int (Int)-import Data.Monoid (Monoid(..))-import Data.Ord (Ord(..))-import Data.Semigroup (Semigroup(..))-import Data.String (IsString(..))-import Text.Show (Show)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL--import Language.Symantic.Document.Sym---- * Type 'Valid'-data Valid repr- =   KO [Error_Valid]- |   Ok repr- deriving (Eq, Show)-instance IsString repr => IsString (Valid repr) where-	fromString = Ok . fromString--valid :: Valid repr -> Valid repr-valid = id---- ** Type 'Error_Valid'-data Error_Valid- =   Error_Valid_not_horizontal TL.Text- |   Error_Valid_negative_replicate Int- deriving (Eq, Show)--instance Semigroup repr => Semigroup (Valid repr) where-	Ok x <> Ok y = Ok $ x <> y-	KO x <> Ok _ = KO x-	Ok _ <> KO y = KO y-	KO x <> KO y = KO $ x <> y-instance (Doc_Text repr, Semigroup repr) => Monoid (Valid repr) where-	mempty  = empty-	mappend = (<>)-instance Functor Valid where-	fmap _ (KO e) = KO e-	fmap f (Ok a) = Ok $ f a-instance Applicative Valid where-	pure = Ok-	Ok f  <*> Ok a  = Ok $ f a-	KO e  <*> KO e' = KO $ e <> e'-	Ok _f <*> KO e  = KO e-	KO e  <*> Ok _a = KO e-instance Monad Valid where-	return = Ok-	Ok a >>= f = f a-	KO e >>= _ = KO e-instance (Doc_Text repr, Semigroup repr) => Doc_Text (Valid repr) where-	replicate i _ | i < 0 = KO [Error_Valid_negative_replicate i]-	replicate i d         = d >>= Ok . replicate i-	int       = pure . int-	integer   = pure . integer-	char      = pure . char-	string    = pure . string-	text      = pure . text-	ltext     = pure . ltext-	charH '\n'= KO [Error_Valid_not_horizontal $ TL.singleton '\n']-	charH c   = Ok $ charH c-	stringH t | '\n' `elem` t = KO [Error_Valid_not_horizontal $ fromString t]-	stringH t = Ok $ stringH t-	textH   t | T.any (== '\n') t = KO [Error_Valid_not_horizontal $ TL.fromStrict t]-	textH   t = Ok $ textH t-	ltextH  t | TL.any (== '\n') t = KO [Error_Valid_not_horizontal t]-	ltextH  t = Ok $ ltextH t-instance Doc_Color repr => Doc_Color (Valid repr) where-	reverse     = fmap reverse-	black       = fmap black-	red         = fmap red-	green       = fmap green-	yellow      = fmap yellow-	blue        = fmap blue-	magenta     = fmap magenta-	cyan        = fmap cyan-	white       = fmap white-	blacker     = fmap blacker-	redder      = fmap redder-	greener     = fmap greener-	yellower    = fmap yellower-	bluer       = fmap bluer-	magentaer   = fmap magentaer-	cyaner      = fmap cyaner-	whiter      = fmap whiter-	onBlack     = fmap onBlack-	onRed       = fmap onRed-	onGreen     = fmap onGreen-	onYellow    = fmap onYellow-	onBlue      = fmap onBlue-	onMagenta   = fmap onMagenta-	onCyan      = fmap onCyan-	onWhite     = fmap onWhite-	onBlacker   = fmap onBlacker-	onRedder    = fmap onRedder-	onGreener   = fmap onGreener-	onYellower  = fmap onYellower-	onBluer     = fmap onBluer-	onMagentaer = fmap onMagentaer-	onCyaner    = fmap onCyaner-	onWhiter    = fmap onWhiter-instance Doc_Decoration repr => Doc_Decoration (Valid repr) where-	bold      = fmap bold-	italic    = fmap italic-	underline = fmap underline

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

@@ -2,7 +2,7 @@ -- PVP:  +-+------- breaking API changes --       | | +----- non-breaking API additions --       | | | +--- code changes with no API change-version: 0.0.0.20180213+version: 0.1.2.20180831 category: Text synopsis: Document symantics. description: Symantics for generating documents.@@ -17,26 +17,24 @@  build-type: Simple cabal-version: >= 1.10-tested-with: GHC==8.2.2+tested-with: GHC==8.4.3 extra-source-files:   stack.yaml extra-tmp-files: -source-repository head+Source-Repository head   location: git://git.autogeree.net/symantic   type:     git  Library   exposed-modules:     Language.Symantic.Document-    Language.Symantic.Document.ANSI-    Language.Symantic.Document.Dim-    Language.Symantic.Document.Plain     Language.Symantic.Document.Sym-    Language.Symantic.Document.Valid+    Language.Symantic.Document.Term+    Language.Symantic.Document.Term.Dimension+    Language.Symantic.Document.Term.IO   default-language: Haskell2010   default-extensions:-    NoImplicitPrelude     DataKinds     DefaultSignatures     FlexibleContexts@@ -44,6 +42,7 @@     LambdaCase     MultiParamTypeClasses     NamedFieldPuns+    NoImplicitPrelude     OverloadedStrings     ScopedTypeVariables     StandaloneDeriving@@ -60,3 +59,44 @@       ansi-terminal >= 0.7     , base          >= 4.6 && < 5     , text          >= 1.2+    , transformers  >= 0.5++Test-Suite symantic-document-test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  other-modules:+    HUnit+  default-language: Haskell2010+  default-extensions:+    DataKinds+    FlexibleContexts+    FlexibleInstances+    LambdaCase+    MultiParamTypeClasses+    NoImplicitPrelude+    NoMonomorphismRestriction+    OverloadedStrings+    ScopedTypeVariables+    TupleSections+    TypeApplications+    TypeFamilies+    TypeOperators+  ghc-options:+    -Wall+    -Wincomplete-uni-patterns+    -Wincomplete-record-updates+    -fno-warn-tabs+    -fhide-source-paths+    -fprint-explicit-kinds+    -- -O0+    -- -fmax-simplifier-iterations=0+    -- -dshow-passes+  build-depends:+      symantic-document+    , base             >= 4.6 && < 5+    , containers       >= 0.5+    , tasty            >= 0.11+    , tasty-hunit      >= 0.9+    , text             >= 1.2+    , transformers     >= 0.5

@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE TypeApplications #-}+module HUnit where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Foldable (Foldable(..))+import Data.Function (($), (.))+import Data.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)+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 ((<+>))++-- * Tests+hunits :: TestTree+hunits = testGroup "HUnit" $+ [ hunitsTerm+ , hunitsTermDimension+ ]++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++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++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++fun :: (Doc.Indentable d, Doc.Breakable d) => d -> d+fun x = "function(" <> Doc.incrIndent 2 (Doc.ifBreak (Doc.newline<>x<>Doc.newline) x) <> ")"++listHorV :: (Doc.Indentable d, Doc.Breakable 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 <> "]")

@@ -0,0 +1,14 @@+module Main where++import Data.Function (($))+import System.IO (IO)+import Test.Tasty++import HUnit++main :: IO ()+main = do+	defaultMain $+		testGroup "Document"+		 [ hunits+		 ]