{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
module Test.Framework.Colors (
Color(..), PrimColor(..), ColorString(..), PrimColorString(..)
, firstDiffColor, secondDiffColor, skipDiffColor, diffColor
, warningColor, testStartColor, testOkColor, pendingColor
, emptyColorString, (+++), unlinesColorString, colorStringFind, ensureNewlineColorString
, colorize, colorizeText, colorize', colorizeText'
, noColor, noColorText, noColor', noColorText'
, renderColorString, maxLength
) where
import qualified Data.Text as T
import Data.String
import Data.Maybe
import Control.Monad
firstDiffColor :: Color
firstDiffColor = PrimColor -> Bool -> Color
Color PrimColor
Magenta Bool
False
secondDiffColor :: Color
secondDiffColor = PrimColor -> Bool -> Color
Color PrimColor
Blue Bool
False
skipDiffColor :: Color
skipDiffColor = PrimColor -> Bool -> Color
Color PrimColor
DarkGray Bool
False
diffColor :: Color
diffColor = PrimColor -> Bool -> Color
Color PrimColor
Brown Bool
False
warningColor :: Color
warningColor = PrimColor -> Bool -> Color
Color PrimColor
Red Bool
True
testStartColor :: Color
testStartColor = PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
True
testOkColor :: Color
testOkColor = PrimColor -> Bool -> Color
Color PrimColor
Green Bool
False
pendingColor :: Color
pendingColor = PrimColor -> Bool -> Color
Color PrimColor
Cyan Bool
True
data Color = Color PrimColor Bool
deriving (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, ReadPrec [Color]
ReadPrec Color
Int -> ReadS Color
ReadS [Color]
(Int -> ReadS Color)
-> ReadS [Color]
-> ReadPrec Color
-> ReadPrec [Color]
-> Read Color
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Color
readsPrec :: Int -> ReadS Color
$creadList :: ReadS [Color]
readList :: ReadS [Color]
$creadPrec :: ReadPrec Color
readPrec :: ReadPrec Color
$creadListPrec :: ReadPrec [Color]
readListPrec :: ReadPrec [Color]
Read)
data PrimColor = Black | Blue | Green | Cyan | Red | Magenta
| Brown | Gray | DarkGray | LightBlue
| LightGreen | LightCyan | LightRed | LightMagenta
| Yellow | White | NoColor
deriving (PrimColor -> PrimColor -> Bool
(PrimColor -> PrimColor -> Bool)
-> (PrimColor -> PrimColor -> Bool) -> Eq PrimColor
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrimColor -> PrimColor -> Bool
== :: PrimColor -> PrimColor -> Bool
$c/= :: PrimColor -> PrimColor -> Bool
/= :: PrimColor -> PrimColor -> Bool
Eq, Int -> PrimColor -> ShowS
[PrimColor] -> ShowS
PrimColor -> String
(Int -> PrimColor -> ShowS)
-> (PrimColor -> String)
-> ([PrimColor] -> ShowS)
-> Show PrimColor
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrimColor -> ShowS
showsPrec :: Int -> PrimColor -> ShowS
$cshow :: PrimColor -> String
show :: PrimColor -> String
$cshowList :: [PrimColor] -> ShowS
showList :: [PrimColor] -> ShowS
Show, ReadPrec [PrimColor]
ReadPrec PrimColor
Int -> ReadS PrimColor
ReadS [PrimColor]
(Int -> ReadS PrimColor)
-> ReadS [PrimColor]
-> ReadPrec PrimColor
-> ReadPrec [PrimColor]
-> Read PrimColor
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PrimColor
readsPrec :: Int -> ReadS PrimColor
$creadList :: ReadS [PrimColor]
readList :: ReadS [PrimColor]
$creadPrec :: ReadPrec PrimColor
readPrec :: ReadPrec PrimColor
$creadListPrec :: ReadPrec [PrimColor]
readListPrec :: ReadPrec [PrimColor]
Read)
startColor :: Color -> T.Text
startColor :: Color -> Text
startColor (Color PrimColor
c Bool
isBold) =
(case PrimColor
c of
PrimColor
Black -> Text
"\ESC[0;30m"
PrimColor
Blue -> Text
"\ESC[0;34m"
PrimColor
Green -> Text
"\ESC[0;32m"
PrimColor
Cyan -> Text
"\ESC[0;36m"
PrimColor
Red -> Text
"\ESC[0;31m"
PrimColor
Magenta -> Text
"\ESC[0;35m"
PrimColor
Brown -> Text
"\ESC[0;33m"
PrimColor
Gray -> Text
"\ESC[0;37m"
PrimColor
DarkGray -> Text
"\ESC[1;30m"
PrimColor
LightBlue -> Text
"\ESC[1;34m"
PrimColor
LightGreen -> Text
"\ESC[1;32m"
PrimColor
LightCyan -> Text
"\ESC[1;36m"
PrimColor
LightRed -> Text
"\ESC[1;31m"
PrimColor
LightMagenta -> Text
"\ESC[1;35m"
PrimColor
Yellow -> Text
"\ESC[1;33m"
PrimColor
White -> Text
"\ESC[1;37m"
PrimColor
NoColor -> Text
"") Text -> Text -> Text
`T.append`
(if Bool
isBold then Text
"\ESC[1m" else Text
"")
reset :: T.Text
reset :: Text
reset = Text
"\ESC[0;0m"
data PrimColorString = PrimColorString Color T.Text (Maybe T.Text)
deriving (PrimColorString -> PrimColorString -> Bool
(PrimColorString -> PrimColorString -> Bool)
-> (PrimColorString -> PrimColorString -> Bool)
-> Eq PrimColorString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PrimColorString -> PrimColorString -> Bool
== :: PrimColorString -> PrimColorString -> Bool
$c/= :: PrimColorString -> PrimColorString -> Bool
/= :: PrimColorString -> PrimColorString -> Bool
Eq, Int -> PrimColorString -> ShowS
[PrimColorString] -> ShowS
PrimColorString -> String
(Int -> PrimColorString -> ShowS)
-> (PrimColorString -> String)
-> ([PrimColorString] -> ShowS)
-> Show PrimColorString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PrimColorString -> ShowS
showsPrec :: Int -> PrimColorString -> ShowS
$cshow :: PrimColorString -> String
show :: PrimColorString -> String
$cshowList :: [PrimColorString] -> ShowS
showList :: [PrimColorString] -> ShowS
Show, ReadPrec [PrimColorString]
ReadPrec PrimColorString
Int -> ReadS PrimColorString
ReadS [PrimColorString]
(Int -> ReadS PrimColorString)
-> ReadS [PrimColorString]
-> ReadPrec PrimColorString
-> ReadPrec [PrimColorString]
-> Read PrimColorString
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PrimColorString
readsPrec :: Int -> ReadS PrimColorString
$creadList :: ReadS [PrimColorString]
readList :: ReadS [PrimColorString]
$creadPrec :: ReadPrec PrimColorString
readPrec :: ReadPrec PrimColorString
$creadListPrec :: ReadPrec [PrimColorString]
readListPrec :: ReadPrec [PrimColorString]
Read)
newtype ColorString = ColorString { ColorString -> [PrimColorString]
unColorString :: [PrimColorString] }
deriving (ColorString -> ColorString -> Bool
(ColorString -> ColorString -> Bool)
-> (ColorString -> ColorString -> Bool) -> Eq ColorString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ColorString -> ColorString -> Bool
== :: ColorString -> ColorString -> Bool
$c/= :: ColorString -> ColorString -> Bool
/= :: ColorString -> ColorString -> Bool
Eq, Int -> ColorString -> ShowS
[ColorString] -> ShowS
ColorString -> String
(Int -> ColorString -> ShowS)
-> (ColorString -> String)
-> ([ColorString] -> ShowS)
-> Show ColorString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ColorString -> ShowS
showsPrec :: Int -> ColorString -> ShowS
$cshow :: ColorString -> String
show :: ColorString -> String
$cshowList :: [ColorString] -> ShowS
showList :: [ColorString] -> ShowS
Show, ReadPrec [ColorString]
ReadPrec ColorString
Int -> ReadS ColorString
ReadS [ColorString]
(Int -> ReadS ColorString)
-> ReadS [ColorString]
-> ReadPrec ColorString
-> ReadPrec [ColorString]
-> Read ColorString
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ColorString
readsPrec :: Int -> ReadS ColorString
$creadList :: ReadS [ColorString]
readList :: ReadS [ColorString]
$creadPrec :: ReadPrec ColorString
readPrec :: ReadPrec ColorString
$creadListPrec :: ReadPrec [ColorString]
readListPrec :: ReadPrec [ColorString]
Read)
instance IsString ColorString where
fromString :: String -> ColorString
fromString = String -> ColorString
noColor
emptyColorString :: ColorString
emptyColorString :: ColorString
emptyColorString = String -> ColorString
noColor String
""
maxLength :: ColorString -> Int
maxLength :: ColorString -> Int
maxLength (ColorString [PrimColorString]
prims) =
let ml :: PrimColorString -> Int
ml (PrimColorString Color
_ Text
t Maybe Text
mt) =
Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Text -> Int
T.length Text
t) (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 ((Text -> Int) -> Maybe Text -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
T.length Maybe Text
mt))
in [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
$ (PrimColorString -> Int) -> [PrimColorString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map PrimColorString -> Int
ml [PrimColorString]
prims
unlinesColorString :: [ColorString] -> ColorString
unlinesColorString :: [ColorString] -> ColorString
unlinesColorString [ColorString]
l =
[ColorString] -> ColorString
concatColorString ([ColorString] -> ColorString) -> [ColorString] -> ColorString
forall a b. (a -> b) -> a -> b
$
(ColorString -> ColorString) -> [ColorString] -> [ColorString]
forall a b. (a -> b) -> [a] -> [b]
map (\ColorString
x -> ColorString -> PrimColorString -> ColorString
appendPrimColorString ColorString
x (Color -> Text -> Maybe Text -> PrimColorString
PrimColorString (PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
False) (String -> Text
T.pack String
"\n") Maybe Text
forall a. Maybe a
Nothing)) [ColorString]
l
where
appendPrimColorString :: ColorString -> PrimColorString -> ColorString
appendPrimColorString (ColorString [PrimColorString]
l) PrimColorString
x =
[PrimColorString] -> ColorString
ColorString ([PrimColorString]
l [PrimColorString] -> [PrimColorString] -> [PrimColorString]
forall a. [a] -> [a] -> [a]
++ [PrimColorString
x])
concatColorString :: [ColorString] -> ColorString
concatColorString :: [ColorString] -> ColorString
concatColorString [ColorString]
l =
[PrimColorString] -> ColorString
ColorString ([PrimColorString] -> ColorString)
-> [PrimColorString] -> ColorString
forall a b. (a -> b) -> a -> b
$ (ColorString -> [PrimColorString])
-> [ColorString] -> [PrimColorString]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(ColorString [PrimColorString]
l) -> [PrimColorString]
l) [ColorString]
l
colorStringFind :: (Char -> Bool) -> ColorString -> Bool -> Maybe Char
colorStringFind :: (Char -> Bool) -> ColorString -> Bool -> Maybe Char
colorStringFind Char -> Bool
pred (ColorString [PrimColorString]
l) Bool
c =
let f :: PrimColorString -> Maybe Char
f = if Bool
c then PrimColorString -> Maybe Char
pcolorStringFindColor else PrimColorString -> Maybe Char
pcolorStringFindNoColor
in [Maybe Char] -> Maybe Char
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ((PrimColorString -> Maybe Char)
-> [PrimColorString] -> [Maybe Char]
forall a b. (a -> b) -> [a] -> [b]
map PrimColorString -> Maybe Char
f [PrimColorString]
l)
where
pcolorStringFindColor :: PrimColorString -> Maybe Char
pcolorStringFindColor (PrimColorString Color
_ Text
t Maybe Text
_) = Text -> Maybe Char
tfind Text
t
pcolorStringFindNoColor :: PrimColorString -> Maybe Char
pcolorStringFindNoColor (PrimColorString Color
_ Text
t Maybe Text
Nothing) = Text -> Maybe Char
tfind Text
t
pcolorStringFindNoColor (PrimColorString Color
_ Text
_ (Just Text
t)) = Text -> Maybe Char
tfind Text
t
tfind :: Text -> Maybe Char
tfind Text
t = (Char -> Bool) -> Text -> Maybe Char
T.find Char -> Bool
pred Text
t
ensureNewlineColorString :: ColorString -> ColorString
ensureNewlineColorString :: ColorString -> ColorString
ensureNewlineColorString cs :: ColorString
cs@(ColorString [PrimColorString]
l) =
let ([Text]
colors, [Text]
noColors) = [(Text, Text)] -> ([Text], [Text])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Text, Text)] -> ([Text], [Text]))
-> [(Text, Text)] -> ([Text], [Text])
forall a b. (a -> b) -> a -> b
$ (PrimColorString -> (Text, Text))
-> [PrimColorString] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map PrimColorString -> (Text, Text)
colorsAndNoColors ([PrimColorString] -> [PrimColorString]
forall a. [a] -> [a]
reverse [PrimColorString]
l)
nlColor :: Bool
nlColor = [Text] -> Bool
needsNl [Text]
colors
nlNoColor :: Bool
nlNoColor = [Text] -> Bool
needsNl [Text]
noColors
in if Bool -> Bool
not Bool
nlColor Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
nlNoColor
then ColorString
cs
else [PrimColorString] -> ColorString
ColorString ([PrimColorString]
l [PrimColorString] -> [PrimColorString] -> [PrimColorString]
forall a. [a] -> [a] -> [a]
++
[Color -> Text -> Maybe Text -> PrimColorString
PrimColorString (PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
False) (Bool -> Text
forall {a}. IsString a => Bool -> a
mkNl Bool
nlColor)
(Text -> Maybe Text
forall a. a -> Maybe a
Just (Bool -> Text
forall {a}. IsString a => Bool -> a
mkNl Bool
nlNoColor))])
where
mkNl :: Bool -> a
mkNl Bool
True = a
"\n"
mkNl Bool
False = a
""
colorsAndNoColors :: PrimColorString -> (Text, Text)
colorsAndNoColors (PrimColorString Color
_ Text
t1 (Just Text
t2)) = (Text
t1, Text
t2)
colorsAndNoColors (PrimColorString Color
_ Text
t1 Maybe Text
Nothing) = (Text
t1, Text
t1)
needsNl :: [Text] -> Bool
needsNl [] = Bool
False
needsNl (Text
t:[Text]
ts) =
let t' :: Text
t' = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') Text
t
in if Text -> Bool
T.null Text
t'
then [Text] -> Bool
needsNl [Text]
ts
else HasCallStack => Text -> Char
Text -> Char
T.last Text
t' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n'
colorize :: Color -> String -> ColorString
colorize :: Color -> String -> ColorString
colorize Color
c String
s = Color -> Text -> ColorString
colorizeText Color
c (String -> Text
T.pack String
s)
colorizeText :: Color -> T.Text -> ColorString
colorizeText :: Color -> Text -> ColorString
colorizeText !Color
c !Text
t = [PrimColorString] -> ColorString
ColorString [Color -> Text -> Maybe Text -> PrimColorString
PrimColorString Color
c Text
t Maybe Text
forall a. Maybe a
Nothing]
colorize' :: Color -> String -> String -> ColorString
colorize' :: Color -> String -> String -> ColorString
colorize' Color
c String
s String
x = Color -> Text -> Text -> ColorString
colorizeText' Color
c (String -> Text
T.pack String
s) (String -> Text
T.pack String
x)
colorizeText' :: Color -> T.Text -> T.Text -> ColorString
colorizeText' :: Color -> Text -> Text -> ColorString
colorizeText' !Color
c !Text
t !Text
x = [PrimColorString] -> ColorString
ColorString [Color -> Text -> Maybe Text -> PrimColorString
PrimColorString Color
c Text
t (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x)]
noColor :: String -> ColorString
noColor :: String -> ColorString
noColor = Color -> String -> ColorString
colorize (PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
False)
noColorText :: T.Text -> ColorString
noColorText :: Text -> ColorString
noColorText = Color -> Text -> ColorString
colorizeText (PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
False)
noColor' :: String -> String -> ColorString
noColor' :: String -> String -> ColorString
noColor' String
s1 String
s2 = Color -> String -> String -> ColorString
colorize' (PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
False) String
s1 String
s2
noColorText' :: T.Text -> T.Text -> ColorString
noColorText' :: Text -> Text -> ColorString
noColorText' Text
t1 Text
t2 = Color -> Text -> Text -> ColorString
colorizeText' (PrimColor -> Bool -> Color
Color PrimColor
NoColor Bool
False) Text
t1 Text
t2
infixr 5 +++
(+++) :: ColorString -> ColorString -> ColorString
ColorString
cs1 +++ :: ColorString -> ColorString -> ColorString
+++ ColorString
cs2 =
case (ColorString
cs1, ColorString
cs2) of
(ColorString [PrimColorString Color
c1 Text
t1 Maybe Text
m1], ColorString (PrimColorString Color
c2 Text
t2 Maybe Text
m2 : [PrimColorString]
rest))
| Color
c1 Color -> Color -> Bool
forall a. Eq a => a -> a -> Bool
== Color
c2 ->
let m3 :: Maybe Text
m3 = case (Maybe Text
m1, Maybe Text
m2) of
(Maybe Text
Nothing, Maybe Text
Nothing) -> Maybe Text
forall a. Maybe a
Nothing
(Just Text
x1, Just Text
x2) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
x1 Text -> Text -> Text
`T.append` Text
x2)
(Just Text
x1, Maybe Text
Nothing) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
x1 Text -> Text -> Text
`T.append` Text
t2)
(Maybe Text
Nothing, Just Text
x2) -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
t1 Text -> Text -> Text
`T.append` Text
x2)
in [PrimColorString] -> ColorString
ColorString (Color -> Text -> Maybe Text -> PrimColorString
PrimColorString Color
c1 (Text
t1 Text -> Text -> Text
`T.append` Text
t2) Maybe Text
m3 PrimColorString -> [PrimColorString] -> [PrimColorString]
forall a. a -> [a] -> [a]
: [PrimColorString]
rest)
(ColorString [PrimColorString]
ps1, ColorString [PrimColorString]
ps2) -> [PrimColorString] -> ColorString
ColorString ([PrimColorString]
ps1 [PrimColorString] -> [PrimColorString] -> [PrimColorString]
forall a. [a] -> [a] -> [a]
++ [PrimColorString]
ps2)
renderColorString :: ColorString -> Bool -> T.Text
renderColorString :: ColorString -> Bool -> Text
renderColorString (ColorString [PrimColorString]
l) Bool
useColor =
[Text] -> Text
T.concat ((PrimColorString -> Text) -> [PrimColorString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map PrimColorString -> Text
render [PrimColorString]
l)
where
render :: PrimColorString -> Text
render = if Bool
useColor then PrimColorString -> Text
renderColors else PrimColorString -> Text
renderNoColors
renderNoColors :: PrimColorString -> Text
renderNoColors (PrimColorString Color
_ Text
_ (Just Text
t)) = Text
t
renderNoColors (PrimColorString Color
_ Text
t Maybe Text
Nothing) = Text
t
renderColors :: PrimColorString -> Text
renderColors (PrimColorString Color
c Text
t Maybe Text
_) =
[Text] -> Text
T.concat [Color -> Text
startColor Color
c, Text
t, Text
reset]