X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcMatches.lhs;h=3457f32ce07509226bdef966681cae71a6162933;hp=db9089c30e6b1873a65252b20c8dac04ba288a36;hb=fb6d198f498d4e325a540f28aaa6e1d1530839c3;hpb=259d5ea8479dbbf0220335c740efebec1bc19a7f diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs index db9089c..3457f32 100644 --- a/compiler/typecheck/TcMatches.lhs +++ b/compiler/typecheck/TcMatches.lhs @@ -12,7 +12,8 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, tcDoStmt, tcMDoStmt, tcGuardStmt ) where -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcMonoExpr, tcPolyExpr ) +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, + tcMonoExpr, tcMonoExprNC, tcPolyExpr ) import HsSyn import TcRnMonad @@ -110,7 +111,8 @@ tcMatchLambda match res_ty where n_pats = matchGroupArity match doc = sep [ ptext (sLit "The lambda expression") - <+> quotes (pprSetDepth 1 $ pprMatches (LambdaExpr :: HsMatchContext Name) match), + <+> quotes (pprSetDepth (PartWay 1) $ + pprMatches (LambdaExpr :: HsMatchContext Name) match), -- The pprSetDepth makes the abstraction print briefly ptext (sLit "has") <+> speakNOf n_pats (ptext (sLit "argument"))] match_ctxt = MC { mc_what = LambdaExpr, @@ -464,24 +466,22 @@ tcLcStmt _ _ stmt _ _ tcDoStmt :: TcStmtChecker 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; } - -- is rather like - -- case rhs of { pat -> } - -- We do inference on rhs, so that information about its type - -- can be refined when type-checking the pattern. + = do { -- Deal with rebindable syntax: + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + -- This level of generality is needed for using do-notation + -- in full generality; see Trac #1537 + + -- I'd like to put this *after* the tcSyntaxOp + -- (see Note [Treat rebindable syntax first], but that breaks + -- the rigidity info for GADTs. When we move to the new story + -- for GADTs, we can move this after tcSyntaxOp + (rhs', rhs_ty) <- tcInferRhoNC rhs - -- Deal with rebindable syntax: - -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty - -- This level of generality is needed for using do-notation - -- in full generality; see Trac #1537 ; ((bind_op', new_res_ty), pat_ty) <- withBox liftedTypeKind $ \ pat_ty -> withBox liftedTypeKind $ \ new_res_ty -> tcSyntaxOp DoOrigin bind_op - (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) + (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) -- If (but only if) the pattern can fail, -- typecheck the 'fail' operator @@ -489,31 +489,94 @@ tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside then return noSyntaxExpr else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy new_res_ty) + -- We should typecheck the RHS *before* the pattern, + -- because of GADTs. + -- do { pat <- rhs; } + -- is rather like + -- case rhs of { pat -> } + -- We do inference on rhs, so that information about its type + -- can be refined when type-checking the pattern. + ; (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) <- tcInferRhoNC rhs - - -- Deal with rebindable syntax; (>>) :: rhs_ty -> new_res_ty -> res_ty - ; (then_op', new_res_ty) <- + = do { -- Deal with rebindable syntax; + -- (>>) :: rhs_ty -> new_res_ty -> res_ty + -- See also Note [Treat rebindable syntax first] + ((then_op', rhs_ty), new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty -> + withBox liftedTypeKind $ \ rhs_ty -> tcSyntaxOp DoOrigin then_op (mkFunTys [rhs_ty, new_res_ty] res_ty) + ; rhs' <- tcMonoExprNC rhs rhs_ty ; thing <- thing_inside new_res_ty ; return (ExprStmt rhs' then_op' rhs_ty, thing) } -tcDoStmt ctxt (RecStmt {}) _ _ - = failWithTc (ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt) - -- This case can't be caught in the renamer - -- see RnExpr.checkRecStmt +tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names + , recS_rec_ids = rec_names, recS_ret_fn = ret_op + , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op }) + res_ty thing_inside + = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names + ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind + ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys + tup_ty = mkBoxedTupleTy tup_elt_tys + + ; tcExtendIdEnv tup_ids $ do + { ((stmts', (ret_op', tup_rets)), stmts_ty) + <- withBox liftedTypeKind $ \ stmts_ty -> + tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> + do { tup_rets <- zipWithM tc_ret tup_names tup_elt_tys + ; ret_op' <- tcSyntaxOp DoOrigin ret_op (mkFunTy tup_ty inner_res_ty) + ; return (ret_op', tup_rets) } + + ; (mfix_op', mfix_res_ty) <- withBox liftedTypeKind $ \ mfix_res_ty -> + tcSyntaxOp DoOrigin mfix_op + (mkFunTy (mkFunTy tup_ty stmts_ty) mfix_res_ty) + + ; (bind_op', new_res_ty) <- withBox liftedTypeKind $ \ new_res_ty -> + tcSyntaxOp DoOrigin bind_op + (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty) + + ; (thing,lie) <- getLIE (thing_inside new_res_ty) + ; lie_binds <- bindInstsOfLocalFuns lie tup_ids + + ; let rec_ids = takeList rec_names tup_ids + ; later_ids <- tcLookupLocalIds later_names + ; traceTc (text "tcdo" <+> vcat [ppr rec_ids <+> ppr (map idType rec_ids), + ppr later_ids <+> ppr (map idType later_ids)]) + ; 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 = lie_binds }, thing) + }} + where + -- Unify the types of the "final" Ids with those of "knot-tied" Ids + tc_ret rec_name mono_ty + = do { poly_id <- tcLookupId rec_name + -- poly_id may have a polymorphic type + -- but mono_ty is just a monomorphic type variable + ; co_fn <- tcSubExp DoOrigin (idType poly_id) mono_ty + ; return (mkHsWrap co_fn (HsVar poly_id)) } tcDoStmt _ stmt _ _ = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt) +\end{code} +Note [Treat rebindable syntax first] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When typechecking + do { bar; ... } :: IO () +we want to typecheck 'bar' in the knowledge that it should be an IO thing, +pushing info from the context into the RHS. To do this, we check the +rebindable syntax first, and push that information into (tcMonoExprNC rhs). +Otherwise the error shows up when cheking the rebindable syntax, and +the expected/inferred stuff is back to front (see Trac #3613). + +\begin{code} -------------------------------- -- Mdo-notation -- The distinctive features here are @@ -532,7 +595,7 @@ 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 stmts laterNames recNames _ _ _ _ _) res_ty thing_inside = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind ; let rec_ids = zipWith mkLocalId recNames rec_tys ; tcExtendIdEnv rec_ids $ do @@ -550,7 +613,7 @@ tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_insid -- (see note [RecStmt] in HsExpr) ; lie_binds <- bindInstsOfLocalFuns lie later_ids - ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing) + ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing) }} where -- Unify the types of the "final" Ids with those of "knot-tied" Ids