[Git][ghc/ghc][wip/issue-23832] Allow cross-tyvar defaulting proposals from plugins

Gergő Érdi (@cactus) gitlab at gitlab.haskell.org
Thu Aug 17 04:50:06 UTC 2023



Gergő Érdi pushed to branch wip/issue-23832 at Glasgow Haskell Compiler / GHC


Commits:
f5b6681f by Gergő Érdi at 2023-08-17T05:49:55+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]]            -- The default type assignments to try
+                   -> [TcTyVar]  -- Variables to default
+                   -> [Ct]       -- All constraints sharing same type variables
+                   -> 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
=====================================
@@ -1055,9 +1055,9 @@ data TcPluginRewriteResult
 -- | A collection of candidate default types for a type variable.
 data DefaultingProposal
   = DefaultingProposal
-    { deProposalTyVar :: TcTyVar
+    { deProposalTyVars :: [TcTyVar]
       -- ^ The type variable to default.
-    , deProposalCandidates :: [Type]
+    , deProposalCandidates :: [[Type]]
       -- ^ Candidate types to default the type variable to.
     , deProposalCts :: [Ct]
       -- ^ The constraints against which defaults are checked.
@@ -1065,7 +1065,7 @@ data DefaultingProposal
 
 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/f5b6681f92984830b8a500a1344c52e2a153cac3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f5b6681f92984830b8a500a1344c52e2a153cac3
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/8d2c9d0e/attachment-0001.html>


More information about the ghc-commits mailing list