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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--
module HaddockDB (ppDocBook) where
import HaddockTypes
import HaddockUtil
import HsSyn
#if __GLASGOW_HASKELL__ < 503
import Pretty
import FiniteMap
#else
import Text.PrettyPrint
import Data.FiniteMap
#endif
-----------------------------------------------------------------------------
-- Printing the results in DocBook format
ppDocBook = error "not working"
{-
ppDocBook :: FilePath -> [(Module, Interface)] -> String
ppDocBook odir mods = render (ppIfaces mods)
ppIfaces mods
= text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" ["
$$ text "]>"
$$ text "<book>"
$$ text "<bookinfo>"
$$ text "<author><othername>HaskellDoc version 0.0</othername></author>"
$$ text "</bookinfo>"
$$ text "<article>"
$$ vcat (map do_mod mods)
$$ text "</article></book>"
where
do_mod (Module mod, iface)
= text "<sect1 id=\"sec-" <> text mod <> text "\">"
$$ text "<title><literal>"
<> text mod
<> text "</literal></title>"
$$ text "<indexterm><primary><literal>"
<> text mod
<> text "</literal></primary></indexterm>"
$$ text "<variablelist>"
$$ vcat (map (do_export mod) (eltsFM (iface_decls iface)))
$$ text "</variablelist>"
$$ text "</sect1>"
do_export mod decl | (nm:_) <- declBinders decl
= text "<varlistentry id=" <> ppLinkId mod nm <> char '>'
$$ text "<term><literal>"
<> do_decl decl
<> text "</literal></term>"
$$ text "<listitem>"
$$ text "<para>"
$$ text "</para>"
$$ text "</listitem>"
$$ text "</varlistentry>"
do_export _ _ = empty
do_decl (HsTypeSig _ [nm] ty _)
= ppHsName nm <> text " :: " <> ppHsType ty
do_decl (HsTypeDecl _ nm args ty _)
= hsep ([text "type", ppHsName nm ]
++ map ppHsName args
++ [equals, ppHsType ty])
do_decl (HsNewTypeDecl loc ctx nm args con drv _)
= hsep ([text "data", ppHsName nm] -- data, not newtype
++ map ppHsName args
) <+> equals <+> ppHsConstr con -- ToDo: derivings
do_decl (HsDataDecl loc ctx nm args cons drv _)
= hsep ([text "data", {-ToDo: context-}ppHsName nm]
++ map ppHsName args)
<+> vcat (zipWith (<+>) (equals : repeat (char '|'))
(map ppHsConstr cons))
do_decl (HsClassDecl loc ty fds decl _)
= hsep [text "class", ppHsType ty]
do_decl decl
= empty
ppHsConstr :: HsConDecl -> Doc
ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) =
ppHsName name
<> (braces . hsep . punctuate comma . map ppField $ fieldList)
ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) =
hsep (ppHsName name : map ppHsBangType typeList)
ppField (HsFieldDecl ns ty doc)
= hsep (punctuate comma (map ppHsName ns) ++
[text "::", ppHsBangType ty])
ppHsBangType :: HsBangType -> Doc
ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty
ppHsBangType (HsUnBangedTy ty) = ppHsType ty
ppHsContext :: HsContext -> Doc
ppHsContext [] = empty
ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+>
hsep (map ppHsAType b)) context)
ppHsType :: HsType -> Doc
ppHsType (HsForAllType Nothing context htype) =
hsep [ ppHsContext context, text "=>", ppHsType htype]
ppHsType (HsForAllType (Just tvs) [] htype) =
hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype])
ppHsType (HsForAllType (Just tvs) context htype) =
hsep (text "forall" : map ppHsName tvs ++ text "." :
ppHsContext context : text "=>" : [ppHsType htype])
ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b]
ppHsType t = ppHsBType t
ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b]
ppHsBType t = ppHsAType t
ppHsAType :: HsType -> Doc
ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l
ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l
-- special case
ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b )
= brackets $ ppHsType b
ppHsAType (HsTyVar name) = ppHsName name
ppHsAType (HsTyCon name) = ppHsQName name
ppHsAType t = parens $ ppHsType t
ppHsQName :: HsQName -> Doc
ppHsQName (UnQual str) = ppHsName str
ppHsQName n@(Qual (Module mod) str)
| n == unit_con_name = ppHsName str
| isSpecial str = ppHsName str
| otherwise
= text "<link linkend=" <> ppLinkId mod str <> char '>'
<> ppHsName str
<> text "</link>"
isSpecial (HsTyClsName id) | HsSpecial _ <- id = True
isSpecial (HsVarName id) | HsSpecial _ <- id = True
isSpecial _ = False
ppHsName :: HsName -> Doc
ppHsName (HsTyClsName id) = ppHsIdentifier id
ppHsName (HsVarName id) = ppHsIdentifier id
ppHsIdentifier :: HsIdentifier -> Doc
ppHsIdentifier (HsIdent str) = text str
ppHsIdentifier (HsSymbol str) = text str
ppHsIdentifier (HsSpecial str) = text str
ppLinkId :: String -> HsName -> Doc
ppLinkId mod str
= hcat [char '\"', text mod, char '.', ppHsName str, char '\"']
-- -----------------------------------------------------------------------------
-- * Misc
parenList :: [Doc] -> Doc
parenList = parens . fsep . punctuate comma
ubxParenList :: [Doc] -> Doc
ubxParenList = ubxparens . fsep . punctuate comma
ubxparens p = text "(#" <> p <> text "#)"
-}
|
