{-# LANGUAGE FlexibleInstances #-}

module AnsiEscape (
    ansi, (#), (##), str, empty, bold, underline,
    black, red, green, yellow, blue, magenta, cyan, white,
    black', red', green', yellow', blue', magenta', cyan', white') where

import Data.List (intercalate)

data Intensity = Normal | Bold
    deriving Show

data Underline = NoUnderline | Underline
    deriving Show

data Color = Black | Red | Green | Yellow | Blue | Magenta | Cyan | White
    deriving (Enum, Show)

data Ansi = AnsiFgColor Color Ansi
          | AnsiBgColor Color Ansi
          | AnsiIntensity Intensity Ansi
          | AnsiUnderline Underline Ansi
          | AnsiString String
          | AnsiConcat Ansi Ansi
    deriving Show

class Ansiable a where
    toAnsi :: a -> Ansi

instance Ansiable [Char] where
    toAnsi = str

instance Ansiable Ansi where
    toAnsi = id

sgr xs = "\ESC[" ++ (intercalate ";" xs) ++ "m"

p_intensity Normal = "22"
p_intensity Bold = "1"

p_underline NoUnderline = "24"
p_underline Underline = "4"

p_fg Nothing = "39"
p_fg (Just c) = '3' : show (fromEnum c)

p_bg Nothing = "49"
p_bg (Just c) = '4' : show (fromEnum c)

ansi :: Ansi -> String
ansi a = ansi' Normal NoUnderline Nothing Nothing a
    where ansi' i u f b (AnsiIntensity i' a) =
              sgr [p_intensity i'] ++ ansi' i' u f b a ++ sgr [p_intensity i]
          ansi' i u f b (AnsiUnderline u' a) =
              sgr [p_underline u'] ++ ansi' i u' f b a ++ sgr [p_underline u]
          ansi' i u f b (AnsiFgColor f' a) =
              sgr [p_fg (Just f')] ++ ansi' i u (Just f') b a ++ sgr [p_fg f]
          ansi' i u f b (AnsiBgColor b' a) =
              sgr [p_bg (Just b')] ++ ansi' i u f (Just b') a ++ sgr [p_bg b]
          ansi' _ _ _ _ (AnsiString xs) = xs
          ansi' i u f b (AnsiConcat x y) = ansi' i u f b x ++ ansi' i u f b y

black, red, green, yellow, blue, magenta, cyan, white,
    black', red', green', yellow', blue', magenta', cyan', white',
    bold, underline :: Ansiable a => a -> Ansi

black   = AnsiFgColor Black   . toAnsi
red     = AnsiFgColor Red     . toAnsi
green   = AnsiFgColor Green   . toAnsi
yellow  = AnsiFgColor Yellow  . toAnsi
blue    = AnsiFgColor Blue    . toAnsi
magenta = AnsiFgColor Magenta . toAnsi
cyan    = AnsiFgColor Cyan    . toAnsi
white   = AnsiFgColor White   . toAnsi

black'   = AnsiBgColor Black   . toAnsi
red'     = AnsiBgColor Red     . toAnsi
green'   = AnsiBgColor Green   . toAnsi
yellow'  = AnsiBgColor Yellow  . toAnsi
blue'    = AnsiBgColor Blue    . toAnsi
magenta' = AnsiBgColor Magenta . toAnsi
cyan'    = AnsiBgColor Cyan    . toAnsi
white'   = AnsiBgColor White   . toAnsi

bold      = AnsiIntensity Bold      . toAnsi
underline = AnsiUnderline Underline . toAnsi

a # b = AnsiConcat (toAnsi a) (toAnsi b)
a ## b = toAnsi a # " " # toAnsi b

str = AnsiString

empty = str ""