Skip to content
Snippets Groups Projects
Commit a6828173 authored by Gergő Érdi's avatar Gergő Érdi Committed by Marge Bot
Browse files

If a defaulting plugin made progress, re-zonk wanteds before built-in defaulting

Fixes #23821.
parent bfe4ffac
No related branches found
No related tags found
No related merge requests found
......@@ -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 {" $
......
......@@ -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
......
{-# 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)
......@@ -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}')
......
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
]
......@@ -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
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment