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 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 ErrUtils ( WarnMsg )
35 import Id ( mkSysLocal, setIdUnique, Id )
36 import Module ( Module )
37 import Var ( TyVar, setTyVarUnique )
39 import SrcLoc ( noSrcLoc, SrcLoc )
41 import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs,
43 import Unique ( Unique )
44 import Name ( Name, nameOccName )
46 import OccName ( occNameFS )
47 import CmdLineOpts ( DynFlags )
52 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
53 a @UniqueSupply@ and some annotations, which
54 presumably include source-file location information:
57 = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings))
62 ds_dflags :: DynFlags,
63 ds_globals :: Name -> TyThing, -- Lookup well-known Ids
64 ds_meta :: DsMetaEnv, -- Template Haskell bindings
65 ds_loc :: SrcLoc, -- to put in pattern-matching error msgs
66 ds_mod :: Module -- module: for SCC profiling
69 -- Inside [| |] brackets, the desugarer looks
70 -- up variables in the DsMetaEnv
71 type DsMetaEnv = NameEnv DsMetaVal
74 = Bound Id -- Bound by a pattern inside the [| |].
75 -- Will be dynamically alpha renamed.
76 -- The Id has type String
78 | Splice TypecheckedHsExpr -- These bindings are introduced by
79 -- the PendingSplices on a HsBracketOut
81 instance Monad DsM where
85 type DsWarnings = Bag DsWarning -- The desugarer reports matches which are
86 -- completely shadowed or incomplete patterns
87 type DsWarning = (Loc, SDoc)
90 {-# INLINE returnDs #-}
92 -- initDs returns the UniqSupply out the end (not just the result)
97 -> Module -- module name: for profiling
101 initDs dflags init_us lookup mod (DsM action)
102 = initUs_ init_us (action ds_env emptyBag)
104 ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup,
105 ds_loc = noSrcLoc, ds_mod = mod,
106 ds_meta = emptyNameEnv }
108 thenDs :: DsM a -> (a -> DsM b) -> DsM b
110 thenDs (DsM m1) m2 = DsM( \ env warns ->
111 m1 env warns `thenUs` \ (result, warns1) ->
112 unDsM (m2 result) env warns1)
114 returnDs :: a -> DsM a
115 returnDs result = DsM (\ env warns -> returnUs (result, warns))
117 listDs :: [DsM a] -> DsM [a]
118 listDs [] = returnDs []
121 listDs xs `thenDs` \ rs ->
124 mapDs :: (a -> DsM b) -> [a] -> DsM [b]
126 mapDs f [] = returnDs []
128 = f x `thenDs` \ r ->
129 mapDs f xs `thenDs` \ rs ->
132 foldlDs :: (a -> b -> DsM a) -> a -> [b] -> DsM a
134 foldlDs k z [] = returnDs z
135 foldlDs k z (x:xs) = k z x `thenDs` \ r ->
138 mapAndUnzipDs :: (a -> DsM (b, c)) -> [a] -> DsM ([b], [c])
140 mapAndUnzipDs f [] = returnDs ([], [])
141 mapAndUnzipDs f (x:xs)
142 = f x `thenDs` \ (r1, r2) ->
143 mapAndUnzipDs f xs `thenDs` \ (rs1, rs2) ->
144 returnDs (r1:rs1, r2:rs2)
146 zipWithDs :: (a -> b -> DsM c) -> [a] -> [b] -> DsM [c]
148 zipWithDs f [] ys = returnDs []
149 zipWithDs f (x:xs) (y:ys)
150 = f x y `thenDs` \ r ->
151 zipWithDs f xs ys `thenDs` \ rs ->
155 And all this mysterious stuff is so we can occasionally reach out and
156 grab one or more names. @newLocalDs@ isn't exported---exported
157 functions are defined with it. The difference in name-strings makes
158 it easier to read debugging output.
161 uniqSMtoDsM :: UniqSM a -> DsM a
162 uniqSMtoDsM u_action = DsM(\ env warns ->
163 u_action `thenUs` \ res ->
164 returnUs (res, warns))
167 getUniqueDs :: DsM Unique
168 getUniqueDs = DsM (\ env warns ->
169 getUniqueUs `thenUs` \ uniq ->
170 returnUs (uniq, warns))
172 getUniquesDs :: DsM [Unique]
173 getUniquesDs = DsM(\ env warns ->
174 getUniquesUs `thenUs` \ uniqs ->
175 returnUs (uniqs, warns))
177 -- Make a new Id with the same print name, but different type, and new unique
178 newUniqueId :: Name -> Type -> DsM Id
180 = getUniqueDs `thenDs` \ uniq ->
181 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
183 duplicateLocalDs :: Id -> DsM Id
184 duplicateLocalDs old_local
185 = getUniqueDs `thenDs` \ uniq ->
186 returnDs (setIdUnique old_local uniq)
188 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
190 = getUniqueDs `thenDs` \ uniq ->
191 returnDs (mkSysLocal FSLIT("ds") uniq ty)
193 newSysLocalsDs tys = mapDs newSysLocalDs tys
196 = getUniqueDs `thenDs` \ uniq ->
197 returnDs (mkSysLocal FSLIT("fail") uniq ty)
198 -- The UserLocal bit just helps make the code a little clearer
202 cloneTyVarsDs :: [TyVar] -> DsM [TyVar]
204 = getUniquesDs `thenDs` \ uniqs ->
205 returnDs (zipWith setTyVarUnique tyvars uniqs)
207 newTyVarsDs :: [TyVar] -> DsM [TyVar]
208 newTyVarsDs tyvar_tmpls
209 = getUniquesDs `thenDs` \ uniqs ->
210 returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs)
213 We can also reach out and either set/grab location information from
214 the @SrcLoc@ being carried around.
217 getDOptsDs :: DsM DynFlags
218 getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns))
220 getModuleDs :: DsM Module
221 getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns))
223 getSrcLocDs :: DsM SrcLoc
224 getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns))
226 putSrcLocDs :: SrcLoc -> DsM a -> DsM a
227 putSrcLocDs new_loc (DsM expr) = DsM(\ env warns ->
228 expr (env { ds_loc = new_loc }) warns)
230 dsWarn :: DsWarning -> DsM ()
231 dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn))
235 dsLookupGlobalId :: Name -> DsM Id
236 dsLookupGlobalId name = DsM(\ env warns ->
237 returnUs (get_id name (ds_globals env name), warns))
239 dsLookupTyCon :: Name -> DsM TyCon
240 dsLookupTyCon name = DsM(\ env warns ->
241 returnUs (get_tycon name (ds_globals env name), warns))
243 get_id name (AnId id) = id
244 get_id name other = pprPanic "dsLookupGlobalId" (ppr name)
246 get_tycon name (ATyCon tc) = tc
247 get_tycon name other = pprPanic "dsLookupTyCon" (ppr name)
251 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
252 dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns))
254 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
255 dsExtendMetaEnv menv (DsM m)
256 = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns)
260 %************************************************************************
262 \subsection{Type synonym @EquationInfo@ and access functions for its pieces}
264 %************************************************************************
268 = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc