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
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--
module HaddockTypes (
-- * Module interfaces
NameEnv, Interface(..), ExportItem(..), ModuleMap,
-- * User documentation strings
DocString, GenDoc(..), Doc, ParsedDoc, DocMarkup(..),
markup, mapIdent,
docAppend, docParagraph,
-- * Misc utilities
nameOfQName, collectNames, declBinders, declMainBinder, splitTyConApp,
restrictTo,
) where
import FiniteMap
import HsSyn
import List (intersect)
import Char (isSpace)
-- ---------------------------------------------------------------------------
-- Describing a module interface
type NameEnv = FiniteMap HsName HsQName
data Interface
= Interface {
iface_filename :: FilePath,
-- ^ the filename that contains the source code for this module
iface_env :: NameEnv,
-- ^ environment mapping names to *original* names
iface_exports :: [ExportItem],
-- ^ the exports used to construct the documentation
iface_orig_exports :: [ExportItem],
-- ^ the exports used to construct the documentation
-- (with orig names, not import names)
iface_decls :: FiniteMap HsName HsDecl,
-- ^ decls from this module (only)
-- restricted to only those bits exported.
-- the map key is the "main name" of the decl.
iface_name_docs :: FiniteMap HsName Doc,
-- ^ maps names exported by this module to documentation.
-- Includes not just "main names" but names of constructors,
-- record fields, etc.
iface_portability :: String,
iface_stability :: String,
iface_maintainer :: String,
-- ^ information from the module header
iface_doc :: Maybe Doc
-- ^ documentation from the module header
}
type DocString = String
data ExportItem
= ExportDecl
HsDecl -- a declaration
| ExportGroup -- a section heading
Int -- section level (1, 2, 3, ... )
String -- section "id" (for hyperlinks)
Doc -- section heading text
type ModuleMap = FiniteMap Module Interface
-- -----------------------------------------------------------------------------
-- Some Utilities
nameOfQName (Qual _ n) = n
nameOfQName (UnQual n) = n
collectNames :: [HsDecl] -> [HsName]
collectNames ds = concat (map declBinders ds)
declMainBinder :: HsDecl -> Maybe HsName
declMainBinder d =
case d of
HsTypeDecl _ n _ _ -> Just n
HsDataDecl _ _ n _ cons _ -> Just n
HsNewTypeDecl _ _ n _ _ _ -> Just n
HsClassDecl _ qt decls -> Just (exQtNm qt)
HsTypeSig _ [n] _ -> Just n
HsTypeSig _ ns _ -> error "declMainBinder"
HsForeignImport _ _ _ _ n _ -> Just n
_ -> Nothing
declBinders :: HsDecl -> [HsName]
declBinders d =
case d of
HsTypeDecl _ n _ _ -> [n]
HsDataDecl _ _ n _ cons _ -> n : concat (map conDeclBinders cons)
HsNewTypeDecl _ _ n _ _ _ -> [n]
HsClassDecl _ qt decls -> exQtNm qt : collectNames decls
HsTypeSig _ ns _ -> ns
HsForeignImport _ _ _ _ n _ -> [n]
_ -> []
conDeclBinders (HsConDecl _ n _ _) = [n]
conDeclBinders (HsRecDecl _ n fields _) = n : concat (map fieldDeclBinders fields)
fieldDeclBinders (HsFieldDecl ns _ _) = ns
exQtNm (HsForAllType _ _ t) = nameOfQName (fst (splitTyConApp t))
exQtNm t = nameOfQName (fst (splitTyConApp t))
splitTyConApp :: HsType -> (HsQName,[HsType])
splitTyConApp t = split t []
where
split :: HsType -> [HsType] -> (HsQName,[HsType])
split (HsTyApp t u) ts = split t (u:ts)
split (HsTyCon t) ts = (t,ts)
split _ _ = error "splitTyConApp"
-- ---------------------------------------------------------------------------
-- Making abstract declarations
restrictTo :: [HsName] -> HsDecl -> HsDecl
restrictTo names decl = case decl of
HsDataDecl loc ctxt n xs cons drv ->
HsDataDecl loc ctxt n xs (restrictCons names cons) drv
HsNewTypeDecl loc ctxt n xs con drv ->
HsDataDecl loc ctxt n xs (restrictCons names [con]) drv
HsClassDecl loc qt decls ->
HsClassDecl loc qt (restrictDecls names decls)
_ -> decl
restrictCons :: [HsName] -> [HsConDecl] -> [HsConDecl]
restrictCons names decls = filter keep decls
where keep (HsConDecl _ n _ _) = n `elem` names
keep (HsRecDecl _ n _ _) = n `elem` names
-- ToDo: records not right
restrictDecls :: [HsName] -> [HsDecl] -> [HsDecl]
restrictDecls names decls = filter keep decls
where keep d = not (null (declBinders d `intersect` names))
-- ToDo: not really correct
-- -----------------------------------------------------------------------------
-- Doc strings and formatting
data GenDoc id
= DocEmpty
| DocAppend (GenDoc id) (GenDoc id)
| DocString String
| DocParagraph (GenDoc id)
| DocIdentifier id
| DocModule String
| DocEmphasis (GenDoc id)
| DocMonospaced (GenDoc id)
| DocUnorderedList [GenDoc id]
| DocOrderedList [GenDoc id]
| DocCodeBlock (GenDoc id)
| DocURL String
type Doc = GenDoc HsQName
type ParsedDoc = GenDoc String
-- | DocMarkup is a set of instructions for marking up documentation.
-- In fact, it's really just a mapping from 'GenDoc' to some other
-- type [a], where [a] is usually the type of the output (HTML, say).
data DocMarkup id a = Markup {
markupEmpty :: a,
markupString :: String -> a,
markupParagraph :: a -> a,
markupAppend :: a -> a -> a,
markupIdentifier :: id -> a,
markupModule :: String -> a,
markupEmphasis :: a -> a,
markupMonospaced :: a -> a,
markupUnorderedList :: [a] -> a,
markupOrderedList :: [a] -> a,
markupCodeBlock :: a -> a,
markupURL :: String -> a
}
markup :: DocMarkup id a -> GenDoc id -> a
markup m DocEmpty = markupEmpty m
markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2)
markup m (DocString s) = markupString m s
markup m (DocParagraph d) = markupParagraph m (markup m d)
markup m (DocIdentifier i) = markupIdentifier m i
markup m (DocModule mod) = markupModule m mod
markup m (DocEmphasis d) = markupEmphasis m (markup m d)
markup m (DocMonospaced d) = markupMonospaced m (markup m d)
markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds)
markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds)
markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)
markup m (DocURL url) = markupURL m url
-- | Since marking up is just a matter of mapping 'Doc' into some
-- other type, we can \'rename\' documentation by marking up 'Doc' into
-- the same thing, modifying only the identifiers embedded in it.
mapIdent f = Markup {
markupEmpty = DocEmpty,
markupString = DocString,
markupParagraph = DocParagraph,
markupAppend = DocAppend,
markupIdentifier = f,
markupModule = DocModule,
markupEmphasis = DocEmphasis,
markupMonospaced = DocMonospaced,
markupUnorderedList = DocUnorderedList,
markupOrderedList = DocOrderedList,
markupCodeBlock = DocCodeBlock,
markupURL = DocURL
}
-- -----------------------------------------------------------------------------
-- ** Smart constructors
-- used to make parsing easier; we group the list items later
docAppend (DocUnorderedList ds1) (DocUnorderedList ds2)
= DocUnorderedList (ds1++ds2)
docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d)
= DocAppend (DocUnorderedList (ds1++ds2)) d
docAppend (DocOrderedList ds1) (DocOrderedList ds2)
= DocOrderedList (ds1++ds2)
docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d)
= DocAppend (DocOrderedList (ds1++ds2)) d
docAppend d1 d2
= DocAppend d1 d2
-- again to make parsing easier - we spot a paragraph whose only item
-- is a DocMonospaced and make it into a DocCodeBlock
docParagraph (DocMonospaced p)
= DocCodeBlock p
docParagraph (DocAppend (DocString s1) (DocMonospaced p))
| all isSpace s1
= DocCodeBlock p
docParagraph (DocAppend (DocString s1)
(DocAppend (DocMonospaced p) (DocString s2)))
| all isSpace s1 && all isSpace s2
= DocCodeBlock p
docParagraph p
= DocParagraph p
|
