    -- | Formats Haskell source code using HTML with font tags.
    module Language.Haskell.HsColour.HTML
        ( hscolour
        , top'n'tail
         -- * Internals
        , renderAnchors, renderComment, renderNewLinesAnchors, escape
        ) where

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

    import Data.Char(isAlphaNum)
    import Text.Printf

    -- | Formats Haskell source code using HTML with font tags.
    hscolour :: ColourPrefs -- ^ Colour preferences.
             -> Bool        -- ^ Whether to include anchors.
             -> Int         -- ^ Starting line number (for line anchors).
             -> String      -- ^ Haskell source code.
             -> String      -- ^ Coloured Haskell source code.
    hscolour :: ColourPrefs -> Bool -> Int -> String -> String
    hscolour ColourPrefs
    pref Bool
    anchor Int
    n =
        String -> String
    pre
        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (if Bool
    anchor then Int -> String -> String
    renderNewLinesAnchors Int
    n
                          (String -> String)
    -> ([(TokenType, String)] -> String)
    -> [(TokenType, String)]
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Either String (TokenType, String) -> String)
    -> [Either String (TokenType, String)] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (((TokenType, String) -> String)
    -> Either String (TokenType, String) -> String
    forall a. (a -> String) -> Either String a -> String
    renderAnchors (ColourPrefs -> (TokenType, String) -> String
    renderToken ColourPrefs
    pref))
                          ([Either String (TokenType, String)] -> String)
    -> ([(TokenType, String)] -> [Either String (TokenType, String)])
    -> [(TokenType, String)]
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [(TokenType, String)] -> [Either String (TokenType, String)]
    insertAnchors
                     else ((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

    top'n'tail :: String -> String -> String
    top'n'tail :: String -> String -> String
    top'n'tail String
    title = (String -> String
    htmlHeader String
    title String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    htmlClose)

    pre :: String -> String
    pre :: String -> String
    pre = (String
    "<pre>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</pre>")

    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)
                             (if TokenType
    t TokenType -> TokenType -> Bool
    forall a. Eq a => a -> a -> Bool
    == TokenType
    Comment then String -> String
    renderComment String
    s else String -> String
    escape String
    s)

    renderAnchors :: (a -> String) -> Either String a -> String
    renderAnchors :: forall a. (a -> String) -> Either String a -> String
    renderAnchors a -> String
    _      (Left String
    v) = String
    "<a name=\""String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    vString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "\"></a>"
    renderAnchors a -> String
    render (Right a
    r) = a -> String
    render a
    r

    -- if there are http://links/ in a comment, turn them into
    -- hyperlinks
    renderComment :: String -> String
    renderComment :: String -> String
    renderComment xs :: String
    xs@(Char
    'h':Char
    't':Char
    't':Char
    'p':Char
    ':':Char
    '/':Char
    '/':String
    _) =
            String -> String
    renderLink String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    renderComment String
    b
        where
            -- see http://www.gbiv.com/protocols/uri/rfc/rfc3986.html#characters
            isUrlChar :: Char -> Bool
    isUrlChar Char
    x = Char -> Bool
    isAlphaNum Char
    x Bool -> Bool -> Bool
    || Char
    x Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    ":/?#[]@!$&'()*+,;=-._~%"
            (String
    a,String
    b) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span Char -> Bool
    isUrlChar String
    xs
            renderLink :: String -> String
    renderLink String
    link = String
    "<a href=\"" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    link String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\">" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    escape String
    link String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "</a>"

    renderComment (Char
    x:String
    xs) = String -> String
    escape [Char
    x] String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    renderComment String
    xs
    renderComment [] = []

    renderNewLinesAnchors :: Int -> String -> String
    renderNewLinesAnchors :: Int -> String -> String
    renderNewLinesAnchors Int
    n = [String] -> String
    unlines ([String] -> String) -> (String -> [String]) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Int, String) -> String) -> [(Int, String)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, String) -> String
    forall {a}. Show a => (a, String) -> String
    render ([(Int, String)] -> [String])
    -> (String -> [(Int, String)]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Int] -> [String] -> [(Int, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    n..] ([String] -> [(Int, String)])
    -> (String -> [String]) -> String -> [(Int, String)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines
        where render :: (a, String) -> String
    render (a
    line, String
    s) = String
    "<a name=\"line-" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    line String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\"></a>" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s

    -- Html stuff
    fontify ::  [Highlight] -> String -> String
    fontify :: [Highlight] -> String -> String
    fontify [] String
    s     = String
    s
    fontify (Highlight
    h:[Highlight]
    hs) String
    s = Highlight -> String -> String
    font Highlight
    h ([Highlight] -> String -> String
    fontify [Highlight]
    hs String
    s)

    font ::  Highlight -> String -> String
    font :: Highlight -> String -> String
    font Highlight
    Normal         String
    s = String
    s
    font Highlight
    Bold           String
    s = String
    "<b>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</b>"
    font Highlight
    Dim            String
    s = String
    "<em>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</em>"
    font Highlight
    Underscore     String
    s = String
    "<u>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</u>"
    font Highlight
    Blink          String
    s = String
    "<blink>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</blink>"
    font Highlight
    ReverseVideo   String
    s = String
    s
    font Highlight
    Concealed      String
    s = String
    s
    font (Foreground (Rgb Word8
    r Word8
    g Word8
    b)) String
    s = String -> Word8 -> Word8 -> Word8 -> String -> String
    forall r. PrintfType r => String -> r
    printf   String
    "<font color=\"#%02x%02x%02x\">%s</font>" Word8
    r Word8
    g Word8
    b String
    s
    font (Background (Rgb Word8
    r Word8
    g Word8
    b)) String
    s = String -> Word8 -> Word8 -> Word8 -> String -> String
    forall r. PrintfType r => String -> r
    printf String
    "<font bgcolor=\"#%02x%02x%02x\">%s</font>" Word8
    r Word8
    g Word8
    b String
    s
    font (Foreground Colour
    c) String
    s =   String
    "<font color="String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Colour -> String
    forall a. Show a => a -> String
    show Colour
    cString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    ">"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</font>"
    font (Background Colour
    c) String
    s = String
    "<font bgcolor="String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Colour -> String
    forall a. Show a => a -> String
    show Colour
    cString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    ">"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</font>"
    font Highlight
    Italic         String
    s = String
    "<i>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    sString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</i>"

    escape ::  String -> String
    escape :: String -> String
    escape (Char
    '<':String
    cs) = String
    "&lt;"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String -> String
    escape String
    cs
    escape (Char
    '>':String
    cs) = String
    "&gt;"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String -> String
    escape String
    cs
    escape (Char
    '&':String
    cs) = String
    "&amp;"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String -> String
    escape String
    cs
    escape (Char
    c:String
    cs)   = Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String
    escape String
    cs
    escape []       = []

    htmlHeader ::  String -> String
    htmlHeader :: String -> String
    htmlHeader String
    title = [String] -> String
    unlines
      [ String
    "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"
      , String
    "<html>"
      , String
    "<head>"
      ,String
    "<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->"
      , String
    "<title>"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    titleString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "</title>"
      , String
    "</head>"
      , String
    "<body>"
      ]
    htmlClose ::  String
    htmlClose :: String
    htmlClose  = String
    "\n</body>\n</html>"