2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 @DsMonad@: monadery used in desugaring
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
17 DsM, mappM, mapAndUnzipM,
18 initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs,
21 newTyVarsDs, newLocalName,
22 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
24 getSrcSpanDs, putSrcSpanDs,
27 UniqSupply, newUniqueSupply,
28 getDOptsDs, getGhcModeDs, doptDs,
29 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
32 DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
35 DsWarning, warnDs, failWithDs,
39 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
43 #include "HsVersions.h"
73 %************************************************************************
75 Data types for the desugarer
77 %************************************************************************
81 = DsMatchContext (HsMatchContext Name) SrcSpan
86 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
87 eqn_rhs :: MatchResult } -- What to do after match
89 type DsWrapper = CoreExpr -> CoreExpr
92 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
93 -- \fail. wrap (case vs of { pats -> rhs fail })
94 -- where vs are not bound by wrap
97 -- A MatchResult is an expression with a hole in it
100 CanItFail -- Tells whether the failure expression is used
101 (CoreExpr -> DsM CoreExpr)
102 -- Takes a expression to plug in at the
103 -- failure point(s). The expression should
106 data CanItFail = CanFail | CantFail
108 orFail CantFail CantFail = CantFail
113 %************************************************************************
117 %************************************************************************
119 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
120 a @UniqueSupply@ and some annotations, which
121 presumably include source-file location information:
123 type DsM result = TcRnIf DsGblEnv DsLclEnv result
125 -- Compatibility functions
132 mapAndUnzipDs = mapAndUnzipM
135 type DsWarning = (SrcSpan, SDoc)
136 -- Not quite the same as a WarnMsg, we have an SDoc here
137 -- and we'll do the print_unqual stuff later on to turn it
140 data DsGblEnv = DsGblEnv {
141 ds_mod :: Module, -- For SCC profiling
142 ds_unqual :: PrintUnqualified,
143 ds_msgs :: IORef Messages, -- Warning messages
144 ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global,
145 -- possibly-imported things
148 data DsLclEnv = DsLclEnv {
149 ds_meta :: DsMetaEnv, -- Template Haskell bindings
150 ds_loc :: SrcSpan -- to put in pattern-matching error msgs
153 -- Inside [| |] brackets, the desugarer looks
154 -- up variables in the DsMetaEnv
155 type DsMetaEnv = NameEnv DsMetaVal
158 = Bound Id -- Bound by a pattern inside the [| |].
159 -- Will be dynamically alpha renamed.
160 -- The Id has type THSyntax.Var
162 | Splice (HsExpr Id) -- These bindings are introduced by
163 -- the PendingSplices on a HsBracketOut
166 -> Module -> GlobalRdrEnv -> TypeEnv
169 -- Print errors and warnings, if any arise
171 initDs hsc_env mod rdr_env type_env thing_inside
172 = do { msg_var <- newIORef (emptyBag, emptyBag)
173 ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
175 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
176 tryM thing_inside -- Catch exceptions (= errors during desugaring)
178 -- Display any errors and warnings
179 -- Note: if -Werror is used, we don't signal an error here.
180 ; let dflags = hsc_dflags hsc_env
181 ; msgs <- readIORef msg_var
182 ; printErrorsAndWarnings dflags msgs
184 ; let final_res | errorsFound dflags msgs = Nothing
185 | otherwise = case either_res of
186 Right res -> Just res
187 Left exn -> pprPanic "initDs" (text (show exn))
188 -- The (Left exn) case happens when the thing_inside throws
189 -- a UserError exception. Then it should have put an error
190 -- message in msg_var, so we just discard the exception
194 initDsTc :: DsM a -> TcM a
195 initDsTc thing_inside
196 = do { this_mod <- getModule
197 ; tcg_env <- getGblEnv
198 ; msg_var <- getErrsVar
199 ; let type_env = tcg_type_env tcg_env
200 rdr_env = tcg_rdr_env tcg_env
201 ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
202 ; setEnvs ds_envs thing_inside }
204 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
205 mkDsEnvs mod rdr_env type_env msg_var
207 sites_var <- newIORef []
208 let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
209 if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
210 gbl_env = DsGblEnv { ds_mod = mod,
211 ds_if_env = (if_genv, if_lenv),
212 ds_unqual = mkPrintUnqualified rdr_env,
214 lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
217 return (gbl_env, lcl_env)
221 %************************************************************************
223 Operations in the monad
225 %************************************************************************
227 And all this mysterious stuff is so we can occasionally reach out and
228 grab one or more names. @newLocalDs@ isn't exported---exported
229 functions are defined with it. The difference in name-strings makes
230 it easier to read debugging output.
233 -- Make a new Id with the same print name, but different type, and new unique
234 newUniqueId :: Name -> Type -> DsM Id
236 = newUnique `thenDs` \ uniq ->
237 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
239 duplicateLocalDs :: Id -> DsM Id
240 duplicateLocalDs old_local
241 = newUnique `thenDs` \ uniq ->
242 returnDs (setIdUnique old_local uniq)
244 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
246 = newUnique `thenDs` \ uniq ->
247 returnDs (mkSysLocal FSLIT("ds") uniq ty)
249 newSysLocalsDs tys = mappM newSysLocalDs tys
252 = newUnique `thenDs` \ uniq ->
253 returnDs (mkSysLocal FSLIT("fail") uniq ty)
254 -- The UserLocal bit just helps make the code a little clearer
258 newTyVarsDs :: [TyVar] -> DsM [TyVar]
259 newTyVarsDs tyvar_tmpls
260 = newUniqueSupply `thenDs` \ uniqs ->
261 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
264 We can also reach out and either set/grab location information from
265 the @SrcSpan@ being carried around.
268 getDOptsDs :: DsM DynFlags
269 getDOptsDs = getDOpts
271 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
274 getGhcModeDs :: DsM GhcMode
275 getGhcModeDs = getDOptsDs >>= return . ghcMode
277 getModuleDs :: DsM Module
278 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
280 getSrcSpanDs :: DsM SrcSpan
281 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
283 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
284 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
286 warnDs :: SDoc -> DsM ()
287 warnDs warn = do { env <- getGblEnv
288 ; loc <- getSrcSpanDs
289 ; let msg = mkWarnMsg loc (ds_unqual env)
290 (ptext SLIT("Warning:") <+> warn)
291 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
294 failWithDs :: SDoc -> DsM a
296 = do { env <- getGblEnv
297 ; loc <- getSrcSpanDs
298 ; let msg = mkErrMsg loc (ds_unqual env) err
299 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
305 dsLookupGlobal :: Name -> DsM TyThing
306 -- Very like TcEnv.tcLookupGlobal
308 = do { env <- getGblEnv
309 ; setEnvs (ds_if_env env)
310 (tcIfaceGlobal name) }
312 dsLookupGlobalId :: Name -> DsM Id
313 dsLookupGlobalId name
314 = dsLookupGlobal name `thenDs` \ thing ->
315 returnDs (tyThingId thing)
317 dsLookupTyCon :: Name -> DsM TyCon
319 = dsLookupGlobal name `thenDs` \ thing ->
320 returnDs (tyThingTyCon thing)
322 dsLookupDataCon :: Name -> DsM DataCon
324 = dsLookupGlobal name `thenDs` \ thing ->
325 returnDs (tyThingDataCon thing)
327 dsLookupClass :: Name -> DsM Class
329 = dsLookupGlobal name `thenDs` \ thing ->
330 returnDs (tyThingClass thing)
334 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
335 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
337 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
338 dsExtendMetaEnv menv thing_inside
339 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside