summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--erebos-tester.cabal3
-rw-r--r--src/TextFormat.hs79
-rw-r--r--src/TextFormat/Ansi.hs83
-rw-r--r--src/TextFormat/Types.hs58
4 files changed, 223 insertions, 0 deletions
diff --git a/erebos-tester.cabal b/erebos-tester.cabal
index fe110c1..a0dd00c 100644
--- a/erebos-tester.cabal
+++ b/erebos-tester.cabal
@@ -63,6 +63,9 @@ executable erebos-tester
Test
Test.Builtins
TestMode
+ TextFormat
+ TextFormat.Ansi
+ TextFormat.Types
Util
Version
Version.Git
diff --git a/src/TextFormat.hs b/src/TextFormat.hs
new file mode 100644
index 0000000..7b8152f
--- /dev/null
+++ b/src/TextFormat.hs
@@ -0,0 +1,79 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module TextFormat (
+ FormattedText,
+ plainText,
+
+ TextStyle,
+ withStyle, noStyle,
+
+ Color(..),
+ setForegroundColor, setBackgroundColor,
+
+ endWithNewline,
+
+ renderPlainText,
+ formattedTextLength,
+ formattedTextHeight,
+) where
+
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import TextFormat.Types
+
+
+plainText :: Text -> FormattedText
+plainText = PlainText
+
+
+withStyle :: TextStyle -> FormattedText -> FormattedText
+withStyle = FormattedText
+
+noStyle :: TextStyle
+noStyle = CustomTextColor Nothing Nothing
+
+setForegroundColor :: Color -> TextStyle -> TextStyle
+setForegroundColor color (CustomTextColor _ bg) = CustomTextColor (Just color) bg
+
+setBackgroundColor :: Color -> TextStyle -> TextStyle
+setBackgroundColor color (CustomTextColor fg _) = CustomTextColor fg (Just color)
+
+
+endWithNewline :: FormattedText -> FormattedText
+endWithNewline = EndWithNewline
+
+
+renderPlainText :: FormattedText -> Text
+renderPlainText = \case
+ PlainText text -> text
+ ConcatenatedText ftexts -> mconcat $ map renderPlainText ftexts
+ FormattedText _ ftext -> renderPlainText ftext
+ EndWithNewline ftext -> let res = renderPlainText ftext
+ in case T.unsnoc res of
+ Just ( _, '\n') -> res
+ _ -> res <> "\n"
+
+formattedTextLength :: FormattedText -> Int
+formattedTextLength = \case
+ PlainText text -> T.length text
+ ConcatenatedText ftexts -> sum $ map formattedTextLength ftexts
+ FormattedText _ ftext -> formattedTextLength ftext
+ EndWithNewline ftext -> formattedTextLength ftext
+
+formattedTextHeight :: FormattedText -> Int
+formattedTextHeight = countLines . collectParts
+ where
+ collectParts = \case
+ PlainText text -> [ text ]
+ ConcatenatedText ftexts -> concatMap collectParts ftexts
+ FormattedText _ ftext -> collectParts ftext
+ EndWithNewline ftext -> collectParts ftext
+ countLines (t : ts)
+ | T.null t = countLines ts
+ | otherwise = 1 + countLines (dropLine (t : ts))
+ countLines [] = 0
+ dropLine (t : ts)
+ | Just ( '\n', t' ) <- T.uncons (T.dropWhile (/= '\n') t) = t' : ts
+ | otherwise = dropLine ts
+ dropLine [] = []
diff --git a/src/TextFormat/Ansi.hs b/src/TextFormat/Ansi.hs
new file mode 100644
index 0000000..0e8d030
--- /dev/null
+++ b/src/TextFormat/Ansi.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module TextFormat.Ansi (
+ FormattedText,
+
+ AnsiText(..),
+ renderAnsiText,
+) where
+
+import Control.Applicative
+import Control.Monad.State
+import Control.Monad.Writer
+
+import Data.String
+import Data.Text (Text)
+import Data.Text qualified as T
+
+import TextFormat.Types
+
+
+newtype AnsiText = AnsiText { fromAnsiText :: Text }
+ deriving (Eq, Ord, Semigroup, Monoid, IsString)
+
+
+data RenderState = RenderState
+ { rsEndedWithNewline :: Bool
+ }
+
+initialRenderState :: RenderState
+initialRenderState = RenderState
+ { rsEndedWithNewline = True
+ }
+
+renderAnsiText :: FormattedText -> AnsiText
+renderAnsiText ft = AnsiText $ T.concat $ execWriter $ flip evalStateT initialRenderState $ go ( Nothing, Nothing ) ft
+ where
+ go :: ( Maybe Color, Maybe Color ) -> FormattedText -> StateT RenderState (Writer [ Text ]) ()
+ go cur@( cfg, cbg ) = \case
+ PlainText text -> do
+ tell [ text ]
+ case T.unsnoc text of
+ Just ( _, c ) -> modify (\s -> s { rsEndedWithNewline = c == '\n' })
+ Nothing -> return ()
+ ConcatenatedText ftexts -> mconcat <$> mapM (go cur) ftexts
+ FormattedText (CustomTextColor fg bg) ftext -> do
+ tell [ ansiColor fg bg ]
+ go ( fg <|> cfg, bg <|> cbg ) ftext
+ tell [ ansiColor
+ (if fg /= cfg then cfg <|> Just DefaultColor else Nothing)
+ (if bg /= cbg then cbg <|> Just DefaultColor else Nothing)
+ ]
+ EndWithNewline ftext -> do
+ go cur ftext
+ gets rsEndedWithNewline >>= \case
+ True -> return ()
+ False -> tell [ "\n" ] >> modify (\s -> s { rsEndedWithNewline = True })
+
+
+ansiColor :: Maybe Color -> Maybe Color -> Text
+ansiColor Nothing Nothing = ""
+ansiColor (Just fg) Nothing = "\ESC[" <> T.pack (show (colorNum fg)) <> "m"
+ansiColor Nothing (Just bg) = "\ESC[" <> T.pack (show (colorNum bg + 10)) <> "m"
+ansiColor (Just fg) (Just bg) = "\ESC[" <> T.pack (show (colorNum fg)) <> ";" <> T.pack (show (colorNum bg + 10)) <> "m"
+
+colorNum :: Color -> Int
+colorNum = \case
+ DefaultColor -> 39
+ Black -> 30
+ Red -> 31
+ Green -> 32
+ Yellow -> 33
+ Blue -> 34
+ Magenta -> 35
+ Cyan -> 36
+ White -> 37
+ BrightBlack -> 90
+ BrightRed -> 91
+ BrightGreen -> 92
+ BrightYellow -> 93
+ BrightBlue -> 94
+ BrightMagenta -> 95
+ BrightCyan -> 96
+ BrightWhite -> 97
diff --git a/src/TextFormat/Types.hs b/src/TextFormat/Types.hs
new file mode 100644
index 0000000..40deabd
--- /dev/null
+++ b/src/TextFormat/Types.hs
@@ -0,0 +1,58 @@
+module TextFormat.Types (
+ FormattedText(..),
+ TextStyle(..),
+ Color(..),
+) where
+
+import Data.String
+import Data.Text (Text)
+
+
+data FormattedText
+ = PlainText Text
+ | ConcatenatedText [ FormattedText ]
+ | FormattedText TextStyle FormattedText
+ | EndWithNewline FormattedText
+
+instance IsString FormattedText where
+ fromString = PlainText . fromString
+
+instance Semigroup FormattedText where
+ ConcatenatedText xs <> ConcatenatedText ys = ConcatenatedText (xs ++ ys)
+ x <> ConcatenatedText ys = ConcatenatedText (x : ys)
+ ConcatenatedText xs <> y = ConcatenatedText (xs ++ [ y ])
+ x <> y = ConcatenatedText [ x, y ]
+
+instance Monoid FormattedText where
+ mempty = ConcatenatedText []
+ mconcat [] = ConcatenatedText []
+ mconcat [ x ] = x
+ mconcat xs = ConcatenatedText $ concatMap flatten xs
+ where
+ flatten (ConcatenatedText ys) = ys
+ flatten y = [ y ]
+
+
+data TextStyle
+ = CustomTextColor (Maybe Color) (Maybe Color)
+
+
+data Color
+ = DefaultColor
+ | Black
+ | Red
+ | Green
+ | Yellow
+ | Blue
+ | Magenta
+ | Cyan
+ | White
+ | BrightBlack
+ | BrightRed
+ | BrightGreen
+ | BrightYellow
+ | BrightBlue
+ | BrightMagenta
+ | BrightCyan
+ | BrightWhite
+ deriving (Eq)
generated by cgit v1.2.3 (git 2.25.1) at 2026-09-02 06:14:02 +0000