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