[Git][ghc/ghc][wip/issue-23832] Allow cross-tyvar defaulting proposals from plugins
Gergő Érdi (@cactus)
gitlab at gitlab.haskell.org
Fri Aug 18 03:50:42 UTC 2023
Gergő Érdi pushed to branch wip/issue-23832 at Glasgow Haskell Compiler / GHC
Commits:
79765409 by Gergő Érdi at 2023-08-18T04:50:28+01:00
Allow cross-tyvar defaulting proposals from plugins
Fixes #23832.
- - - - -
17 changed files:
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Types/Error/Codes.hs
- docs/users_guide/9.10.1-notes.rst
- docs/users_guide/extending_ghc.rst
- testsuite/tests/plugins/Makefile
- + testsuite/tests/plugins/T23832.hs
- + testsuite/tests/plugins/T23832_misaligned.hs
- + testsuite/tests/plugins/T23832_misaligned.stderr
- testsuite/tests/plugins/all.T
- testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
- + testsuite/tests/plugins/defaulting-plugin/DefaultMisaligned.hs
- + testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs
- testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
Changes:
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1854,6 +1854,12 @@ instance Diagnostic TcRnMessage where
, text "In the future GHC will no longer implicitly quantify over such variables"
]
+ TcRnMisalignedDefaultingProposal tvs tys -> mkSimpleDecorated $
+ vcat [ text "Defaulting plugin returned invalid defaulting proposal."
+ , hang (text "Type variables:") 2 $ ppr tvs
+ , hang (text "Proposed types:") 2 $ ppr tys
+ ]
+
diagnosticReason = \case
TcRnUnknownMessage m
-> diagnosticReason m
@@ -2458,6 +2464,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnIllegalTypeExpr{}
-> ErrorWithoutFlag
+ TcRnMisalignedDefaultingProposal{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3112,6 +3120,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnIllegalTypeExpr{}
-> noHints
+ TcRnMisalignedDefaultingProposal{}
+ -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -4122,6 +4122,18 @@ data TcRnMessage where
-}
TcRnIllegalTypeExpr :: TcRnMessage
+ {-| TcRnMisalignedDefaultingProposal is an error raised when a
+ defaulting plugin returns a defaulting proposal with the list of
+ default types not matching the list of type variables.
+
+ Test cases:
+ T23832_misaligned
+ -}
+ TcRnMisalignedDefaultingProposal
+ :: ![TcTyVar] -- ^ The type variables proposed for defaulting
+ -> ![Type] -- ^ The default types proposed
+ -> TcRnMessage
+
deriving Generic
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -63,7 +63,7 @@ import GHC.Core.Type
import GHC.Core.Ppr
import GHC.Core.TyCon ( TyConBinder, isTypeFamilyTyCon )
import GHC.Builtin.Types
-import GHC.Core.Unify ( tcMatchTyKi )
+import GHC.Core.Unify ( tcMatchTyKis )
import GHC.Unit.Module ( getModule )
import GHC.Utils.Misc
import GHC.Utils.Panic
@@ -3619,9 +3619,10 @@ applyDefaultingRules wanteds
where run_defaulting_plugin wanteds p =
do { groups <- runTcPluginTcS (p wanteds)
; defaultedGroups <-
- filterM (\g -> disambigGroup
+ filterM (\g -> disambigMultiGroup
(deProposalCandidates g)
- (deProposalTyVar g, deProposalCts g))
+ (deProposalTyVars g)
+ (deProposalCts g))
groups
; traceTcS "defaultingPlugin " $ ppr defaultedGroups
; case defaultedGroups of
@@ -3693,51 +3694,62 @@ disambigGroup :: [Type] -- The default types
-> (TcTyVar, [Ct]) -- All constraints sharing same type variable
-> TcS Bool -- True <=> something happened, reflected in ty_binds
-disambigGroup [] _
- = return False
-disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)
- = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])
- ; fake_ev_binds_var <- TcS.newTcEvBinds
- ; tclvl <- TcS.getTcLevel
- ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group
-
- ; if success then
- -- Success: record the type variable binding, and return
- do { unifyTyVar the_tv default_ty
- ; wrapWarnTcS $ warnDefaulting the_tv wanteds default_ty
- ; traceTcS "disambigGroup succeeded }" (ppr default_ty)
- ; return True }
- else
- -- Failure: try with the next type
- do { traceTcS "disambigGroup failed, will try other default types }"
- (ppr default_ty)
- ; disambigGroup default_tys group } }
- where
- try_group
- | Just subst <- mb_subst
- = do { lcl_env <- TcS.getLclEnv
- ; tc_lvl <- TcS.getTcLevel
- ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)
- -- Equality constraints are possible due to type defaulting plugins
- ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'
- | wanted <- wanteds
- , CtWanted { ctev_pred = pred
- , ctev_rewriters = rewriters }
- <- return (ctEvidence wanted)
- , let pred' = substTy subst pred ]
- ; fmap isEmptyWC $
- solveSimpleWanteds $ listToBag $
- map mkNonCanonical wanted_evs }
+disambigGroup default_tys (the_tv, wanteds)
+ = disambigMultiGroup [[default_ty] | default_ty <- default_tys] [the_tv] wanteds
- | otherwise
- = return False
-
- the_ty = mkTyVarTy the_tv
- mb_subst = tcMatchTyKi the_ty default_ty
- -- Make sure the kinds match too; hence this call to tcMatchTyKi
- -- E.g. suppose the only constraint was (Typeable k (a::k))
- -- With the addition of polykinded defaulting we also want to reject
- -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.
+disambigMultiGroup :: [[Type]] -- ^ default type assignments to try
+ -> [TcTyVar] -- ^ variables to default
+ -> [Ct] -- ^ check these are solved by defaulting
+ -> TcS Bool -- True <=> something happened, reflected in ty_binds
+disambigMultiGroup defaults the_tvs wanteds = anyM propose defaults
+ where
+ propose default_tys
+ = do { traceTcS "disambigMultiGroup {" (vcat [ ppr default_tys, ppr the_tvs, ppr wanteds ])
+ ; unless (equalLength the_tvs default_tys) $
+ failTcS $ TcRnMisalignedDefaultingProposal the_tvs default_tys
+ ; fake_ev_binds_var <- TcS.newTcEvBinds
+ ; tclvl <- TcS.getTcLevel
+ ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group
+
+ ; if success then
+ -- Success: record the type variable binding, and return
+ do { zipWithM_ unifyTyVar the_tvs default_tys
+ ; wrapWarnTcS $ forM_ (zip the_tvs default_tys) $ \(the_tv, default_ty) ->
+ warnDefaulting the_tv wanteds default_ty
+ ; traceTcS "disambigMultiGroup succeeded }" (ppr default_tys)
+ ; return True }
+ else
+ -- Failure: try with the next type
+ do { traceTcS "disambigMultiGroup failed, will try other default types }"
+ (ppr default_tys)
+ ; return False }
+ }
+ where
+ try_group
+ | Just subst <- mb_subst
+ = do { lcl_env <- TcS.getLclEnv
+ ; tc_lvl <- TcS.getTcLevel
+ ; let loc = mkGivenLoc tc_lvl (getSkolemInfo unkSkol) (mkCtLocEnv lcl_env)
+ -- Equality constraints are possible due to type defaulting plugins
+ ; wanted_evs <- sequence [ newWantedNC loc rewriters pred'
+ | wanted <- wanteds
+ , CtWanted { ctev_pred = pred
+ , ctev_rewriters = rewriters }
+ <- return (ctEvidence wanted)
+ , let pred' = substTy subst pred ]
+ ; fmap isEmptyWC $
+ solveSimpleWanteds $ listToBag $
+ map mkNonCanonical wanted_evs }
+
+ | otherwise
+ = return False
+
+ the_tys = mkTyVarTys the_tvs
+ mb_subst = tcMatchTyKis the_tys default_tys
+ -- Make sure the kinds match too; hence this call to tcMatchTyKi
+ -- E.g. suppose the only constraint was (Typeable k (a::k))
+ -- With the addition of polykinded defaulting we also want to reject
+ -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.
-- In interactive mode, or with -XExtendedDefaultRules,
-- we default Show a to Show () to avoid gratuitous errors on "show []"
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1052,20 +1052,23 @@ data TcPluginRewriteResult
, tcRewriterNewWanteds :: [Ct]
}
--- | A collection of candidate default types for a type variable.
+-- | A collection of candidate default types for sets of type variables.
data DefaultingProposal
= DefaultingProposal
- { deProposalTyVar :: TcTyVar
- -- ^ The type variable to default.
- , deProposalCandidates :: [Type]
- -- ^ Candidate types to default the type variable to.
+ { deProposalTyVars :: [TcTyVar]
+ -- ^ The type variables to default.
+ , deProposalCandidates :: [[Type]]
+ -- ^ Candidate types to default the type variables to.
+ --
+ -- All of the inner lists should have the same length as the
+ -- list of type variables we are defaulting.
, deProposalCts :: [Ct]
-- ^ The constraints against which defaults are checked.
}
instance Outputable DefaultingProposal where
ppr p = text "DefaultingProposal"
- <+> ppr (deProposalTyVar p)
+ <+> ppr (deProposalTyVars p)
<+> ppr (deProposalCandidates p)
<+> ppr (deProposalCts p)
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -594,6 +594,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnImplicitRhsQuantification" = 16382
GhcDiagnosticCode "TcRnBadTyConTelescope" = 87279
GhcDiagnosticCode "TcRnPatersonCondFailure" = 22979
+ GhcDiagnosticCode "TcRnMisalignedDefaultingProposal" = 72071
-- TcRnTypeApplicationsDisabled
GhcDiagnosticCode "TypeApplication" = 23482
=====================================
docs/users_guide/9.10.1-notes.rst
=====================================
@@ -51,6 +51,9 @@ Compiler
- Fixed a bug where compiling with both :ghc-flag:`-ddump-timings` and :ghc-flag:`-ddump-to-file` did not
suppress printing timings to the console. See :ghc-ticket:`20316`.
+- Defaulting plugins can now propose solutions to entangled sets of type variables. This allows defaulting
+ of multi-parameter type classes. See :ghc-tickect:`23832`.
+
GHCi
~~~~
=====================================
docs/users_guide/extending_ghc.rst
=====================================
@@ -1349,7 +1349,7 @@ Defaulting plugins
Defaulting plugins are called when ambiguous variables might otherwise cause
errors, in the same way as the built-in defaulting mechanism.
-A defaulting plugin can propose potential ways to fill an ambiguous variable
+A defaulting plugin can propose potential ways to fill ambiguous variables
according to whatever criteria you would like. GHC will verify that those
proposals will not lead to type errors in a context that you declare.
@@ -1357,13 +1357,16 @@ Defaulting plugins have a single access point in the `GHC.Tc.Types` module
::
- -- | A collection of candidate default types for a type variable.
+ -- | A collection of candidate default types for sets of type variables.
data DefaultingProposal
= DefaultingProposal
- { deProposalTyVar :: TcTyVar
- -- ^ The type variable to default.
- , deProposalCandidates :: [Type]
- -- ^ Candidate types to default the type variable to.
+ { deProposalTyVars :: [TcTyVar]
+ -- ^ The type variables to default.
+ , deProposalCandidates :: [[Type]]
+ -- ^ Candidate types to default the type variables to.
+ --
+ -- All of the inner lists should have the same length as the
+ -- list of type variables we are defaulting.
, deProposalCts :: [Ct]
-- ^ The constraints against which defaults are checked.
}
@@ -1384,11 +1387,11 @@ Defaulting plugins have a single access point in the `GHC.Tc.Types` module
The plugin gets a combination of wanted constraints which can be most easily
broken down into simple wanted constraints with ``approximateWC``. The result of
-running the plugin should be a ``DefaultingPluginResult``, a list of types that
-should be attempted for a given type variable that is ambiguous in a given
+running the plugin should be a ``DefaultingPluginResult``: a list of types that
+should be attempted for the given type variables that are ambiguous in a given
context. GHC will check if one of the proposals is acceptable in the given
context and then default to it. The most robust context to provide is the list
-of all wanted constraints that mention the variable you are defaulting. If you
+of all wanted constraints that mention the variables you are defaulting. If you
leave out a constraint, the default will be accepted, and then potentially
result in a type checker error if it is incompatible with one of the constraints
you left out. This can be a useful way of forcing a default and reporting errors
=====================================
testsuite/tests/plugins/Makefile
=====================================
@@ -176,6 +176,10 @@ test-defaulting-plugin-fail:
T23821:
-"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 T23821.hs -package-db defaulting-plugin/pkg.test-defaulting-plugin/local.package.conf
+.PHONY: T23832 T23832_misaligned
+T23832 T23832_misaligned:
+ -"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 $@.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/T23832.hs
=====================================
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fplugin DefaultMultiParam #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Main where
+
+class C a b where
+ op :: a -> b -> ()
+
+instance C Double Int where
+ op _ _ = ()
+
+main :: IO ()
+main = pure $ op 1 2
=====================================
testsuite/tests/plugins/T23832_misaligned.hs
=====================================
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -fplugin DefaultMisaligned #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module Main where
+
+class C a b where
+ op :: a -> b -> ()
+
+instance C Double Int where
+ op _ _ = ()
+
+main :: IO ()
+main = pure $ op 1 2
=====================================
testsuite/tests/plugins/T23832_misaligned.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T23832_misaligned.hs:1:1: error: [GHC-72071]
+ Defaulting plugin returned invalid defaulting proposal.
+ Type variables: [a_aIJ, b_aIK]
+ Proposed types: [Double, Int, Int]
=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -285,6 +285,16 @@ test('T23821',
pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin TOP={top}')],
makefile_test, [])
+test('T23832',
+ [extra_files(['defaulting-plugin/']),
+ pre_cmd('$MAKE -s --no-print-directory -C defaulting-plugin package.test-defaulting-plugin TOP={top}')],
+ makefile_test, [])
+
+test('T23832_misaligned',
+ [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
=====================================
@@ -23,7 +23,7 @@ plugin = defaultPlugin
defaultEverythingToInt :: WantedConstraints -> TcPluginM [DefaultingProposal]
defaultEverythingToInt wanteds = pure
- [ DefaultingProposal tv [intTy] [ct]
+ [ DefaultingProposal [tv] [[intTy]] [ct]
| ct <- bagToList $ approximateWC True wanteds
, Just (cls, tys) <- pure $ getClassPredTys_maybe (ctPred ct)
, [ty] <- pure $ filterOutInvisibleTypes (classTyCon cls) tys
=====================================
testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
=====================================
@@ -89,7 +89,7 @@ solveDefaultType state wanteds = do
case M.lookup (tyVarKind var) defaults of
Nothing -> error "Bug, we already checked that this variable has a default"
Just deftys -> do
- pure [DefaultingProposal var deftys cts])
+ pure [DefaultingProposal [var] [[defty] | defty <- deftys] cts])
groups
where isVariableDefaultable defaults v = isAmbiguousTyVar v && M.member (tyVarKind v) defaults
=====================================
testsuite/tests/plugins/defaulting-plugin/DefaultMisaligned.hs
=====================================
@@ -0,0 +1,33 @@
+module DefaultMisaligned(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 (doubleTy, intTy)
+import Data.Maybe (mapMaybe)
+
+plugin :: Plugin
+plugin = defaultPlugin
+ { defaultingPlugin = \_ -> Just DefaultingPlugin
+ { dePluginInit = pure ()
+ , dePluginRun = \ _ -> defaultMisaligned
+ , dePluginStop = \ _ -> pure ()
+ }
+ }
+
+defaultMisaligned :: WantedConstraints -> TcPluginM [DefaultingProposal]
+defaultMisaligned wanteds = pure
+ [ DefaultingProposal [tv1, tv2] [[doubleTy, intTy, intTy]] [ct] -- Deliberately mis-aligned to trigger a Tc error
+ | ct <- bagToList $ approximateWC True wanteds
+ , Just (cls, tys) <- pure $ getClassPredTys_maybe (ctPred ct)
+ , tys'@[_, _] <- pure $ filterOutInvisibleTypes (classTyCon cls) tys
+ , tvs@[tv1, tv2] <- pure $ mapMaybe getTyVar_maybe tys'
+ , all isMetaTyVar tvs
+ ]
=====================================
testsuite/tests/plugins/defaulting-plugin/DefaultMultiParam.hs
=====================================
@@ -0,0 +1,34 @@
+module DefaultMultiParam(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 (doubleTy, intTy)
+import Data.Maybe (mapMaybe)
+
+plugin :: Plugin
+plugin = defaultPlugin
+ { defaultingPlugin = \_ -> Just DefaultingPlugin
+ { dePluginInit = pure ()
+ , dePluginRun = \ _ -> defaultBinaryClassesToDoubleInt
+ , dePluginStop = \ _ -> pure ()
+ }
+ }
+
+-- Default every class constraint of form `C a b` to `C Double Int`
+defaultBinaryClassesToDoubleInt :: WantedConstraints -> TcPluginM [DefaultingProposal]
+defaultBinaryClassesToDoubleInt wanteds = pure
+ [ DefaultingProposal [tv1, tv2] [[doubleTy, intTy]] [ct]
+ | ct <- bagToList $ approximateWC True wanteds
+ , Just (cls, tys) <- pure $ getClassPredTys_maybe (ctPred ct)
+ , tys'@[_, _] <- pure $ filterOutInvisibleTypes (classTyCon cls) tys
+ , tvs@[tv1, tv2] <- pure $ mapMaybe getTyVar_maybe tys'
+ , all isMetaTyVar tvs
+ ]
=====================================
testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
=====================================
@@ -6,5 +6,9 @@ version: 0.1.0.0
library
default-language: Haskell2010
build-depends: base, ghc, containers
- exposed-modules: DefaultLifted DefaultInterference
+ exposed-modules:
+ DefaultLifted
+ DefaultInterference
+ DefaultMultiParam
+ DefaultMisaligned
ghc-options: -Wall
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/797654097dce128c736836961d1f9493049f883b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/797654097dce128c736836961d1f9493049f883b
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/20230817/2a2d6c92/attachment-0001.html>
More information about the ghc-commits
mailing list