1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
|
-- | 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 = ("<pre>"++) . (++"</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) = "<a name=\""++v++"\"></a>"
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 = "<a href=\"" ++ link ++ "\">" ++ escape link ++ "</a>"
renderComment (x:xs) = escape [x] ++ renderComment xs
renderComment [] = []
renderNewLinesAnchors :: Int -> String -> String
renderNewLinesAnchors n = unlines . map render . zip [n..] . lines
where render (line, s) = "<a name=\"line-" ++ show line ++ "\"></a>" ++ 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 = "<b>"++s++"</b>"
font Dim s = "<em>"++s++"</em>"
font Underscore s = "<u>"++s++"</u>"
font Blink s = "<blink>"++s++"</blink>"
font ReverseVideo s = s
font Concealed s = s
font (Foreground (Rgb r g b)) s = printf "<font color=\"#%02x%02x%02x\">%s</font>" r g b s
font (Background (Rgb r g b)) s = printf "<font bgcolor=\"#%02x%02x%02x\">%s</font>" r g b s
font (Foreground c) s = "<font color="++show c++">"++s++"</font>"
font (Background c) s = "<font bgcolor="++show c++">"++s++"</font>"
font Italic s = "<i>"++s++"</i>"
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
[ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 3.2 Final//EN\">"
, "<html>"
, "<head>"
,"<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->"
, "<title>"++title++"</title>"
, "</head>"
, "<body>"
]
htmlClose :: String
htmlClose = "\n</body>\n</html>"
|
