{-# LANGUAGE OverloadedStrings #-}
module Data.Text.Escaped
( Escaped
( Plain
, Reset
, Bold
, Dim
, Underlined
, Blink
, Reverse
, Hidden
, FG
, BG
)
, Color(..)
, black
, blue
, cyan
, darkGray
, green
, lightBlue
, lightCyan
, lightGray
, lightGreen
, lightMagenta
, lightRed
, lightYellow
, magenta
, red
, white
, yellow
, fg
, bg
, esc
, render
, plain
, visibleLength
, terminalRenderer
) where
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import System.Posix.IO (stdOutput)
import System.Posix.Terminal (queryTerminal)
import Test.QuickCheck
import Test.QuickCheck.Instances.Text ()
data Color
= Default
| Custom Int
| Black
| Blue
| Cyan
| DarkGray
| Green
| LightBlue
| LightCyan
| LightGray
| LightGreen
| LightMagenta
| LightRed
| LightYellow
| Magenta
| Red
| White
| Yellow
deriving (Eq, Show)
instance Arbitrary Color where
arbitrary = oneof
[ pure Default
, Custom <$> arbitrary
, pure Black
, pure Blue
, pure Cyan
, pure DarkGray
, pure Green
, pure LightBlue
, pure LightCyan
, pure LightGray
, pure LightGreen
, pure LightMagenta
, pure LightRed
, pure LightYellow
, pure Magenta
, pure Red
, pure White
, pure Yellow
]
data Escaped
= Plain Text
| Reset
| Bold
| Dim
| Underlined
| Blink
| Reverse
| Hidden
| FG Color
| BG Color
| Many [Escaped]
deriving (Eq, Show)
instance Arbitrary Escaped where
arbitrary = oneof $ chunks <> [Many <$> listOf1 (oneof chunks)]
where
chunks =
[ Plain <$> arbitrary
, pure Reset
, pure Bold
, pure Dim
, pure Underlined
, pure Blink
, pure Reverse
, pure Hidden
, FG <$> arbitrary
, BG <$> arbitrary
]
instance IsString Escaped where
fromString = Plain . T.pack
instance Semigroup Escaped where
x <> (Plain t) | T.null t = x
(Plain t) <> y | T.null t = y
(Many a) <> (Many b) = Many $ a <> b
(Many a) <> b = Many $ a <> [b]
a <> (Many b) = Many $ a:b
a <> b = Many [a, b]
instance Monoid Escaped where
mempty = Plain ""
mappend = (<>)
render :: Escaped -> Text
render (Plain t) = t
render (Many es) = T.concat $ map render es
render Reset = "\ESC[0m"
render Bold = "\ESC[1m"
render Dim = "\ESC[2m"
render Underlined = "\ESC[3m"
render Blink = "\ESC[5m"
render Reverse = "\ESC[7m"
render Hidden = "\ESC[8m"
render (FG c) = "\ESC[" <> fgColorCode c <> "m"
render (BG c) = "\ESC[" <> bgColorCode c <> "m"
plain :: Escaped -> Text
plain (Plain t) = t
plain (Many es) = T.concat $ map plain es
plain _ = ""
black :: Escaped -> Escaped
black = fg Black
blue :: Escaped -> Escaped
blue = fg Blue
cyan :: Escaped -> Escaped
cyan = fg Cyan
darkGray :: Escaped -> Escaped
darkGray = fg DarkGray
green :: Escaped -> Escaped
green = fg Green
lightBlue :: Escaped -> Escaped
lightBlue = fg LightBlue
lightCyan :: Escaped -> Escaped
lightCyan = fg LightCyan
lightGray :: Escaped -> Escaped
lightGray = fg LightGray
lightGreen :: Escaped -> Escaped
lightGreen = fg LightGreen
lightMagenta :: Escaped -> Escaped
lightMagenta = fg LightMagenta
lightRed :: Escaped -> Escaped
lightRed = fg LightRed
lightYellow :: Escaped -> Escaped
lightYellow = fg LightYellow
magenta :: Escaped -> Escaped
magenta = fg Magenta
red :: Escaped -> Escaped
red = fg Red
white :: Escaped -> Escaped
white = fg White
yellow :: Escaped -> Escaped
yellow = fg Yellow
fg :: Color -> Escaped -> Escaped
fg = esc . FG
bg :: Color -> Escaped -> Escaped
bg = esc . BG
esc :: Escaped -> Escaped -> Escaped
esc a b = a <> b <> Reset
visibleLength :: Escaped -> Int
visibleLength (Plain t) = T.length t
visibleLength (Many es) = sum $ map visibleLength es
visibleLength _ = 0
terminalRenderer :: IO (Escaped -> Text)
terminalRenderer = do
istty <- queryTerminal stdOutput
return $ if istty then render else plain
fgColorCode :: Color -> Text
fgColorCode Default = "39"
fgColorCode (Custom n) = "38;5;" <> T.pack (show n)
fgColorCode Black = "30"
fgColorCode Blue = "34"
fgColorCode Cyan = "36"
fgColorCode DarkGray = "90"
fgColorCode Green = "32"
fgColorCode LightBlue = "94"
fgColorCode LightCyan = "96"
fgColorCode LightGray = "37"
fgColorCode LightGreen = "92"
fgColorCode LightMagenta = "95"
fgColorCode LightRed = "91"
fgColorCode LightYellow = "93"
fgColorCode Magenta = "35"
fgColorCode Red = "31"
fgColorCode White = "97"
fgColorCode Yellow = "33"
bgColorCode :: Color -> Text
bgColorCode Default = "49"
bgColorCode (Custom n) = "48;5;" <> T.pack (show n)
bgColorCode Black = "40"
bgColorCode Blue = "44"
bgColorCode Cyan = "46"
bgColorCode DarkGray = "100"
bgColorCode Green = "42"
bgColorCode LightBlue = "104"
bgColorCode LightCyan = "106"
bgColorCode LightGray = "100"
bgColorCode LightGreen = "102"
bgColorCode LightMagenta = "105"
bgColorCode LightRed = "101"
bgColorCode LightYellow = "103"
bgColorCode Magenta = "45"
bgColorCode Red = "41"
bgColorCode White = "107"
bgColorCode Yellow = "103"