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,
24 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
26 bindLocalsDs, getLocalBindsDs,
28 DsWarning, warnDs, failWithDs,
32 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
36 #include "HsVersions.h"
67 %************************************************************************
69 Data types for the desugarer
71 %************************************************************************
75 = DsMatchContext (HsMatchContext Name) SrcSpan
80 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
81 eqn_rhs :: MatchResult } -- What to do after match
83 type DsWrapper = CoreExpr -> CoreExpr
86 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
87 -- \fail. wrap (case vs of { pats -> rhs fail })
88 -- where vs are not bound by wrap
91 -- A MatchResult is an expression with a hole in it
94 CanItFail -- Tells whether the failure expression is used
95 (CoreExpr -> DsM CoreExpr)
96 -- Takes a expression to plug in at the
97 -- failure point(s). The expression should
100 data CanItFail = CanFail | CantFail
102 orFail CantFail CantFail = CantFail
107 %************************************************************************
111 %************************************************************************
113 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
114 a @UniqueSupply@ and some annotations, which
115 presumably include source-file location information:
117 type DsM result = TcRnIf DsGblEnv DsLclEnv result
119 -- Compatibility functions
126 mapAndUnzipDs = mapAndUnzipM
129 type DsWarning = (SrcSpan, SDoc)
130 -- Not quite the same as a WarnMsg, we have an SDoc here
131 -- and we'll do the print_unqual stuff later on to turn it
134 data DsGblEnv = DsGblEnv {
135 ds_mod :: Module, -- For SCC profiling
136 ds_unqual :: PrintUnqualified,
137 ds_msgs :: IORef Messages, -- Warning messages
138 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
139 -- possibly-imported things
142 data DsLclEnv = DsLclEnv {
143 ds_meta :: DsMetaEnv, -- Template Haskell bindings
144 ds_loc :: SrcSpan, -- to put in pattern-matching error msgs
145 ds_locals :: OccEnv Id -- For locals in breakpoints
148 -- Inside [| |] brackets, the desugarer looks
149 -- up variables in the DsMetaEnv
150 type DsMetaEnv = NameEnv DsMetaVal
153 = Bound Id -- Bound by a pattern inside the [| |].
154 -- Will be dynamically alpha renamed.
155 -- The Id has type THSyntax.Var
157 | Splice (HsExpr Id) -- These bindings are introduced by
158 -- the PendingSplices on a HsBracketOut
161 -> Module -> GlobalRdrEnv -> TypeEnv
164 -- Print errors and warnings, if any arise
166 initDs hsc_env mod rdr_env type_env thing_inside
167 = do { msg_var <- newIORef (emptyBag, emptyBag)
168 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
170 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
171 tryM thing_inside -- Catch exceptions (= errors during desugaring)
173 -- Display any errors and warnings
174 -- Note: if -Werror is used, we don't signal an error here.
175 ; let dflags = hsc_dflags hsc_env
176 ; msgs <- readIORef msg_var
177 ; printErrorsAndWarnings dflags msgs
179 ; let final_res | errorsFound dflags msgs = Nothing
180 | otherwise = case either_res of
181 Right res -> Just res
182 Left exn -> pprPanic "initDs" (text (show exn))
183 -- The (Left exn) case happens when the thing_inside throws
184 -- a UserError exception. Then it should have put an error
185 -- message in msg_var, so we just discard the exception
189 initDsTc :: DsM a -> TcM a
190 initDsTc thing_inside
191 = do { this_mod <- getModule
192 ; tcg_env <- getGblEnv
193 ; msg_var <- getErrsVar
194 ; let type_env = tcg_type_env tcg_env
195 rdr_env = tcg_rdr_env tcg_env
196 ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
197 ; setEnvs ds_envs thing_inside }
199 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
200 mkDsEnvs mod rdr_env type_env msg_var
202 sites_var <- newIORef []
203 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
204 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
205 gbl_env = DsGblEnv { ds_mod = mod,
206 ds_if_env = (if_genv, if_lenv),
207 ds_unqual = mkPrintUnqualified rdr_env,
209 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
211 ds_locals = emptyOccEnv }
213 return (gbl_env, lcl_env)
217 %************************************************************************
219 Operations in the monad
221 %************************************************************************
223 And all this mysterious stuff is so we can occasionally reach out and
224 grab one or more names. @newLocalDs@ isn't exported---exported
225 functions are defined with it. The difference in name-strings makes
226 it easier to read debugging output.
229 -- Make a new Id with the same print name, but different type, and new unique
230 newUniqueId :: Name -> Type -> DsM Id
232 = newUnique `thenDs` \ uniq ->
233 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
235 duplicateLocalDs :: Id -> DsM Id
236 duplicateLocalDs old_local
237 = newUnique `thenDs` \ uniq ->
238 returnDs (setIdUnique old_local uniq)
240 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
242 = newUnique `thenDs` \ uniq ->
243 returnDs (mkSysLocal FSLIT("ds") uniq ty)
245 newSysLocalsDs tys = mappM newSysLocalDs tys
248 = newUnique `thenDs` \ uniq ->
249 returnDs (mkSysLocal FSLIT("fail") uniq ty)
250 -- The UserLocal bit just helps make the code a little clearer
254 newTyVarsDs :: [TyVar] -> DsM [TyVar]
255 newTyVarsDs tyvar_tmpls
256 = newUniqueSupply `thenDs` \ uniqs ->
257 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
260 We can also reach out and either set/grab location information from
261 the @SrcSpan@ being carried around.
264 getDOptsDs :: DsM DynFlags
265 getDOptsDs = getDOpts
267 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
270 getGhcModeDs :: DsM GhcMode
271 getGhcModeDs = getDOptsDs >>= return . ghcMode
273 getModuleDs :: DsM Module
274 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
276 getSrcSpanDs :: DsM SrcSpan
277 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
279 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
280 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
282 warnDs :: SDoc -> DsM ()
283 warnDs warn = do { env <- getGblEnv
284 ; loc <- getSrcSpanDs
285 ; let msg = mkWarnMsg loc (ds_unqual env)
286 (ptext SLIT("Warning:") <+> warn)
287 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
290 failWithDs :: SDoc -> DsM a
292 = do { env <- getGblEnv
293 ; loc <- getSrcSpanDs
294 ; let msg = mkErrMsg loc (ds_unqual env) err
295 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
301 dsLookupGlobal :: Name -> DsM TyThing
302 -- Very like TcEnv.tcLookupGlobal
304 = do { env <- getGblEnv
305 ; setEnvs (ds_if_env env)
306 (tcIfaceGlobal name) }
308 dsLookupGlobalId :: Name -> DsM Id
309 dsLookupGlobalId name
310 = dsLookupGlobal name `thenDs` \ thing ->
311 returnDs (tyThingId thing)
313 dsLookupTyCon :: Name -> DsM TyCon
315 = dsLookupGlobal name `thenDs` \ thing ->
316 returnDs (tyThingTyCon thing)
318 dsLookupDataCon :: Name -> DsM DataCon
320 = dsLookupGlobal name `thenDs` \ thing ->
321 returnDs (tyThingDataCon thing)
325 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
326 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
328 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
329 dsExtendMetaEnv menv thing_inside
330 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
334 getLocalBindsDs :: DsM [Id]
335 getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
337 bindLocalsDs :: [Id] -> DsM a -> DsM a
338 bindLocalsDs new_ids enclosed_scope =
339 updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
341 where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]