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
|
module HaddockHH(ppHHContents, ppHHIndex) where
import HsSyn hiding(Doc)
#if __GLASGOW_HASKELL__ < 503
import Pretty
import FiniteMap
#else
import Text.PrettyPrint
import Data.FiniteMap
#endif
import HaddockModuleTree
import HaddockUtil
import HaddockTypes
contentsHHFile, indexHHFile :: String
contentsHHFile = "index.hhc"
indexHHFile = "index.hhk"
ppHHContents :: FilePath -> [(Module,Interface)] -> IO ()
ppHHContents odir ifaces = do
let tree = mkModuleTree (map (\(mod,_) -> (mod,Nothing)) ifaces) --TODO: packages
html =
text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
text "<HTML>" $$
text "<HEAD>" $$
text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
text "<!-- Sitemap 1.0 -->" $$
text "</HEAD><BODY>" $$
ppModuleTree tree $$
text "</BODY><HTML>"
writeFile (odir ++ pathSeparator:contentsHHFile) (render html)
where
ppModuleTree :: [ModuleTree] -> Doc
ppModuleTree ts =
text "<OBJECT type=\"text/site properties\">" $$
text "<PARAM name=\"FrameName\" value=\"main\">" $$
text "</OBJECT>" $$
text "<UL>" $+$
nest 4 (fn [] ts) $+$
text "</UL>"
fn :: [String] -> [ModuleTree] -> Doc
fn ss [x] = ppNode ss x
fn ss (x:xs) = ppNode ss x $$ fn ss xs
fn _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
ppNode :: [String] -> ModuleTree -> Doc
ppNode ss (Node s leaf _pkg []) =
ppLeaf s ss leaf
ppNode ss (Node s leaf _pkg ts) =
ppLeaf s ss leaf $$
text "<UL>" $+$
nest 4 (fn (s:ss) ts) $+$
text "</UL>"
ppLeaf s ss isleaf =
text "<LI>" <> nest 4
(text "<OBJECT type=\"text/sitemap\">" $$
text "<PARAM name=\"Name\" value=\"" <> text s <> text "\">" $$
(if isleaf then text "<PARAM name=\"Local\" value=\"" <> text (moduleHtmlFile "" mdl) <> text "\">" else empty) $$
text "</OBJECT>") $+$
text "</LI>"
where
mdl = foldr (++) "" (s' : map ('.':) ss')
(s':ss') = reverse (s:ss)
-- reconstruct the module name
-------------------------------
ppHHIndex :: FilePath -> [(Module,Interface)] -> IO ()
ppHHIndex odir ifaces = do
let html =
text "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">" $$
text "<HTML>" $$
text "<HEAD>" $$
text "<META name=\"GENERATOR\" content=\"Haddock\">" $$
text "<!-- Sitemap 1.0 -->" $$
text "</HEAD><BODY>" $$
text "<UL>" $+$
nest 4 (ppList index) $+$
text "</UL>" $$
text "</BODY><HTML>"
writeFile (odir ++ pathSeparator:indexHHFile) (render html)
where
index :: [(HsName, [Module])]
index = fmToList (foldr getIfaceIndex emptyFM ifaces)
getIfaceIndex (mdl,iface) fm =
addListToFM_C (++) fm [(name, [mdl]) | (name, Qual mdl' _) <- fmToList (iface_env iface), mdl == mdl']
ppList [] = empty
ppList ((name,(Module mdl:_)):mdls) =
text "<LI>" <> nest 4
(text "<OBJECT type=\"text/sitemap\">" $$
text "<PARAM name=\"Name\" value=\"" <> text (show name) <> text "\">" $$
text "<PARAM name=\"Local\" value=\"" <> text (nameHtmlRef "" mdl name) <> text "\">" $$
text "</OBJECT>") $+$
text "</LI>" $$
ppList mdls
|
