diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/typecheck/TcArrows.hs | 3 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnMonad.hs | 22 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnTypes.hs | 34 |
3 files changed, 38 insertions, 21 deletions
diff --git a/compiler/typecheck/TcArrows.hs b/compiler/typecheck/TcArrows.hs index f1546b4e42..b4c3bcc60f 100644 --- a/compiler/typecheck/TcArrows.hs +++ b/compiler/typecheck/TcArrows.hs @@ -197,8 +197,6 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) do { arg_ty <- newFlexiTyVarTy openTypeKind ; let fun_ty = mkCmdArrTy env arg_ty res_ty ; fun' <- select_arrow_scope (tcMonoExpr fun fun_ty) - -- ToDo: There should be no need for the escapeArrowScope stuff - -- See Note [Escaping the arrow scope] in TcRnTypes ; arg' <- tcMonoExpr arg arg_ty @@ -208,6 +206,7 @@ tc_cmd env cmd@(HsCmdArrApp fun arg _ ho_app lr) (_, res_ty) -- proc for the (-<) case. -- Local bindings, inside the enclosing proc, are not in scope -- inside f. In the higher-order case (-<<), they are. + -- See Note [Escaping the arrow scope] in TcRnTypes select_arrow_scope tc = case ho_app of HsHigherOrderApp -> tc HsFirstOrderApp -> escapeArrowScope tc diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 013b8a4ab0..77f2f6189f 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -380,6 +380,28 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env) {- ************************************************************************ * * + Arrow scopes +* * +************************************************************************ +-} + +newArrowScope :: TcM a -> TcM a +newArrowScope + = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) } + +-- Return to the stored environment (from the enclosing proc) +escapeArrowScope :: TcM a -> TcM a +escapeArrowScope + = updLclEnv $ \ env -> + case tcl_arrow_ctxt env of + NoArrowCtxt -> env + ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt + , tcl_lie = lie + , tcl_rdr = rdr_env } + +{- +************************************************************************ +* * Unique supply * * ************************************************************************ diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 7035bf310d..260a636ac8 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -45,7 +45,7 @@ module TcRnTypes( ThLevel, impLevel, outerLevel, thLevel, -- Arrows - ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, + ArrowCtxt(..), -- Canonical constraints Xi, Ct(..), Cts, emptyCts, andCts, andManyCts, pprCts, @@ -603,7 +603,7 @@ data TcLclEnv -- Changes as we move inside an expression = TcLclEnv { tcl_loc :: SrcSpan, -- Source span tcl_ctxt :: [ErrCtxt], -- Error context, innermost on top - tcl_tclvl :: TcLevel, -- Birthplace for new unification variables + tcl_tclvl :: TcLevel, -- Birthplace for new unification variables tcl_th_ctxt :: ThStage, -- Template Haskell context tcl_th_bndrs :: ThBindEnv, -- Binding level of in-scope Names @@ -761,26 +761,22 @@ recording the environment when passing a proc (using newArrowScope), and returning to that (using escapeArrowScope) on the left of -< and the head of (|..|). -All this can be dealt with by the *renamer*; by the time we get to -the *type checker* we have sorted out the scopes +All this can be dealt with by the *renamer*. But the type checker needs +to be involved too. Example (arrowfail001) + class Foo a where foo :: a -> () + data Bar = forall a. Foo a => Bar a + get :: Bar -> () + get = proc x -> case x of Bar a -> foo -< a +Here the call of 'foo' gives rise to a (Foo a) constraint that should not +be captured by the pattern match on 'Bar'. Rather it should join the +constraints from further out. So we must capture the constraint bag +from further out in the ArrowCtxt that we push inwards. -} -data ArrowCtxt +data ArrowCtxt -- Note [Escaping the arrow scope] = NoArrowCtxt - | ArrowCtxt (Env TcGblEnv TcLclEnv) - --- Record the current environment (outside a proc) -newArrowScope :: TcM a -> TcM a -newArrowScope - = updEnv $ \env -> - env { env_lcl = (env_lcl env) { tcl_arrow_ctxt = ArrowCtxt env } } - --- Return to the stored environment (from the enclosing proc) -escapeArrowScope :: TcM a -> TcM a -escapeArrowScope - = updEnv $ \ env -> case tcl_arrow_ctxt (env_lcl env) of - NoArrowCtxt -> env - ArrowCtxt env' -> env' + | ArrowCtxt LocalRdrEnv (TcRef WantedConstraints) + --------------------------- -- TcTyThing |