aboutsummaryrefslogtreecommitdiff
path: root/src/HaddockRename.hs
blob: 86e7449075b49ec3642e793bd5675935634eb87d (plain) (blame)
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
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
--
-- Haddock - A Haskell Documentation Tool
--
-- (c) Simon Marlow 2002
--

module HaddockRename (
	RnM, runRn, runRnFM,	-- the monad (instance of Monad)

	renameExportList, 
	renameDecl,
	renameExportItems, renameInstHead,
	renameDoc, renameMaybeDoc,
  ) where

import HaddockTypes
import HsSyn

#if __GLASGOW_HASKELL__ < 503
import FiniteMap
#else
import Data.FiniteMap
#endif

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 ctx0 t args cons0 drv0 doc0 -> do
	    ctx <- renameContext ctx0
	    cons <- mapM renameConDecl cons0
	    drv <- mapM (lookupRn id) drv0
	    doc <- renameMaybeDoc doc0
	    return (HsDataDecl loc ctx t args cons drv doc)
        HsNewTypeDecl loc ctx0 t args con0 drv0 doc0 -> do
	    ctx <- renameContext ctx0
	    con <- renameConDecl con0
	    drv <- mapM (lookupRn id) drv0
	    doc <- renameMaybeDoc doc0
	    return (HsNewTypeDecl loc ctx t args con drv doc)
        HsClassDecl loc ctxt0 nm tvs fds decls0 doc0 -> do
	    ctxt <- renameContext 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 <- renameContext 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

renameContext :: HsContext -> RnM HsContext
renameContext = mapM renamePred

renameIPContext :: HsIPContext -> RnM HsIPContext
renameIPContext cs = mapM renameCtxt cs
 where
   renameCtxt (HsIP n t)   = liftM (HsIP n) (renameType t)
   renameCtxt (HsAssump c) = liftM HsAssump (renamePred c)

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 <- renameIPContext 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 (HsTyIP n ty0) = do
  ty <- renameType ty0
  return (HsTyIP n ty0)
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)

renameInstHead :: InstHead -> RnM InstHead
renameInstHead (ctx,asst) = do
  ctx <- renameContext ctx
  asst <- renamePred asst
  return (ctx,asst)

-- -----------------------------------------------------------------------------
-- 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,
  markupDefList       = liftM DocDefList . mapM markupDef,
  markupCodeBlock     = liftM DocCodeBlock,
  markupURL	      = return . DocURL,
  markupAName	      = return . DocAName
  }

markupDef (ma,mb) = do a <- ma; b <- mb; return (a,b)

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 insts) -- x is an original name, don't rename it
	   = do decl <- renameDecl decl0
		mapM renameInstHead insts
		return (ExportDecl x decl insts)
	rn (ExportNoDecl x y subs)
	   = do y' <- lookupRn id y
	        subs' <- mapM (lookupRn id) subs
		return (ExportNoDecl x y' subs')
	rn (ExportDoc doc0)
	   = do doc <- renameDoc doc0
		return (ExportDoc doc)