blob: aec6d416e695a6b90cb586933d2eede33e3c7214 (
plain) (
blame)
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
|
-----------------------------------------------------------------------------
-- |
-- Module : Haddock.Backends.DevHelp
-- Copyright : (c) Simon Marlow 2003-2006,
-- David Waern 2006
-- License : BSD-like
--
-- Maintainer : haddock@projects.haskell.org
-- Stability : experimental
-- Portability : portable
-----------------------------------------------------------------------------
module Haddock.Backends.DevHelp (ppDevHelpFile) where
import Haddock.ModuleTree
import Haddock.Types hiding (Doc)
import Haddock.Utils
import Module
import Name ( Name, nameModule, getOccString, nameOccName )
import Data.Maybe ( fromMaybe )
import qualified Data.Map as Map
import Text.PrettyPrint
ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO ()
ppDevHelpFile odir doctitle maybe_package ifaces = do
let devHelpFile = package++".devhelp"
tree = mkModuleTree True [ (ifaceMod iface, toDescription iface) | iface <- ifaces ]
doc =
text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$
(text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>
text "\" link=\""<>text contentsHtmlFile<>text"\" author=\"\" name=\""<>text package<>text "\">") $$
text "<chapters>" $$
nest 4 (ppModuleTree [] tree) $+$
text "</chapters>" $$
text "<functions>" $$
nest 4 (ppList index) $+$
text "</functions>" $$
text "</book>"
writeFile (pathJoin [odir, devHelpFile]) (render doc)
where
package = fromMaybe "pkg" maybe_package
ppModuleTree :: [String] -> [ModuleTree] -> Doc
ppModuleTree ss [x] = ppNode ss x
ppModuleTree ss (x:xs) = ppNode ss x $$ ppModuleTree ss xs
ppModuleTree _ [] = error "HaddockHH.ppHHContents.fn: no module trees given"
ppNode :: [String] -> ModuleTree -> Doc
ppNode ss (Node s leaf _ _short ts) =
case ts of
[] -> text "<sub"<+>ppAttribs<>text "/>"
_ ->
text "<sub"<+>ppAttribs<>text ">" $$
nest 4 (ppModuleTree (s:ss) ts) $+$
text "</sub>"
where
ppLink | leaf = text (moduleHtmlFile (mkModule (stringToPackageId "")
(mkModuleName mdl)))
| otherwise = empty
ppAttribs = text "name="<>doubleQuotes (text s)<+>text "link="<>doubleQuotes ppLink
mdl = foldr (++) "" (s' : map ('.':) ss')
(s':ss') = reverse (s:ss)
-- reconstruct the module name
index :: [(Name, [Module])]
index = Map.toAscList (foldr getModuleIndex Map.empty ifaces)
getModuleIndex iface fm =
Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | name <- ifaceExports iface, nameModule name == mdl]) fm
where mdl = ifaceMod iface
ppList :: [(Name, [Module])] -> Doc
ppList [] = empty
ppList ((name,refs):mdls) =
ppReference name refs $$
ppList mdls
ppReference :: Name -> [Module] -> Doc
ppReference _ [] = empty
ppReference name (mdl:refs) =
text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$
ppReference name refs
|
