matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) ->
returnDs (scrungleMatch discrim_var core_discrim matching_code)
+-- Pepe: The binds are in scope in the body but NOT in the binding group
+-- This is to avoid silliness in breakpoints
dsExpr (HsLet binds body)
- = dsAndThenMaybeInsertBreakpoint body `thenDs` \ body' ->
+ = (bindLocalsDs (map unLoc $ collectLocalBinders binds) $
+ dsAndThenMaybeInsertBreakpoint body) `thenDs` \ body' ->
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
; returnDs (mkApps then_expr2 [rhs2, rest]) }
go (LetStmt binds : stmts)
- = do { rest <- go stmts
+ = do { rest <- bindLocalsDs (map unLoc$ collectLocalBinders binds) $
+ go stmts
; dsLocalBinds binds rest }
-
+
+ -- Notice how due to the placement of bindLocals, binders in this stmt
+ -- are available in posterior stmts but Not in this one rhs.
+ -- This is to avoid silliness in breakpoints
go (BindStmt pat rhs bind_op fail_op : stmts)
- = do { body <- go stmts
+ =
+ do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat
result_ty (cantFailMatchResult body)
; returnDs (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) }
go (BindStmt pat rhs _ _ : stmts)
- = do { body <- go stmts
+ = do { body <- bindLocalsDs (collectPatBinders pat) $ go stmts
; var <- selectSimpleMatchVarL pat
; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat
result_ty (cantFailMatchResult body)
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn
+import HsUtils
import CoreSyn
import Var
import Type
import PrelNames
import Name
import SrcLoc
+
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
-> GRHSs Id -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
-
-dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty
- = mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results ->
+dsGRHSs hs_ctx pats (GRHSs grhss binds) rhs_ty =
+ bindLocalsDs (bindsBinders ++ patsBinders) $
+ mappM (dsGRHS hs_ctx pats rhs_ty) grhss `thenDs` \ match_results ->
let
match_result1 = foldr1 combineMatchResults match_results
- match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1
+ match_result2 = adjustMatchResultDs
+ (\e -> bindLocalsDs patsBinders $ dsLocalBinds binds e)
+ match_result1
-- NB: nested dsLet inside matchResult
in
returnDs match_result2
+ where bindsBinders = map unLoc (collectLocalBinders binds)
+ patsBinders = collectPatsBinders (map (L undefined) pats)
dsGRHS hs_ctx pats rhs_ty (L loc (GRHS guards rhs))
- = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty
+ = do rhs' <- maybeInsertBreakpoint rhs rhs_ty
+ matchGuards (map unLoc guards) hs_ctx rhs' rhs_ty
\end{code}
returnDs (mkGuardedMatchResult pred_expr match_result)
matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
- = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ = bindLocalsDs (map unLoc $ collectLocalBinders binds) $
+ matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
returnDs (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
-- Reason: dsLet takes the body expression as its argument
-- body expression in hand
matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty
- = matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
+ = bindLocalsDs (collectPatBinders pat) $
+ matchGuards stmts ctx rhs rhs_ty `thenDs` \ match_result ->
dsLExpr bind_rhs `thenDs` \ core_rhs ->
matchSinglePat core_rhs ctx pat rhs_ty match_result
\end{code}
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
- getBkptSitesDs,
+ bindLocalsDs, getLocalBindsDs, getBkptSitesDs,
-- Warnings
DsWarning, warnDs, failWithDs,
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
- ds_loc :: SrcSpan -- to put in pattern-matching error msgs
+ ds_loc :: SrcSpan, -- to put in pattern-matching error msgs
+ ds_locals :: OccEnv Id -- For locals in breakpoints
}
-- Inside [| |] brackets, the desugarer looks
initDs hsc_env mod rdr_env type_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
- ; let (ds_gbl_env, ds_lcl_env) = mkDsEnvs mod rdr_env type_env msg_var
+ ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
tryM thing_inside -- Catch exceptions (= errors during desugaring)
; msg_var <- getErrsVar
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
- ; setEnvs (mkDsEnvs this_mod rdr_env type_env msg_var) thing_inside }
+ ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var
+ ; setEnvs ds_envs thing_inside }
-mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv
- -> IORef Messages -> (DsGblEnv, DsLclEnv)
+mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
mkDsEnvs mod rdr_env type_env msg_var
- = (gbl_env, lcl_env)
- where
- if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
- if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
- gbl_env = DsGblEnv { ds_mod = mod,
- ds_if_env = (if_genv, if_lenv),
- ds_unqual = mkPrintUnqualified rdr_env,
- ds_msgs = msg_var }
- lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
- ds_loc = noSrcSpan }
+ = do
+ sites_var <- newIORef []
+ let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+ if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod)
+ gbl_env = DsGblEnv { ds_mod = mod,
+ ds_if_env = (if_genv, if_lenv),
+ ds_unqual = mkPrintUnqualified rdr_env,
+ ds_msgs = msg_var,
+ ds_bkptSites = sites_var}
+ lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
+ ds_loc = noSrcSpan,
+ ds_locals = emptyOccEnv }
+
+ return (gbl_env, lcl_env)
+
\end{code}
%************************************************************************
\end{code}
\begin{code}
+getLocalBindsDs :: DsM [Id]
+getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) }
+
+bindLocalsDs :: [Id] -> DsM a -> DsM a
+bindLocalsDs new_ids enclosed_scope =
+ updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids})
+ enclosed_scope
+ where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ]
getBkptSitesDs :: DsM (IORef SiteMap)
getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) }