[Git][ghc/ghc][master] If a defaulting plugin made progress, re-zonk wanteds before built-in defaulting

[Marge Bot (@marge-bot)]

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


Commits:
a6828173 by Gergő Érdi at 2023-08-16T09:35:41-04:00
If a defaulting plugin made progress, re-zonk wanteds before built-in defaulting

Fixes #23821.

- - - - -


6 changed files:

- compiler/GHC/Tc/Solver.hs
- testsuite/tests/plugins/Makefile
- + testsuite/tests/plugins/T23821.hs
- testsuite/tests/plugins/all.T
- + testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
- testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal


Changes:

=====================================
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 {" $


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


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


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


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


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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a6828173b90dbd276be593c1690aa34317c13c72
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/20230816/3f50e151/attachment-0001.html>