X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=46b67da9be0db0b97d2bd7c2ac176342933b9fca;hp=255d97bed6813fa5021799b0abab56336e03a575;hb=ba05282d3915e7051b3f016366b971a8506b0093;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 255d97b..46b67da 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -17,7 +17,6 @@ import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId, import HsSyn import TcRnMonad -import Inst import TcEnv import TcPat import TcMType @@ -26,13 +25,11 @@ import TcBinds import TcUnify import Name import TysWiredIn -import PrelNames import Id import TyCon import TysPrim import Coercion ( mkSymCoI ) import Outputable -import VarSet import BasicTypes ( Arity ) import Util import SrcLoc @@ -76,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty ; checkArgs fun_name matches ; (wrap_gen, (wrap_fun, group)) - <- tcGen (SigSkol (FunSigCtxt fun_name)) emptyVarSet exp_ty $ \ _ exp_rho -> + <- tcGen (SigSkol (FunSigCtxt fun_name)) exp_ty $ \ _ exp_rho -> -- Note [Polymorphic expected type for tcMatchesFun] matchFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty matches @@ -186,7 +183,7 @@ tcMatch ctxt pat_tys rhs_ty match where tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss) = add_match_ctxt match $ - do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $ tc_grhss ctxt maybe_rhs_sig grhss rhs_ty ; return (Match pats' Nothing grhss') } @@ -265,19 +262,10 @@ tcDoStmts DoExpr stmts body res_ty tcBody body ; return (HsDo DoExpr stmts' body' res_ty) } -tcDoStmts ctxt@(MDoExpr _) stmts body res_ty - = do { (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty - ; let res_ty' = mkAppTy m_ty elt_ty -- The matchExpected consumes res_ty - tc_rhs rhs = tcInfer $ \ pat_ty -> - tcMonoExpr rhs (mkAppTy m_ty pat_ty) - - ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $ +tcDoStmts MDoExpr stmts body res_ty + = do { (stmts', body') <- tcStmts MDoExpr tcDoStmt stmts res_ty $ tcBody body - - ; let names = [mfixName, bindMName, thenMName, returnMName, failMName] - ; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names - ; return $ mkHsWrapCoI coi $ - HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' } + ; return (HsDo MDoExpr stmts' body' res_ty) } tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) @@ -345,7 +333,7 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat rhs_ty $ thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -363,7 +351,7 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty]) - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -419,12 +407,17 @@ tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty th case maybeByExpr of Nothing -> do -- We must validate that usingExpr :: forall a. [a] -> [a] - usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy)) + let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy) + usingExpr' <- tcPolyExpr usingExpr using_ty return (usingExpr', Nothing) Just byExpr -> do - -- We must infer a type such that e :: t and then check that usingExpr :: forall a. (a -> t) -> [a] -> [a] + -- We must infer a type such that e :: t and then check that + -- usingExpr :: forall a. (a -> t) -> [a] -> [a] (byExpr', tTy) <- tcInferRhoNC byExpr - usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy))) + let using_ty = mkForAllTy alphaTyVar $ + (alphaTy `mkFunTy` tTy) + `mkFunTy` alphaListTy `mkFunTy` alphaListTy + usingExpr' <- tcPolyExpr usingExpr using_ty return (usingExpr', Just byExpr') binders' <- tcLookupLocalIds binders @@ -439,24 +432,26 @@ tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <- tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do - (by', using_ty) <- case by of - Nothing -> -- check that using :: forall a. [a] -> [[a]] - return (Nothing, mkForAllTy alphaTyVar $ - alphaListTy `mkFunTy` alphaListListTy) - - Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]] - -- where by :: t - do { (by_e', t_ty) <- tcInferRhoNC by_e - ; return (Just by_e', mkForAllTy alphaTyVar $ - (alphaTy `mkFunTy` t_ty) - `mkFunTy` alphaListTy - `mkFunTy` alphaListListTy) } + (by', using_ty) <- + case by of + Nothing -> -- check that using :: forall a. [a] -> [[a]] + return (Nothing, mkForAllTy alphaTyVar $ + alphaListTy `mkFunTy` alphaListListTy) + + Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]] + -- where by :: t + do { (by_e', t_ty) <- tcInferRhoNC by_e + ; return (Just by_e', mkForAllTy alphaTyVar $ + (alphaTy `mkFunTy` t_ty) + `mkFunTy` alphaListTy + `mkFunTy` alphaListListTy) } -- Find the Ids (and hence types) of all old binders bndr_ids <- tcLookupLocalIds bndr_names return (bndr_ids, by', using_ty, elt_ty') - -- Ensure that every old binder of type b is linked up with its new binder which should have type [b] + -- Ensure that every old binder of type b is linked up with + -- its new binder which should have type [b] ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids bindersMap' = bndr_ids `zip` list_bndr_ids -- See Note [GroupStmt binder map] in HsExpr @@ -465,7 +460,8 @@ tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') } Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) } - -- Type check the thing in the environment with these new binders and return the result + -- Type check the thing in the environment with + -- these new binders and return the result ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty') ; return (GroupStmt stmts' bindersMap' by' using', thing) } where @@ -473,7 +469,8 @@ tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside alphaListListTy = mkTyConApp m_tc [alphaListTy] mk_list_bndr :: Name -> TcId -> TcId - mk_list_bndr list_bndr_name bndr_id = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id]) + mk_list_bndr list_bndr_name bndr_id + = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id]) tcLcStmt _ _ stmt _ _ = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) @@ -507,7 +504,7 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) ; rhs' <- tcMonoExprNC rhs rhs_ty - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside new_res_ty ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } @@ -563,7 +560,7 @@ tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing) + , recS_rec_rets = tup_rets }, thing) }} tcDoStmt _ stmt _ _ @@ -591,7 +588,7 @@ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference -> TcStmtChecker tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty $ + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ thing_inside res_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } @@ -600,7 +597,8 @@ tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside ; thing <- thing_inside res_ty ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) } -tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside +tcMDoStmt tc_rhs ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames + , recS_rec_ids = recNames }) res_ty thing_inside = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind ; let rec_ids = zipWith mkLocalId recNames rec_tys ; tcExtendIdEnv rec_ids $ do @@ -617,11 +615,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing -- some of them with polymorphic things with the same Name -- (see note [RecStmt] in HsExpr) --- Need the bindLocalMethods if we re-add Method constraints --- ; lie_binds <- bindLocalMethods lie later_ids - ; let lie_binds = emptyTcEvBinds - - ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing) + ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets, thing) }} tcMDoStmt _ _ stmt _ _ @@ -653,6 +647,6 @@ checkArgs fun (MatchGroup (match1:matches) _) args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats -checkArgs _ _ = panic "TcPat.checkArgs" -- Matches always non-empty +checkArgs fun _ = pprPanic "TcPat.checkArgs" (ppr fun) -- Matches always non-empty \end{code}