X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=db9089c30e6b1873a65252b20c8dac04ba288a36;hp=37fbd190f811bc8b6a43d20eb20c89bb4876d875;hb=259d5ea8479dbbf0220335c740efebec1bc19a7f;hpb=27de38efce6d73d2a0209f803cfa98c82773e773 diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 37fbd19..db9089c 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -12,7 +12,7 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, tcDoStmt, tcMDoStmt, tcGuardStmt ) where -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr ) +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr ) import HsSyn import TcRnMonad @@ -73,7 +73,7 @@ tcMatchesFun fun_name inf matches exp_ty -- This is one of two places places we call subFunTys -- The point is that if expected_y is a "hole", we want -- to make pat_tys and rhs_ty as "holes" too. - ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty -> + ; subFunTys doc n_pats exp_ty (Just (FunSigCtxt fun_name)) $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty matches } where @@ -105,7 +105,7 @@ tcMatchesCase ctxt scrut_ty matches res_ty tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId) tcMatchLambda match res_ty - = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty -> + = subFunTys doc n_pats res_ty Nothing $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match where n_pats = matchGroupArity match @@ -166,7 +166,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') <- tcLamPats pats pat_tys rhs_ty $ + do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys rhs_ty $ tc_grhss ctxt maybe_rhs_sig grhss ; return (Match pats' Nothing grhss') } @@ -267,7 +267,7 @@ tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId) tcBody body res_ty = do { traceTc (text "tcBody" <+> ppr res_ty) - ; body' <- tcPolyExpr body res_ty + ; body' <- tcMonoExpr body res_ty ; return body' } \end{code} @@ -326,9 +326,9 @@ tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside ; thing <- thing_inside res_ty ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) } -tcGuardStmt _ (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRho rhs - ; (pat', thing) <- tcLamPat pat rhs_ty 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 thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcGuardStmt _ stmt _ _ @@ -342,10 +342,10 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) -> TcStmtChecker -- A generator, pat <- rhs -tcLcStmt m_tc _ (BindStmt pat rhs _ _) res_ty thing_inside +tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty -> tcMonoExpr rhs (mkTyConApp m_tc [ty]) - ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard @@ -404,7 +404,7 @@ tcLcStmt m_tc ctxt (TransformStmt (stmts, binders) usingExpr maybeByExpr) elt_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] - (byExpr', tTy) <- tcInferRho byExpr + (byExpr', tTy) <- tcInferRhoNC byExpr usingExpr' <- tcPolyExpr usingExpr (mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListTy))) return (usingExpr', Just byExpr') @@ -428,7 +428,7 @@ tcLcStmt m_tc ctxt (GroupStmt (stmts, bindersMap) groupByClause) elt_ty thing_in tcPolyExpr usingExpr (mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListListTy)) >>= (return . GroupByNothing) GroupBySomething eitherUsingExpr byExpr -> do -- We must infer a type such that byExpr :: t - (byExpr', tTy) <- tcInferRho byExpr + (byExpr', tTy) <- tcInferRhoNC byExpr -- If it exists, we then check that usingExpr :: forall a. (a -> t) -> [a] -> [[a]] let expectedUsingType = mkForAllTy alphaTyVar ((alphaTy `mkFunTy` tTy) `mkFunTy` (alphaListTy `mkFunTy` alphaListListTy)) @@ -463,8 +463,8 @@ tcLcStmt _ _ stmt _ _ tcDoStmt :: TcStmtChecker -tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRho rhs +tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- We should use type *inference* for the RHS computations, -- becuase of GADTs. -- do { pat <- rhs; } @@ -489,13 +489,13 @@ tcDoStmt _ (BindStmt pat rhs bind_op fail_op) res_ty thing_inside then return noSyntaxExpr else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) - ; (pat', thing) <- tcLamPat pat pat_ty new_res_ty thing_inside + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty new_res_ty thing_inside ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside - = do { (rhs', rhs_ty) <- tcInferRho rhs + = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty ; (then_op', new_res_ty) <- @@ -522,9 +522,9 @@ tcDoStmt _ stmt _ _ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference -> TcStmtChecker -tcMDoStmt tc_rhs _ (BindStmt pat rhs _ _) res_ty thing_inside +tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside