[commit: ghc] wip/type-app: Propagate polytypes into if and case. (0dedbfa)

[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/0dedbfa0ae5695d9afad7e47afc4112fc0f23035/ghc

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

commit 0dedbfa0ae5695d9afad7e47afc4112fc0f23035
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Fri Jul 10 10:15:15 2015 -0400

    Propagate polytypes into if and case.


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

0dedbfa0ae5695d9afad7e47afc4112fc0f23035
 compiler/typecheck/TcExpr.hs    |  6 ++----
 compiler/typecheck/TcMType.hs   | 21 +++++++++++++++++++++
 compiler/typecheck/TcMatches.hs | 11 ++++-------
 3 files changed, 27 insertions(+), 11 deletions(-)

diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index ca7cbc3..26ce358 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -456,12 +456,10 @@ tcExpr (HsIf Nothing pred b1 b2) res_ty    -- Ordinary 'if'
   = do { pred' <- tcMonoExpr pred boolTy
             -- this forces the branches to be fully instantiated
             -- (See #10619)
-       ; tau_ty <- newFlexiTyVarTy openTypeKind
-       ; wrap   <- tcSubTypeHR tau_ty res_ty
-       ; tau_ty <- zonkTcType tau_ty
+       ; tau_ty <- tauTvsForReturnTvs res_ty
        ; b1' <- tcMonoExpr b1 tau_ty
        ; b2' <- tcMonoExpr b2 tau_ty
-       ; return $ mkHsWrap wrap $ HsIf Nothing pred' b1' b2' }
+       ; tcWrapResult (HsIf Nothing pred' b1' b2') tau_ty res_ty }
 
 tcExpr (HsIf (Just fun) pred b1 b2) res_ty
   -- Note [Rebindable syntax for if]
diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index 4bf725f..01853dc 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -22,6 +22,7 @@ module TcMType (
   newReturnTyVar, newReturnTyVarTy,
   newMetaKindVar, newMetaKindVars,
   mkTcTyVarName, cloneMetaTyVar,
+  tauTvsForReturnTvs,
 
   newMetaTyVar, readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,
   newMetaDetails, isFilledMetaTyVar, isUnfilledMetaTyVar,
@@ -435,6 +436,26 @@ newReturnTyVar kind = newMetaTyVar ReturnTv kind
 newReturnTyVarTy :: Kind -> TcM TcType
 newReturnTyVarTy kind = TyVarTy <$> newReturnTyVar kind
 
+-- | Replace all the ReturnTvs in a type with TauTvs. These types are
+-- *not* then unified. The caller may wish to do that. No variables
+-- are looked through here. Similarly, no synonyms are looked through,
+-- as doing so won't expose more ReturnTvs.
+tauTvsForReturnTvs :: TcType -> TcM TcType
+tauTvsForReturnTvs = go emptyTvSubst
+  where
+    go env ty@(TyVarTy tv)
+      | isReturnTyVar tv     = newFlexiTyVarTy (substTy env (tyVarKind tv))
+      | otherwise            = return $ substTy env ty
+    go env (AppTy ty1 ty2)   = AppTy <$> go env ty1 <*> go env ty2
+    go env (TyConApp tc tys) = TyConApp tc <$> mapM (go env) tys
+    go env (FunTy ty1 ty2)   = FunTy <$> go env ty1 <*> go env ty2
+    go env (ForAllTy tv ty)
+      = do { k <- go env (tyVarKind tv)
+           ; let tv'  = setTyVarKind tv k
+                 env' = extendTvSubst env tv (TyVarTy tv')
+           ; ForAllTy tv' <$> go env' ty }
+    go _   ty@(LitTy {})     = return ty
+
 tcInstTyVars :: [TKVar] -> TcM (TvSubst, [TcTyVar])
 -- Instantiate with META type variables
 -- Note that this works for a sequence of kind and type
diff --git a/compiler/typecheck/TcMatches.hs b/compiler/typecheck/TcMatches.hs
index fc3c18a..940679c 100644
--- a/compiler/typecheck/TcMatches.hs
+++ b/compiler/typecheck/TcMatches.hs
@@ -186,17 +186,14 @@ data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
 
 tcMatches ctxt pat_tys rhs_ty group@(MG { mg_alts = matches, mg_origin = origin })
   = ASSERT( not (null matches) )        -- Ensure that rhs_ty is filled in
-    do  { (wrap, rhs_ty') <-
+    do  { rhs_ty' <-
              if isSingletonMatchGroup group
                   -- no need to monomorphise the RHS if there's only one
-             then return (idHsWrapper, rhs_ty)
+             then return rhs_ty
                   -- TODO (RAE): Document this behavior.
-             else do { tau_ty <- newFlexiTyVarTy openTypeKind
-                     ; wrap   <- tcSubTypeDS GenSigCtxt tau_ty rhs_ty
-                     ; tau_ty <- zonkTcType tau_ty
-                         -- seems more efficient to zonk just once
-                     ; return (wrap, tau_ty) }
+             else tauTvsForReturnTvs rhs_ty
         ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty') matches
+        ; wrap <- tcSubTypeHR rhs_ty' rhs_ty
         ; return (wrap, MG { mg_alts = matches'
                            , mg_arg_tys = pat_tys
                            , mg_res_ty = rhs_ty'