summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2016-06-09 14:44:00 +0100
committerSimon Peyton Jones <simonpj@microsoft.com>2016-06-10 17:18:56 +0100
commit3ae18df176081474ecc1ae90d5b6957d660afbb6 (patch)
tree70de7fd19d930bdcf8763f895bf9ba22639ce88f
parent0f0b002ce4593a78b8996c77c063c89e09b284e4 (diff)
downloadhaskell-3ae18df176081474ecc1ae90d5b6957d660afbb6.tar.gz
Minor refactoring
Use tauifyExpType rather than something hand-rolled
-rw-r--r--compiler/typecheck/TcExpr.hs14
-rw-r--r--compiler/typecheck/TcMatches.hs10
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