Refactor in TcMatches

* Move the several calls of tauifyMultipleMatches into tcMatches,
  so that it can be called only once, and the invariants are
  clearer

* I discovered in doing this that HsLamCase had a redundant and
  tiresome argument, so I removed it. That in turn allowed some
  modest but nice code simplification

11 files changed, 39 insertions, 48 deletions

diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index c48df8ad4c..139aa0e38d 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -519,7 +519,7 @@ addTickHsExpr e@(HsOverLit _)    = return e
 addTickHsExpr e@(HsOverLabel _)  = return e
 addTickHsExpr e@(HsLit _)        = return e
 addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
-addTickHsExpr (HsLamCase ty mgs) = liftM (HsLamCase ty) (addTickMatchGroup True mgs)
+addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)
 addTickHsExpr (HsApp e1 e2)      = liftM2 HsApp (addTickLHsExprNever e1)
                                                 (addTickLHsExpr      e2)
 addTickHsExpr (HsAppTypeOut e ty) = liftM2 HsAppTypeOut (addTickLHsExprNever e)
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index ad46320779..c037bb19ab 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -226,10 +226,9 @@ dsExpr (NegApp expr neg_expr)
 dsExpr (HsLam a_Match)
   = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
 
-dsExpr (HsLamCase arg matches)
-  = do { arg_var <- newSysLocalDs arg
-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
-       ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
+dsExpr (HsLamCase matches)
+  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
+       ; return $ Lam discrim_var matching_code }
 
 dsExpr e@(HsApp fun arg)
   = mkCoreAppDs (text "HsApp" <+> ppr e) <$> dsLExpr fun <*> dsLExpr arg
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 833da59453..84f1a9ca58 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1086,7 +1086,7 @@ repE e@(HsRecFld f) = case f of
 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
 repE (HsLit l)     = do { a <- repLiteral l;           repLit a }
 repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
