2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
9 initDs, returnDs, thenDs, mapDs, listDs, fixDs,
10 mapAndUnzipDs, zipWithDs, foldlDs,
12 newTyVarsDs, cloneTyVarsDs,
13 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
15 getSrcLocDs, putSrcLocDs,
17 getUniqueDs, getUniquesDs,
18 UniqSupply, getUniqSupplyDs,
20 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
22 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
29 #include "HsVersions.h"
31 import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
32 import HscTypes ( TyThing(..) )
33 import Bag ( emptyBag, snocBag, Bag )
34 import DataCon ( DataCon )
35 import TyCon ( TyCon )
36 import DataCon ( DataCon )
37 import Id ( mkSysLocal, setIdUnique, Id )
38 import Module ( Module )
39 import Var ( TyVar, setTyVarUnique )
41 import SrcLoc ( noSrcLoc, SrcLoc )
43 import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
44 fixUs, UniqSM, UniqSupply, getUs )
45 import Unique ( Unique )
46 import Name ( Name, nameOccName )
48 import OccName ( occNameFS )
49 import CmdLineOpts ( DynFlags )
54 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
55 a @UniqueSupply@ and some annotations, which
56 presumably include source-file location information:
59 = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings))
64 ds_dflags :: DynFlags,
65 ds_globals :: Name -> TyThing, -- Lookup well-known Ids
66 ds_meta :: DsMetaEnv, -- Template Haskell bindings
67 ds_loc :: SrcLoc, -- to put in pattern-matching error msgs
68 ds_mod :: Module -- module: for SCC profiling
71 -- Inside [| |] brackets, the desugarer looks
72 -- up variables in the DsMetaEnv
73 type DsMetaEnv = NameEnv DsMetaVal
76 = Bound Id -- Bound by a pattern inside the [| |].
77 -- Will be dynamically alpha renamed.
78 -- The Id has type String
80 | Splice TypecheckedHsExpr -- These bindings are introduced by
81 -- the PendingSplices on a HsBracketOut
83 instance Monad DsM where
87 type DsWarnings = Bag DsWarning -- The desugarer reports matches which are
88 -- completely shadowed or incomplete patterns
89 type DsWarning = (SrcLoc, SDoc)
92 {-# INLINE returnDs #-}
94 -- initDs returns the UniqSupply out the end (not just the result)
99 -> Module -- module name: for profiling
103 initDs dflags init_us lookup mod (DsM action)
104 = initUs_ init_us (action ds_env emptyBag)
106 ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup,
107 ds_loc = noSrcLoc, ds_mod = mod,
108 ds_meta = emptyNameEnv }
110 thenDs :: DsM a -> (a -> DsM b) -> DsM b
112 thenDs (DsM m1) m2 = DsM( \ env warns ->
113 m1 env warns `thenUs` \ (result, warns1) ->
114 unDsM (m2 result) env warns1)
116 returnDs :: a -> DsM a
117 returnDs result = DsM (\ env warns -> returnUs (result, warns))
119 fixDs :: (a -> DsM a) -> DsM a
120 fixDs f = DsM (\env warns -> fixUs (\ ~(a, _warns') -> unDsM (f a) env warns))
122 listDs :: [DsM a] -> DsM [a]
123 listDs [] = returnDs []
126 listDs xs `thenDs` \ rs ->
129 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
131 mapDs f [] = returnDs []
133 = f x `thenDs` \ r ->
134 mapDs f xs `thenDs` \ rs ->
137 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
139 foldlDs k z [] = returnDs z
140 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
143 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
145 mapAndUnzipDs f [] = returnDs ([], [])
146 mapAndUnzipDs f (x:xs)
147 = f x `thenDs` \ (r1, r2) ->
148 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
149 returnDs (r1:rs1, r2:rs2)
151 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
153 zipWithDs f [] ys = returnDs []
154 zipWithDs f (x:xs) (y:ys)
155 = f x y `thenDs` \ r ->
156 zipWithDs f xs ys `thenDs` \ rs ->
160 And all this mysterious stuff is so we can occasionally reach out and
161 grab one or more names. @newLocalDs@ isn't exported---exported
162 functions are defined with it. The difference in name-strings makes
163 it easier to read debugging output.
166 uniqSMtoDsM :: UniqSM a -> DsM a
167 uniqSMtoDsM u_action = DsM(\ env warns ->
168 u_action `thenUs` \ res ->
169 returnUs (res, warns))
172 getUniqueDs :: DsM Unique
173 getUniqueDs = DsM (\ env warns ->
174 getUniqueUs `thenUs` \ uniq ->
175 returnUs (uniq, warns))
177 getUniquesDs :: DsM [Unique]
178 getUniquesDs = DsM(\ env warns ->
179 getUniquesUs `thenUs` \ uniqs ->
180 returnUs (uniqs, warns))
182 getUniqSupplyDs :: DsM UniqSupply
183 getUniqSupplyDs = DsM(\ env warns ->
184 getUs `thenUs` \ uniqs ->
185 returnUs (uniqs, warns))
187 -- Make a new Id with the same print name, but different type, and new unique
188 newUniqueId :: Name -> Type -> DsM Id
190 = getUniqueDs `thenDs` \ uniq ->
191 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
193 duplicateLocalDs :: Id -> DsM Id
194 duplicateLocalDs old_local
195 = getUniqueDs `thenDs` \ uniq ->
196 returnDs (setIdUnique old_local uniq)
198 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
200 = getUniqueDs `thenDs` \ uniq ->
201 returnDs (mkSysLocal FSLIT("ds") uniq ty)
203 newSysLocalsDs tys = mapDs newSysLocalDs tys
206 = getUniqueDs `thenDs` \ uniq ->
207 returnDs (mkSysLocal FSLIT("fail") uniq ty)
208 -- The UserLocal bit just helps make the code a little clearer
212 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
214 = getUniquesDs `thenDs` \ uniqs ->
215 returnDs (zipWith setTyVarUnique tyvars uniqs)
217 newTyVarsDs :: [TyVar] -> DsM [TyVar]
218 newTyVarsDs tyvar_tmpls
219 = getUniquesDs `thenDs` \ uniqs ->
220 returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
223 We can also reach out and either set/grab location information from
224 the @SrcLoc@ being carried around.
227 getDOptsDs :: DsM DynFlags
228 getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
230 getModuleDs :: DsM Module
231 getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
233 getSrcLocDs :: DsM SrcLoc
234 getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
236 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
237 putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
238 expr (env { ds_loc = new_loc }) warns)
240 dsWarn :: DsWarning -> DsM ()
241 dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
245 dsLookupGlobal :: Name -> DsM TyThing
247 = DsM(\ env warns -> returnUs (ds_globals env name, warns))
249 dsLookupGlobalId :: Name -> DsM Id
250 dsLookupGlobalId name
251 = dsLookupGlobal name `thenDs` \ thing ->
252 returnDs $ case thing of
254 other -> pprPanic "dsLookupGlobalId" (ppr name)
256 dsLookupTyCon :: Name -> DsM TyCon
258 = dsLookupGlobal name `thenDs` \ thing ->
259 returnDs $ case thing of
261 other -> pprPanic "dsLookupTyCon" (ppr name)
263 dsLookupDataCon :: Name -> DsM DataCon
265 = dsLookupGlobal name `thenDs` \ thing ->
266 returnDs $ case thing of
268 other -> pprPanic "dsLookupDataCon" (ppr name)
272 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
273 dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
275 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
276 dsExtendMetaEnv menv (DsM m)
277 = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
281 %************************************************************************
283 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
285 %************************************************************************
289 = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc