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,
27 DsWarning, warnDs, failWithDs,
31 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
35 #include "HsVersions.h"
64 %************************************************************************
66 Data types for the desugarer
68 %************************************************************************
72 = DsMatchContext (HsMatchContext Name) SrcSpan
77 = EqnInfo { 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 ; (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 ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
193 ; setEnvs ds_envs thing_inside }
195 mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
196 mkDsEnvs mod rdr_env type_env msg_var
198 sites_var <- newIORef []
199 let 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,
208 return (gbl_env, lcl_env)
212 %************************************************************************
214 Operations in the monad
216 %************************************************************************
218 And all this mysterious stuff is so we can occasionally reach out and
219 grab one or more names. @newLocalDs@ isn't exported---exported
220 functions are defined with it. The difference in name-strings makes
221 it easier to read debugging output.
224 -- Make a new Id with the same print name, but different type, and new unique
225 newUniqueId :: Name -> Type -> DsM Id
227 = newUnique `thenDs` \ uniq ->
228 returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty)
230 duplicateLocalDs :: Id -> DsM Id
231 duplicateLocalDs old_local
232 = newUnique `thenDs` \ uniq ->
233 returnDs (setIdUnique old_local uniq)
235 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
237 = newUnique `thenDs` \ uniq ->
238 returnDs (mkSysLocal FSLIT("ds") uniq ty)
240 newSysLocalsDs tys = mappM newSysLocalDs tys
243 = newUnique `thenDs` \ uniq ->
244 returnDs (mkSysLocal FSLIT("fail") uniq ty)
245 -- The UserLocal bit just helps make the code a little clearer
249 newTyVarsDs :: [TyVar] -> DsM [TyVar]
250 newTyVarsDs tyvar_tmpls
251 = newUniqueSupply `thenDs` \ uniqs ->
252 returnDs (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply uniqs))
255 We can also reach out and either set/grab location information from
256 the @SrcSpan@ being carried around.
259 getDOptsDs :: DsM DynFlags
260 getDOptsDs = getDOpts
262 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
265 getGhcModeDs :: DsM GhcMode
266 getGhcModeDs = getDOptsDs >>= return . ghcMode
268 getModuleDs :: DsM Module
269 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
271 getSrcSpanDs :: DsM SrcSpan
272 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
274 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
275 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
277 warnDs :: SDoc -> DsM ()
278 warnDs warn = do { env <- getGblEnv
279 ; loc <- getSrcSpanDs
280 ; let msg = mkWarnMsg loc (ds_unqual env)
281 (ptext SLIT("Warning:") <+> warn)
282 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
285 failWithDs :: SDoc -> DsM a
287 = do { env <- getGblEnv
288 ; loc <- getSrcSpanDs
289 ; let msg = mkErrMsg loc (ds_unqual env) err
290 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
296 dsLookupGlobal :: Name -> DsM TyThing
297 -- Very like TcEnv.tcLookupGlobal
299 = do { env <- getGblEnv
300 ; setEnvs (ds_if_env env)
301 (tcIfaceGlobal name) }
303 dsLookupGlobalId :: Name -> DsM Id
304 dsLookupGlobalId name
305 = dsLookupGlobal name `thenDs` \ thing ->
306 returnDs (tyThingId thing)
308 dsLookupTyCon :: Name -> DsM TyCon
310 = dsLookupGlobal name `thenDs` \ thing ->
311 returnDs (tyThingTyCon thing)
313 dsLookupDataCon :: Name -> DsM DataCon
315 = dsLookupGlobal name `thenDs` \ thing ->
316 returnDs (tyThingDataCon thing)
320 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
321 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
323 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
324 dsExtendMetaEnv menv thing_inside
325 = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside