summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simon.peytonjones@gmail.com>2023-02-08 22:05:41 +0000
committersheaf <sam.derbyshire@gmail.com>2023-02-20 12:06:32 +0100
commit7080a93fd09b71aa6c94e6336eb054e9f5592932 (patch)
tree05ffb196258994f464b467c21386d51bca3fe4e6
parenta203ad854ffee802e6bf0aca26e6c9a99bec3865 (diff)
downloadhaskell-wip/T22908.tar.gz
Improve GHC.Tc.Gen.App.tcInstFunwip/T22908
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
-rw-r--r--compiler/GHC/Tc/Gen/App.hs28
-rw-r--r--testsuite/tests/ghci/scripts/T12447.stdout2
-rw-r--r--testsuite/tests/ghci/scripts/T14796.stdout3
-rw-r--r--testsuite/tests/ghci/scripts/T17403.stdout2
-rw-r--r--testsuite/tests/ghci/scripts/T22908.script4
-rw-r--r--testsuite/tests/ghci/scripts/T22908.stdout1
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
7 files changed, 22 insertions, 19 deletions
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'])