1-- | Formats Haskell source code using HTML with font tags. 2module Language.Haskell.HsColour.HTML 3 ( hscolour 4 , top'n'tail 5 -- * Internals 6 , renderAnchors, renderComment, renderNewLinesAnchors, escape 7 ) where 8 9import Language.Haskell.HsColour.Anchors 10import Language.Haskell.HsColour.Classify as Classify 11import Language.Haskell.HsColour.Colourise 12 13import Data.Char(isAlphaNum) 14import Text.Printf 15 16 17-- | Formats Haskell source code using HTML with font tags. 18hscolour :: ColourPrefs -- ^ Colour preferences. 19 -> Bool -- ^ Whether to include anchors. 20 -> Int -- ^ Starting line number (for line anchors). 21 -> String -- ^ Haskell source code. 22 -> String -- ^ Coloured Haskell source code. 23hscolour pref anchor n = 24 pre 25 . (if anchor then renderNewLinesAnchors n 26 . concatMap (renderAnchors (renderToken pref)) 27 . insertAnchors 28 else concatMap (renderToken pref)) 29 . tokenise 30 31top'n'tail :: String -> String -> String 32top'n'tail title = (htmlHeader title ++) . (++htmlClose) 33 34pre :: String -> String 35pre = ("<pre>"++) . (++"</pre>") 36 37renderToken :: ColourPrefs -> (TokenType,String) -> String 38renderToken pref (t,s) = fontify (colourise pref t) 39 (if t == Comment then renderComment s else escape s) 40 41renderAnchors :: (a -> String) -> Either String a -> String 42renderAnchors _ (Left v) = "<a name=\""++v++"\"></a>" 43renderAnchors render (Right r) = render r 44 45-- if there are http://links/ in a comment, turn them into 46-- hyperlinks 47renderComment :: String -> String 48renderComment xs@('h':'t':'t':'p':':':'/':'/':_) = 49 renderLink a ++ renderComment b 50 where 51 -- see http://www.gbiv.com/protocols/uri/rfc/rfc3986.html#characters 52 isUrlChar x = isAlphaNum x || x `elem` ":/?#[]@!$&'()*+,;=-._~%" 53 (a,b) = span isUrlChar xs 54 renderLink link = "<a href=\"" ++ link ++ "\">" ++ escape link ++ "</a>" 55 56renderComment (x:xs) = escape [x] ++ renderComment xs 57renderComment [] = [] 58 59renderNewLinesAnchors :: Int -> String -> String 60renderNewLinesAnchors n = unlines . map render . zip [n..] . lines 61 where render (line, s) = "<a name=\"line-" ++ show line ++ "\"></a>" ++ s 62 63-- Html stuff 64fontify :: [Highlight] -> String -> String 65fontify [] s = s 66fontify (h:hs) s = font h (fontify hs s) 67 68font :: Highlight -> String -> String 69font Normal s = s 70font Bold s = "<b>"++s++"</b>" 71font Dim s = "<em>"++s++"</em>" 72font Underscore s = "<u>"++s++"</u>" 73font Blink s = "<blink>"++s++"</blink>" 74font ReverseVideo s = s 75font Concealed s = s 76font (Foreground (Rgb r g b)) s = printf "<font color=\"#%02x%02x%02x\">%s</font>" r g b s 77font (Background (Rgb r g b)) s = printf "<font bgcolor=\"#%02x%02x%02x\">%s</font>" r g b s 78font (Foreground c) s = "<font color="++show c++">"++s++"</font>" 79font (Background c) s = "<font bgcolor="++show c++">"++s++"</font>" 80font Italic s = "<i>"++s++"</i>" 81 82escape :: String -> String 83escape ('<':cs) = "<"++escape cs 84escape ('>':cs) = ">"++escape cs 85escape ('&':cs) = "&"++escape cs 86escape (c:cs) = c: escape cs 87escape [] = [] 88 89htmlHeader :: String -> String 90htmlHeader title = unlines 91 [ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">" 92 , "<html>" 93 , "<head>" 94 ,"<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->" 95 , "<title>"++title++"</title>" 96 , "</head>" 97 , "<body>" 98 ] 99htmlClose :: String 100htmlClose = "\n</body>\n</html>" 101