X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcArrows.lhs;h=38ca1f6341c03f44ddc2692e349c087c4d7b8b08;hb=2c6f7109e521e906fda9e3ed7c78b85b7bffcea1;hp=794fa093c7429b758c334edc57e2525acf90fbfa;hpb=1dfb756e01201c62ddde93010b3384d4d9644ad6;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index 794fa09..38ca1f6 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -11,16 +11,16 @@ module TcArrows ( tcProc ) where 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, tcSkolTyVars, zonkTcType ) -import TcBinds ( tcBindsAndThen ) +import TcBinds ( tcLocalBinds ) import TcSimplify ( tcSimplifyCheck ) import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo ) import TcRnMonad @@ -50,13 +50,13 @@ tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr 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 @@ -74,7 +74,10 @@ tcProc pat cmd exp_ty \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] @@ -108,11 +111,10 @@ tc_cmd env (HsPar cmd) res_ty ; 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) $ @@ -142,19 +144,19 @@ tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) 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 @@ -195,39 +197,33 @@ tc_cmd env cmd@(HsLam (MatchGroup [L mtch_loc (match@(Match pats maybe_rhs_sig g 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) ----------------------------------------------------------------- @@ -256,7 +252,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) 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 @@ -267,7 +263,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) -- 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 @@ -295,7 +291,7 @@ tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) 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]) @@ -330,7 +326,7 @@ tc_cmd env cmd _ \begin{code} mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2] -arrowTyConKind :: Kind -- *->*->* +arrowTyConKind :: Kind -- *->*->* arrowTyConKind = mkArrowKinds [liftedTypeKind, liftedTypeKind] liftedTypeKind \end{code}