-- | Formats Haskell source code using HTML with font tags.
module Language.Haskell.HsColour.HTML
(hscolour,
-- * 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)
-- | Formats Haskell source code using HTML with font tags.
hscolour :: ColourPrefs -- ^ Colour preferences.
-> Bool -- ^ Whether to include anchors.
-> Bool -- ^ Whether output should be partial.
-> String -- ^ Title for webpage output.
-> String -- ^ Haskell source code.
-> String -- ^ Coloured Haskell source code.
hscolour pref anchor partial title =
(if partial then id else top'n'tail title)
. pre
. (if anchor then renderNewLinesAnchors
. concatMap (renderAnchors (renderToken pref))
. insertAnchors
else concatMap (renderToken pref))
. tokenise
top'n'tail :: String -> String -> String
top'n'tail title = (htmlHeader title ++) . (++htmlClose)
pre :: String -> String
pre = (""++) . (++"
")
renderToken :: ColourPrefs -> (TokenType,String) -> String
renderToken pref (t,s) = fontify (colourise pref t)
(if t == Comment then renderComment s else escape s)
renderAnchors :: ((TokenType,String)->String)
-> Either String (TokenType,String) -> String
renderAnchors _ (Left v) = ""
renderAnchors render (Right r) = render r
-- if there are http://links/ in a comment, turn them into
-- hyperlinks
renderComment :: String -> String
renderComment xs@('h':'t':'t':'p':':':'/':'/':_) =
renderLink a ++ renderComment b
where
-- see http://www.gbiv.com/protocols/uri/rfc/rfc3986.html#characters
isUrlChar x = isAlphaNum x || x `elem` ":/?#[]@!$&'()*+,;=-._~%"
(a,b) = span isUrlChar xs
renderLink link = "" ++ escape link ++ ""
renderComment (x:xs) = escape [x] ++ renderComment xs
renderComment [] = []
renderNewLinesAnchors :: String -> String
renderNewLinesAnchors = unlines . map render . zip [1..] . lines
where render (line, s) = "" ++ s
-- Html stuff
fontify [] s = s
fontify (h:hs) s = font h (fontify hs s)
font Normal s = s
font Bold s = ""++s++""
font Dim s = ""++s++""
font Underscore s = ""++s++""
font Blink s = ""
font ReverseVideo s = s
font Concealed s = s
font (Foreground c) s = ""++s++""
font (Background c) s = ""++s++""
escape ('<':cs) = "<"++escape cs
escape ('>':cs) = ">"++escape cs
escape ('&':cs) = "&"++escape cs
escape (c:cs) = c: escape cs
escape [] = []
htmlHeader title = unlines
[ ""
, ""
, ""
,""
, ""++title++""
, ""
, ""
]
htmlClose = "\n\n"