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 ()

-- | Supported colors
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
  -- Too bad @Custom@ makes arbitraryBoundedEnum not useful
  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
      ]

-- | Bits of escaped text
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
  -- Avoid invalid Many-of-Many nesting, which triggers an infinite loop. Such
  -- a value is impossible to construct because we don't export the Many
  -- constructor.
  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
  -- A bit explicit, but ensures identity works
  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 an @'Escaped'@ to actually-escaped @'Text'@
--
-- Examples:
--
-- >>> render "Some text via OverloadedStrings."
-- "Some text via OverloadedStrings."
--
-- >>> render $ Plain "Some text."
-- "Some text."
--
-- >>> render $ "Some " <> FG Red <> "red" <> Reset <> " text."
-- "Some \ESC[31mred\ESC[0m text."
--
-- >>> render $ "Some " <> blue "blue" <> " text."
-- "Some \ESC[34mblue\ESC[0m text."
--
-- >>> render $ "Some " <> fg (Custom 212) "color 212" <> " text."
-- "Some \ESC[38;5;212mcolor 212\ESC[0m text."
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"

-- | Render only the @'Text'@ parts
--
-- Examples
--
-- >>> plain $ Plain "Some text."
-- "Some text."
--
-- >>> plain $ "Some " <> FG Red <> "red" <> Reset <> " text."
-- "Some red text."
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

-- | Escape with foreground @'Color'@, then @'Reset'@
--
-- >>> fg Red "red"
-- Many [FG Red,Plain "red",Reset]
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

-- | Escape with background @'Color'@, then @'Reset'@
--
-- >>> bg Red "red"
-- Many [BG Red,Plain "red",Reset]
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

-- | Apply the given escape, then @'Reset'@
--
-- >>> esc (FG Red) "red"
-- Many [FG Red,Plain "red",Reset]
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

-- | Calculate the /visible/ length of an @'Escaped'@
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

-- | An @'IO'@ action to produce the appropriate renderer for a terminal
--
-- Returns @'render'@ if @stdout@ is a terminal, otherwise @'plain'@
--
-- >>> r <- terminalRenderer
-- >>> print $ r $ red "red text"
-- "red text"
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"