2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 @DsMonad@: monadery used in desugaring
10 DsM, mappM, mapAndUnzipM,
11 initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
14 newTyVarsDs, newLocalName,
15 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
17 getSrcSpanDs, putSrcSpanDs,
20 UniqSupply, newUniqueSupply,
21 getDOptsDs, getGhcModeDs, doptDs,
22 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
25 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
28 DsWarning, warnDs, failWithDs,
32 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
36 #include "HsVersions.h"
66 %************************************************************************
68 Data types for the desugarer
70 %************************************************************************
74 = DsMatchContext (HsMatchContext Name) SrcSpan
79 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
80 eqn_rhs :: MatchResult } -- What to do after match
82 type DsWrapper = CoreExpr -> CoreExpr
85 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
86 -- \fail. wrap (case vs of { pats -> rhs fail })
87 -- where vs are not bound by wrap
90 -- A MatchResult is an expression with a hole in it
93 CanItFail -- Tells whether the failure expression is used
94 (CoreExpr -> DsM CoreExpr)
95 -- Takes a expression to plug in at the
96 -- failure point(s). The expression should
99 data CanItFail = CanFail | CantFail
101 orFail CantFail CantFail = CantFail
106 %************************************************************************
110 %************************************************************************
112 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
113 a @UniqueSupply@ and some annotations, which
114 presumably include source-file location information:
116 type DsM result = TcRnIf DsGblEnv DsLclEnv result
118 -- Compatibility functions
125 mapAndUnzipDs = mapAndUnzipM
128 type DsWarning = (SrcSpan, SDoc)
129 -- Not quite the same as a WarnMsg, we have an SDoc here
130 -- and we'll do the print_unqual stuff later on to turn it
133 data DsGblEnv = DsGblEnv {
134 ds_mod :: Module, -- For SCC profiling
135 ds_unqual :: PrintUnqualified,
136 ds_msgs :: IORef Messages, -- Warning messages
137 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
138 -- possibly-imported things
141 data DsLclEnv = DsLclEnv {
142 ds_meta :: DsMetaEnv, -- Template Haskell bindings
143 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
146 -- Inside [| |] brackets, the desugarer looks
147 -- up variables in the DsMetaEnv
148 type DsMetaEnv = NameEnv DsMetaVal
151 = Bound Id -- Bound by a pattern inside the [| |].
152 -- Will be dynamically alpha renamed.
153 -- The Id has type THSyntax.Var
155 | Splice (HsExpr Id) -- These bindings are introduced by
156 -- the PendingSplices on a HsBracketOut
159 -> Module -> GlobalRdrEnv -> TypeEnv
162 -- Print errors and warnings, if any arise
164 initDs hsc_env mod rdr_env type_env thing_inside
165 = do { msg_var <- newIORef (emptyBag, emptyBag)
166 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
168 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
169 tryM thing_inside -- Catch exceptions (= errors during desugaring)
171 -- Display any errors and warnings
172 -- Note: if -Werror is used, we don't signal an error here.
173 ; let dflags = hsc_dflags hsc_env
174 ; msgs <- readIORef msg_var
175 ; printErrorsAndWarnings dflags msgs
177 ; let final_res | errorsFound dflags msgs = Nothing
178 | otherwise = case either_res of
179 Right res -> Just res
180 Left exn -> pprPanic "initDs" (text (show exn))
181 -- The (Left exn) case happens when the thing_inside throws
182 -- a UserError exception. Then it should have put an error
183 -- message in msg_var, so we just discard the exception
187 initDsTc :: DsM a -> TcM a
188 initDsTc thing_inside
189 = do { this_mod <- getModule
190 ; tcg_env <- getGblEnv
191 ; msg_var <- getErrsVar
192 ; let type_env = tcg_type_env tcg_env
193 rdr_env = tcg_rdr_env tcg_env
194 ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
195 ; setEnvs ds_envs thing_inside }
197 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
198 mkDsEnvs mod rdr_env type_env msg_var
200 sites_var <- newIORef []
201 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
202 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
203 gbl_env = DsGblEnv { ds_mod = mod,
204 ds_if_env = (if_genv, if_lenv),
205 ds_unqual = mkPrintUnqualified rdr_env,
207 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
210 return (gbl_env, lcl_env)
214 %************************************************************************
216 Operations in the monad
218 %************************************************************************
220 And all this mysterious stuff is so we can occasionally reach out and
221 grab one or more names. @newLocalDs@ isn't exported---exported
222 functions are defined with it. The difference in name-strings makes
223 it easier to read debugging output.
226 -- Make a new Id with the same print name, but different type, and new unique
227 newUniqueId :: Name -> Type -> DsM Id
229 = newUnique `thenDs` \ uniq ->
230 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
232 duplicateLocalDs :: Id -> DsM Id
233 duplicateLocalDs old_local
234 = newUnique `thenDs` \ uniq ->
235 returnDs (setIdUnique old_local uniq)
237 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
239 = newUnique `thenDs` \ uniq ->
240 returnDs (mkSysLocal FSLIT("ds") uniq ty)
242 newSysLocalsDs tys = mappM newSysLocalDs tys
245 = newUnique `thenDs` \ uniq ->
246 returnDs (mkSysLocal FSLIT("fail") uniq ty)
247 -- The UserLocal bit just helps make the code a little clearer
251 newTyVarsDs :: [TyVar] -> DsM [TyVar]
252 newTyVarsDs tyvar_tmpls
253 = newUniqueSupply `thenDs` \ uniqs ->
254 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
257 We can also reach out and either set/grab location information from
258 the @SrcSpan@ being carried around.
261 getDOptsDs :: DsM DynFlags
262 getDOptsDs = getDOpts
264 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
267 getGhcModeDs :: DsM GhcMode
268 getGhcModeDs = getDOptsDs >>= return . ghcMode
270 getModuleDs :: DsM Module
271 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
273 getSrcSpanDs :: DsM SrcSpan
274 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
276 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
277 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
279 warnDs :: SDoc -> DsM ()
280 warnDs warn = do { env <- getGblEnv
281 ; loc <- getSrcSpanDs
282 ; let msg = mkWarnMsg loc (ds_unqual env)
283 (ptext SLIT("Warning:") <+> warn)
284 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
287 failWithDs :: SDoc -> DsM a
289 = do { env <- getGblEnv
290 ; loc <- getSrcSpanDs
291 ; let msg = mkErrMsg loc (ds_unqual env) err
292 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
298 dsLookupGlobal :: Name -> DsM TyThing
299 -- Very like TcEnv.tcLookupGlobal
301 = do { env <- getGblEnv
302 ; setEnvs (ds_if_env env)
303 (tcIfaceGlobal name) }
305 dsLookupGlobalId :: Name -> DsM Id
306 dsLookupGlobalId name
307 = dsLookupGlobal name `thenDs` \ thing ->
308 returnDs (tyThingId thing)
310 dsLookupTyCon :: Name -> DsM TyCon
312 = dsLookupGlobal name `thenDs` \ thing ->
313 returnDs (tyThingTyCon thing)
315 dsLookupDataCon :: Name -> DsM DataCon
317 = dsLookupGlobal name `thenDs` \ thing ->
318 returnDs (tyThingDataCon thing)
320 dsLookupClass :: Name -> DsM Class
322 = dsLookupGlobal name `thenDs` \ thing ->
323 returnDs (tyThingClass thing)
327 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
328 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
330 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
331 dsExtendMetaEnv menv thing_inside
332 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside