diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-09 14:44:00 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2016-06-10 17:18:56 +0100 |
commit | 3ae18df176081474ecc1ae90d5b6957d660afbb6 (patch) | |
tree | 70de7fd19d930bdcf8763f895bf9ba22639ce88f | |
parent | 0f0b002ce4593a78b8996c77c063c89e09b284e4 (diff) | |
download | haskell-3ae18df176081474ecc1ae90d5b6957d660afbb6.tar.gz |
Minor refactoring
Use tauifyExpType rather than something hand-rolled
-rw-r--r-- | compiler/typecheck/TcExpr.hs | 14 | ||||
-rw-r--r-- | compiler/typecheck/TcMatches.hs | 10 |
2 files changed, 12 insertions, 12 deletions
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 25a62cb7b3..f078ba4da8 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -533,9 +533,10 @@ tcExpr (HsCase scrut matches) res_ty tcExpr (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if' = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy) - -- this forces the branches to be fully instantiated - -- (See #10619) - ; res_ty <- mkCheckExpType <$> expTypeToType res_ty + ; res_ty <- tauifyExpType res_ty + -- Just like Note [Case branches must never infer a non-tau type] + -- in TcMatches (See #10619) + ; b1' <- tcMonoExpr b1 res_ty ; b2' <- tcMonoExpr b2 res_ty ; return (HsIf Nothing pred' b1' b2') } @@ -553,9 +554,10 @@ tcExpr (HsIf (Just fun) pred b1 b2) res_ty tcExpr (HsMultiIf _ alts) res_ty = do { res_ty <- if isSingleton alts then return res_ty - else mkCheckExpType <$> expTypeToType res_ty - -- Just like Note [Case branches must never infer a non-tau type] - -- in TcMatches + else tauifyExpType res_ty + -- Just like TcMatches + -- Note [Case branches must never infer a non-tau type] + ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts ; res_ty <- readExpType res_ty ; return (HsMultiIf res_ty alts') } diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs index d4867f54da..8d59b8f92d 100644 --- a/compiler/typecheck/TcMatches.hs +++ b/compiler/typecheck/TcMatches.hs @@ -90,8 +90,7 @@ tcMatchesFun fn@(L _ fun_name) matches exp_ty do { (matches', wrap_fun) <- matchExpectedFunTys herald arity exp_rho $ \ pat_tys rhs_ty -> - -- See Note [Case branches must never infer a non-tau type] - do { tcMatches match_ctxt pat_tys rhs_ty matches } + tcMatches match_ctxt pat_tys rhs_ty matches ; return (wrap_fun, matches') } ; return (wrap_gen <.> wrap_fun, group) } where @@ -187,10 +186,7 @@ tauifyMultipleMatches group exp_tys | otherwise = mapM tauifyExpType exp_tys -- NB: In the empty-match case, this ensures we fill in the ExpType --- | Type-check a MatchGroup. If there are multiple RHSs, the expected type --- must already be tauified. --- See Note [Case branches must never infer a non-tau type] --- about tauifyMultipleMatches +-- | Type-check a MatchGroup. tcMatches :: (Outputable (body Name)) => TcMatchCtxt body -> [ExpSigmaType] -- Expected pattern types -> ExpRhoType -- Expected result-type of the Match. @@ -207,6 +203,8 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches , mg_origin = origin }) = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys) + -- See Note [Case branches must never infer a non-tau type] + ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches ; pat_tys <- mapM readExpType pat_tys ; rhs_ty <- readExpType rhs_ty |