{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
module System.Console.Pretty
( Color(..) , Pretty(..) , Section(..) , Style(..)
, supportsPretty)
where
import qualified Data.Char as C
import Data.Monoid ((<>))
import qualified Data.Text as T
import GHC.IO.Handle (Handle)
import System.Environment (lookupEnv)
import System.IO (hIsTerminalDevice, stdout)
data Section = Foreground | Background
data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default
deriving (Int -> Color
Color -> Int
Color -> [Color]
Color -> Color
Color -> Color -> [Color]
Color -> Color -> Color -> [Color]
(Color -> Color)
-> (Color -> Color)
-> (Int -> Color)
-> (Color -> Int)
-> (Color -> [Color])
-> (Color -> Color -> [Color])
-> (Color -> Color -> [Color])
-> (Color -> Color -> Color -> [Color])
-> Enum Color
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Color -> Color
succ :: Color -> Color
$cpred :: Color -> Color
pred :: Color -> Color
$ctoEnum :: Int -> Color
toEnum :: Int -> Color
$cfromEnum :: Color -> Int
fromEnum :: Color -> Int
$cenumFrom :: Color -> [Color]
enumFrom :: Color -> [Color]
$cenumFromThen :: Color -> Color -> [Color]
enumFromThen :: Color -> Color -> [Color]
$cenumFromTo :: Color -> Color -> [Color]
enumFromTo :: Color -> Color -> [Color]
$cenumFromThenTo :: Color -> Color -> Color -> [Color]
enumFromThenTo :: Color -> Color -> Color -> [Color]
Enum)
data Style
= Normal | Bold | Faint | Italic
| Underline | SlowBlink | ColoredNormal | Reverse
deriving (Int -> Style
Style -> Int
Style -> [Style]
Style -> Style
Style -> Style -> [Style]
Style -> Style -> Style -> [Style]
(Style -> Style)
-> (Style -> Style)
-> (Int -> Style)
-> (Style -> Int)
-> (Style -> [Style])
-> (Style -> Style -> [Style])
-> (Style -> Style -> [Style])
-> (Style -> Style -> Style -> [Style])
-> Enum Style
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Style -> Style
succ :: Style -> Style
$cpred :: Style -> Style
pred :: Style -> Style
$ctoEnum :: Int -> Style
toEnum :: Int -> Style
$cfromEnum :: Style -> Int
fromEnum :: Style -> Int
$cenumFrom :: Style -> [Style]
enumFrom :: Style -> [Style]
$cenumFromThen :: Style -> Style -> [Style]
enumFromThen :: Style -> Style -> [Style]
$cenumFromTo :: Style -> Style -> [Style]
enumFromTo :: Style -> Style -> [Style]
$cenumFromThenTo :: Style -> Style -> Style -> [Style]
enumFromThenTo :: Style -> Style -> Style -> [Style]
Enum)
class Pretty a where
color :: Color -> a -> a
color = Section -> Color -> a -> a
forall a. Pretty a => Section -> Color -> a -> a
colorize Section
Foreground
bgColor :: Color -> a -> a
bgColor = Section -> Color -> a -> a
forall a. Pretty a => Section -> Color -> a -> a
colorize Section
Background
colorize :: Section -> Color -> a -> a
style :: Style -> a -> a
instance Pretty T.Text where
colorize :: Section -> Color -> Text -> Text
colorize Section
section Color
col Text
str =
Text
"\x1b[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
sectionNum Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
(Char -> Text
T.singleton (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char
C.intToDigit (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Color -> Int
forall a. Enum a => a -> Int
fromEnum Color
col)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"\x1b[0m"
where
sectionNum :: T.Text
sectionNum :: Text
sectionNum = case Section
section of
Section
Foreground -> Text
"9"
Section
Background -> Text
"4"
style :: Style -> Text -> Text
style Style
sty Text
str =
Text
"\x1b[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
(Char -> Text
T.singleton (Char -> Text) -> Char -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Char
C.intToDigit (Int -> Char) -> Int -> Char
forall a b. (a -> b) -> a -> b
$ Style -> Int
forall a. Enum a => a -> Int
fromEnum Style
sty)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"m" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"\x1b[0m"
instance Pretty String where
colorize :: Section -> Color -> [Char] -> [Char]
colorize Section
section Color
col [Char]
str =
[Char]
"\x1b[" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char]
sectionNum [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
Int -> [Char]
forall a. Show a => a -> [Char]
show (Color -> Int
forall a. Enum a => a -> Int
fromEnum Color
col)
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"m" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char]
str [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char]
"\x1b[0m"
where
sectionNum :: String
sectionNum :: [Char]
sectionNum = case Section
section of
Section
Foreground -> [Char]
"9"
Section
Background -> [Char]
"4"
style :: Style -> [Char] -> [Char]
style Style
sty [Char]
str =
[Char]
"\x1b[" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
Int -> [Char]
forall a. Show a => a -> [Char]
show (Style -> Int
forall a. Enum a => a -> Int
fromEnum Style
sty)
[Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"m" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char]
str [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
[Char]
"\x1b[0m"
supportsPretty :: IO Bool
supportsPretty :: IO Bool
supportsPretty =
Handle -> IO Bool
hSupportsANSI Handle
stdout
where
hSupportsANSI :: Handle -> IO Bool
hSupportsANSI :: Handle -> IO Bool
hSupportsANSI Handle
h = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> IO Bool -> IO (Bool -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO Bool
hIsTerminalDevice Handle
h IO (Bool -> Bool) -> IO Bool -> IO Bool
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool
isDumb)
where
isDumb :: IO Bool
isDumb = (Maybe [Char] -> Maybe [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"dumb") (Maybe [Char] -> Bool) -> IO (Maybe [Char]) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"TERM"