[commit: ghc] wip/rae: Fix #11313. (604427c)

[git at git.haskell.org]

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

On branch  : wip/rae
Link       : http://ghc.haskell.org/trac/ghc/changeset/604427c812cd2c6f1b0f0dd9ace699b8f0666527/ghc

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

commit 604427c812cd2c6f1b0f0dd9ace699b8f0666527
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Feb 10 09:38:09 2016 -0500

    Fix #11313.
    
    Previously, we looked through synonyms when counting arguments,
    but that's a bit silly.


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

604427c812cd2c6f1b0f0dd9ace699b8f0666527
 compiler/typecheck/TcMType.hs                       |  5 +++--
 compiler/types/Type.hs                              | 17 ++++++++++++++++-
 testsuite/tests/typecheck/should_fail/T11313.hs     |  9 +++++++++
 testsuite/tests/typecheck/should_fail/T11313.stderr |  6 ++++++
 testsuite/tests/typecheck/should_fail/all.T         |  1 +
 5 files changed, 35 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcMType.hs b/compiler/typecheck/TcMType.hs
index e4c8b4b..e4da9aa 100644
--- a/compiler/typecheck/TcMType.hs
+++ b/compiler/typecheck/TcMType.hs
@@ -1328,13 +1328,14 @@ zonkTidyTcType env ty = do { ty' <- zonkTcType ty
 
 -- | Make an 'ErrorThing' storing a type.
 mkTypeErrorThing :: TcType -> ErrorThing
-mkTypeErrorThing ty = ErrorThing ty (Just $ length $ snd $ splitAppTys ty)
+mkTypeErrorThing ty = ErrorThing ty (Just $ length $ snd $ repSplitAppTys ty)
                                  zonkTidyTcType
+   -- NB: Use *rep*splitAppTys, else we get #11313
 
 -- | Make an 'ErrorThing' storing a type, with some extra args known about
 mkTypeErrorThingArgs :: TcType -> Int -> ErrorThing
 mkTypeErrorThingArgs ty num_args
-  = ErrorThing ty (Just $ (length $ snd $ splitAppTys ty) + num_args)
+  = ErrorThing ty (Just $ (length $ snd $ repSplitAppTys ty) + num_args)
                zonkTidyTcType
 
 zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)
diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs
index 67365e3..1d6d086 100644
--- a/compiler/types/Type.hs
+++ b/compiler/types/Type.hs
@@ -21,7 +21,7 @@ module Type (
         mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,
         getCastedTyVar_maybe, tyVarKind,
 
-        mkAppTy, mkAppTys, splitAppTy, splitAppTys,
+        mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,
         splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,
 
         mkFunTy, mkFunTys, splitFunTy, splitFunTy_maybe,
@@ -691,6 +691,21 @@ splitAppTys ty = split ty ty []
                                                (TyConApp funTyCon [], [ty1,ty2])
     split orig_ty _                     args = (orig_ty, args)
 
+-- | Like 'splitAppTys', but doesn't look through type synonyms
+repSplitAppTys :: Type -> (Type, [Type])
+repSplitAppTys ty = split ty []
+  where
+    split (AppTy ty arg) args = split ty (arg:args)
+    split (TyConApp tc tc_args) args
+      = let n | mightBeUnsaturatedTyCon tc = 0
+              | otherwise                  = tyConArity tc
+            (tc_args1, tc_args2) = splitAt n tc_args
+        in
+        (TyConApp tc tc_args1, tc_args2 ++ args)
+    split (ForAllTy (Anon ty1) ty2) args = ASSERT( null args )
+                                           (TyConApp funTyCon [], [ty1, ty2])
+    split ty args = (ty, args)
+
 {-
                       LitTy
                       ~~~~~
diff --git a/testsuite/tests/typecheck/should_fail/T11313.hs b/testsuite/tests/typecheck/should_fail/T11313.hs
new file mode 100644
index 0000000..86ac958
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11313.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeApplications #-}
+
+module T11313 where
+
+import Data.Kind
+
+x = fmap @ (*)
+
+-- test error message output, which was quite silly before
diff --git a/testsuite/tests/typecheck/should_fail/T11313.stderr b/testsuite/tests/typecheck/should_fail/T11313.stderr
new file mode 100644
index 0000000..7a681d1
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T11313.stderr
@@ -0,0 +1,6 @@
+
+T11313.hs:7:12: error:
+    • Expected kind ‘* -> *’, but ‘*’ has kind ‘*’
+    • In the type ‘*’
+      In the expression: fmap @*
+      In an equation for ‘x’: x = fmap @*
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 69df866..7ca4141 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -407,3 +407,4 @@ test('T11464', normal, compile_fail, [''])
 test('T11473', expect_broken(11473), compile_fail, [''])
 test('T11563', normal, compile_fail, [''])
 test('T11541', normal, compile_fail, [''])
+test('T11313', normal, compile_fail, [''])