import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho )
import HsSyn
-import TcHsSyn ( mkHsLet )
+import TcHsSyn ( mkHsDictLet )
-import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
- TcMatchCtxt(..), tcMatchesCase )
+import TcMatches ( tcMatchPats, matchCtxt, tcStmts, tcMDoStmt, tcGuardStmt,
+ TcMatchCtxt(..), tcMatchesCase )
import TcType ( TcType, TcTauType, TcRhoType, mkFunTys, mkTyConApp,
mkTyVarTy, mkAppTys, tcSplitTyConApp_maybe, tcEqType,
SkolemInfo(..) )
-import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVar, zonkTcType )
-import TcBinds ( tcBindsAndThen )
+import TcMType ( newTyFlexiVarTy, newTyFlexiVarTys, tcSkolTyVars, zonkTcType )
+import TcBinds ( tcLocalBinds )
import TcSimplify ( tcSimplifyCheck )
import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo )
import TcRnMonad
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]
; return (HsPar cmd') }
tc_cmd env (HsLet binds (L body_loc body)) res_ty
- = tcBindsAndThen glue binds $
- setSrcSpan body_loc $
- tc_cmd env body res_ty
- where
- glue binds expr = HsLet [binds] (L body_loc expr)
+ = do { (binds', body') <- tcLocalBinds binds $
+ setSrcSpan body_loc $
+ tc_cmd env body res_ty
+ ; return (HsLet binds' (L body_loc body')) }
tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $
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
n_pats = length pats
stk' = drop n_pats cmd_stk
match_ctxt = LambdaExpr -- Maybe KappaExpr?
+ pg_ctxt = PatGuard match_ctxt
tc_grhss (GRHSs grhss binds)
- = tcBindsAndThen glueBindsOnGRHSs binds $
- do { grhss' <- mappM (wrapLocM tc_grhs) grhss
- ; return (GRHSs grhss' []) }
-
- stmt_ctxt = SC { sc_what = PatGuard match_ctxt,
- sc_rhs = tcInferRho,
- sc_body = \ body -> tcCmd env body (stk', res_ty),
- sc_ty = res_ty } -- ToDo: Is this right?
- tc_grhs (GRHS guarded)
- = do { guarded' <- tcStmts stmt_ctxt guarded
- ; return (GRHS guarded') }
+ = do { (binds', grhss') <- tcLocalBinds binds $
+ mappM (wrapLocM tc_grhs) grhss
+ ; return (GRHSs grhss' binds') }
+
+ tc_grhs (GRHS guards body)
+ = do { (guards', rhs') <- tcStmts pg_ctxt
+ (tcGuardStmt res_ty)
+ guards
+ (tcCmd env body (stk', res_ty))
+ ; return (GRHS guards' rhs') }
-------------------------------------------
-- Do notation
-tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty)
+tc_cmd env cmd@(HsDo do_or_lc stmts body ty) (cmd_stk, res_ty)
= do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd)
- ; stmts' <- tcStmts stmt_ctxt stmts
- ; return (HsDo do_or_lc stmts' [] res_ty) }
- -- The 'methods' needed for the HsDo are in the enclosing HsCmd
- -- hence the empty list here
+ ; (stmts', body') <- tcStmts do_or_lc tc_stmt stmts $
+ tcCmd env body ([], res_ty)
+ ; return (HsDo do_or_lc stmts' body' res_ty) }
where
- stmt_ctxt = SC { sc_what = do_or_lc,
- sc_rhs = tc_rhs,
- sc_body = tc_ret,
- sc_ty = res_ty }
-
+ tc_stmt = tcMDoStmt res_ty tc_rhs
tc_rhs rhs = do { ty <- newTyFlexiVarTy liftedTypeKind
; rhs' <- tcCmd env rhs ([], ty)
; return (rhs', ty) }
- tc_ret body = tcCmd env body ([], res_ty)
-----------------------------------------------------------------
--- Arrow ``forms'' (| e |) c1 .. cn
+-- Arrow ``forms'' (| e c1 .. cn |)
--
-- G |-b c : [s1 .. sm] s
-- pop(G) |- e : forall w. b ((w,s1) .. sm) s
-- -> a ((w,t1) .. tn) t
-- e \not\in (s, s1..sm, t, t1..tn)
-- ----------------------------------------------
--- G |-a (| e |) c : [t1 .. tn] t
+-- G |-a (| e c |) : [t1 .. tn] t
tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty)
= addErrCtxt (cmdCtxt cmd) $
do { cmds_w_tys <- zipWithM new_cmd_ty cmd_args [1..]
; span <- getSrcSpanM
- ; w_tv <- tcSkolTyVar (ArrowSkol span) alphaTyVar
+ ; [w_tv] <- tcSkolTyVars (ArrowSkol span) [alphaTyVar]
; let w_ty = mkTyVarTy w_tv -- Just a convenient starting point
-- a ((w,t1) .. tn) t
e_res_ty
-- Check expr
- ; (expr', lie) <- 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
-- the s1..sm and check each cmd
; cmds' <- mapM (tc_cmd w_tv) cmds_w_tys
- ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsLet inst_binds expr')) fixity cmds')
+ ; returnM (HsArrForm (mkHsTyLam [w_tv] (mkHsDictLet inst_binds expr')) fixity cmds')
}
where
-- Make the types
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])
\begin{code}
mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]
-arrowTyConKind :: Kind -- *->*->*
+arrowTyConKind :: Kind -- *->*->*
arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind
\end{code}
projects / ghc-hetmet.git / blobdiff