2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
9 initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, foldlDs,
12 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
14 getSrcSpanDs, putSrcSpanDs,
17 UniqSupply, newUniqueSupply,
19 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
21 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
28 EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
32 #include "HsVersions.h"
35 import CoreSyn ( CoreExpr )
36 import HsSyn ( HsExpr, HsMatchContext, Pat )
37 import TcIface ( tcIfaceGlobal )
38 import RdrName ( GlobalRdrEnv )
39 import HscTypes ( TyThing(..), TypeEnv, HscEnv,
40 tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
41 import Bag ( emptyBag, snocBag, Bag )
42 import DataCon ( DataCon )
43 import TyCon ( TyCon )
44 import DataCon ( DataCon )
45 import Id ( mkSysLocal, setIdUnique, Id )
46 import Module ( Module )
47 import Var ( TyVar, setTyVarUnique )
49 import SrcLoc ( noSrcSpan, SrcSpan )
51 import UniqSupply ( UniqSupply, uniqsFromSupply )
52 import Name ( Name, nameOccName )
54 import OccName ( occNameFS )
55 import CmdLineOpts ( DynFlags )
56 import ErrUtils ( WarnMsg, mkWarnMsg )
59 import DATA_IOREF ( newIORef, readIORef )
64 %************************************************************************
66 Data types for the desugarer
68 %************************************************************************
72 = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
77 = EqnInfo { eqn_wrap :: DsWrapper, -- Bindings
78 eqn_pats :: [Pat Id], -- The patterns for an eqn
79 eqn_rhs :: MatchResult } -- What to do after match
81 type DsWrapper = CoreExpr -> CoreExpr
84 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
85 -- \fail. wrap (case vs of { pats -> rhs fail })
86 -- where vs are not in the domain of wrap
89 -- A MatchResult is an expression with a hole in it
92 CanItFail -- Tells whether the failure expression is used
93 (CoreExpr -> DsM CoreExpr)
94 -- Takes a expression to plug in at the
95 -- failure point(s). The expression should
98 data CanItFail = CanFail | CantFail
100 orFail CantFail CantFail = CantFail
105 %************************************************************************
109 %************************************************************************
111 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
112 a @UniqueSupply@ and some annotations, which
113 presumably include source-file location information:
115 type DsM result = TcRnIf DsGblEnv DsLclEnv result
117 -- Compatibility functions
123 mapAndUnzipDs = mapAndUnzipM
126 type DsWarning = (SrcSpan, SDoc)
127 -- Not quite the same as a WarnMsg, we have an SDoc here
128 -- and we'll do the print_unqual stuff later on to turn it
131 data DsGblEnv = DsGblEnv {
132 ds_mod :: Module, -- For SCC profiling
133 ds_warns :: IORef (Bag DsWarning), -- Warning messages
134 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
135 -- possibly-imported things
138 data DsLclEnv = DsLclEnv {
139 ds_meta :: DsMetaEnv, -- Template Haskell bindings
140 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
143 -- Inside [| |] brackets, the desugarer looks
144 -- up variables in the DsMetaEnv
145 type DsMetaEnv = NameEnv DsMetaVal
148 = Bound Id -- Bound by a pattern inside the [| |].
149 -- Will be dynamically alpha renamed.
150 -- The Id has type THSyntax.Var
152 | Splice (HsExpr Id) -- These bindings are introduced by
153 -- the PendingSplices on a HsBracketOut
155 -- initDs returns the UniqSupply out the end (not just the result)
158 -> Module -> GlobalRdrEnv -> TypeEnv
160 -> IO (a, Bag WarnMsg)
162 initDs hsc_env mod rdr_env type_env thing_inside
163 = do { warn_var <- newIORef emptyBag
164 ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
165 ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
166 ; gbl_env = DsGblEnv { ds_mod = mod,
167 ds_if_env = (if_genv, if_lenv),
168 ds_warns = warn_var }
169 ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
170 ds_loc = noSrcSpan } }
172 ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
174 ; warns <- readIORef warn_var
175 ; return (res, mapBag mk_warn warns)
178 print_unqual = unQualInScope rdr_env
180 mk_warn :: (SrcSpan,SDoc) -> WarnMsg
181 mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
184 %************************************************************************
186 Operations in the monad
188 %************************************************************************
190 And all this mysterious stuff is so we can occasionally reach out and
191 grab one or more names. @newLocalDs@ isn't exported---exported
192 functions are defined with it. The difference in name-strings makes
193 it easier to read debugging output.
196 -- Make a new Id with the same print name, but different type, and new unique
197 newUniqueId :: Name -> Type -> DsM Id
199 = newUnique `thenDs` \ uniq ->
200 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
202 duplicateLocalDs :: Id -> DsM Id
203 duplicateLocalDs old_local
204 = newUnique `thenDs` \ uniq ->
205 returnDs (setIdUnique old_local uniq)
207 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
209 = newUnique `thenDs` \ uniq ->
210 returnDs (mkSysLocal FSLIT("ds") uniq ty)
212 newSysLocalsDs tys = mappM newSysLocalDs tys
215 = newUnique `thenDs` \ uniq ->
216 returnDs (mkSysLocal FSLIT("fail") uniq ty)
217 -- The UserLocal bit just helps make the code a little clearer
221 newTyVarsDs :: [TyVar] -> DsM [TyVar]
222 newTyVarsDs tyvar_tmpls
223 = newUniqueSupply `thenDs` \ uniqs ->
224 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
227 We can also reach out and either set/grab location information from
228 the @SrcSpan@ being carried around.
231 getDOptsDs :: DsM DynFlags
232 getDOptsDs = getDOpts
234 getModuleDs :: DsM Module
235 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
237 getSrcSpanDs :: DsM SrcSpan
238 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
240 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
241 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
243 dsWarn :: DsWarning -> DsM ()
244 dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
246 msg = ptext SLIT("Warning:") <+> warn
250 dsLookupGlobal :: Name -> DsM TyThing
251 -- Very like TcEnv.tcLookupGlobal
253 = do { env <- getGblEnv
254 ; setEnvs (ds_if_env env)
255 (tcIfaceGlobal name) }
257 dsLookupGlobalId :: Name -> DsM Id
258 dsLookupGlobalId name
259 = dsLookupGlobal name `thenDs` \ thing ->
260 returnDs (tyThingId thing)
262 dsLookupTyCon :: Name -> DsM TyCon
264 = dsLookupGlobal name `thenDs` \ thing ->
265 returnDs (tyThingTyCon thing)
267 dsLookupDataCon :: Name -> DsM DataCon
269 = dsLookupGlobal name `thenDs` \ thing ->
270 returnDs (tyThingDataCon thing)
274 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
275 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
277 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
278 dsExtendMetaEnv menv thing_inside
279 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside