[commit: ghc] wip/type-app: Vta1 passes (0067224)

[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/006722400485d7525827c4acff4f99e7eda558e2/ghc

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

commit 006722400485d7525827c4acff4f99e7eda558e2
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Jul 1 17:29:18 2015 -0400

    Vta1 passes


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

006722400485d7525827c4acff4f99e7eda558e2
 compiler/typecheck/Inst.hs    | 11 ++++++-----
 compiler/typecheck/TcUnify.hs |  5 ++++-
 2 files changed, 10 insertions(+), 6 deletions(-)

diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs
index bc98be8..6d66a8e 100644
--- a/compiler/typecheck/Inst.hs
+++ b/compiler/typecheck/Inst.hs
@@ -232,13 +232,14 @@ top_instantiate :: Bool   -- True <=> instantiate *all* variables
                 -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 top_instantiate inst_all orig ty
   | not (null tvs && null theta)
-  = do { let (inst_tvs, leave_tvs) = span should_inst tvs
-             inst_theta
-               | null leave_tvs = theta
-               | otherwise      = []
+  = do { let (inst_tvs, leave_tvs)     = span should_inst tvs
+             (inst_theta, leave_theta)
+               | null leave_tvs = (theta, [])
+               | otherwise      = ([], theta)
        ; (subst, inst_tvs') <- tcInstTyVars inst_tvs
        ; let inst_theta' = substTheta subst inst_theta
-             sigma'      = substTy    subst (mkForAllTys leave_tvs rho)
+             sigma'      = substTy    subst (mkForAllTys leave_tvs $
+                                             mkFunTys leave_theta rho)
 
        ; wrap1 <- instCall orig (mkTyVarTys inst_tvs') inst_theta'
        ; traceTc "Instantiating (inferred only)"
diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index e74dab0..889fbd0 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -216,6 +216,7 @@ match_fun_tys ea herald orig_fun orig_args orig_ty = go orig_args orig_ty
       | Just (Just hs_ty_arg) <- fmap isLHsTypeExpr_maybe arg
       = do { let origin = case ea of Expected    -> panic "match_fun_tys"
                                      Actual orig -> orig
+           ; traceTc "RAE1" (ppr arg $$ ppr args $$ ppr ty)
            ; (wrap1, upsilon_ty) <- topInstantiateInferred origin ty
                -- wrap1 :: ty "->" upsilon_ty
            ; case tcSplitForAllTy_maybe upsilon_ty of
@@ -224,6 +225,7 @@ match_fun_tys ea herald orig_fun orig_args orig_ty = go orig_args orig_ty
                  do { let kind = tyVarKind tv
                     ; ty_arg <- tcCheckLHsType hs_ty_arg kind
                     ; let insted_ty = substTyWith [tv] [ty_arg] inner_ty
+                    ; traceTc "RAE3" (ppr upsilon_ty $$ ppr tv $$ ppr inner_ty $$ ppr insted_ty $$ ppr ty_arg)
                     ; (inner_wrap, arg_tys, res_ty) <- go args insted_ty
                         -- inner_wrap :: insted_ty "->" arg_tys -> res_ty
                     ; let inst_wrap = mkWpTyApps [ty_arg]
@@ -234,7 +236,8 @@ match_fun_tys ea herald orig_fun orig_args orig_ty = go orig_args orig_ty
 
     go args ty
       | not (null tvs && null theta)
-      = do { (wrap, (arg_tys, res_ty)) <- exposeRhoType ea ty $ \rho ->
+      = do { traceTc "RAE2" (ppr args $$ ppr ty)
+           ; (wrap, (arg_tys, res_ty)) <- exposeRhoType ea ty $ \rho ->
              do { (inner_wrap, arg_tys, res_ty) <- go args rho
                 ; return (inner_wrap, (arg_tys, res_ty)) }
            ; return (wrap, arg_tys, res_ty) }