Commit eca538c8 authored by mnislaih's avatar mnislaih

Capturing and keeping track of local bindins in the desugarer

Used in the desugaring of the breakpoint primitive
parent 1df34b32
......@@ -290,8 +290,11 @@ dsExpr (HsCase discrim matches)
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)
......@@ -602,11 +605,16 @@ dsDo stmts body result_ty
; 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)
......@@ -666,7 +674,7 @@ dsMDo tbl stmts body result_ty
; 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)
......
......@@ -14,6 +14,7 @@ import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds )
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn
import HsUtils
import CoreSyn
import Var
import Type
......@@ -27,6 +28,7 @@ import TysWiredIn
import PrelNames
import Name
import SrcLoc
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
......@@ -56,18 +58,23 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext
-> 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}
......@@ -110,7 +117,8 @@ matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty
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
......@@ -118,7 +126,8 @@ matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty
-- 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}
......
......@@ -23,7 +23,7 @@ module DsMonad (
DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
getBkptSitesDs,
bindLocalsDs, getLocalBindsDs, getBkptSitesDs,
-- Warnings
DsWarning, warnDs, failWithDs,
......@@ -143,7 +143,8 @@ data DsGblEnv = DsGblEnv {
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
......@@ -166,7 +167,7 @@ initDs :: HscEnv
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)
......@@ -194,21 +195,26 @@ initDsTc thing_inside
; 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}
%************************************************************************
......@@ -328,6 +334,14 @@ dsExtendMetaEnv menv thing_inside
\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) }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment