import Symantic.Document.API
--- * Type 'AnsiText'
-newtype AnsiText d = AnsiText { unAnsiText :: Reader [SGR] d }
-instance Show d => Show (AnsiText d) where
- show (AnsiText d) = show $ runReader d []
-
-ansiText :: AnsiText d -> AnsiText d
-ansiText = id
-
-runAnsiText :: AnsiText d -> d
-runAnsiText (AnsiText d) = (`runReader` []) d
-
-instance From Char d => From Char (AnsiText d) where
- from = AnsiText . return . from
-instance From String d => From String (AnsiText d) where
- from = AnsiText . return . from
-instance From Text d => From Text (AnsiText d) where
- from = AnsiText . return . from
-instance From TL.Text d => From TL.Text (AnsiText d) where
- from = AnsiText . return . from
-instance From s (AnsiText d) => From (Line s) (AnsiText d) where
- from = from . unLine
-instance From s (AnsiText d) => From (Word s) (AnsiText d) where
- from = from . unWord
-instance From String d => IsString (AnsiText d) where
- fromString = from
-instance Semigroup d => Semigroup (AnsiText d) where
- AnsiText x <> AnsiText y = AnsiText $ liftA2 (<>) x y
-instance Monoid d => Monoid (AnsiText d) where
- 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.
- width (AnsiText ds) = width $ runReader ds mempty
- nullWidth (AnsiText ds) = nullWidth $ runReader ds mempty
-instance Spaceable d => Spaceable (AnsiText d) where
- newline = AnsiText $ return newline
- space = AnsiText $ return space
- spaces = AnsiText . return . spaces
-instance (Semigroup d, From [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, From [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
- align (AnsiText d) = AnsiText $ align <$> d
- setIndent p i (AnsiText d) = AnsiText $ ReaderT $ \inh ->
- Identity $
- setIndent
- (unAnsiText p`runReader`inh) i
- (runReader d inh)
- incrIndent p i (AnsiText d) = AnsiText $ ReaderT $ \inh ->
- Identity $
- incrIndent
- (unAnsiText p`runReader`inh) i
- (runReader d inh)
- fill w (AnsiText d) = AnsiText $ fill w <$> d
- fillOrBreak w (AnsiText d) = AnsiText $ fillOrBreak w <$> d
-instance Listable d => Listable (AnsiText d) where
- ul ds = AnsiText $ (ul <$>) $ sequence $ unAnsiText <$> ds
- ol ds = AnsiText $ (ol <$>) $ sequence $ unAnsiText <$> ds
-instance Wrappable d => Wrappable (AnsiText d) where
- setWidth w (AnsiText d) = AnsiText $ setWidth w <$> d
- breakpoint = AnsiText $ return breakpoint
- breakspace = AnsiText $ return breakspace
- endline = AnsiText $ return endline
- breakalt (AnsiText x) (AnsiText y) = AnsiText $ liftA2 breakalt x y
-
-ansiTextSGR ::
- Semigroup d => From [SGR] d =>
- SGR -> AnsiText d -> AnsiText d
-ansiTextSGR newSGR (AnsiText d) = AnsiText $ do
- oldSGR <- ask
- (\m -> from [newSGR] <> m <> from (Reset:List.reverse oldSGR))
- <$> local (newSGR :) d
-
-- * Type 'PlainText'
-- | Drop 'Colorable16' and 'Decorable'.
newtype PlainText d = PlainText { unPlainText :: d }
, plainInh_justify :: !Bool
, plainInh_indent :: !Indent
, plainInh_indenting :: !(Plain d)
+ , plainInh_sgr :: ![SGR]
}
defPlainInh :: Spaceable d => PlainInh d
, plainInh_justify = False
, plainInh_indent = 0
, plainInh_indenting = mempty
+ , plainInh_sgr = []
}
-- ** Type 'PlainFit'
then k (id, st {plainState_buffer = PlainChunk_Ignored (from sgr) : plainState_buffer st})
else k ((from sgr <>), st)
+-- * Justifying
justifyLinePlain ::
Spaceable d =>
PlainInh d -> PlainState d -> d
_ -> runPlainChunk w <> go ws lls
go (w:ws) [] = runPlainChunk w <> go ws []
go [] _ls = mempty
+
+-- * Escaping
+instance (Semigroup d, From [SGR] d) => Colorable16 (Plain d) where
+ reverse = plainSGR $ SetSwapForegroundBackground True
+ black = plainSGR $ SetColor Foreground Dull Black
+ red = plainSGR $ SetColor Foreground Dull Red
+ green = plainSGR $ SetColor Foreground Dull Green
+ yellow = plainSGR $ SetColor Foreground Dull Yellow
+ blue = plainSGR $ SetColor Foreground Dull Blue
+ magenta = plainSGR $ SetColor Foreground Dull Magenta
+ cyan = plainSGR $ SetColor Foreground Dull Cyan
+ white = plainSGR $ SetColor Foreground Dull White
+ blacker = plainSGR $ SetColor Foreground Vivid Black
+ redder = plainSGR $ SetColor Foreground Vivid Red
+ greener = plainSGR $ SetColor Foreground Vivid Green
+ yellower = plainSGR $ SetColor Foreground Vivid Yellow
+ bluer = plainSGR $ SetColor Foreground Vivid Blue
+ magentaer = plainSGR $ SetColor Foreground Vivid Magenta
+ cyaner = plainSGR $ SetColor Foreground Vivid Cyan
+ whiter = plainSGR $ SetColor Foreground Vivid White
+ onBlack = plainSGR $ SetColor Background Dull Black
+ onRed = plainSGR $ SetColor Background Dull Red
+ onGreen = plainSGR $ SetColor Background Dull Green
+ onYellow = plainSGR $ SetColor Background Dull Yellow
+ onBlue = plainSGR $ SetColor Background Dull Blue
+ onMagenta = plainSGR $ SetColor Background Dull Magenta
+ onCyan = plainSGR $ SetColor Background Dull Cyan
+ onWhite = plainSGR $ SetColor Background Dull White
+ onBlacker = plainSGR $ SetColor Background Vivid Black
+ onRedder = plainSGR $ SetColor Background Vivid Red
+ onGreener = plainSGR $ SetColor Background Vivid Green
+ onYellower = plainSGR $ SetColor Background Vivid Yellow
+ onBluer = plainSGR $ SetColor Background Vivid Blue
+ onMagentaer = plainSGR $ SetColor Background Vivid Magenta
+ onCyaner = plainSGR $ SetColor Background Vivid Cyan
+ onWhiter = plainSGR $ SetColor Background Vivid White
+instance (Semigroup d, From [SGR] d) => Decorable (Plain d) where
+ bold = plainSGR $ SetConsoleIntensity BoldIntensity
+ underline = plainSGR $ SetUnderlining SingleUnderline
+ italic = plainSGR $ SetItalicized True
+
+plainSGR ::
+ Semigroup d =>
+ From [SGR] d =>
+ SGR -> Plain d -> Plain d
+plainSGR newSGR p = before <> middle <> after
+ where
+ before = Plain $ \inh st k ->
+ let d = from [newSGR] in
+ if plainInh_justify inh
+ then k (id, st
+ { plainState_buffer =
+ PlainChunk_Ignored d :
+ plainState_buffer st
+ })
+ else k ((d <>), st)
+ middle = Plain $ \inh ->
+ unPlain p inh{plainInh_sgr=newSGR:plainInh_sgr inh}
+ after = Plain $ \inh st k ->
+ let d = from $ Reset : List.reverse (plainInh_sgr inh) in
+ if plainInh_justify inh
+ then k (id, st
+ { plainState_buffer =
+ PlainChunk_Ignored d :
+ plainState_buffer st
+ })
+ else k ((d <>), st)
import Symantic.Document.API
import Symantic.Document.Plain
-import Symantic.Document.AnsiText
-- * Tests
hunits :: TestTree
, 10 `maxWidth` spaces 2<>align(breakalt "fits" "over"<>newline<>"12345678901")
==> " fits\n\
\ 12345678901"
+ -- handle escaping correctly over custom indenting
+ , 10 `maxWidth` setIndent (blue "X") 1 (red ("12"<>green "4\n5" <> "6"))
+ ==> "\ESC[31m12\ESC[32m4\n\ESC[34mX\ESC[0;31;32m5\ESC[0;31m6\ESC[0m"
+ , 10 `maxWidth` setIndent (blue "X") 1 (justify (red ("1 2 3 4"<>green " 5 6 " <> "7 ") <> "8"))
+ ==> "\ESC[31m1 2 3 4\ESC[32m 5\n\ESC[34mX\ESC[0;31;32m6 \ESC[0;31m7 \ESC[0m8"
-- breakspace backtracking is bounded by the removable indentation
-- (hence it can actually wrap a few words in reasonable time).
, 80 `maxWidth`
\amet, venenatis ornare, ultrices ut, nisi."
]
where
- (==>) :: IsString d => d ~ String => AnsiText (Plain d) -> d -> Assertion; infix 0 ==>
+ (==>) :: IsString d => d ~ String => Plain d -> d -> Assertion; infix 0 ==>
p ==> exp = got @?= exp
- where got = runPlain $ runAnsiText p
+ where got = runPlain p
testList :: String -> [Assertion] -> TestTree
testList n as = testGroup n $ List.zipWith testCase (show <$> [1::Int ..]) as
sourcephile / git / haskell / symantic-plaintext.git / commitdiff