[Git][ghc/ghc][wip/issue-23832] Allow cross-tyvar defaulting proposals from plugins
Gergő Érdi (@cactus)
gitlab at gitlab.haskell.org
Wed Aug 30 02:06:14 UTC 2023
Gergő Érdi pushed to branch wip/issue-23832 at Glasgow Haskell Compiler / GHC
Commits:
622de5dd by Gergő Érdi at 2023-08-30T03:05:53+01:00
Allow cross-tyvar defaulting proposals from plugins
Fixes #23832.
- - - - -
21 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/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,24 @@ instance Diagnostic TcRnMessage where
, text "In the future GHC will no longer implicitly quantify over such variables"
]
+ TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs ->
+ mkSimpleDecorated $
+ pprWithExplicitKindsWhen True $
+ vcat [ text "Invalid defaulting proposal."
+ , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon)
+ 2 (pprQuotedList (NE.toList bad_tvs))
+ , hang (text "Defaulting proposal:")
+ 2 (ppr proposal)
+ , hang (text "Wanted constraints:")
+ 2 (pprQuotedList (map ctPred wanteds))
+ ]
+ where
+ why
+ | _ :| [] <- bad_tvs
+ = text "it is not an unfilled metavariable"
+ | otherwise
+ = text "they are not unfilled metavariables"
+
diagnosticReason = \case
TcRnUnknownMessage m
-> diagnosticReason m
@@ -2462,6 +2480,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnIllegalTypeExpr{}
-> ErrorWithoutFlag
+ TcRnInvalidDefaultedTyVar{}
+ -> ErrorWithoutFlag
diagnosticHints = \case
TcRnUnknownMessage m
@@ -3116,6 +3136,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnIllegalTypeExpr{}
-> noHints
+ TcRnInvalidDefaultedTyVar{}
+ -> noHints
diagnosticCode = constructorCode
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -4118,6 +4118,19 @@ data TcRnMessage where
-}
TcRnIllegalTypeExpr :: 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, Type)] -- ^ The plugin-proposed type variable defaults
+ -> NE.NonEmpty TcTyVar -- ^ The invalid type variables of the proposal
+ -> 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 )
@@ -77,9 +79,10 @@ import qualified GHC.LanguageExtensions as LangExt
import Control.Monad
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.State.Strict ( StateT(runStateT), put )
-import Data.Foldable ( toList )
+import Data.Foldable ( toList, traverse_ )
import Data.List ( partition )
-import Data.List.NonEmpty ( NonEmpty(..) )
+import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
import GHC.Data.Maybe ( mapMaybe )
{-
@@ -3611,7 +3614,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 +3622,10 @@ applyDefaultingRules wanteds
where run_defaulting_plugin wanteds p =
do { groups <- runTcPluginTcS (p wanteds)
; defaultedGroups <-
- filterM (\g -> disambigGroup
- (deProposalCandidates g)
- (deProposalTyVar g, deProposalCts g))
+ filterM (\g -> disambigMultiGroup
+ wanteds
+ (deProposalCts g)
+ (deProposals g))
groups
; traceTcS "defaultingPlugin " $ ppr defaultedGroups
; case defaultedGroups of
@@ -3689,55 +3693,79 @@ 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 } }
- 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 orig_wanteds default_tys (the_tv, wanteds)
+ = disambigMultiGroup orig_wanteds wanteds [[(the_tv, default_ty)] | default_ty <- default_tys]
- | 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 :: WantedConstraints -- ^ Original constraints, for diagnostic purposes
+ -> [Ct] -- ^ check these are solved by defaulting
+ -> [[(TcTyVar, Type)]] -- ^ defaulting type assignments to try
+ -> TcS Bool -- True <=> something happened, reflected in ty_binds
+disambigMultiGroup orig_wanteds wanteds = anyM propose
+ where
+ propose proposal
+ = do { traceTcS "disambigMultiGroup {" (vcat [ ppr proposal, ppr wanteds ])
+ ; invalid_tvs <- filterOutM TcS.isUnfilledMetaTyVar tvs
+ ; traverse_ (errInvalidDefaultedTyVar orig_wanteds proposal) (nonEmpty 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 tvs)
+ ; forM_ deep_tvs $ \ tv -> mapM_ (unifyTyVar tv) (lookupVarEnv (getTvSubstEnv subst) tv)
+ ; wrapWarnTcS $ mapM_ (uncurry $ warnDefaulting wanteds) proposal
+ ; traceTcS "disambigMultiGroup succeeded }" (ppr proposal)
+ ; return True }
+ Nothing -> -- Failure: try with the next defaulting group
+ do { traceTcS "disambigMultiGroup failed, will try other default types }"
+ (ppr proposal)
+ ; return False } }
+ where
+ (tvs, default_tys) = unzip proposal
+
+ 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
+
+ mb_subst = tcMatchTyKis (mkTyVarTys tvs) 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.
+
+errInvalidDefaultedTyVar :: WantedConstraints -> [(TcTyVar, Type)] -> NonEmpty TcTyVar -> TcS ()
+errInvalidDefaultedTyVar wanteds proposal problematic_tvs
+ = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_proposal tidy_problems
+ where
+ proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) proposal
+ tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs
+ tidy_wanteds = map (tidyCt tidy_env) $ flattenWC wanteds
+ tidy_proposal = [(tidyTyCoVarOcc tidy_env tv, tidyType tidy_env ty) | (tv, ty) <- proposal]
+ tidy_problems = fmap (tidyTyCoVarOcc tidy_env) problematic_tvs
+
+ flattenWC :: WantedConstraints -> [Ct]
+ flattenWC (WC { wc_simple = cts, wc_impl = impls })
+ = ctsElts cts ++ concatMap (flattenWC . ic_wanted) impls
-- 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,21 @@ 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.
+ { deProposals :: [[(TcTyVar, Type)]]
+ -- ^ The type variable assignments to try.
, deProposalCts :: [Ct]
-- ^ The constraints against which defaults are checked.
}
instance Outputable DefaultingProposal where
ppr p = text "DefaultingProposal"
- <+> ppr (deProposalTyVar p)
- <+> ppr (deProposalCandidates p)
+ <+> ppr (deProposals 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,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnImplicitRhsQuantification" = 16382
GhcDiagnosticCode "TcRnBadTyConTelescope" = 87279
GhcDiagnosticCode "TcRnPatersonCondFailure" = 22979
+ 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-ticket:`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,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.
+ { deProposals :: [[(TcTyVar, Type)]]
+ -- ^ The type variable assignments to try.
, 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 +1381,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_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,7 @@
+
+T23832_invalid.hs:1:1: error: [GHC-45625]
+ Invalid defaulting proposal.
+ The following type variable cannot be defaulted, as it is not an unfilled metavariable:
+ ‘a’
+ Defaulting proposal: [(a, Double)]
+ Wanted constraints: ‘C a’
=====================================
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_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, doubleTy), (tv2, 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
+ DefaultInvalid
ghc-options: -Wall
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/622de5ddc8b57bfdf47f62e83715c5564653c779
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/622de5ddc8b57bfdf47f62e83715c5564653c779
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/20230829/79fba29b/attachment-0001.html>
More information about the ghc-commits
mailing list