X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=a73b1d3a91de9f8fd41dfff2ecbd62090919e790;hp=255d97bed6813fa5021799b0abab56336e03a575;hb=b10d7d079ec9c3fc22d4700fe484dd297bddb805;hpb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516 diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 255d97b..a73b1d3 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -32,7 +32,6 @@ import TyCon import TysPrim import Coercion ( mkSymCoI ) import Outputable -import VarSet import BasicTypes ( Arity ) import Util import SrcLoc @@ -76,7 +75,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 +185,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') } @@ -345,7 +344,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 +362,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 +418,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 +443,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 +471,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 +480,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 +515,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) } @@ -591,7 +599,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) } @@ -653,6 +661,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}