[commit: ghc] wip/type-app: Fix bug in TcLambdaCase (ceea8af)

[git at git.haskell.org]

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

On branch  : wip/type-app
Link       : http://ghc.haskell.org/trac/ghc/changeset/ceea8afc2392569d551ad2538cb9d8c3c6caff16/ghc

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

commit ceea8afc2392569d551ad2538cb9d8c3c6caff16
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Jul 15 13:23:56 2015 -0400

    Fix bug in TcLambdaCase


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

ceea8afc2392569d551ad2538cb9d8c3c6caff16
 compiler/typecheck/TcEvidence.hs | 5 ++++-
 compiler/typecheck/TcExpr.hs     | 3 ++-
 2 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index 299e6a2..0848008 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -595,7 +595,10 @@ WpHole <.> c = c
 c <.> WpHole = c
 c1 <.> c2    = c1 `WpCompose` c2
 
-mkWpFun :: HsWrapper -> HsWrapper -> TcType -> TcType -> HsWrapper
+mkWpFun :: HsWrapper -> HsWrapper
+        -> TcType    -- the "from" type of the first wrapper
+        -> TcType    -- the "to" type of the second wrapper
+        -> HsWrapper
 mkWpFun WpHole       WpHole       _  _  = WpHole
 mkWpFun WpHole       (WpCast co2) t1 _  = WpCast (mkTcFunCo Representational (mkTcRepReflCo t1) co2)
 mkWpFun (WpCast co1) WpHole       _  t2 = WpCast (mkTcFunCo Representational (mkTcSymCo co1) (mkTcRepReflCo t2))
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 26ce358..d93f5ba 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -200,7 +200,8 @@ tcExpr e@(HsLamCase _ matches) res_ty
   = do {(wrap1, [arg_ty], body_ty) <-
             matchExpectedFunTys Expected msg 1 res_ty
        ; (wrap2, matches') <- tcMatchesCase match_ctxt arg_ty matches body_ty
-       ; return $ mkHsWrap (wrap1 <.> wrap2) $ HsLamCase arg_ty matches' }
+       ; return $ mkHsWrap (wrap1 <.> mkWpFun idHsWrapper wrap2 arg_ty body_ty) $
+                  HsLamCase arg_ty matches' }
   where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
                   , ptext (sLit "requires")]
         match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }