[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:52:13 UTC 2023



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


Commits:
40de3f7d by Gergő Érdi at 2023-08-18T04:51:09+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
=====================================
@@ -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
+T23821 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:


=====================================
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/40de3f7d19e6aea3be19a14ffec8f148234070da

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/40de3f7d19e6aea3be19a14ffec8f148234070da
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/3852573f/attachment-0001.html>


More information about the ghc-commits mailing list