-- | 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 pref anchor n = pre . (if anchor then renderNewLinesAnchors n . 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 :: (a -> String) -> Either String a -> 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 :: Int -> String -> String renderNewLinesAnchors n = unlines . map render . zip [n..] . lines where render (line, s) = "" ++ s -- Html stuff fontify :: [Highlight] -> String -> String fontify [] s = s fontify (h:hs) s = font h (fontify hs s) font :: Highlight -> String -> String font Normal s = s font Bold s = ""++s++"" font Dim s = ""++s++"" font Underscore s = ""++s++"" font Blink s = ""++s++"" font ReverseVideo s = s font Concealed s = s font (Foreground (Rgb r g b)) s = printf "%s" r g b s font (Background (Rgb r g b)) s = printf "%s" r g b s font (Foreground c) s = ""++s++"" font (Background c) s = ""++s++"" font Italic s = ""++s++"" escape :: String -> String escape ('<':cs) = "<"++escape cs escape ('>':cs) = ">"++escape cs escape ('&':cs) = "&"++escape cs escape (c:cs) = c: escape cs escape [] = [] htmlHeader :: String -> String htmlHeader title = unlines [ "" , "" , "" ,"" , ""++title++"" , "" , "" ] htmlClose :: String htmlClose = "\n\n"