diff --git a/Language/Symantic/Document.hs b/Language/Symantic/Document.hs deleted file mode 100644 --- a/Language/Symantic/Document.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Language.Symantic.Document - ( module Language.Symantic.Document.Sym - ) where -import Language.Symantic.Document.Sym diff --git a/Language/Symantic/Document/Sym.hs b/Language/Symantic/Document/Sym.hs deleted file mode 100644 --- a/Language/Symantic/Document/Sym.hs +++ /dev/null @@ -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)) diff --git a/Language/Symantic/Document/Term.hs b/Language/Symantic/Document/Term.hs deleted file mode 100644 --- a/Language/Symantic/Document/Term.hs +++ /dev/null @@ -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 diff --git a/Language/Symantic/Document/Term/Dimension.hs b/Language/Symantic/Document/Term/Dimension.hs deleted file mode 100644 --- a/Language/Symantic/Document/Term/Dimension.hs +++ /dev/null @@ -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 diff --git a/Language/Symantic/Document/Term/IO.hs b/Language/Symantic/Document/Term/IO.hs deleted file mode 100644 --- a/Language/Symantic/Document/Term/IO.hs +++ /dev/null @@ -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 diff --git a/Symantic/Document.hs b/Symantic/Document.hs new file mode 100644 --- /dev/null +++ b/Symantic/Document.hs @@ -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 diff --git a/Symantic/Document/API.hs b/Symantic/Document/API.hs new file mode 100644 --- /dev/null +++ b/Symantic/Document/API.hs @@ -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)) diff --git a/Symantic/Document/AnsiText.hs b/Symantic/Document/AnsiText.hs new file mode 100644 --- /dev/null +++ b/Symantic/Document/AnsiText.hs @@ -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 diff --git a/Symantic/Document/Plain.hs b/Symantic/Document/Plain.hs new file mode 100644 --- /dev/null +++ b/Symantic/Document/Plain.hs @@ -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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,3 @@ -resolver: lts-12.8 +resolver: lts-13.19 packages: - '.' diff --git a/symantic-document.cabal b/symantic-document.cabal --- a/symantic-document.cabal +++ b/symantic-document.cabal @@ -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 diff --git a/test/HUnit.hs b/test/HUnit.hs --- a/test/HUnit.hs +++ b/test/HUnit.hs @@ -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)) <> ")"