2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
9 initDs, returnDs, thenDs, mapDs, listDs,
10 mapAndUnzipDs, zipWithDs, foldlDs,
12 newTyVarsDs, cloneTyVarsDs,
13 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
15 getSrcLocDs, putSrcLocDs,
17 getUniqueDs, getUniquesDs,
19 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
21 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
28 #include "HsVersions.h"
30 import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
31 import HscTypes ( TyThing(..) )
32 import Bag ( emptyBag, snocBag, Bag )
33 import TyCon ( TyCon )
34 import Id ( mkSysLocal, setIdUnique, Id )
35 import Module ( Module )
36 import Var ( TyVar, setTyVarUnique )
38 import SrcLoc ( noSrcLoc, SrcLoc )
40 import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
42 import Unique ( Unique )
43 import Name ( Name, nameOccName )
45 import OccName ( occNameFS )
46 import CmdLineOpts ( DynFlags )
51 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
52 a @UniqueSupply@ and some annotations, which
53 presumably include source-file location information:
56 = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings))
61 ds_dflags :: DynFlags,
62 ds_globals :: Name -> TyThing, -- Lookup well-known Ids
63 ds_meta :: DsMetaEnv, -- Template Haskell bindings
64 ds_loc :: SrcLoc, -- to put in pattern-matching error msgs
65 ds_mod :: Module -- module: for SCC profiling
68 -- Inside [| |] brackets, the desugarer looks
69 -- up variables in the DsMetaEnv
70 type DsMetaEnv = NameEnv DsMetaVal
73 = Bound Id -- Bound by a pattern inside the [| |].
74 -- Will be dynamically alpha renamed.
75 -- The Id has type String
77 | Splice TypecheckedHsExpr -- These bindings are introduced by
78 -- the PendingSplices on a HsBracketOut
80 instance Monad DsM where
84 type DsWarnings = Bag DsWarning -- The desugarer reports matches which are
85 -- completely shadowed or incomplete patterns
86 type DsWarning = (SrcLoc, SDoc)
89 {-# INLINE returnDs #-}
91 -- initDs returns the UniqSupply out the end (not just the result)
96 -> Module -- module name: for profiling
100 initDs dflags init_us lookup mod (DsM action)
101 = initUs_ init_us (action ds_env emptyBag)
103 ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup,
104 ds_loc = noSrcLoc, ds_mod = mod,
105 ds_meta = emptyNameEnv }
107 thenDs :: DsM a -> (a -> DsM b) -> DsM b
109 thenDs (DsM m1) m2 = DsM( \ env warns ->
110 m1 env warns `thenUs` \ (result, warns1) ->
111 unDsM (m2 result) env warns1)
113 returnDs :: a -> DsM a
114 returnDs result = DsM (\ env warns -> returnUs (result, warns))
116 listDs :: [DsM a] -> DsM [a]
117 listDs [] = returnDs []
120 listDs xs `thenDs` \ rs ->
123 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
125 mapDs f [] = returnDs []
127 = f x `thenDs` \ r ->
128 mapDs f xs `thenDs` \ rs ->
131 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
133 foldlDs k z [] = returnDs z
134 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
137 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
139 mapAndUnzipDs f [] = returnDs ([], [])
140 mapAndUnzipDs f (x:xs)
141 = f x `thenDs` \ (r1, r2) ->
142 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
143 returnDs (r1:rs1, r2:rs2)
145 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
147 zipWithDs f [] ys = returnDs []
148 zipWithDs f (x:xs) (y:ys)
149 = f x y `thenDs` \ r ->
150 zipWithDs f xs ys `thenDs` \ rs ->
154 And all this mysterious stuff is so we can occasionally reach out and
155 grab one or more names. @newLocalDs@ isn't exported---exported
156 functions are defined with it. The difference in name-strings makes
157 it easier to read debugging output.
160 uniqSMtoDsM :: UniqSM a -> DsM a
161 uniqSMtoDsM u_action = DsM(\ env warns ->
162 u_action `thenUs` \ res ->
163 returnUs (res, warns))
166 getUniqueDs :: DsM Unique
167 getUniqueDs = DsM (\ env warns ->
168 getUniqueUs `thenUs` \ uniq ->
169 returnUs (uniq, warns))
171 getUniquesDs :: DsM [Unique]
172 getUniquesDs = DsM(\ env warns ->
173 getUniquesUs `thenUs` \ uniqs ->
174 returnUs (uniqs, warns))
176 -- Make a new Id with the same print name, but different type, and new unique
177 newUniqueId :: Name -> Type -> DsM Id
179 = getUniqueDs `thenDs` \ uniq ->
180 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
182 duplicateLocalDs :: Id -> DsM Id
183 duplicateLocalDs old_local
184 = getUniqueDs `thenDs` \ uniq ->
185 returnDs (setIdUnique old_local uniq)
187 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
189 = getUniqueDs `thenDs` \ uniq ->
190 returnDs (mkSysLocal FSLIT("ds") uniq ty)
192 newSysLocalsDs tys = mapDs newSysLocalDs tys
195 = getUniqueDs `thenDs` \ uniq ->
196 returnDs (mkSysLocal FSLIT("fail") uniq ty)
197 -- The UserLocal bit just helps make the code a little clearer
201 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
203 = getUniquesDs `thenDs` \ uniqs ->
204 returnDs (zipWith setTyVarUnique tyvars uniqs)
206 newTyVarsDs :: [TyVar] -> DsM [TyVar]
207 newTyVarsDs tyvar_tmpls
208 = getUniquesDs `thenDs` \ uniqs ->
209 returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
212 We can also reach out and either set/grab location information from
213 the @SrcLoc@ being carried around.
216 getDOptsDs :: DsM DynFlags
217 getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
219 getModuleDs :: DsM Module
220 getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
222 getSrcLocDs :: DsM SrcLoc
223 getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
225 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
226 putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
227 expr (env { ds_loc = new_loc }) warns)
229 dsWarn :: DsWarning -> DsM ()
230 dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
234 dsLookupGlobal :: Name -> DsM TyThing
236 = DsM(\ env warns -> returnUs (ds_globals env name, warns))
238 dsLookupGlobalId :: Name -> DsM Id
239 dsLookupGlobalId name
240 = dsLookupGlobal name `thenDs` \ thing ->
241 returnDs (get_id name thing)
243 dsLookupTyCon :: Name -> DsM TyCon
245 = dsLookupGlobal name `thenDs` \ thing ->
246 returnDs (get_tycon name thing)
248 get_id name (AnId id) = id
249 get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
251 get_tycon name (ATyCon tc) = tc
252 get_tycon name other = pprPanic "dsLookupTyCon" (ppr name)
256 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
257 dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
259 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
260 dsExtendMetaEnv menv (DsM m)
261 = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
265 %************************************************************************
267 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
269 %************************************************************************
273 = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc