module Partyline ( Color(..)
             , PartylineMsg(..)
             , Format(..)
             , partylinemsg
             ) where

import Data.Char (chr)
import Data.Maybe (fromMaybe)
import Text.ParserCombinators.Parsec

data Color = Cyan
           | Black
           | BrightBlue
           | Grey
           | Magenta
           | DarkGreen
           | BrightGreen
           | LightGrey
           | DarkRed
           | DarkBlue
           | Brown
           | Purple
           | BrightRed
           | DarkCyan
           | White
           | Yellow
           deriving (Show, Eq)

data FormatHint = Reset
                | Bold | Underline | Italic
                | Color Color

data RawPartylineMsg = Text String | FormatHint FormatHint

data PartylineMsg = PartylineMsg Format String

instance Show PartylineMsg where
    show (PartylineMsg f s) =
        (xmlTag (show $ color f) . maybeTag (bold f) "*" .
         maybeTag (underline f) "_" . maybeTag (italic f) "/") s
        where
          xmlTag delim s = "<" ++ delim ++ ">" ++ s ++ "</" ++ delim ++ ">"
          maybeTag cond delim s
              | cond      = delim ++ s ++ delim
              | otherwise = s

data Format = Format { bold, underline, italic :: Bool
                     , color :: Color }
              deriving (Show)

formatting :: [(Char, FormatHint)]
formatting = map (\(c, d) -> (chr c, d))
             [ (0xFF, Reset                     )
             , (   2, Bold                      )
             , (  22, Italic                    )
             , (  31, Underline                 )
             , (   3, Color Cyan                )
             , (   4, Color Black               )
             , (   5, Color BrightBlue          )
             , (   6, Color Grey                )
             , (   8, Color Magenta             )
             , (  12, Color DarkGreen           )
             , (  14, Color BrightGreen         )
             , (  15, Color LightGrey           )
             , (  16, Color DarkRed             )
             , (  17, Color DarkBlue            )
             , (  18, Color Brown               )
             -- copyright Cadbury
             , (  19, Color Purple              )
             , (  20, Color BrightRed           )
             , (  23, Color DarkCyan            )
             , (  24, Color White               )
             , (  25, Color Yellow              )
             ]

formattingChars :: [Char]
formattingChars = map fst formatting

toFormatHint :: Char -> FormatHint
toFormatHint c = case lookup c formatting of
                   Just d -> d
                   Nothing -> error "Formatting inconsistensy"

partylinemsg :: Parser [PartylineMsg]
partylinemsg = many1 rawmsg >>= return . formatPartyline

rawmsg :: Parser RawPartylineMsg
rawmsg = do
      (oneOf formattingChars >>= return . FormatHint . toFormatHint)
  <|> (many1 (noneOf formattingChars) >>= return . Text)

toggleBold, toggleUnderline, toggleItalic :: Format -> Format
toggleBold      f@(Format {bold      = x}) = f {bold      = not x}
toggleUnderline f@(Format {underline = x}) = f {underline = not x}
toggleItalic    f@(Format {italic    = x}) = f {italic    = not x}

defaultFormat :: Format
defaultFormat = Format False False False Black

formatPartyline :: [RawPartylineMsg] -> [PartylineMsg]
formatPartyline = formatPartyline' defaultFormat [Black]

formatPartyline' :: Format -> [Color] -> [RawPartylineMsg] -> [PartylineMsg]

formatPartyline' _ _ [] = []

-- copy text over with last format
formatPartyline' lastFormat colors ((Text t):ms) =
    (PartylineMsg lastFormat t) : formatPartyline' lastFormat colors ms

-- make a new format
formatPartyline' format colors ((FormatHint hint):ms) =
    formatPartyline' (newFormat hint) (newColors hint) ms
    where
      newFormat Reset           = defaultFormat
      newFormat Bold            = toggleBold      format
      newFormat Underline       = toggleUnderline format
      newFormat Italic          = toggleItalic    format
      newFormat (Color tc)
          | tc == (head colors) = format {color = (head . tail) colors}
          | otherwise           = format {color = tc}
      newColors (Color tc)
          | tc == (head colors) = tail colors
          | otherwise           = tc:colors
      newColors Reset           = (color defaultFormat):colors
      newColors _               = colors