diff --git a/compiler/GHC/Tc/Solver.hs b/compiler/GHC/Tc/Solver.hs index a09d7b3346b748226d50f489cb21ad00d705d327..094ee9d3d05342f51f52ef4f4d64449fc8b1518d 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 986acba47232f0bc9d749ee971144295b59d1865..0811d378ae8fde275d22bc65d708d3a633a0bba9 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 0000000000000000000000000000000000000000..e0c3d50fc985197536845222d7260f7e96ff191c --- /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 98c55bfc607b1f79a238a2f28af86c0a03c0e482..4b4bb85a895bcd6f09dc28cab1052043e443a50d 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 0000000000000000000000000000000000000000..e4a51ce69cd1f2efb05f0a72aeb2828a144fba52 --- /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 a8f69ab7a08d4d252dfcd63ad00d2bb634076a11..60b500ac0a260b268dcdad8829a60a5db1b81a77 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