[commit: ghc] ghc-8.0: Minor refactoring to tauifyMultipleMatches (4825afe)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/4825afeca73a7560591c5ddff1eb071ef6d5a182/ghc

>---------------------------------------------------------------

commit 4825afeca73a7560591c5ddff1eb071ef6d5a182
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Feb 12 13:44:44 2016 +0000

    Minor refactoring to tauifyMultipleMatches
    
    No change in behaviour
    
    (cherry picked from commit 24305bead969fdf85be8b8f4a42cd88ad21a7e16)


>---------------------------------------------------------------

4825afeca73a7560591c5ddff1eb071ef6d5a182
 compiler/typecheck/TcMType.hs   |  7 +++++++
 compiler/typecheck/TcMatches.hs | 24 ++++++++----------------
 2 files changed, 15 insertions(+), 16 deletions(-)

diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 3d9e57c..a79c346 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -32,6 +32,7 @@ module TcMType (
   ExpType(..), ExpSigmaType, ExpRhoType,
   mkCheckExpType, newOpenInferExpType, readExpType, readExpType_maybe,
   writeExpType, expTypeToType, checkingExpType_maybe, checkingExpType,
+  tauifyExpType,
 
   --------------------------------
   -- Creating fresh type variables for pm checking
@@ -386,6 +387,12 @@ checkingExpType :: String -> ExpType -> TcType
 checkingExpType _   (Check ty) = ty
 checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)
 
+tauifyExpType :: ExpType -> TcM ExpType
+-- ^ Turn a (Infer hole) type into a (Check alpha),
+-- where alpha is a fresh unificaiton variable
+tauifyExpType exp_ty = do { ty <- expTypeToType exp_ty
+                          ; return (Check ty) }
+
 -- | Extracts the expected type if there is one, or generates a new
 -- TauTv if there isn't.
 expTypeToType :: ExpType -> TcM TcType
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index c1d9048..b918ecf 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -94,9 +94,7 @@ tcMatchesFun fun_name matches exp_ty
                        <- matchExpectedFunTys herald arity exp_rho $
                           \ pat_tys rhs_ty ->
                      -- See Note [Case branches must never infer a non-tau type]
-                     do { rhs_ty : pat_tys
-                            <- mapM (tauifyMultipleMatches matches)
-                                    (rhs_ty : pat_tys)
+                     do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
                         ; tcMatches match_ctxt pat_tys rhs_ty matches }
                   ; return (wrap_fun, matches') }
         ; return (wrap_gen <.> wrap_fun, group) }
@@ -121,7 +119,7 @@ tcMatchesCase :: (Outputable (body Name)) =>
                  -- wrapper goes from MatchGroup's ty to expected ty
 
 tcMatchesCase ctxt scrut_ty matches res_ty
-  = do { res_ty <- tauifyMultipleMatches matches res_ty
+  = do { [res_ty] <- tauifyMultipleMatches matches [res_ty]
        ; tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches }
 
 tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
@@ -134,8 +132,7 @@ tcMatchLambda herald match_ctxt match res_ty
   = do { ((match', pat_tys), wrap)
            <- matchExpectedFunTys herald n_pats res_ty $
               \ pat_tys rhs_ty ->
-              do { rhs_ty : pat_tys <- mapM (tauifyMultipleMatches match)
-                                            (rhs_ty : pat_tys)
+              do { rhs_ty:pat_tys <- tauifyMultipleMatches match (rhs_ty:pat_tys)
                  ; match' <- tcMatches match_ctxt pat_tys rhs_ty match
                  ; pat_tys <- mapM readExpType pat_tys
                  ; return (match', pat_tys) }
@@ -196,16 +193,11 @@ still gets assigned a polytype.
 -- expected type into TauTvs.
 -- See Note [Case branches must never infer a non-tau type]
 tauifyMultipleMatches :: MatchGroup id body
-                      -> ExpType
-                      -> TcM ExpType
-tauifyMultipleMatches group exp_ty
-  | isSingletonMatchGroup group
-  = return exp_ty
-
-  | otherwise
-  = mkCheckExpType <$> expTypeToType exp_ty
-      -- NB: This also ensures that an empty match still fills in the
-      -- ExpType
+                      -> [ExpType] -> TcM [ExpType]
+tauifyMultipleMatches group exp_tys
+  | isSingletonMatchGroup group = return 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.