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
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--
module HaddockRename (
RnM, runRn, runRnFM, -- the monad (instance of Monad)
renameExportList,
renameDecl,
renameExportItems,
renameDoc,
) where
import HaddockTypes
import HsSyn
import FiniteMap
import Monad
-- -----------------------------------------------------------------------------
-- Monad for renaming
-- The monad does two things for us: it passes around the environment for
-- renaming, and it returns a list of names which couldn't be found in
-- the environment.
newtype GenRnM n a = RnM {unRn :: (n -> Maybe HsQName) -> (a,[n])}
type RnM a = GenRnM HsQName a
instance Monad (GenRnM n) where
(>>=) = thenRn
return = returnRn
returnRn a = RnM (\lkp -> (a,[]))
m `thenRn` k = RnM (\lkp -> case unRn m lkp of
(a,out1) -> case unRn (k a) lkp of
(b,out2) -> (b,out1++out2))
getLookupRn = RnM (\lkp -> (lkp,[]))
outRn name = RnM (\lkp -> ((),[name]))
lookupRn :: (HsQName -> a) -> HsQName -> RnM a
lookupRn and_then name = do
lkp <- getLookupRn
case lkp name of
Nothing -> do outRn name; return (and_then name)
Just maps_to -> return (and_then maps_to)
runRnFM :: FiniteMap HsQName HsQName -> RnM a -> (a,[HsQName])
runRnFM env rn = unRn rn (lookupFM env)
runRn :: (n -> Maybe HsQName) -> GenRnM n a -> (a,[n])
runRn lkp rn = unRn rn lkp
-- -----------------------------------------------------------------------------
-- Renaming source code & documentation
renameExportList :: [HsExportSpec] -> RnM [HsExportSpec]
renameExportList spec = mapM renameExport spec
where
renameExport (HsEVar x) = lookupRn HsEVar x
renameExport (HsEAbs x) = lookupRn HsEAbs x
renameExport (HsEThingAll x) = lookupRn HsEThingAll x
renameExport (HsEThingWith x cs) = do
cs' <- mapM (lookupRn id) cs
lookupRn (\x' -> HsEThingWith x' cs') x
renameExport (HsEModuleContents m) = return (HsEModuleContents m)
renameExport (HsEGroup lev doc) = do
doc <- renameDoc doc
return (HsEGroup lev doc)
renameExport (HsEDoc doc) = do
doc <- renameDoc doc
return (HsEDoc doc)
renameExport (HsEDocNamed str) = return (HsEDocNamed str)
renameDecl :: HsDecl -> RnM HsDecl
renameDecl decl
= case decl of
HsTypeDecl loc t args ty doc -> do
ty <- renameType ty
doc <- renameMaybeDoc doc
return (HsTypeDecl loc t args ty doc)
HsDataDecl loc ctx t args cons drv doc -> do
cons <- mapM renameConDecl cons
doc <- renameMaybeDoc doc
return (HsDataDecl loc ctx t args cons drv doc)
HsNewTypeDecl loc ctx t args con drv doc -> do
con <- renameConDecl con
doc <- renameMaybeDoc doc
return (HsNewTypeDecl loc ctx t args con drv doc)
HsClassDecl loc qt fds decls doc -> do
qt <- renameClassHead qt
decls <- mapM renameDecl decls
doc <- renameMaybeDoc doc
return (HsClassDecl loc qt fds decls doc)
HsTypeSig loc fs qt doc -> do
qt <- renameType qt
doc <- renameMaybeDoc doc
return (HsTypeSig loc fs qt doc)
HsForeignImport loc cc safe ent n ty doc -> do
ty <- renameType ty
doc <- renameMaybeDoc doc
return (HsForeignImport loc cc safe ent n ty doc)
HsInstDecl loc ctxt asst decls -> do
ctxt <- mapM renamePred ctxt
asst <- renamePred asst
return (HsInstDecl loc ctxt asst decls)
HsDocCommentNamed loc name doc -> do
doc <- renameDoc doc
return (HsDocCommentNamed loc name doc)
_ ->
return decl
renameClassHead (HsForAllType tvs ctx ty) = do
ctx <- mapM renamePred ctx
return (HsForAllType tvs ctx ty)
renameClassHead ty = do
return ty
renameConDecl (HsConDecl loc nm tvs ctxt tys doc) = do
tys <- mapM renameBangTy tys
doc <- renameMaybeDoc doc
return (HsConDecl loc nm tvs ctxt tys doc)
renameConDecl (HsRecDecl loc nm tvs ctxt fields doc) = do
fields <- mapM renameField fields
doc <- renameMaybeDoc doc
return (HsRecDecl loc nm tvs ctxt fields doc)
renameField (HsFieldDecl ns ty doc) = do
ty <- renameBangTy ty
doc <- renameMaybeDoc doc
return (HsFieldDecl ns ty doc)
renameBangTy (HsBangedTy ty) = HsBangedTy `liftM` renameType ty
renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
renamePred (c,tys) = do
tys <- mapM renameType tys
lookupRn (\c' -> (c',tys)) c
renameType (HsForAllType tvs ctx ty) = do
ctx <- mapM renamePred ctx
ty <- renameType ty
return (HsForAllType tvs ctx ty)
renameType (HsTyFun arg res) = do
arg <- renameType arg
res <- renameType res
return (HsTyFun arg res)
renameType (HsTyTuple b tys) = do
tys <- mapM renameType tys
return (HsTyTuple b tys)
renameType (HsTyApp ty arg) = do
ty <- renameType ty
arg <- renameType arg
return (HsTyApp ty arg)
renameType (HsTyVar nm) =
return (HsTyVar nm)
renameType (HsTyCon nm) =
lookupRn HsTyCon nm
renameType (HsTyDoc ty doc) = do
ty <- renameType ty
doc <- renameDoc doc
return (HsTyDoc ty doc)
-- -----------------------------------------------------------------------------
-- Renaming documentation
-- Renaming documentation is done by "marking it up" from ordinary Doc
-- into (Rn Doc), which can then be renamed with runRn.
markupRename :: DocMarkup [HsQName] (RnM Doc)
markupRename = Markup {
markupEmpty = return DocEmpty,
markupString = return . DocString,
markupParagraph = liftM DocParagraph,
markupAppend = liftM2 DocAppend,
markupIdentifier = lookupForDoc,
markupModule = return . DocModule,
markupEmphasis = liftM DocEmphasis,
markupMonospaced = liftM DocMonospaced,
markupUnorderedList = liftM DocUnorderedList . sequence,
markupOrderedList = liftM DocOrderedList . sequence,
markupCodeBlock = liftM DocCodeBlock,
markupURL = return . DocURL
}
renameDoc = markup markupRename
renameMaybeDoc Nothing = return Nothing
renameMaybeDoc (Just doc) = Just `liftM` renameDoc doc
-- ---------------------------------------------------------------------------
-- Looking up names in documentation
lookupForDoc :: [HsQName] -> RnM Doc
lookupForDoc qns = do
lkp <- getLookupRn
case [ n | Just n <- map lkp qns ] of
ns@(_:_) -> return (DocIdentifier ns)
[] -> -- if we were given a qualified name, but there's nothing
-- matching that name in scope, then just assume its existence
-- (this means you can use qualified names in doc strings wihout
-- worrying about whether the entity is in scope).
let quals = filter isQualified qns in
if (not (null quals)) then
return (DocIdentifier quals)
else
-- no qualified names: just replace this name with its
-- string representation.
return (DocString (show (head qns)))
where
isQualified (Qual m i) = True
isQualified _ = False
-- -----------------------------------------------------------------------------
renameExportItems items = mapM rn items
where
rn (ExportModule mod)
= return (ExportModule mod)
rn (ExportGroup lev id doc)
= do doc <- renameDoc doc
return (ExportGroup lev id doc)
rn (ExportDecl x decl) -- x is an original name, don't rename it
= do decl <- renameDecl decl
return (ExportDecl x decl)
rn (ExportDoc doc)
= do doc <- renameDoc doc
return (ExportDoc doc)
|
