[Git][ghc/ghc][wip/issue-23832] Allow cross-tyvar defaulting proposals from plugins
Gergő Érdi (@cactus)
gitlab at gitlab.haskell.org
Fri Aug 18 01:56:25 UTC 2023
Gergő Érdi pushed to branch wip/issue-23832 at Glasgow Haskell Compiler / GHC
Commits:
d00ac294 by Gergő Érdi at 2023-08-18T02:56:16+01:00
Allow cross-tyvar defaulting proposals from plugins
Fixes #23832.
- - - - -
4 changed files:
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Types.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultInterference.hs
- testsuite/tests/plugins/defaulting-plugin/DefaultLifted.hs
Changes:
=====================================
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,60 @@ 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 ])
+ ; 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)
=====================================
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
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d00ac294576eeb868cf2f6c0c02ca5d25b1c3291
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d00ac294576eeb868cf2f6c0c02ca5d25b1c3291
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/7a731135/attachment-0001.html>
More information about the ghc-commits
mailing list