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) = "&lt;"++escape cs
84escape ('>':cs) = "&gt;"++escape cs
85escape ('&':cs) = "&amp;"++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