2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[DsMonad]{@DsMonad@: monadery used in desugaring}
8 DsM, mappM, mapAndUnzipM,
9 initDs, initDsTc, 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,
25 DsWarning, warnDs, failWithDs,
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, mkPrintUnqualified )
42 import Bag ( emptyBag, snocBag )
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 ( Messages, mkWarnMsg, mkErrMsg,
57 printErrorsAndWarnings, errorsFound )
58 import DATA_IOREF ( newIORef, readIORef )
63 %************************************************************************
65 Data types for the desugarer
67 %************************************************************************
71 = DsMatchContext (HsMatchContext Name) SrcSpan
76 = EqnInfo { eqn_wrap :: DsWrapper, -- Bindings
77 eqn_pats :: [Pat Id], -- The patterns for an eqn
78 eqn_rhs :: MatchResult } -- What to do after match
80 type DsWrapper = CoreExpr -> CoreExpr
83 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
84 -- \fail. wrap (case vs of { pats -> rhs fail })
85 -- where vs are not bound by wrap
88 -- A MatchResult is an expression with a hole in it
91 CanItFail -- Tells whether the failure expression is used
92 (CoreExpr -> DsM CoreExpr)
93 -- Takes a expression to plug in at the
94 -- failure point(s). The expression should
97 data CanItFail = CanFail | CantFail
99 orFail CantFail CantFail = CantFail
104 %************************************************************************
108 %************************************************************************
110 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
111 a @UniqueSupply@ and some annotations, which
112 presumably include source-file location information:
114 type DsM result = TcRnIf DsGblEnv DsLclEnv result
116 -- 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_unqual :: PrintUnqualified,
134 ds_msgs :: IORef Messages, -- 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
157 -> Module -> GlobalRdrEnv -> TypeEnv
160 -- Print errors and warnings, if any arise
162 initDs hsc_env mod rdr_env type_env thing_inside
163 = do { msg_var <- newIORef (emptyBag, emptyBag)
164 ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
166 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
167 tryM thing_inside -- Catch exceptions (= errors during desugaring)
169 -- Display any errors and warnings
170 -- Note: if -Werror is used, we don't signal an error here.
171 ; let dflags = hsc_dflags hsc_env
172 ; msgs <- readIORef msg_var
173 ; printErrorsAndWarnings dflags msgs
175 ; let final_res | errorsFound dflags msgs = Nothing
176 | otherwise = case either_res of
177 Right res -> Just res
178 Left exn -> pprPanic "initDs" (text (show exn))
179 -- The (Left exn) case happens when the thing_inside throws
180 -- a UserError exception. Then it should have put an error
181 -- message in msg_var, so we just discard the exception
185 initDsTc :: DsM a -> TcM a
186 initDsTc thing_inside
187 = do { this_mod <- getModule
188 ; tcg_env <- getGblEnv
189 ; msg_var <- getErrsVar
190 ; let type_env = tcg_type_env tcg_env
191 rdr_env = tcg_rdr_env tcg_env
192 ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
194 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
195 -> IORef Messages -> (DsGblEnv, DsLclEnv)
196 mkDsEnvs mod rdr_env type_env msg_var
199 if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
200 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
201 gbl_env = DsGblEnv { ds_mod = mod,
202 ds_if_env = (if_genv, if_lenv),
203 ds_unqual = mkPrintUnqualified rdr_env,
205 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
209 %************************************************************************
211 Operations in the monad
213 %************************************************************************
215 And all this mysterious stuff is so we can occasionally reach out and
216 grab one or more names. @newLocalDs@ isn't exported---exported
217 functions are defined with it. The difference in name-strings makes
218 it easier to read debugging output.
221 -- Make a new Id with the same print name, but different type, and new unique
222 newUniqueId :: Name -> Type -> DsM Id
224 = newUnique `thenDs` \ uniq ->
225 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
227 duplicateLocalDs :: Id -> DsM Id
228 duplicateLocalDs old_local
229 = newUnique `thenDs` \ uniq ->
230 returnDs (setIdUnique old_local uniq)
232 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
234 = newUnique `thenDs` \ uniq ->
235 returnDs (mkSysLocal FSLIT("ds") uniq ty)
237 newSysLocalsDs tys = mappM newSysLocalDs tys
240 = newUnique `thenDs` \ uniq ->
241 returnDs (mkSysLocal FSLIT("fail") uniq ty)
242 -- The UserLocal bit just helps make the code a little clearer
246 newTyVarsDs :: [TyVar] -> DsM [TyVar]
247 newTyVarsDs tyvar_tmpls
248 = newUniqueSupply `thenDs` \ uniqs ->
249 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
252 We can also reach out and either set/grab location information from
253 the @SrcSpan@ being carried around.
256 getDOptsDs :: DsM DynFlags
257 getDOptsDs = getDOpts
259 getModuleDs :: DsM Module
260 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
262 getSrcSpanDs :: DsM SrcSpan
263 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
265 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
266 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
268 warnDs :: SDoc -> DsM ()
269 warnDs warn = do { env <- getGblEnv
270 ; loc <- getSrcSpanDs
271 ; let msg = mkWarnMsg loc (ds_unqual env)
272 (ptext SLIT("Warning:") <+> warn)
273 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
276 failWithDs :: SDoc -> DsM a
278 = do { env <- getGblEnv
279 ; loc <- getSrcSpanDs
280 ; let msg = mkErrMsg loc (ds_unqual env) err
281 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
287 dsLookupGlobal :: Name -> DsM TyThing
288 -- Very like TcEnv.tcLookupGlobal
290 = do { env <- getGblEnv
291 ; setEnvs (ds_if_env env)
292 (tcIfaceGlobal name) }
294 dsLookupGlobalId :: Name -> DsM Id
295 dsLookupGlobalId name
296 = dsLookupGlobal name `thenDs` \ thing ->
297 returnDs (tyThingId thing)
299 dsLookupTyCon :: Name -> DsM TyCon
301 = dsLookupGlobal name `thenDs` \ thing ->
302 returnDs (tyThingTyCon thing)
304 dsLookupDataCon :: Name -> DsM DataCon
306 = dsLookupGlobal name `thenDs` \ thing ->
307 returnDs (tyThingDataCon thing)
311 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
312 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
314 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
315 dsExtendMetaEnv menv thing_inside
316 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside