From a6828173b90dbd276be593c1690aa34317c13c72 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Gerg=C5=91=20=C3=89rdi?= <gergo@erdi.hu>
Date: Thu, 10 Aug 2023 09:11:41 +0100
Subject: [PATCH] If a defaulting plugin made progress, re-zonk wanteds before
built-in defaulting
Fixes #23821.
---
compiler/GHC/Tc/Solver.hs | 6 ++++
testsuite/tests/plugins/Makefile | 4 +++
testsuite/tests/plugins/T23821.hs | 12 +++++++
testsuite/tests/plugins/all.T | 5 +++
.../defaulting-plugin/DefaultInterference.hs | 32 +++++++++++++++++++
.../defaulting-plugin/defaulting-plugin.cabal | 2 +-
6 files changed, 60 insertions(+), 1 deletion(-)
create mode 100644 testsuite/tests/plugins/T23821.hs
create mode 100644 testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs
index a09d7b3346b7..094ee9d3d053 100644
--- a/compiler/GHC/Tc/Solver.hs
+++ b/compiler/GHC/Tc/Solver.hs
@@ -3598,6 +3598,12 @@ applyDefaultingRules wanteds
; return defaultedGroups
}
+ -- If a defaulting plugin solves a tyvar, some of the wanteds
+ -- will have filled-in metavars by now (see #23281). So we
+ -- re-zonk to make sure the built-in defaulting rules don't try
+ -- to solve the same metavars.
+ ; wanteds <- if or plugin_defaulted then TcS.zonkWC wanteds else pure wanteds
+
; let groups = findDefaultableGroups info wanteds
; traceTcS "applyDefaultingRules {" $
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index 986acba47232..0811d378ae8f 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -172,6 +172,10 @@ test-defaulting-plugin:
test-defaulting-plugin-fail:
-"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -v0 test-defaulting-plugin-fail.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin-fail/local.package.conf
+.PHONY: T23821
+T23821:
+ -"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 T23821.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin/local.package.conf
+
.PHONY: plugins-order
plugins-order:
"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins-order.hs -package-db plugin-recomp/pkg.plugins01/local.package.conf -fplugin ImpurePlugin -fplugin PurePlugin -fplugin-opt ImpurePlugin:First_Option -fplugin-opt PurePlugin:Second_Option -fplugin-opt PurePlugin:Second_Option_2 -fplugin FingerprintPlugin -fplugin-opt FingerprintPlugin:1
diff --git a/testsuite/tests/plugins/T23821.hs b/testsuite/tests/plugins/T23821.hs
new file mode 100644
index 000000000000..e0c3d50fc985
--- /dev/null
+++ b/testsuite/tests/plugins/T23821.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fplugin DefaultInterference #-}
+{-# LANGUAGE ExtendedDefaultRules #-}
+module Main where
+
+class IsColor a where
+ op :: a -> ()
+
+instance IsColor (Int, Int, Int) where
+ op _ = ()
+
+main :: IO ()
+main = pure $ op (1, 2, 3)
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 98c55bfc607b..4b4bb85a895b 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -280,6 +280,11 @@ test('test-defaulting-plugin-fail',
pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin-fail TOP={top}')],
makefile_test, [])
+test('T23821',
+ [extra_files(['defaulting-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin TOP={top}')],
+ makefile_test, [])
+
test('plugins-order',
[extra_files(['plugin-recomp/', 'plugin-recomp-test.hs']),
pre_cmd('$MAKE -s --no-print-directory -C plugin-recomp package.plugins01 TOP={top}')
diff --git a/testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs b/testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
new file mode 100644
index 000000000000..e4a51ce69cd1
--- /dev/null
+++ b/testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
@@ -0,0 +1,32 @@
+module DefaultInterference(plugin) where
+
+import GHC.Driver.Plugins
+import GHC.Tc.Plugin
+import GHC.Tc.Types
+import GHC.Tc.Utils.TcType
+import GHC.Tc.Types.Constraint
+import GHC.Core.Predicate
+import GHC.Tc.Solver
+import GHC.Core.Type
+import GHC.Core.Class
+import GHC.Data.Bag
+import GHC.Builtin.Types (intTy)
+
+plugin :: Plugin
+plugin = defaultPlugin
+ { defaultingPlugin = \_ -> Just DefaultingPlugin
+ { dePluginInit = pure ()
+ , dePluginRun = \ _ -> defaultEverythingToInt
+ , dePluginStop = \ _ -> pure ()
+ }
+ }
+
+defaultEverythingToInt :: WantedConstraints -> TcPluginM [DefaultingProposal]
+defaultEverythingToInt wanteds = pure
+ [ DefaultingProposal tv [intTy] [ct]
+ | ct <- bagToList $ approximateWC True wanteds
+ , Just (cls, tys) <- pure $ getClassPredTys_maybe (ctPred ct)
+ , [ty] <- pure $ filterOutInvisibleTypes (classTyCon cls) tys
+ , Just tv <- pure $ getTyVar_maybe ty
+ , isMetaTyVar tv
+ ]
diff --git a/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal b/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
index a8f69ab7a08d..60b500ac0a26 100644
--- a/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
+++ b/testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
@@ -6,5 +6,5 @@ version: 0.1.0.0
library
default-language: Haskell2010
build-depends: base, ghc, containers
- exposed-modules: DefaultLifted
+ exposed-modules: DefaultLifted DefaultInterference
ghc-options: -Wall
--
GitLab