X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=bd83a55e29bce3e1361ee0cb5794077bfd883990;hp=07a1094d58de98b08937c346db5965a070bac90f;hb=a8427a4125e9b78e88a487eeabf018f1c6e8bc08;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1 diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index 07a1094..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,37 +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 TcHsType ( tcPatSig, UserTypeCtxt(..) ) -import Inst ( newMethodFromName ) -import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv, - tcExtendTyVarEnv2 ) -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} %************************************************************************ @@ -59,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 @@ -87,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 @@ -103,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 @@ -114,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} @@ -144,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 _) @@ -162,21 +153,30 @@ 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 - ; returnM (Match pats' Nothing grhss') } + ; return (Match pats' Nothing grhss') } tc_grhss ctxt Nothing grhss rhs_ty = tcGRHSs ctxt grhss rhs_ty -- No result signature - tc_grhss ctxt (Just res_sig) grhss rhs_ty - = do { (inner_ty, sig_tvs) <- tcPatSig ResSigCtxt res_sig rhs_ty - ; tcExtendTyVarEnv2 sig_tvs $ - tcGRHSs ctxt grhss inner_ty } + -- Result type sigs are no longer supported + 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 (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 @@ -191,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 $ @@ -216,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 @@ -239,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 @@ -248,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} @@ -263,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 @@ -275,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 @@ -313,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 @@ -330,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 @@ -386,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. @@ -396,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, @@ -410,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 @@ -433,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 @@ -468,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) @@ -500,16 +506,13 @@ checkArgs fun (MatchGroup (match1:matches) _) args_in_match :: LMatch Name -> Int args_in_match (L _ (Match pats _ _)) = length pats +checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty \end{code} \begin{code} 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}