From 7080a93fd09b71aa6c94e6336eb054e9f5592932 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simon.peytonjones@gmail.com>
Date: Wed, 8 Feb 2023 22:05:41 +0000
Subject: Improve GHC.Tc.Gen.App.tcInstFun

It wasn't behaving right when inst_final=False, and the
function had no type variables
   f :: Foo => Int

Rather a corner case, but we might as well do it right.

Fixes #22908

Unexpectedly, three test cases (all using :type in GHCi) got
slightly better output as a result:
  T17403, T14796, T12447
---
 compiler/GHC/Tc/Gen/App.hs                 | 28 ++++++++++++----------------
 testsuite/tests/ghci/scripts/T12447.stdout |  2 +-
 testsuite/tests/ghci/scripts/T14796.stdout |  3 ++-
 testsuite/tests/ghci/scripts/T17403.stdout |  2 +-
 testsuite/tests/ghci/scripts/T22908.script |  4 ++++
 testsuite/tests/ghci/scripts/T22908.stdout |  1 +
 testsuite/tests/ghci/scripts/all.T         |  1 +
 7 files changed, 22 insertions(+), 19 deletions(-)
 create mode 100644 testsuite/tests/ghci/scripts/T22908.script
 create mode 100644 testsuite/tests/ghci/scripts/T22908.stdout

diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 06158cace3..c8c1730b35 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -543,25 +543,16 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
           HsUnboundVar {} -> True
           _               -> False
 
-    inst_all, inst_inferred, inst_none :: ForAllTyFlag -> Bool
-    inst_all (Invisible {}) = True
-    inst_all Required       = False
-
-    inst_inferred (Invisible InferredSpec)  = True
-    inst_inferred (Invisible SpecifiedSpec) = False
-    inst_inferred Required                  = False
-
-    inst_none _ = False
-
     inst_fun :: [HsExprArg 'TcpRn] -> ForAllTyFlag -> Bool
-    inst_fun [] | inst_final  = inst_all
-                | otherwise   = inst_none
-                -- Using `inst_none` for `:type` avoids
+    -- True <=> instantiate a tyvar with this ForAllTyFlag
+    inst_fun [] | inst_final  = isInvisibleForAllTyFlag
+                | otherwise   = const False
+                -- Using `const False` for `:type` avoids
                 -- `forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b`
                 -- turning into `forall a {r2} (b :: TYPE r2). a -> b`.
                 -- See #21088.
-    inst_fun (EValArg {} : _) = inst_all
-    inst_fun _                = inst_inferred
+    inst_fun (EValArg {} : _) = isInvisibleForAllTyFlag
+    inst_fun _                = isInferredForAllTyFlag
 
     -----------
     go, go1 :: Delta
@@ -588,7 +579,12 @@ tcInstFun do_ql inst_final (rn_fun, fun_ctxt) fun_sigma rn_args
     -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate
     go1 delta acc so_far fun_ty args
       | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty
-      , (theta, body2) <- tcSplitPhiTy body1
+      , (theta, body2) <- if inst_fun args Inferred
+                          then tcSplitPhiTy body1
+                          else ([], body1)
+        -- inst_fun args Inferred: dictionary parameters are like Inferred foralls
+        -- E.g. #22908: f :: Foo => blah
+        -- No foralls!  But if inst_final=False, don't instantiate
       , not (null tvs && null theta)
       = do { (inst_tvs, wrap, fun_rho) <- addHeadCtxt fun_ctxt $
                                           instantiateSigma fun_orig tvs theta body2
diff --git a/testsuite/tests/ghci/scripts/T12447.stdout b/testsuite/tests/ghci/scripts/T12447.stdout
index 6c469eeef3..aa85191c2e 100644
--- a/testsuite/tests/ghci/scripts/T12447.stdout
+++ b/testsuite/tests/ghci/scripts/T12447.stdout
@@ -1,3 +1,3 @@
 deferEither @(_ ~ _)
-  :: (Typeable w1, Typeable w2) =>
+  :: Deferrable (w1 ~ w2) =>
      proxy (w1 ~ w2) -> ((w1 ~ w2) => r) -> Either String r
diff --git a/testsuite/tests/ghci/scripts/T14796.stdout b/testsuite/tests/ghci/scripts/T14796.stdout
index c8bb21936a..f9740468d4 100644
--- a/testsuite/tests/ghci/scripts/T14796.stdout
+++ b/testsuite/tests/ghci/scripts/T14796.stdout
@@ -1 +1,2 @@
-ECC @() @[] @() :: [()] -> ECC (() :: Constraint) [] ()
+ECC @() @[] @()
+  :: (() :: Constraint) => [()] -> ECC (() :: Constraint) [] ()
diff --git a/testsuite/tests/ghci/scripts/T17403.stdout b/testsuite/tests/ghci/scripts/T17403.stdout
index deff4906ac..c543c3d0e5 100644
--- a/testsuite/tests/ghci/scripts/T17403.stdout
+++ b/testsuite/tests/ghci/scripts/T17403.stdout
@@ -1 +1 @@
-f :: String
+f :: (() :: Constraint) => String
diff --git a/testsuite/tests/ghci/scripts/T22908.script b/testsuite/tests/ghci/scripts/T22908.script
new file mode 100644
index 0000000000..3380b08ccd
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T22908.script
@@ -0,0 +1,4 @@
+:set -XMultiParamTypeClasses
+class Foo where foo :: Int
+:t foo
+
diff --git a/testsuite/tests/ghci/scripts/T22908.stdout b/testsuite/tests/ghci/scripts/T22908.stdout
new file mode 100644
index 0000000000..42d1e38c1d
--- /dev/null
+++ b/testsuite/tests/ghci/scripts/T22908.stdout
@@ -0,0 +1 @@
+foo :: Foo => Int
diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T
index 6dad147225..fa22b7ae8d 100755
--- a/testsuite/tests/ghci/scripts/all.T
+++ b/testsuite/tests/ghci/scripts/all.T
@@ -372,3 +372,4 @@ test('T21294a', normal, ghci_script, ['T21294a.script'])
 test('T21507', normal, ghci_script, ['T21507.script'])
 test('T22695', normal, ghci_script, ['T22695.script'])
 test('T22817', normal, ghci_script, ['T22817.script'])
+test('T22908', normal, ghci_script, ['T22908.script'])
-- 
cgit v1.2.1