[commit: ghc] tc-untouchables: Fix kind unification in the special rule for ($) (e7279ac)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : tc-untouchables

http://hackage.haskell.org/trac/ghc/changeset/e7279ac81674d83c3a1e4a1515ca3beb4dd3c7d4

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

commit e7279ac81674d83c3a1e4a1515ca3beb4dd3c7d4
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Sep 28 15:25:41 2012 +0100

    Fix kind unification in the special rule for ($)

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

 compiler/typecheck/TcExpr.lhs |   24 ++++++++++++++++--------
 1 files changed, 16 insertions(+), 8 deletions(-)

diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index eb18764..d2ebc74 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -313,20 +313,28 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
 
        ; let doc = ptext (sLit "The first argument of ($) takes")
        ; (co_arg1, [arg2_ty], op_res_ty) <- matchExpectedFunTys doc 1 arg1_ty
-       	 -- arg2_ty maybe polymorphic; that's the point
+         -- arg1_ty = arg2_ty -> op_res_ty
+       	 -- And arg2_ty maybe polymorphic; that's the point
 
        -- Make sure that the argument and result types have kind '*'
        -- Eg we do not want to allow  (D#  $  4.0#)   Trac #5570
-       ; _ <- unifyKind (typeKind arg2_ty) liftedTypeKind
-       ; _ <- unifyKind (typeKind res_ty)  liftedTypeKind
+       -- ($) :: forall ab. (a->b) -> a -> b
+       ; a_ty <- newFlexiTyVarTy liftedTypeKind
+       ; b_ty <- newFlexiTyVarTy liftedTypeKind
 
        ; arg2' <- tcArg op (arg2, arg2_ty, 2)
-       ; co_res <- unifyType op_res_ty res_ty
-       ; op_id <- tcLookupId op_name
 
-       ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id))
-       ; return $ mkHsWrapCo co_res $
-         OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' }
+       ; co_res <- unifyType b_ty res_ty        -- b ~ res
+       ; co_a   <- unifyType arg2_ty   a_ty     -- arg2 ~ a
+       ; co_b   <- unifyType op_res_ty b_ty     -- op_res ~ b
+       ; op_id  <- tcLookupId op_name
+
+       ; let op' = L loc (HsWrap (mkWpTyApps [a_ty, b_ty]) (HsVar op_id))
+       ; return $ mkHsWrapCo (co_res) $
+         OpApp (mkLHsWrapCo (mkTcFunCo co_a co_b) $
+                mkLHsWrapCo co_arg1 arg1') 
+               op' fix 
+               (mkLHsWrapCo co_a arg2') }
 
   | otherwise
   = do { traceTc "Non Application rule" (ppr op)