-repE (HsLamCase _ (MG { mg_alts = L _ ms }))
+repE (HsLamCase (MG { mg_alts = L _ ms }))
                    = do { ms' <- mapM repMatchTup ms
                         ; core_ms <- coreList matchQTyConName ms'
                         ; repLamCase core_ms }
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 90e3886c84..47bbfb99bf 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -721,8 +721,7 @@ cvtl e = wrapL (cvt e)
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
                             ; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
     cvt (LamCaseE ms)  = do { ms' <- mapM cvtMatch ms
-                            ; return $ HsLamCase placeHolderType
-                                                 (mkMatchGroup FromSource ms')
+                            ; return $ HsLamCase (mkMatchGroup FromSource ms')
                             }
     cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar e' }
                                  -- Note [Dropping constructors]
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index a18fbd4765..05f1ac8ce1 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -194,7 +194,7 @@ data HsExpr id
 
        -- For details on above see note [Api annotations] in ApiAnnotation
 
-  | HsLamCase (PostTc id Type) (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
+  | HsLamCase (MatchGroup id (LHsExpr id)) -- ^ Lambda-case
        --
        -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLam',
        --           'ApiAnnotation.AnnCase','ApiAnnotation.AnnOpen',
@@ -751,7 +751,7 @@ ppr_expr (ExplicitTuple exprs boxity)
 ppr_expr (HsLam matches)
   = pprMatches (LambdaExpr :: HsMatchContext id) matches
 
-ppr_expr (HsLamCase _ matches)
+ppr_expr (HsLamCase matches)
   = sep [ sep [text "\\case {"],
           nest 2 (pprMatches (CaseAlt :: HsMatchContext id) matches <+> char '}') ]
 
@@ -1260,12 +1260,14 @@ isInfixMatch match = case m_fixity match of
 isEmptyMatchGroup :: MatchGroup id body -> Bool
 isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
 
--- | Is there only one RHS in this group?
-isSingletonMatchGroup :: MatchGroup id body -> Bool
-isSingletonMatchGroup (MG { mg_alts = L _ [match] })
-  | L _ (Match { m_grhss = GRHSs { grhssGRHSs = [_] } }) <- match
+-- | Is there only one RHS in this list of matches?
+isSingletonMatchGroup :: [LMatch id body] -> Bool
+isSingletonMatchGroup matches
+  | [L _ match] <- matches
+  , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match
   = True
-isSingletonMatchGroup _ = False
+  | otherwise
+  = False
 
 matchGroupArity :: MatchGroup id body -> Arity
 -- Precondition: MatchGroup is non-empty
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 0b11b04a5e..497566154a 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2151,7 +2151,7 @@ exp10 :: { LHsExpr RdrName }
                                                (mj AnnLet $1:mj AnnIn $3
                                                  :(fst $ unLoc $2)) }
         | '\\' 'lcase' altslist
-            {% ams (sLL $1 $> $ HsLamCase placeHolderType
+            {% ams (sLL $1 $> $ HsLamCase
                                    (mkMatchGroup FromSource (snd $ unLoc $3)))
                    (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }
         | 'if' exp optSemi 'then' exp optSemi 'else' exp
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index de03b8d796..86bd178c70 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -220,10 +220,9 @@ rnExpr (HsLam matches)
   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches
        ; return (HsLam matches', fvMatch) }
 
-rnExpr (HsLamCase _arg matches)
+rnExpr (HsLamCase matches)
   = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches
-       -- ; return (HsLamCase arg matches', fvs_ms) }
-       ; return (HsLamCase placeHolderType matches', fvs_ms) }
+       ; return (HsLamCase matches', fvs_ms) }
 
 rnExpr (HsCase expr matches)
   = do { (new_expr, e_fvs) <- rnLExpr expr
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index af347d8d64..5eb28f0728 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -230,8 +230,8 @@ tcExpr e@(HsOverLabel l) res_ty  -- See Note [Type-checking overloaded labels]
   origin = OverLabelOrigin l
 
 tcExpr (HsLam match) res_ty
-  = do  { (co_fn, _, match') <- tcMatchLambda herald match_ctxt match res_ty
-        ; return (mkHsWrap co_fn (HsLam match')) }
+  = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
+        ; return (mkHsWrap wrap (HsLam match')) }
   where
     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
     herald = sep [ text "The lambda expression" <+>
@@ -240,15 +240,16 @@ tcExpr (HsLam match) res_ty
                         -- The pprSetDepth makes the abstraction print briefly
                    text "has"]
 
-tcExpr e@(HsLamCase _ matches) res_ty
-  = do { (co_fn, ~[arg_ty], matches')
+tcExpr e@(HsLamCase matches) res_ty
+  = do { (matches', wrap)
            <- tcMatchLambda msg match_ctxt matches res_ty
            -- The laziness annotation is because we don't want to fail here
            -- if there are multiple arguments
-       ; return (mkHsWrap co_fn $ HsLamCase arg_ty matches') }
-  where msg = sep [ text "The function" <+> quotes (ppr e)
-                  , text "requires"]
-        match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
+       ; return (mkHsWrap wrap $ HsLamCase matches') }
+  where
+    msg = sep [ text "The function" <+> quotes (ppr e)
+              , text "requires"]
+    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
 
 tcExpr e@(ExprWithTySig expr sig_ty) res_ty
   = do { sig_info <- checkNoErrs $  -- Avoid error cascade
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index f6fa01a5d0..502842d44a 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -623,10 +623,9 @@ zonkExpr env (HsLam matches)
   = do new_matches <- zonkMatchGroup env zonkLExpr matches
        return (HsLam new_matches)
 
-zonkExpr env (HsLamCase arg matches)
-  = do new_arg <- zonkTcTypeToType env arg
-       new_matches <- zonkMatchGroup env zonkLExpr matches
-       return (HsLamCase new_arg new_matches)
+zonkExpr env (HsLamCase matches)
+  = do new_matches <- zonkMatchGroup env zonkLExpr matches
+       return (HsLamCase new_matches)
 
 zonkExpr env (HsApp e1 e2)
   = do new_e1 <- zonkLExpr env e1
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index b96746d85f..05b836cccb 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -90,8 +90,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 <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
-                        ; tcMatches match_ctxt pat_tys rhs_ty matches }
+                     do { tcMatches match_ctxt pat_tys rhs_ty matches }
                   ; return (wrap_fun, matches') }
         ; return (wrap_gen <.> wrap_fun, group) }
   where
@@ -115,24 +114,16 @@ 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]
-       ; tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches }
+  = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches
 
 tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify
               -> TcMatchCtxt HsExpr
               -> MatchGroup Name (LHsExpr Name)
               -> ExpRhoType   -- deeply skolemised
-              -> TcM (HsWrapper, [TcSigmaType], MatchGroup TcId (LHsExpr TcId))
-                     -- also returns the argument types
+              -> TcM (MatchGroup TcId (LHsExpr TcId), HsWrapper)
 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 <- 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) }
-       ; return (wrap, pat_tys, match') }
+  = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->
+    tcMatches match_ctxt pat_tys rhs_ty match
   where
     n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
            | otherwise               = matchGroupArity match
@@ -188,7 +179,7 @@ still gets assigned a polytype.
 -- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the
 -- expected type into TauTvs.
 -- See Note [Case branches must never infer a non-tau type]
-tauifyMultipleMatches :: MatchGroup id body
+tauifyMultipleMatches :: [LMatch id body]
                       -> [ExpType] -> TcM [ExpType]
 tauifyMultipleMatches group exp_tys
   | isSingletonMatchGroup group = return exp_tys
@@ -214,7 +205,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 { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
+  = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)
+       ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
        ; pat_tys  <- mapM readExpType pat_tys
        ; rhs_ty   <- readExpType rhs_ty
        ; return (MG { mg_alts = L l matches'
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 84bf2db62b..a7bb56a112 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -2821,7 +2821,7 @@ exprCtOrigin (HsIPVar ip)       = IPOccOrigin ip
 exprCtOrigin (HsOverLit lit)    = LiteralOrigin lit
 exprCtOrigin (HsLit {})         = Shouldn'tHappenOrigin "concrete literal"
 exprCtOrigin (HsLam matches)    = matchesCtOrigin matches
-exprCtOrigin (HsLamCase _ ms)   = matchesCtOrigin ms
+exprCtOrigin (HsLamCase ms)     = matchesCtOrigin ms
 exprCtOrigin (HsApp (L _ e1) _) = exprCtOrigin e1
 exprCtOrigin (HsAppType (L _ e1) _) = exprCtOrigin e1
 exprCtOrigin (HsAppTypeOut {})      = panic "exprCtOrigin HsAppTypeOut"