-- | 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 Char(isAlphaNum)
import Text.Printf


-- | Formats Haskell source code using HTML with font tags.
hscolour :: ColourPrefs -- ^ Colour preferences.
         -> Bool        -- ^ Whether to include anchors.
         -> String      -- ^ Haskell source code.
         -> String      -- ^ Coloured Haskell source code.
hscolour :: ColourPrefs -> Bool -> String -> Stringhscolour pref :: ColourPrefspref anchor :: Boolanchor = 
    pre :: String -> Stringpre
    (.) :: (b -> c) -> (a -> b) -> a -> c. (if anchor :: Boolanchor then renderNewLinesAnchors :: String -> StringrenderNewLinesAnchors
                      (.) :: (b -> c) -> (a -> b) -> a -> c. concatMap :: (a -> [b]) -> [a] -> [b]concatMap (renderAnchors :: (a -> String) -> Either String a -> StringrenderAnchors (renderToken :: ColourPrefs -> (TokenType, String) -> StringrenderToken pref :: ColourPrefspref))
                      (.) :: (b -> c) -> (a -> b) -> a -> c. insertAnchors ::
  [(TokenType, String)] -> [Either Anchor (TokenType, String)]insertAnchors
                 else concatMap :: (a -> [b]) -> [a] -> [b]concatMap (renderToken :: ColourPrefs -> (TokenType, String) -> StringrenderToken pref :: ColourPrefspref))
    (.) :: (b -> c) -> (a -> b) -> a -> c. tokenise :: String -> [(TokenType, String)]tokenise

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

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

renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken :: ColourPrefs -> (TokenType, String) -> StringrenderToken pref :: ColourPrefspref (t :: TokenTypet,s :: Strings) = fontify :: [Highlight] -> String -> Stringfontify (colourise :: ColourPrefs -> TokenType -> [Highlight]colourise pref :: ColourPrefspref t :: TokenTypet)
                         (if t :: TokenTypet (==) :: Eq a => a -> a -> Bool== Comment :: TokenTypeComment then renderComment :: String -> StringrenderComment s :: Strings else escape :: String -> Stringescape s :: Strings)

renderAnchors :: (a -> String) -> Either String a -> String
renderAnchors :: (a -> String) -> Either String a -> StringrenderAnchors _      (Left v :: Stringv) = "<a name=\""(++) :: [a] -> [a] -> [a]++v :: Stringv(++) :: [a] -> [a] -> [a]++"\"></a>"
renderAnchors render :: a -> Stringrender (Right r :: ar) = render :: a -> Stringrender r :: ar

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

renderNewLinesAnchors :: String -> String
renderNewLinesAnchors :: String -> StringrenderNewLinesAnchors = unlines :: [String] -> Stringunlines (.) :: (b -> c) -> (a -> b) -> a -> c. map :: (a -> b) -> [a] -> [b]map render :: a -> Stringrender (.) :: (b -> c) -> (a -> b) -> a -> c. zip :: [a] -> [b] -> [(a, b)]zip [1..] (.) :: (b -> c) -> (a -> b) -> a -> c. lines :: String -> [String]lines
    where render :: Show a => (a, [Char]) -> [Char]render (line :: aline, s :: [Char]s) = "<a name=\"line-" (++) :: [a] -> [a] -> [a]++ show :: Show a => a -> Stringshow line :: aline (++) :: [a] -> [a] -> [a]++ "\"></a>" (++) :: [a] -> [a] -> [a]++ s :: Strings

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

font ::  Highlight -> String -> String
font :: Highlight -> String -> Stringfont Normal         s :: Strings = s :: Strings
font Bold           s :: Strings = "<b>"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</b>"
font Dim            s :: Strings = "<em>"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</em>"
font Underscore     s :: Strings = "<u>"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</u>"
font Blink          s :: Strings = "<blink>"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</blink>"
font ReverseVideo   s :: Strings = s :: Strings
font Concealed      s :: Strings = s :: Strings
font (Foreground (Rgb r :: Word8r g :: Word8g b :: Word8b)) s :: Strings = printf :: PrintfType r => String -> rprintf   "<font color=\"#%02x%02x%02x\">%s</font>" r :: ar g :: Word8g b :: [Char]b s :: Strings
font (Background (Rgb r :: Word8r g :: Word8g b :: Word8b)) s :: Strings = printf :: PrintfType r => String -> rprintf "<font bgcolor=\"#%02x%02x%02x\">%s</font>" r :: ar g :: Word8g b :: [Char]b s :: Strings
font (Foreground c :: Colourc) s :: Strings =   "<font color="(++) :: [a] -> [a] -> [a]++show :: Show a => a -> Stringshow c :: Colourc(++) :: [a] -> [a] -> [a]++">"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</font>"
font (Background c :: Colourc) s :: Strings = "<font bgcolor="(++) :: [a] -> [a] -> [a]++show :: Show a => a -> Stringshow c :: Colourc(++) :: [a] -> [a] -> [a]++">"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</font>"
font Italic         s :: Strings = "<i>"(++) :: [a] -> [a] -> [a]++s :: Strings(++) :: [a] -> [a] -> [a]++"</i>"

escape ::  String -> String
escape :: String -> Stringescape ('<':cs :: [Char]cs) = "&lt;"(++) :: [a] -> [a] -> [a]++escape :: String -> Stringescape cs :: [Char]cs
escape ('>':cs :: [Char]cs) = "&gt;"(++) :: [a] -> [a] -> [a]++escape :: String -> Stringescape cs :: [Char]cs
escape ('&':cs :: [Char]cs) = "&amp;"(++) :: [a] -> [a] -> [a]++escape :: String -> Stringescape cs :: [Char]cs
escape (c :: Charc:cs :: [Char]cs)   = c :: Colourc(:) :: a -> [a] -> [a]: escape :: String -> Stringescape cs :: [Char]cs
escape []       = [] :: [a][]

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