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
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--
module HaddockRename (
RnM, runRn, runRnFM, -- the monad (instance of Monad)
renameExportList,
renameDecl,
renameExportItems,
renameDoc, renameMaybeDoc,
) 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 -> GenRnM n a
returnRn a = RnM (\_ -> (a,[]))
thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b
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 (HsQName -> Maybe HsQName)
getLookupRn = RnM (\lkp -> (lkp,[]))
outRn :: HsQName -> RnM ()
outRn name = RnM (\_ -> ((),[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 doc0) = do
doc <- renameDoc doc0
return (HsEGroup lev doc)
renameExport (HsEDoc doc0) = do
doc <- renameDoc doc0
return (HsEDoc doc)
renameExport (HsEDocNamed str) = return (HsEDocNamed str)
renameDecl :: HsDecl -> RnM HsDecl
renameDecl decl
= case decl of
HsTypeDecl loc t args ty0 doc0 -> do
ty <- renameType ty0
doc <- renameMaybeDoc doc0
return (HsTypeDecl loc t args ty doc)
HsDataDecl loc ctx t args cons0 drv doc0 -> do
cons <- mapM renameConDecl cons0
doc <- renameMaybeDoc doc0
return (HsDataDecl loc ctx t args cons drv doc)
HsNewTypeDecl loc ctx t args con0 drv doc0 -> do
con <- renameConDecl con0
doc <- renameMaybeDoc doc0
return (HsNewTypeDecl loc ctx t args con drv doc)
HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do
ctxt <- mapM renamePred ctxt0
decls <- mapM renameDecl decls0
doc <- renameMaybeDoc doc0
return (HsClassDecl loc ctxt nm tvs fds decls doc)
HsTypeSig loc fs qt0 doc0 -> do
qt <- renameType qt0
doc <- renameMaybeDoc doc0
return (HsTypeSig loc fs qt doc)
HsForeignImport loc cc safe ent n ty0 doc0 -> do
ty <- renameType ty0
doc <- renameMaybeDoc doc0
return (HsForeignImport loc cc safe ent n ty doc)
HsInstDecl loc ctxt0 asst0 decls -> do
ctxt <- mapM renamePred ctxt0
asst <- renamePred asst0
return (HsInstDecl loc ctxt asst decls)
HsDocCommentNamed loc name doc0 -> do
doc <- renameDoc doc0
return (HsDocCommentNamed loc name doc)
_ ->
return decl
renameConDecl :: HsConDecl -> RnM HsConDecl
renameConDecl (HsConDecl loc nm tvs ctxt tys0 doc0) = do
tys <- mapM renameBangTy tys0
doc <- renameMaybeDoc doc0
return (HsConDecl loc nm tvs ctxt tys doc)
renameConDecl (HsRecDecl loc nm tvs ctxt fields0 doc0) = do
fields <- mapM renameField fields0
doc <- renameMaybeDoc doc0
return (HsRecDecl loc nm tvs ctxt fields doc)
renameField :: HsFieldDecl -> RnM HsFieldDecl
renameField (HsFieldDecl ns ty0 doc0) = do
ty <- renameBangTy ty0
doc <- renameMaybeDoc doc0
return (HsFieldDecl ns ty doc)
renameBangTy :: HsBangType -> RnM HsBangType
renameBangTy (HsBangedTy ty) = HsBangedTy `liftM` renameType ty
renameBangTy (HsUnBangedTy ty) = HsUnBangedTy `liftM` renameType ty
renamePred :: (HsQName,[HsType]) -> RnM (HsQName,[HsType])
renamePred (c,tys0) = do
tys <- mapM renameType tys0
lookupRn (\c' -> (c',tys)) c
renameType :: HsType -> RnM HsType
renameType (HsForAllType tvs ctx0 ty0) = do
ctx <- mapM renamePred ctx0
ty <- renameType ty0
return (HsForAllType tvs ctx ty)
renameType (HsTyFun arg0 res0) = do
arg <- renameType arg0
res <- renameType res0
return (HsTyFun arg res)
renameType (HsTyTuple b tys0) = do
tys <- mapM renameType tys0
return (HsTyTuple b tys)
renameType (HsTyApp ty0 arg0) = do
ty <- renameType ty0
arg <- renameType arg0
return (HsTyApp ty arg)
renameType (HsTyVar nm) =
return (HsTyVar nm)
renameType (HsTyCon nm) =
lookupRn HsTyCon nm
renameType (HsTyDoc ty0 doc0) = do
ty <- renameType ty0
doc <- renameDoc doc0
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,
markupAName = return . DocAName
}
renameDoc :: Doc -> RnM Doc
renameDoc = markup markupRename
renameMaybeDoc :: Maybe Doc -> RnM (Maybe Doc)
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 _ _) = True
isQualified _ = False
-- -----------------------------------------------------------------------------
renameExportItems :: [ExportItem] -> RnM [ExportItem]
renameExportItems items = mapM rn items
where
rn (ExportModule mod0)
= return (ExportModule mod0)
rn (ExportGroup lev id0 doc0)
= do doc <- renameDoc doc0
return (ExportGroup lev id0 doc)
rn (ExportDecl x decl0) -- x is an original name, don't rename it
= do decl <- renameDecl decl0
return (ExportDecl x decl)
rn (ExportDoc doc0)
= do doc <- renameDoc doc0
return (ExportDoc doc)
|
