[Git][ghc/ghc][wip/issue-23832] Allow cross-tyvar defaulting proposals from plugins
Gergő Érdi (@cactus)
gitlab at gitlab.haskell.org
Fri Aug 25 05:02:52 UTC 2023
Gergő Érdi pushed to branch wip/issue-23832 at Glasgow Haskell Compiler / GHC
Commits:
f4438d63 by Gergő Érdi at 2023-08-25T06:02:26+01:00
Allow cross-tyvar defaulting proposals from plugins
Fixes #23832.
- - - - -
23 changed files:
- compiler/GHC/Tc/Errors.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Instance/FunDeps.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Monad.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_invalid.hs
- + testsuite/tests/plugins/T23832_invalid.stderr
- + 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/DefaultInvalid.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.hs
=====================================
@@ -2548,10 +2548,10 @@ relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs
(RelevantBindings (bd:bds) discards) tc_bndrs }
-----------------------
-warnDefaulting :: TcTyVar -> [Ct] -> Type -> TcM ()
-warnDefaulting _ [] _
+warnDefaulting :: [Ct] -> TcTyVar -> Type -> TcM ()
+warnDefaulting [] _ _
= panic "warnDefaulting: empty Wanteds"
-warnDefaulting the_tv wanteds@(ct:_) default_ty
+warnDefaulting wanteds@(ct:_) the_tv default_ty
= do { warn_default <- woptM Opt_WarnTypeDefaults
; env0 <- liftZonkM $ tcInitTidyEnv
-- don't want to report all the superclass constraints, which
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1858,6 +1858,29 @@ instance Diagnostic TcRnMessage where
, text "In the future GHC will no longer implicitly quantify over such variables"
]
+ TcRnMisalignedDefaultingProposal wanteds tvs tys ->
+ mkSimpleDecorated $
+ pprWithExplicitKindsWhen True $
+ vcat [ hang (text "Defaulting plugin returned invalid defaulting proposal when passed these constraints:") 2 $
+ pprQuotedList (map ctPred wanteds)
+ , hang (text "Type variables:") 2 $
+ pprQuotedList tvs
+ , hang (text "Proposed types:") 2 $
+ pprQuotedList tys
+ , text "The lists have different lengths."
+ ]
+
+ TcRnInvalidDefaultedTyVar wanteds tvs bad_tvs ->
+ mkSimpleDecorated $
+ pprWithExplicitKindsWhen True $
+ vcat [ hang (text "Defaulting plugin returned invalid defaulting proposal when passed these constraints:") 2 $
+ pprQuotedList (map ctPred wanteds)
+ , hang (text "Type variables:") 2 $
+ pprQuotedList tvs
+ , hang (text "Of which the following are not an unfilled metavariables:") 2 $
+ pprQuotedList bad_tvs
+ ]
+
diagnosticReason = \case
TcRnUnknownMessage m
-> diagnosticReason m
@@ -2462,6 +2485,10 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnIllegalTypeExpr{}
-> ErrorWithoutFlag
+ TcRnMisalignedDefaultingProposal{}
+ -> ErrorWithoutFlag
+ TcRnInvalidDefaultedTyVar{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3116,6 +3143,10 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnIllegalTypeExpr{}
-> noHints
+ TcRnMisalignedDefaultingProposal{}
+ -> noHints
+ TcRnInvalidDefaultedTyVar{}
+ -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -4118,6 +4118,33 @@ data TcRnMessage where
-}
TcRnIllegalTypeExpr :: TcRnMessage
+ {-| TcRnMisalignedDefaultingProposal is an error raised when a
+ defaulting plugin returns a defaulting proposal in which the list of
+ default types has a different length than the list of type variables
+ to default.
+
+ Test cases:
+ T23832_misaligned
+ -}
+ TcRnMisalignedDefaultingProposal
+ :: ![Ct] -- ^ The constraints passed to the plugin
+ -> ![TcTyVar] -- ^ The type variables proposed for defaulting
+ -> ![Type] -- ^ The default types proposed
+ -> TcRnMessage
+
+ {-| TcRnInvalidDefaultedTyVar is an error raised when a
+ defaulting plugin proposes to default a type variable that is
+ not an unfilled metavariable
+
+ Test cases:
+ T23832_invalid
+ -}
+ TcRnInvalidDefaultedTyVar
+ :: ![Ct] -- ^ The constraints passed to the plugin
+ -> [TcTyVar] -- ^ The type variable proposed for defaulting...
+ -> [TcTyVar] -- ^ ..ouf of which these are invalid
+ -> TcRnMessage
+
deriving Generic
=====================================
compiler/GHC/Tc/Instance/FunDeps.hs
=====================================
@@ -96,7 +96,7 @@ Assume:
Then `improveFromInstEnv` should return a FDEqn with
FDEqn { fd_qtvs = [], fd_eqs = [Pair Bool ty] }
-describing an equality (Int ~ ty). To do this we /match/ the instance head
+describing an equality (Bool ~ ty). To do this we /match/ the instance head
against the [W], using just the LHS of the fundep; if we match, we return
an equality for the RHS.
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -38,6 +38,7 @@ import GHC.Driver.DynFlags
import GHC.Data.FastString
import GHC.Data.List.SetOps
import GHC.Types.Name
+import GHC.Types.Unique.Set
import GHC.Types.Id
import GHC.Utils.Outputable
import GHC.Builtin.Utils
@@ -63,11 +64,12 @@ 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
import GHC.Types.Var
+import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Id.Make ( unboxedUnitExpr )
@@ -3611,7 +3613,7 @@ applyDefaultingRules wanteds
, text "groups =" <+> ppr groups
, text "info =" <+> ppr info ]
- ; something_happeneds <- mapM (disambigGroup default_tys) groups
+ ; something_happeneds <- mapM (disambigGroup wanteds default_tys) groups
; traceTcS "applyDefaultingRules }" (ppr something_happeneds)
@@ -3619,9 +3621,11 @@ applyDefaultingRules wanteds
where run_defaulting_plugin wanteds p =
do { groups <- runTcPluginTcS (p wanteds)
; defaultedGroups <-
- filterM (\g -> disambigGroup
+ filterM (\g -> disambigMultiGroup
+ wanteds
+ (deProposalTyVars g)
(deProposalCandidates g)
- (deProposalTyVar g, deProposalCts g))
+ (deProposalCts g))
groups
; traceTcS "defaultingPlugin " $ ppr defaultedGroups
; case defaultedGroups of
@@ -3689,55 +3693,91 @@ findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds
(ovl_strings && (cls `hasKey` isStringClassKey))
------------------------------
-disambigGroup :: [Type] -- The default types
- -> (TcTyVar, [Ct]) -- All constraints sharing same type variable
+disambigGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes
+ -> [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 } }
+disambigGroup orig_wanteds default_tys (the_tv, wanteds)
+ = disambigMultiGroup orig_wanteds [the_tv] [[default_ty] | default_ty <- default_tys] wanteds
+
+disambigMultiGroup :: WantedConstraints -- ^ Original constraints, for diagnostic purposes
+ -> [TcTyVar] -- ^ variables to default
+ -> [[Type]] -- ^ default type assignments to try
+ -> [Ct] -- ^ check these are solved by defaulting
+ -> TcS Bool -- True <=> something happened, reflected in ty_binds
+disambigMultiGroup orig_wanteds the_tvs defaults wanteds = anyM propose defaults
+ where
+ propose default_tys
+ = do { traceTcS "disambigMultiGroup {" (vcat [ ppr default_tys, ppr the_tvs, ppr wanteds ])
+ -- Only with a defaulting plugin could these lengths be mismatched.
+ -- We report an error, instead of silently failing to default.
+ ; unless (equalLength the_tvs default_tys) $
+ errMisalignedDefaultingProposal orig_wanteds the_tvs default_tys
+ ; invalid_tvs <- filterOutM TcS.isUnfilledMetaTyVar the_tvs
+ ; unless (null invalid_tvs) $
+ errInvalidDefaultedTyVar orig_wanteds the_tvs invalid_tvs
+ ; fake_ev_binds_var <- TcS.newTcEvBinds
+ ; tclvl <- TcS.getTcLevel
+ ; mb_subst <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group
+
+ ; case mb_subst of
+ Just subst -> -- Success: record the type variable bindings, and return
+ do { deep_tvs <- filterM TcS.isUnfilledMetaTyVar $ nonDetEltsUniqSet $ closeOverKinds (mkVarSet the_tvs)
+ ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv)
+ ; wrapWarnTcS $ zipWithM_ (warnDefaulting wanteds) the_tvs default_tys
+ ; traceTcS "disambigMultiGroup succeeded }" (ppr default_tys)
+ ; return True }
+ Nothing -> -- 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 ]
+ ; residual_wc <- solveSimpleWanteds $ listToBag $ map mkNonCanonical wanted_evs
+ ; return $ if isEmptyWC residual_wc then Just subst else Nothing }
+
+ | otherwise
+ = return Nothing
+
+ 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.
+
+flattenCtsOfWC :: WantedConstraints -> [Ct]
+flattenCtsOfWC (WC { wc_simple = cts, wc_impl = impls })
+ = ctsElts cts ++ concatMap (flattenCtsOfWC . ic_wanted) impls
+
+errMisalignedDefaultingProposal :: WantedConstraints -> [TcTyVar] -> [Type] -> TcS ()
+errMisalignedDefaultingProposal wanteds the_tvs default_tys
+ = failTcS $ TcRnMisalignedDefaultingProposal tidy_wanteds tidy_tvs default_tys
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 }
+ tidy_env = tidyFreeTyCoVars emptyTidyEnv $ tyCoVarsOfWCList wanteds ++ the_tvs
+ tidy_wanteds = map (tidyCt tidy_env) $ flattenCtsOfWC wanteds
+ tidy_tvs = map (tidyTyCoVarOcc tidy_env) the_tvs
- | 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.
+errInvalidDefaultedTyVar :: WantedConstraints -> [TcTyVar] -> [TcTyVar] -> TcS ()
+errInvalidDefaultedTyVar wanteds tvs problematic_tvs
+ = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_tvs tidy_problems
+ where
+ tidy_env = tidyFreeTyCoVars emptyTidyEnv (tvs ++ problematic_tvs)
+ tidy_wanteds = map (tidyCt tidy_env) $ flattenCtsOfWC wanteds
+ tidy_tvs = map (tidyTyCoVarOcc tidy_env) tvs
+ tidy_problems = map (tidyTyCoVarOcc tidy_env) problematic_tvs
-- In interactive mode, or with -XExtendedDefaultRules,
-- we default Show a to Show () to avoid gratuitous errors on "show []"
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -105,7 +105,7 @@ module GHC.Tc.Solver.Monad (
tcInstSkolTyVarsX,
TcLevel,
- isFilledMetaTyVar_maybe, isFilledMetaTyVar,
+ isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,
zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,
zonkTyCoVarsAndFVList,
zonkSimples, zonkWC,
@@ -1478,6 +1478,9 @@ isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)
isFilledMetaTyVar :: TcTyVar -> TcS Bool
isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)
+isUnfilledMetaTyVar :: TcTyVar -> TcS Bool
+isUnfilledMetaTyVar tv = wrapTcS $ TcM.isUnfilledMetaTyVar tv
+
zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet
zonkTyCoVarsAndFV tvs = liftZonkTcS (TcM.zonkTyCoVarsAndFV tvs)
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -86,7 +86,7 @@ module GHC.Tc.Types(
-- Defaulting plugin
DefaultingPlugin(..), DefaultingProposal(..),
- FillDefaulting, DefaultingPluginResult,
+ FillDefaulting,
-- Role annotations
RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,
@@ -1052,25 +1052,27 @@ 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)
-type DefaultingPluginResult = [DefaultingProposal]
-type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult
+type FillDefaulting = WantedConstraints -> TcPluginM [DefaultingProposal]
-- | A plugin for controlling defaulting.
data DefaultingPlugin = forall s. DefaultingPlugin
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -71,7 +71,7 @@ To ensure uniqueness across GHC versions, we proceed as follows:
GhcDiagnosticCode "MyNewErrorConstructor" = 12345
You can obtain new randomly-generated error codes by using
- https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain.
+ https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain
You will get a type error if you try to use an error code that is already
used by another constructor.
@@ -594,6 +594,8 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnImplicitRhsQuantification" = 16382
GhcDiagnosticCode "TcRnBadTyConTelescope" = 87279
GhcDiagnosticCode "TcRnPatersonCondFailure" = 22979
+ GhcDiagnosticCode "TcRnMisalignedDefaultingProposal" = 72071
+ GhcDiagnosticCode "TcRnInvalidDefaultedTyVar" = 45625
-- 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,19 +1357,21 @@ 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.
}
- type DefaultingPluginResult = [DefaultingProposal]
- type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult
+ type FillDefaulting = WantedConstraints -> TcPluginM [DefaultingProposal]
-- | A plugin for controlling defaulting.
data DefaultingPlugin = forall s. DefaultingPlugin
@@ -1384,12 +1386,12 @@ 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 ``[DefaultingProposal]``: 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
-leave out a constraint, the default will be accepted, and then potentially
+context and then default to it. The most robust context to return in ``deProposalCts``
+is the list 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
to the user.
=====================================
testsuite/tests/plugins/Makefile
=====================================
@@ -172,9 +172,9 @@ 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: T23821 T23832 T23832_misaligned T23832_invalid
+T23821 T23832 T23832_misaligned T23832_invalid:
+ -"$(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:
=====================================
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_invalid.hs
=====================================
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fplugin DefaultInvalid #-}
+module Main where
+
+class C a where
+ op :: a -> ()
+
+instance C Double where
+ op x = ()
+
+bar :: a -> ()
+bar = op
+
+main :: IO ()
+main = pure ()
=====================================
testsuite/tests/plugins/T23832_invalid.stderr
=====================================
@@ -0,0 +1,6 @@
+
+T23832_invalid.hs:1:1: error: [GHC-45625]
+ Defaulting plugin returned invalid defaulting proposal when passed these constraints:
+ ‘C a’
+ Type variables: ‘a’
+ Of which the following are not an unfilled metavariables: ‘a’
=====================================
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,7 @@
+
+T23832_misaligned.hs:1:1: error: [GHC-72071]
+ Defaulting plugin returned invalid defaulting proposal when passed these constraints:
+ ‘C a0 b0’, ‘Num a0’, ‘Num b0’
+ Type variables: ‘a0’, ‘b0’
+ Proposed types: ‘Double’, ‘Int’, ‘Int’
+ The lists have different lengths.
=====================================
testsuite/tests/plugins/all.T
=====================================
@@ -285,6 +285,21 @@ 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('T23832_invalid',
+ [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/DefaultInvalid.hs
=====================================
@@ -0,0 +1,25 @@
+module DefaultInvalid(plugin) where
+
+import GHC.Driver.Plugins
+import GHC.Tc.Plugin
+import GHC.Tc.Types
+import GHC.Tc.Types.Constraint
+import GHC.Builtin.Types (doubleTy)
+
+plugin :: Plugin
+plugin = defaultPlugin
+ { defaultingPlugin = \_ -> Just DefaultingPlugin
+ { dePluginInit = pure ()
+ , dePluginRun = \ _ -> defaultInvalid
+ , dePluginStop = \ _ -> pure ()
+ }
+ }
+
+defaultInvalid :: WantedConstraints -> TcPluginM [DefaultingProposal]
+defaultInvalid wanteds = pure [ DefaultingProposal [tv] [[doubleTy]] [] | tv <- tvs ]
+ where
+ tvs = varsOfWC wanteds
+
+ varsOfWC WC{ wc_impl = implications } = concatMap varsOfImpl implications
+ varsOfImpl Implic{ ic_wanted = wanted } = tyCoVarsOfWCList wanted
+ -- Deliberately buggy to trigger error GHC-45625
=====================================
testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
=====================================
@@ -68,7 +68,7 @@ data PluginState = PluginState { defaultClassName :: Name }
lookupName :: Module -> OccName -> TcPluginM Name
lookupName md occ = lookupOrig md occ
-solveDefaultType :: PluginState -> [Ct] -> TcPluginM DefaultingPluginResult
+solveDefaultType :: PluginState -> [Ct] -> TcPluginM [DefaultingProposal]
solveDefaultType _ [] = return []
solveDefaultType state wanteds = do
envs <- getInstEnvs
@@ -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
@@ -103,7 +103,7 @@ initialize :: TcPluginM PluginState
initialize = do
lookupDefaultTypes
-run :: PluginState -> WantedConstraints -> TcPluginM DefaultingPluginResult
+run :: PluginState -> WantedConstraints -> TcPluginM [DefaultingProposal]
run s ws = do
solveDefaultType s (ctsElts $ approximateWC False ws)
=====================================
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,10 @@ version: 0.1.0.0
library
default-language: Haskell2010
build-depends: base, ghc, containers
- exposed-modules: DefaultLifted DefaultInterference
+ exposed-modules:
+ DefaultLifted
+ DefaultInterference
+ DefaultMultiParam
+ DefaultMisaligned
+ DefaultInvalid
ghc-options: -Wall
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4438d632717bc366ec5f5858ab44de326ba342c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f4438d632717bc366ec5f5858ab44de326ba342c
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/20230825/efb22466/attachment-0001.html>
More information about the ghc-commits
mailing list