-- | Formats Haskell source code using mIRC codes.
--   (see http:\/\/irssi.org\/documentation\/formats)
module Language.Haskell.HsColour.MIRC (hscolour) where

import Language.Haskell.HsColour.Classify as Classify
import Language.Haskell.HsColour.Colourise

import Char(isAlphaNum)


-- | Formats Haskell source code using mIRC codes.
hscolour :: ColourPrefs -- ^ Colour preferences.
         -> String      -- ^ Haskell source code.
         -> String      -- ^ Coloured Haskell source code.
hscolour :: ColourPrefs -> String -> Stringhscolour pref :: ColourPrefspref = concatMap :: (a -> [b]) -> [a] -> [b]concatMap (renderToken :: ColourPrefs -> (TokenType, String) -> StringrenderToken pref :: ColourPrefspref) (.) :: (b -> c) -> (a -> b) -> a -> c. tokenise :: String -> [(TokenType, String)]tokenise

renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, String) -> StringrenderToken pref :: ColourPrefspref (t :: TokenTypet,s :: Strings) = fontify :: [Highlight] -> [Char] -> Stringfontify (colourise :: ColourPrefs -> TokenType -> [Highlight]colourise pref :: ColourPrefspref t :: TokenTypet) s :: Strings


-- mIRC stuff
fontify :: [Highlight] -> [Char] -> Stringfontify hs :: [Highlight]hs =
    mircColours :: MircColour -> String -> StringmircColours (joinColours :: [Highlight] -> MircColourjoinColours hs :: [Highlight]hs)
    (.) :: (b -> c) -> (a -> b) -> a -> c. highlight :: [Highlight] -> [Char] -> [Char]highlight (filter :: (a -> Bool) -> [a] -> [a]filter (elem :: Eq a => a -> [a] -> Bool`elem`[Normal :: HighlightNormal,Bold :: HighlightBold,Underscore :: HighlightUnderscore,ReverseVideo :: HighlightReverseVideo]) hs :: [Highlight]hs)
  where
    highlight :: [Highlight] -> [Char] -> [Char]highlight [] s :: [Char]s     = s :: Strings
    highlight (h :: Highlighth:hs :: [Highlight]hs) s :: [Char]s = font :: Highlight -> [Char] -> [Char]font h :: Highlighth (highlight :: [Highlight] -> [Char] -> [Char]highlight hs :: [Highlight]hs s :: Strings)

    font :: Highlight -> [Char] -> [Char]font Normal         s :: [Char]s = s :: Strings
    font Bold           s :: [Char]s = '\^B'(:) :: a -> [a] -> [a]:s :: Strings(++) :: [a] -> [a] -> [a]++"\^B"
    font Underscore     s :: [Char]s = '\^_'(:) :: a -> [a] -> [a]:s :: Strings(++) :: [a] -> [a] -> [a]++"\^_"
    font ReverseVideo   s :: [Char]s = '\^V'(:) :: a -> [a] -> [a]:s :: Strings(++) :: [a] -> [a] -> [a]++"\^V"

-- mIRC combines colour codes in a non-modular way
data bg :: Maybe ColourMircColour = Mirc :: Colour -> Bool -> Maybe Colour -> Bool -> MircColourMirc { fg :: MircColour -> Colourfg::Colour, dim :: MircColour -> Booldim::Bool, bg :: MircColour -> Maybe Colourbg::Maybe Colour, blink :: MircColour -> Boolblink::Bool}

joinColours :: [Highlight] -> MircColour
joinColours :: [Highlight] -> MircColourjoinColours = foldr :: (a -> b -> b) -> b -> [a] -> bfoldr join :: Highlight -> MircColour -> MircColourjoin (Mirc {fg :: Colourfg=Black :: ColourBlack, dim :: Booldim=False :: BoolFalse, bg :: Maybe Colourbg=Nothing :: Maybe aNothing, blink :: Boolblink=False :: BoolFalse})
  where
    join :: Highlight -> MircColour -> MircColourjoin Blink           mirc :: MircColourmirc = mirc :: MircColourmirc {blink :: Boolblink=True :: BoolTrue}
    join Dim             mirc :: MircColourmirc = mirc :: MircColourmirc {dim :: Booldim=True :: BoolTrue}
    join (Foreground fg :: Colourfg) mirc :: MircColourmirc = mirc :: MircColourmirc {fg :: Colourfg=fg :: Colourfg}
    join (Background bg :: Colourbg) mirc :: MircColourmirc = mirc :: MircColourmirc {bg :: Maybe Colourbg=Just :: a -> Maybe aJust bg :: Maybe Colourbg}
    join Concealed       mirc :: MircColourmirc = mirc :: MircColourmirc {fg :: Colourfg=Black :: ColourBlack, bg :: Maybe Colourbg=Just :: a -> Maybe aJust Black :: ColourBlack}
    join _               mirc :: MircColourmirc = mirc :: MircColourmirc

mircColours :: MircColour -> String -> String
mircColours :: MircColour -> String -> StringmircColours (Mirc fg :: Colourfg dim :: Booldim Nothing   blink :: Boolblink) s :: Strings = '\^C'(:) :: a -> [a] -> [a]: code :: Colour -> Bool -> Stringcode fg :: Colourfg dim :: Booldim(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"\^O"
mircColours (Mirc fg :: Colourfg dim :: Booldim (Just bg :: Colourbg) blink :: Boolblink) s :: Strings = '\^C'(:) :: a -> [a] -> [a]: code :: Colour -> Bool -> Stringcode fg :: Colourfg dim :: Booldim(++) :: [a] -> [a] -> [a]++','
                                                   (:) :: a -> [a] -> [a]: code :: Colour -> Bool -> Stringcode bg :: Maybe Colourbg blink :: Boolblink(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"\^O"

code :: Colour -> Bool -> String
code :: Colour -> Bool -> Stringcode Black   False = "1"
code Red     False = "5"
code Green   False = "3"
code Yellow  False = "7"
code Blue    False = "2"
code Magenta False = "6"
code Cyan    False = "10"
code White   False = "0"
code Black   True  = "14"
code Red     True  = "4"
code Green   True  = "9"
code Yellow  True  = "8"
code Blue    True  = "12"
code Magenta True  = "13"
code Cyan    True  = "11"
code White   True  = "15"
code c :: Colourc@(Rgb _ _ _) b :: Boolb = code :: Colour -> Bool -> Stringcode (projectToBasicColour8 :: Colour -> ColourprojectToBasicColour8 c :: Colourc) b :: Boolb