X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=bd83a55e29bce3e1361ee0cb5794077bfd883990;hp=27d1e9b3b68120c1ae2339935f5444deb97128f6;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=5a552652286f9a019d37ded2428fb6543b169310 diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 27d1e9b..bd83a55 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -1,12 +1,14 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcMatches]{Typecheck some @Matches@} + +TcMatches: Typecheck some @Matches@ \begin{code} module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, matchCtxt, TcMatchCtxt(..), - tcStmts, tcDoStmts, + tcStmts, tcDoStmts, tcBody, tcDoStmt, tcMDoStmt, tcGuardStmt ) where @@ -14,35 +16,24 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr ) -import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..), - Match(..), LMatch, GRHSs(..), GRHS(..), - Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..), - pprMatch, isIrrefutableHsPat, mkHsCoerce, - pprMatchContext, pprStmtContext, - noSyntaxExpr, matchGroupArity, pprMatches, - ExprCoFn ) - +import HsSyn import TcRnMonad -import Inst ( newMethodFromName ) -import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv ) -import TcPat ( PatCtxt(..), tcPats, tcPat ) -import TcMType ( newFlexiTyVarTy, newFlexiTyVarTys ) -import TcType ( TcType, TcRhoType, - BoxySigmaType, BoxyRhoType, - mkFunTys, mkFunTy, mkAppTy, mkTyConApp, - liftedTypeKind ) -import TcBinds ( tcLocalBinds ) -import TcUnify ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy, - subFunTys, tcSubExp, withBox ) -import TcSimplify ( bindInstsOfLocalFuns ) -import Name ( Name ) -import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy ) -import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName ) -import Id ( idType, mkLocalId ) -import TyCon ( TyCon ) +import TcGadt +import Inst +import TcEnv +import TcPat +import TcMType +import TcType +import TcBinds +import TcUnify +import TcSimplify +import Name +import TysWiredIn +import PrelNames +import Id +import TyCon import Outputable -import SrcLoc ( Located(..), getLoc ) -import ErrUtils ( Message ) +import SrcLoc \end{code} %************************************************************************ @@ -57,12 +48,12 @@ is used in error messages. It checks that all the equations have the same number of arguments before using @tcMatches@ to do the work. \begin{code} -tcMatchesFun :: Name +tcMatchesFun :: Name -> Bool -> MatchGroup Name -> BoxyRhoType -- Expected type of function - -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body + -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body -tcMatchesFun fun_name matches exp_ty +tcMatchesFun fun_name inf matches exp_ty = do { -- Check that they all have the same no of arguments -- Location is in the monad, set the caller so that -- any inter-equation error messages get some vaguely @@ -85,7 +76,7 @@ tcMatchesFun fun_name matches exp_ty doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name) <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument")) n_pats = matchGroupArity matches - match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcPolyExpr } + match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody } \end{code} @tcMatchesCase@ doesn't do the argument-count check because the @@ -101,7 +92,7 @@ tcMatchesCase :: TcMatchCtxt -- Case context tcMatchesCase ctxt scrut_ty matches res_ty = tcMatches ctxt [scrut_ty] res_ty matches -tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId) +tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId) tcMatchLambda match res_ty = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty -> tcMatches match_ctxt pat_tys rhs_ty match @@ -112,17 +103,19 @@ tcMatchLambda match res_ty -- The pprSetDepth makes the abstraction print briefly ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))] match_ctxt = MC { mc_what = LambdaExpr, - mc_body = tcPolyExpr } + mc_body = tcBody } \end{code} @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. \begin{code} tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId) -tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty +-- Used for pattern bindings +tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (emptyRefinement, res_ty) + -- emptyRefinement: no refinement in a pattern binding where match_ctxt = MC { mc_what = PatBindRhs, - mc_body = tcPolyExpr } + mc_body = tcBody } \end{code} @@ -142,7 +135,7 @@ tcMatches :: TcMatchCtxt data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is mc_body :: LHsExpr Name -- Type checker for a body of an alternative - -> BoxyRhoType + -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId) } tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _) @@ -160,8 +153,8 @@ tcMatch ctxt pat_tys rhs_ty match = wrapLocM (tc_match ctxt pat_tys rhs_ty) match where tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss) - = addErrCtxt (matchCtxt (mc_what ctxt) match) $ - do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $ + = add_match_ctxt match $ + do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $ tc_grhss ctxt maybe_rhs_sig grhss ; return (Match pats' Nothing grhss') } @@ -169,13 +162,21 @@ tcMatch ctxt pat_tys rhs_ty match = tcGRHSs ctxt grhss rhs_ty -- No result signature -- Result type sigs are no longer supported - tc_grhss ctxt (Just res_sig) grhss rhs_ty + tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty) = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature") <+> ppr res_sig) - ; tcGRHSs ctxt grhss rhs_ty } + ; tcGRHSs ctxt grhss (co, rhs_ty) } + + -- For (\x -> e), tcExpr has already said "In the expresssion \x->e" + -- so we don't want to add "In the lambda abstraction \x->e" + add_match_ctxt match thing_inside + = case mc_what ctxt of + LambdaExpr -> thing_inside + m_ctxt -> addErrCtxt (matchCtxt m_ctxt match) thing_inside ------------- -tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId) +tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType) + -> TcM (GRHSs TcId) -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like @@ -190,7 +191,7 @@ tcGRHSs ctxt (GRHSs grhss binds) res_ty ; returnM (GRHSs grhss' binds') } ------------- -tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId) +tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId) tcGRHS ctxt res_ty (GRHS guards rhs) = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $ @@ -215,21 +216,24 @@ tcDoStmts :: HsStmtContext Name -> TcM (HsExpr TcId) -- Returns a HsDo tcDoStmts ListComp stmts body res_ty = do { elt_ty <- boxySplitListTy res_ty - ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $ - tcBody (doBodyCtxt ListComp body) body + ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts + (emptyRefinement,elt_ty) $ + tcBody body ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) } tcDoStmts PArrComp stmts body res_ty = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty - ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $ - tcBody (doBodyCtxt PArrComp body) body + ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts + (emptyRefinement, elt_ty) $ + tcBody body ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } tcDoStmts DoExpr stmts body res_ty = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty - ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts res_ty' $ - tcBody (doBodyCtxt DoExpr body) body + ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts + (emptyRefinement, res_ty') $ + tcBody body ; return (HsDo DoExpr stmts' body' res_ty') } tcDoStmts ctxt@(MDoExpr _) stmts body res_ty @@ -238,8 +242,9 @@ tcDoStmts ctxt@(MDoExpr _) stmts body res_ty tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty -> tcMonoExpr rhs (mkAppTy m_ty pat_ty) - ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $ - tcBody (doBodyCtxt ctxt body) body + ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts + (emptyRefinement, res_ty') $ + tcBody body ; let names = [mfixName, bindMName, thenMName, returnMName, failMName] ; insts <- mapM (newMethodFromName DoOrigin m_ty) names @@ -247,10 +252,12 @@ tcDoStmts ctxt@(MDoExpr _) stmts body res_ty tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt) -tcBody :: Message -> LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId) -tcBody ctxt body res_ty - = -- addErrCtxt ctxt $ -- This context adds little that is useful - tcPolyExpr body res_ty +tcBody :: LHsExpr Name -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId) +tcBody body (reft, res_ty) + = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft) + ; let (co, res_ty') = refineResType reft res_ty + ; body' <- tcPolyExpr body res_ty' + ; return (mkLHsWrap co body') } \end{code} @@ -262,11 +269,11 @@ tcBody ctxt body res_ty \begin{code} type TcStmtChecker - = forall thing. HsStmtContext Name - -> Stmt Name - -> BoxyRhoType -- Result type for comprehension - -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt - -> TcM (Stmt TcId, thing) + = forall thing. HsStmtContext Name + -> Stmt Name + -> (Refinement, BoxyRhoType) -- Result type for comprehension + -> ((Refinement,BoxyRhoType) -> TcM thing) -- Checker for what follows the stmt + -> TcM (Stmt TcId, thing) -- The incoming BoxyRhoType may be refined by type refinements -- before being passed to the thing_inside @@ -274,8 +281,8 @@ type TcStmtChecker tcStmts :: HsStmtContext Name -> TcStmtChecker -- NB: higher-rank type -> [LStmt Name] - -> BoxyRhoType - -> (BoxyRhoType -> TcM thing) + -> (Refinement, BoxyRhoType) + -> ((Refinement, BoxyRhoType) -> TcM thing) -> TcM ([LStmt TcId], thing) -- Note the higher-rank type. stmt_chk is applied at different @@ -312,7 +319,7 @@ tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRho rhs - ; (pat', thing) <- tcPat LamPat pat rhs_ty res_ty thing_inside + ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcGuardStmt ctxt stmt res_ty thing_inside @@ -329,7 +336,7 @@ tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) 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) <- tcPat LamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard @@ -385,7 +392,7 @@ tcLcStmt m_tc ctxt stmt elt_ty thing_inside tcDoStmt :: TcType -- Monad type, m -> TcStmtChecker -tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside +tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty -> tcMonoExpr rhs (mkAppTy m_ty pat_ty) -- We should use type *inference* for the RHS computations, becuase of GADTs. @@ -395,7 +402,7 @@ tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside -- We do inference on rhs, so that information about its type can be refined -- when type-checking the pattern. - ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty, @@ -409,14 +416,14 @@ tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } -tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) res_ty thing_inside +tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b a_ty <- newFlexiTyVarTy liftedTypeKind ; let rhs_ty = mkAppTy m_ty a_ty then_ty = mkFunTys [rhs_ty, res_ty] res_ty ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty ; rhs' <- tcPolyExpr rhs rhs_ty - ; thing <- thing_inside res_ty + ; thing <- thing_inside reft_res_ty ; return (ExprStmt rhs' then_op' rhs_ty, thing) } tcDoStmt m_ty ctxt stmt res_ty thing_inside @@ -432,7 +439,7 @@ tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference -> TcStmtChecker tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside + ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside @@ -467,7 +474,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid -- poly_id may have a polymorphic type -- but mono_ty is just a monomorphic type variable ; co_fn <- tcSubExp (idType poly_id) mono_ty - ; return (mkHsCoerce co_fn (HsVar poly_id)) } + ; return (mkHsWrap co_fn (HsVar poly_id)) } tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt) @@ -506,10 +513,6 @@ checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match) -doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc -doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon) - 4 (ppr body) - stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon) 4 (ppr stmt) \end{code}