aboutsummaryrefslogtreecommitdiff
path: root/src/HaddockRename.hs
blob: 4c5a631b3fdf5004ad9ab3797449dcd9b457a5dd (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
--
-- 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 doc) 
	   = do doc <- renameDoc doc
	        return (ExportGroup lev doc)
	rn (ExportDecl decl)
	   = do decl <- renameDecl decl
		return (ExportDecl decl)