    -- | 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