tcProc pat cmd exp_ty
-- gaw 2004 FIX?
- = do { arr_ty <- newTyFlexiVarTy arrowTyConKind
+ = newArrowScope $ do
+ { arr_ty <- newTyFlexiVarTy arrowTyConKind
; [arg_ty, res_ty] <- newTyFlexiVarTys 2 liftedTypeKind
; zapExpectedTo exp_ty (mkAppTys arr_ty [arg_ty,res_ty])
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
- ; ([pat'], cmd') <- incProcLevel $
- tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
+ ; ([pat'], cmd') <- tcMatchPats [pat] [Check arg_ty] (Check res_ty) $
tcCmdTop cmd_env cmd ([], res_ty)
-- The False says don't do GADT type refinement
-- This is a conservative choice, but I'm not sure of the consequences
\begin{code}
type CmdStack = [TcTauType]
-data CmdEnv = CmdEnv { cmd_arr :: TcType } -- The arrow type constructor, of kind *->*->*
+data CmdEnv
+ = CmdEnv {
+ cmd_arr :: TcType -- arrow type constructor, of kind *->*->*
+ }
mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType
mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]
do { arg_ty <- newTyFlexiVarTy openTypeKind
; let fun_ty = mkCmdArrTy env (foldl mkPairTy arg_ty cmd_stk) res_ty
- ; fun' <- pop_arrow_binders (tcCheckRho fun fun_ty)
+ ; fun' <- select_arrow_scope (tcCheckRho fun fun_ty)
; arg' <- tcCheckRho arg arg_ty
; return (HsArrApp fun' arg' fun_ty ho_app lr) }
where
- -- Before type-checking f, remove the "arrow binders" from the
- -- environment in the (-<) case.
+ -- Before type-checking f, use the environment of the enclosing
+ -- proc for the (-<) case.
-- Local bindings, inside the enclosing proc, are not in scope
-- inside f. In the higher-order case (-<<), they are.
- pop_arrow_binders tc = case ho_app of
+ select_arrow_scope tc = case ho_app of
HsHigherOrderApp -> tc
- HsFirstOrderApp -> popArrowBinders tc
+ HsFirstOrderApp -> escapeArrowScope tc
-------------------------------------------
-- Command application
e_res_ty
-- Check expr
- ; (expr', lie) <- popArrowBinders (getLIE (tcCheckRho expr e_ty))
+ ; (expr', lie) <- escapeArrowScope (getLIE (tcCheckRho expr e_ty))
; inst_binds <- tcSimplifyCheck sig_msg [w_tv] [] lie
-- Check that the polymorphic variable hasn't been unified with anything
not (w_tv `elemVarSet` tyVarsOfTypes arg_tys))
(badFormFun i tup_ty')
- ; tcCmdTop (CmdEnv { cmd_arr = b }) cmd (arg_tys, s) }
+ ; tcCmdTop (env { cmd_arr = b }) cmd (arg_tys, s) }
unscramble :: TcType -> (TcType, [TcType])
-- unscramble ((w,s1) .. sn) = (w, [s1..sn])