[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