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
|
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--
module HaddockRename (
RnM, runRn, runRnFM, -- the monad (instance of Monad)
renameExportList,
renameDecl,
renameExportItems,
renameDoc, resolveDoc,
) 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 str) = return (HsEGroup lev str)
renameDecl :: HsDecl -> RnM HsDecl
renameDecl decl
= case decl of
HsTypeDecl loc t args ty -> do
ty <- renameType ty
return (HsTypeDecl loc t args ty)
HsDataDecl loc ctx t args cons drv -> do
cons <- mapM renameConDecl cons
return (HsDataDecl loc ctx t args cons drv)
HsNewTypeDecl loc ctx t args con drv -> do
con <- renameConDecl con
return (HsNewTypeDecl loc ctx t args con drv)
HsClassDecl loc qt decls -> do
qt <- renameClassHead qt
decls <- mapM renameDecl decls
return (HsClassDecl loc qt decls)
HsTypeSig loc fs qt -> do
qt <- renameType qt
return (HsTypeSig loc fs qt)
HsForeignImport loc cc safe ent n ty -> do
ty <- renameType ty
return (HsForeignImport loc cc safe ent n ty)
_ ->
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 tys maybe_doc) = do
tys <- mapM renameBangTy tys
return (HsConDecl loc nm tys maybe_doc)
renameConDecl (HsRecDecl loc nm fields maybe_doc) = do
fields <- mapM renameField fields
return (HsRecDecl loc nm fields maybe_doc)
renameField (HsFieldDecl ns ty doc) = do
ty <- renameBangTy ty
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
-- -----------------------------------------------------------------------------
-- 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 = lookupRn DocIdentifier,
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
markupResolveDoc :: DocMarkup String (GenRnM String Doc)
markupResolveDoc = Markup {
markupEmpty = return DocEmpty,
markupString = return . DocString,
markupParagraph = liftM DocParagraph,
markupAppend = liftM2 DocAppend,
markupIdentifier = lookupIdString,
markupModule = return . DocModule,
markupEmphasis = liftM DocEmphasis,
markupMonospaced = liftM DocMonospaced,
markupUnorderedList = liftM DocUnorderedList . sequence,
markupOrderedList = liftM DocOrderedList . sequence,
markupCodeBlock = liftM DocCodeBlock,
markupURL = return . DocURL
}
resolveDoc = markup markupResolveDoc
lookupIdString :: String -> GenRnM String Doc
lookupIdString str = do
fn <- getLookupRn
case fn str of
Nothing -> return (DocString str)
Just n -> return (DocIdentifier n)
-- -----------------------------------------------------------------------------
renameExportItems items = mapM rn items
where
rn (ExportGroup lev id doc)
= do doc <- renameDoc doc
return (ExportGroup lev id doc)
rn (ExportDecl decl)
= do decl <- renameDecl decl
return (ExportDecl decl)
|
