[commit: ghc] master: fix misleading error message regarding function arity (09b7943)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/09b7943321f89b945d10f8a914f4c2cbf73dff91/ghc

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

commit 09b7943321f89b945d10f8a914f4c2cbf73dff91
Author: Yuras Shumovich <shumovichy at gmail.com>
Date:   Tue Dec 9 18:11:44 2014 -0600

    fix misleading error message regarding function arity
    
    Summary:
    The error reports something like:
    
      The function ‘f’ is applied to three arguments,
      but its type ‘Int -> Float -> Char -> Bool’ has only three
    
    The original type was "Monad m => Int -> Float -> m Bool", but
    "m" was unified with "-> Char".
    
    Now it looks better:
    
      The function ‘f’ is applied to three arguments,
      its type is ‘Int -> Float -> m0 Bool’,
      it is specialized to ‘Int -> Float -> Char -> Bool’
    
    Test Plan: T9605
    
    Reviewers: simonpj, austin
    
    Reviewed By: austin
    
    Subscribers: carter, thomie
    
    Differential Revision: https://phabricator.haskell.org/D556
    
    GHC Trac Issues: #9605


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

09b7943321f89b945d10f8a914f4c2cbf73dff91
 compiler/typecheck/TcUnify.hs                      | 34 ++++++++++++++++------
 testsuite/tests/typecheck/should_fail/T9605.hs     |  7 +++++
 testsuite/tests/typecheck/should_fail/T9605.stderr | 11 +++++++
 testsuite/tests/typecheck/should_fail/all.T        |  1 +
 4 files changed, 44 insertions(+), 9 deletions(-)

diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs
index b75f0e8..5c80769 100644
--- a/compiler/typecheck/TcUnify.hs
+++ b/compiler/typecheck/TcUnify.hs
@@ -145,8 +145,19 @@ matchExpectedFunTys herald arity orig_ty
 
        -- In all other cases we bale out into ordinary unification
        -- However unlike the meta-tyvar case, we are sure that the
-       -- number of arrows doesn't match up, so we can add a bit
-       -- more context to the error message (cf Trac #7869)
+       -- number of arguments doesn't match arity of the original
+       -- type, so we can add a bit more context to the error message
+       -- (cf Trac #7869).
+       --
+       -- It is not always an error, because specialized type may have
+       -- different arity, for example:
+       --
+       -- > f1 = f2 'a'
+       -- > f2 :: Monad m => m Bool
+       -- > f2 = undefined
+       --
+       -- But in that case we add specialized type into error context
+       -- anyway, because it may be useful. See also Trac #9605.
     go n_req ty = addErrCtxtM mk_ctxt $
                   defer n_req ty
 
@@ -160,16 +171,21 @@ matchExpectedFunTys herald arity orig_ty
 
     ------------
     mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc)
-    mk_ctxt env = do { (env', orig_ty) <- zonkTidyTcType env orig_ty
-                     ; let (args, _) = tcSplitFunTys orig_ty
+    mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_ty
+                     ; let (args, _) = tcSplitFunTys ty
                            n_actual = length args
-                     ; return (env', mk_msg orig_ty n_actual) }
+                           (env'', orig_ty') = tidyOpenType env' orig_ty
+                     ; return (env'', mk_msg orig_ty' ty n_actual) }
 
-    mk_msg ty n_args
+    mk_msg orig_ty ty n_args
       = herald <+> speakNOf arity (ptext (sLit "argument")) <> comma $$
-        sep [ptext (sLit "but its type") <+> quotes (pprType ty),
-             if n_args == 0 then ptext (sLit "has none")
-             else ptext (sLit "has only") <+> speakN n_args]
+        if n_args == arity
+          then ptext (sLit "its type is") <+> quotes (pprType orig_ty) <>
+               comma $$
+               ptext (sLit "it is specialized to") <+> quotes (pprType ty)
+          else sep [ptext (sLit "but its type") <+> quotes (pprType ty),
+                    if n_args == 0 then ptext (sLit "has none")
+                    else ptext (sLit "has only") <+> speakN n_args]
 
 {-
 Note [Foralls to left of arrow]
diff --git a/testsuite/tests/typecheck/should_fail/T9605.hs b/testsuite/tests/typecheck/should_fail/T9605.hs
new file mode 100644
index 0000000..b94afb4
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T9605.hs
@@ -0,0 +1,7 @@
+module T9605 where
+
+f1 :: Monad m => m Bool
+f1 = undefined
+
+f2 :: Monad m => m Bool
+f2 = f1 undefined
diff --git a/testsuite/tests/typecheck/should_fail/T9605.stderr b/testsuite/tests/typecheck/should_fail/T9605.stderr
new file mode 100644
index 0000000..4ba1d33
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T9605.stderr
@@ -0,0 +1,11 @@
+
+T9605.hs:7:6:
+    Couldn't match type ‘Bool’ with ‘m Bool’
+    Expected type: t0 -> m Bool
+      Actual type: t0 -> Bool
+    Relevant bindings include f2 :: m Bool (bound at T9605.hs:7:1)
+    The function ‘f1’ is applied to one argument,
+    its type is ‘m0 Bool’,
+    it is specialized to ‘t0 -> Bool’
+    In the expression: f1 undefined
+    In an equation for ‘f2’: f2 = f1 undefined
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index 1546b3a..27dbef9 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -352,3 +352,4 @@ test('T9109', normal, compile_fail, [''])
 test('T9497d', normal, compile_fail, ['-fdefer-type-errors -fno-defer-typed-holes'])
 test('T8044', normal, compile_fail, [''])
 test('T4921', normal, compile_fail, [''])
+test('T9605', normal, compile_fail, [''])