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

Gergő Érdi (@cactus) gitlab at gitlab.haskell.org
Thu Aug 24 08:56:28 UTC 2023



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


Commits:
b59f0c02 by Gergő Érdi at 2023-08-24T09:38:22+01:00
Allow cross-tyvar defaulting proposals from plugins

Fixes #23832.

- - - - -


22 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/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 $
+               ppr 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 $
+               ppr 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
+      :: !WantedConstraints -- ^ The constraints passed to the plugin
+      -> ![TcTyVar]         -- ^ The type variables proposed for defaulting
+      -> ![Type]            -- ^ The default types proposed
+      -> TcRnMessage
+
+  {-| TcRnMiInvalidDefaultedTyVar 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
+      :: !WantedConstraints -- ^ 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
=====================================
@@ -63,11 +63,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 +3612,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 +3620,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 +3692,90 @@ 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 [the_tv] [[default_ty] | default_ty <- default_tys] 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 :: 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 is_valid the_tvs
+             ; unless (null invalid_tvs) $
+                 errInvalidDefaultedTyVar orig_wanteds the_tvs invalid_tvs
+             ; 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 $ zipWithM_ (warnDefaulting wanteds) the_tvs default_tys
+                      ; 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
+        is_valid tv
+          = do { let is_meta = isMetaTyVar tv
+               ; is_filled <- if is_meta then TcS.isFilledMetaTyVar tv else return False
+               ; return $ is_meta && not is_filled }
+
+        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.
+
+errMisalignedDefaultingProposal :: WantedConstraints -> [TcTyVar] -> [Type] -> TcS ()
+errMisalignedDefaultingProposal wanteds the_tvs default_tys
+  = do { let tidy_env = tidyFreeTyCoVars emptyTidyEnv the_tvs
+             tidy_tvs = map (tidyTyCoVarOcc tidy_env) the_tvs
+       ; failTcS $ TcRnMisalignedDefaultingProposal wanteds tidy_tvs default_tys }
+
+errInvalidDefaultedTyVar :: WantedConstraints -> [TcTyVar] -> [TcTyVar] -> TcS ()
+errInvalidDefaultedTyVar wanteds tvs problematic_tvs
+  = do { let tidy_env = tidyFreeTyCoVars emptyTidyEnv (tvs ++ problematic_tvs)
+             tidy_tvs = map (tidyTyCoVarOcc tidy_env) tvs
+             tidy_problems = map (tidyTyCoVarOcc tidy_env) problematic_tvs
+       ; failTcS $ TcRnInvalidDefaultedTyVar wanteds tidy_tvs tidy_problems }
 
 -- In interactive mode, or with -XExtendedDefaultRules,
 -- we default Show a to Show () to avoid gratuitous errors on "show []"


=====================================
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,11 +1386,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 ``[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
+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 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,16 @@
+
+T23832_invalid.hs:1:1: error: [GHC-45625]
+    Defaulting plugin returned invalid defaulting proposal when passed these constraints:
+      WC {wc_impl =
+            Implic {
+              TcLevel = 1
+              Skolems = a
+              Given-eqs = NoGivenEqs
+              Status = Unsolved
+              Given =
+              Wanted = WC {wc_simple = [W] $dC_aJ6 {0}:: C a (CDictCan)}
+              Binds = EvBindsVar<aJ8>
+              the type signature for:
+                bar :: forall a. 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,10 @@
+
+T23832_misaligned.hs:1:1: error: [GHC-72071]
+    Defaulting plugin returned invalid defaulting proposal when passed these constraints:
+      WC {wc_simple =
+            [W] $dC_aIL {0}:: C a0 b0 (CDictCan)
+            [W] $dNum_aMb {0}:: Num a0 (CDictCan)
+            [W] $dNum_aMe {0}:: Num b0 (CDictCan)}
+    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/b59f0c0297349c35aaaf2afd6130a2bbe8c1c299

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b59f0c0297349c35aaaf2afd6130a2bbe8c1c299
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/20230824/9fc3f221/attachment-0001.html>


More information about the ghc-commits mailing list