{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
module Trammel where

import Data.List
import Data.String
import Data.Monoid
import Data.Maybe (catMaybes)
import Data.Ix (inRange)


data Trammel a
    = Plain a
    | Gaudy [Int] (Trammel a)
    | Append (Trammel a) (Trammel a)
    | Empty
  deriving (Eq, Show)


instance Monoid (Trammel a) where
    mappend = Append
    mempty = Empty


instance IsString a => IsString (Trammel a) where
    fromString = Plain . fromString


data Color = AnsiColor Int | Xterm256 Int | XtermRGB Int Int Int
  deriving (Eq, Show)


getColor :: Color -> [Int] -> Color
getColor c0 [] = c0
getColor c0 (c:s)
    | inRange (30, 37) c = getColor (AnsiColor c) s
    | c == 38 = case s of
                  (5:i:s')     -> getColor (Xterm256 i) s'
                  (2:r:g:b:s') -> getColor (XtermRGB r g b) s'
                  _            -> getColor c0 s
    | c == 39 = getColor (AnsiColor 39) s
    | otherwise = getColor c0 s


toGR :: Color -> [Int]
toGR (AnsiColor i) = [i]
toGR (Xterm256 i) = [38,5,i]
toGR (XtermRGB r g b) = [38,2,r,g,b]


-- TODO maybe bold and underline could be simply Bools
type RenderState = [(Color,Int,Int)]

emptyRenderState :: RenderState
emptyRenderState = [(AnsiColor 39,22,24)]

renderString :: RenderState -> Trammel String -> String -> String

renderString _ (Plain s) y = s ++ y

renderString rs@((fc0, b0, u0):_) (Gaudy c t) y =
    let fc = getColor fc0 c
        b  = f (`elem`[1,22]) b0 c
        u  = f (`elem`[4,24]) u0 c
        gr = catMaybes $
              ( if fc /= fc0 then map Just (toGR fc) else [] ) ++
              [ if b /= b0 then Just b else Nothing
              , if u /= u0 then Just u else Nothing
              ]
        ungr = catMaybes $
              ( if fc /= fc0 then map Just (toGR fc0) else [] ) ++
              [ if b /= b0 then Just b0 else Nothing
              , if u /= u0 then Just u0 else Nothing
              ]
    in sgr gr ++ renderString ((fc, b, u):rs) t (sgr ungr ++ y)
  where
    f p alt xs =
        case filter p xs of
            [] -> alt
            xs' -> last xs'

renderString _ (Gaudy _ _) _ =
    error "renderString called w/o proper initial state"
    -- where a proper initial state is s.th. like emptyRenderState

renderString r (Append t1 t2) y =
    renderString r t1 $ renderString r t2 y

renderString _ Empty y = y


len :: Trammel String -> Int
len (Plain x) = length x
len (Gaudy _ x) = len x
len (Append t1 t2) = len t1 + len t2
len Empty = 0


pp :: Trammel String -> String
pp t = renderString emptyRenderState t ""


sgr :: [Int] -> String
sgr [] = []
sgr xs = ("\ESC["++) . (++"m") . intercalate ";" $ map show xs