2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
8 DsM, mappM, mapAndUnzipM,
9 initDs, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
12 newTyVarsDs, newLocalName,
13 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
15 getSrcSpanDs, putSrcSpanDs,
18 UniqSupply, newUniqueSupply,
20 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
22 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
29 EquationInfo(..), MatchResult(..), DsWrapper, idWrapper,
33 #include "HsVersions.h"
36 import CoreSyn ( CoreExpr )
37 import HsSyn ( HsExpr, HsMatchContext, Pat )
38 import TcIface ( tcIfaceGlobal )
39 import RdrName ( GlobalRdrEnv )
40 import HscTypes ( TyThing(..), TypeEnv, HscEnv,
41 tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope )
42 import Bag ( emptyBag, snocBag, Bag )
43 import DataCon ( DataCon )
44 import TyCon ( TyCon )
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 DynFlags ( 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
124 mapAndUnzipDs = mapAndUnzipM
127 type DsWarning = (SrcSpan, SDoc)
128 -- Not quite the same as a WarnMsg, we have an SDoc here
129 -- and we'll do the print_unqual stuff later on to turn it
132 data DsGblEnv = DsGblEnv {
133 ds_mod :: Module, -- For SCC profiling
134 ds_warns :: IORef (Bag DsWarning), -- Warning messages
135 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
136 -- possibly-imported things
139 data DsLclEnv = DsLclEnv {
140 ds_meta :: DsMetaEnv, -- Template Haskell bindings
141 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
144 -- Inside [| |] brackets, the desugarer looks
145 -- up variables in the DsMetaEnv
146 type DsMetaEnv = NameEnv DsMetaVal
149 = Bound Id -- Bound by a pattern inside the [| |].
150 -- Will be dynamically alpha renamed.
151 -- The Id has type THSyntax.Var
153 | Splice (HsExpr Id) -- These bindings are introduced by
154 -- the PendingSplices on a HsBracketOut
156 -- initDs returns the UniqSupply out the end (not just the result)
159 -> Module -> GlobalRdrEnv -> TypeEnv
161 -> IO (a, Bag WarnMsg)
163 initDs hsc_env mod rdr_env type_env thing_inside
164 = do { warn_var <- newIORef emptyBag
165 ; let { if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
166 ; if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
167 ; gbl_env = DsGblEnv { ds_mod = mod,
168 ds_if_env = (if_genv, if_lenv),
169 ds_warns = warn_var }
170 ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
171 ds_loc = noSrcSpan } }
173 ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
175 ; warns <- readIORef warn_var
176 ; return (res, mapBag mk_warn warns)
179 print_unqual = unQualInScope rdr_env
181 mk_warn :: (SrcSpan,SDoc) -> WarnMsg
182 mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
185 %************************************************************************
187 Operations in the monad
189 %************************************************************************
191 And all this mysterious stuff is so we can occasionally reach out and
192 grab one or more names. @newLocalDs@ isn't exported---exported
193 functions are defined with it. The difference in name-strings makes
194 it easier to read debugging output.
197 -- Make a new Id with the same print name, but different type, and new unique
198 newUniqueId :: Name -> Type -> DsM Id
200 = newUnique `thenDs` \ uniq ->
201 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
203 duplicateLocalDs :: Id -> DsM Id
204 duplicateLocalDs old_local
205 = newUnique `thenDs` \ uniq ->
206 returnDs (setIdUnique old_local uniq)
208 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
210 = newUnique `thenDs` \ uniq ->
211 returnDs (mkSysLocal FSLIT("ds") uniq ty)
213 newSysLocalsDs tys = mappM newSysLocalDs tys
216 = newUnique `thenDs` \ uniq ->
217 returnDs (mkSysLocal FSLIT("fail") uniq ty)
218 -- The UserLocal bit just helps make the code a little clearer
222 newTyVarsDs :: [TyVar] -> DsM [TyVar]
223 newTyVarsDs tyvar_tmpls
224 = newUniqueSupply `thenDs` \ uniqs ->
225 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
228 We can also reach out and either set/grab location information from
229 the @SrcSpan@ being carried around.
232 getDOptsDs :: DsM DynFlags
233 getDOptsDs = getDOpts
235 getModuleDs :: DsM Module
236 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
238 getSrcSpanDs :: DsM SrcSpan
239 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
241 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
242 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
244 dsWarn :: SDoc -> DsM ()
245 dsWarn warn = do { env <- getGblEnv
246 ; loc <- getSrcSpanDs
247 ; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
249 msg = ptext SLIT("Warning:") <+> warn
253 dsLookupGlobal :: Name -> DsM TyThing
254 -- Very like TcEnv.tcLookupGlobal
256 = do { env <- getGblEnv
257 ; setEnvs (ds_if_env env)
258 (tcIfaceGlobal name) }
260 dsLookupGlobalId :: Name -> DsM Id
261 dsLookupGlobalId name
262 = dsLookupGlobal name `thenDs` \ thing ->
263 returnDs (tyThingId thing)
265 dsLookupTyCon :: Name -> DsM TyCon
267 = dsLookupGlobal name `thenDs` \ thing ->
268 returnDs (tyThingTyCon thing)
270 dsLookupDataCon :: Name -> DsM DataCon
272 = dsLookupGlobal name `thenDs` \ thing ->
273 returnDs (tyThingDataCon thing)
277 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
278 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
280 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
281 dsExtendMetaEnv menv thing_inside
282 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside