[Git][ghc/ghc][master] Improve GHC.Tc.Gen.App.tcInstFun

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
7080a93f by Simon Peyton Jones at 2023-02-20T12:06:32+01:00
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

- - - - -


7 changed files:

- compiler/GHC/Tc/Gen/App.hs
- testsuite/tests/ghci/scripts/T12447.stdout
- testsuite/tests/ghci/scripts/T14796.stdout
- testsuite/tests/ghci/scripts/T17403.stdout
- + testsuite/tests/ghci/scripts/T22908.script
- + testsuite/tests/ghci/scripts/T22908.stdout
- testsuite/tests/ghci/scripts/all.T


Changes:

=====================================
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


=====================================
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


=====================================
testsuite/tests/ghci/scripts/T14796.stdout
=====================================
@@ -1 +1,2 @@
-ECC @() @[] @() :: [()] -> ECC (() :: Constraint) [] ()
+ECC @() @[] @()
+  :: (() :: Constraint) => [()] -> ECC (() :: Constraint) [] ()


=====================================
testsuite/tests/ghci/scripts/T17403.stdout
=====================================
@@ -1 +1 @@
-f :: String
+f :: (() :: Constraint) => String


=====================================
testsuite/tests/ghci/scripts/T22908.script
=====================================
@@ -0,0 +1,4 @@
+:set -XMultiParamTypeClasses
+class Foo where foo :: Int
+:t foo
+


=====================================
testsuite/tests/ghci/scripts/T22908.stdout
=====================================
@@ -0,0 +1 @@
+foo :: Foo => Int


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7080a93fd09b71aa6c94e6336eb054e9f5592932

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7080a93fd09b71aa6c94e6336eb054e9f5592932
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230220/592ee5c7/attachment-0001.html>