-- | 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 Data.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 -> String
hscolour ColourPrefs
pref = ((TokenType, String) -> String) -> [(TokenType, String)] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (ColourPrefs -> (TokenType, String) -> String
renderToken ColourPrefs
pref) ([(TokenType, String)] -> String)
-> (String -> [(TokenType, String)]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [(TokenType, String)]
tokenise

renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, String) -> String
renderToken ColourPrefs
pref (TokenType
t,String
s) = [Highlight] -> String -> String
fontify (ColourPrefs -> TokenType -> [Highlight]
colourise ColourPrefs
pref TokenType
t) String
s


-- mIRC stuff
fontify :: [Highlight] -> String -> String
fontify [Highlight]
hs =
    MircColour -> String -> String
mircColours ([Highlight] -> MircColour
joinColours [Highlight]
hs)
    (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Highlight] -> String -> String
highlight ((Highlight -> Bool) -> [Highlight] -> [Highlight]
forall a. (a -> Bool) -> [a] -> [a]
filter (Highlight -> [Highlight] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[Highlight
Normal,Highlight
Bold,Highlight
Underscore,Highlight
ReverseVideo]) [Highlight]
hs)
  where
    highlight :: [Highlight] -> String -> String
highlight [] String
s     = String
s
    highlight (Highlight
h:[Highlight]
hs) String
s = Highlight -> String -> String
font Highlight
h ([Highlight] -> String -> String
highlight [Highlight]
hs String
s)

    font :: Highlight -> String -> String
font Highlight
Normal         String
s = String
s
    font Highlight
Bold           String
s = Char
'\^B'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\^B"
    font Highlight
Underscore     String
s = Char
'\^_'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\^_"
    font Highlight
ReverseVideo   String
s = Char
'\^V'Char -> String -> String
forall a. a -> [a] -> [a]
:String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\^V"

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

joinColours :: [Highlight] -> MircColour
joinColours :: [Highlight] -> MircColour
joinColours = (Highlight -> MircColour -> MircColour)
-> MircColour -> [Highlight] -> MircColour
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Highlight -> MircColour -> MircColour
join (Mirc {fg :: Colour
fg=Colour
Black, dim :: Bool
dim=Bool
False, bg :: Maybe Colour
bg=Maybe Colour
forall a. Maybe a
Nothing, blink :: Bool
blink=Bool
False})
  where
    join :: Highlight -> MircColour -> MircColour
join Highlight
Blink           MircColour
mirc = MircColour
mirc {blink=True}
    join Highlight
Dim             MircColour
mirc = MircColour
mirc {dim=True}
    join (Foreground Colour
fg) MircColour
mirc = MircColour
mirc {fg=fg}
    join (Background Colour
bg) MircColour
mirc = MircColour
mirc {bg=Just bg}
    join Highlight
Concealed       MircColour
mirc = MircColour
mirc {fg=Black, bg=Just Black}
    join Highlight
_               MircColour
mirc = MircColour
mirc

mircColours :: MircColour -> String -> String
mircColours :: MircColour -> String -> String
mircColours (Mirc Colour
fg Bool
dim Maybe Colour
Nothing   Bool
blink) String
s = Char
'\^C'Char -> String -> String
forall a. a -> [a] -> [a]
: Colour -> Bool -> String
code Colour
fg Bool
dimString -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\^O"
mircColours (Mirc Colour
fg Bool
dim (Just Colour
bg) Bool
blink) String
s = Char
'\^C'Char -> String -> String
forall a. a -> [a] -> [a]
: Colour -> Bool -> String
code Colour
fg Bool
dimString -> String -> String
forall a. [a] -> [a] -> [a]
++Char
','
                                                   Char -> String -> String
forall a. a -> [a] -> [a]
: Colour -> Bool -> String
code Colour
bg Bool
blinkString -> String -> String
forall a. [a] -> [a] -> [a]
++String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\^O"

code :: Colour -> Bool -> String
code :: Colour -> Bool -> String
code Colour
Black   Bool
False = String
"01"
code Colour
Red     Bool
False = String
"05"
code Colour
Green   Bool
False = String
"03"
code Colour
Yellow  Bool
False = String
"07"
code Colour
Blue    Bool
False = String
"02"
code Colour
Magenta Bool
False = String
"06"
code Colour
Cyan    Bool
False = String
"10"
code Colour
White   Bool
False = String
"00"
code Colour
Black   Bool
True  = String
"14"
code Colour
Red     Bool
True  = String
"04"
code Colour
Green   Bool
True  = String
"09"
code Colour
Yellow  Bool
True  = String
"08"
code Colour
Blue    Bool
True  = String
"12"
code Colour
Magenta Bool
True  = String
"13"
code Colour
Cyan    Bool
True  = String
"11"
code Colour
White   Bool
True  = String
"15"
code c :: Colour
c@(Rgb Word8
_ Word8
_ Word8
_) Bool
b = Colour -> Bool -> String
code (Colour -> Colour
projectToBasicColour8 Colour
c) Bool
b