{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE BangPatterns #-}
--
-- Copyright (c) 2011, 2012   Stefan Wehr - http://www.stefanwehr.de
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
--

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
/= :: Color -> Color -> Bool
$c/= :: Color -> Color -> Bool
== :: Color -> Color -> Bool
$c== :: 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
showList :: [Color] -> ShowS
$cshowList :: [Color] -> ShowS
show :: Color -> String
$cshow :: Color -> String
showsPrec :: Int -> Color -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [Color]
$creadListPrec :: ReadPrec [Color]
readPrec :: ReadPrec Color
$creadPrec :: ReadPrec Color
readList :: ReadS [Color]
$creadList :: ReadS [Color]
readsPrec :: Int -> ReadS Color
$creadsPrec :: Int -> ReadS 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
/= :: PrimColor -> PrimColor -> Bool
$c/= :: PrimColor -> PrimColor -> Bool
== :: PrimColor -> PrimColor -> Bool
$c== :: 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
showList :: [PrimColor] -> ShowS
$cshowList :: [PrimColor] -> ShowS
show :: PrimColor -> String
$cshow :: PrimColor -> String
showsPrec :: Int -> PrimColor -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [PrimColor]
$creadListPrec :: ReadPrec [PrimColor]
readPrec :: ReadPrec PrimColor
$creadPrec :: ReadPrec PrimColor
readList :: ReadS [PrimColor]
$creadList :: ReadS [PrimColor]
readsPrec :: Int -> ReadS PrimColor
$creadsPrec :: Int -> ReadS 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) {- no-color fallback -}
                    deriving (PrimColorString -> PrimColorString -> Bool
(PrimColorString -> PrimColorString -> Bool)
-> (PrimColorString -> PrimColorString -> Bool)
-> Eq PrimColorString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PrimColorString -> PrimColorString -> Bool
$c/= :: PrimColorString -> PrimColorString -> Bool
== :: PrimColorString -> PrimColorString -> Bool
$c== :: 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
showList :: [PrimColorString] -> ShowS
$cshowList :: [PrimColorString] -> ShowS
show :: PrimColorString -> String
$cshow :: PrimColorString -> String
showsPrec :: Int -> PrimColorString -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [PrimColorString]
$creadListPrec :: ReadPrec [PrimColorString]
readPrec :: ReadPrec PrimColorString
$creadPrec :: ReadPrec PrimColorString
readList :: ReadS [PrimColorString]
$creadList :: ReadS [PrimColorString]
readsPrec :: Int -> ReadS PrimColorString
$creadsPrec :: Int -> ReadS 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
/= :: ColorString -> ColorString -> Bool
$c/= :: ColorString -> ColorString -> Bool
== :: ColorString -> ColorString -> Bool
$c== :: 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
showList :: [ColorString] -> ShowS
$cshowList :: [ColorString] -> ShowS
show :: ColorString -> String
$cshow :: ColorString -> String
showsPrec :: Int -> ColorString -> ShowS
$cshowsPrec :: Int -> 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
readListPrec :: ReadPrec [ColorString]
$creadListPrec :: ReadPrec [ColorString]
readPrec :: ReadPrec ColorString
$creadPrec :: ReadPrec ColorString
readList :: ReadS [ColorString]
$creadList :: ReadS [ColorString]
readsPrec :: Int -> ReadS ColorString
$creadsPrec :: Int -> ReadS 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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Int
T.length Maybe Text
mt))
    in [Int] -> Int
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 p. IsString p => Bool -> p
mkNl Bool
nlColor)
                                              (Text -> Maybe Text
forall a. a -> Maybe a
Just (Bool -> Text
forall p. IsString p => Bool -> p
mkNl Bool
nlNoColor))])
    where
      mkNl :: Bool -> p
mkNl Bool
True = p
"\n"
      mkNl Bool
False = p
""
      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 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]