[Git][ghc/ghc][wip/issue-23832] 6 commits: ghc classes documentation: rm redundant comment

Gergő Érdi (@cactus) gitlab at gitlab.haskell.org
Thu Aug 31 04:27:57 UTC 2023



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


Commits:
99fff496 by Dominik Schrempf at 2023-08-31T00:04:46-04:00
ghc classes documentation: rm redundant comment

- - - - -
fe021bab by Dominik Schrempf at 2023-08-31T00:04:46-04:00
prelude documentation: various nits

- - - - -
48c84547 by Dominik Schrempf at 2023-08-31T00:04:46-04:00
integer documentation: minor corrections

- - - - -
20cd12f4 by Dominik Schrempf at 2023-08-31T00:04:46-04:00
real documentation: nits

- - - - -
dd39bdc0 by sheaf at 2023-08-31T00:05:27-04:00
Add a test for #21765

This issue (of reporting a constraint as being redundant even though
removing it causes typechecking to fail) was fixed in aed1974e.
This commit simply adds a regression test.

Fixes #21765

- - - - -
cae4eaf2 by Gergő Érdi at 2023-08-31T04:27:45+00:00
Allow cross-tyvar defaulting proposals from plugins

Fixes #23832.

- - - - -


27 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
- libraries/base/Data/Tuple.hs
- libraries/base/GHC/Enum.hs
- libraries/base/GHC/Real.hs
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- libraries/ghc-prim/GHC/Classes.hs
- 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/DefaultMultiParam.hs
- testsuite/tests/plugins/defaulting-plugin/defaulting-plugin.cabal
- + testsuite/tests/typecheck/should_compile/T21765.hs
- testsuite/tests/typecheck/should_compile/all.T


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
=====================================
@@ -1863,6 +1863,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
@@ -2469,6 +2487,8 @@ instance Diagnostic TcRnMessage where
       -> ErrorWithoutFlag
     TcRnIllegalTypeExpr{}
       -> ErrorWithoutFlag
+    TcRnInvalidDefaultedTyVar{}
+      -> ErrorWithoutFlag
 
   diagnosticHints = \case
     TcRnUnknownMessage m
@@ -3125,6 +3145,8 @@ instance Diagnostic TcRnMessage where
       -> noHints
     TcRnIllegalTypeExpr{}
       -> noHints
+    TcRnInvalidDefaultedTyVar{}
+      -> noHints
 
   diagnosticCode = constructorCode
 


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -4127,6 +4127,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.
@@ -595,6 +595,7 @@ type family GhcDiagnosticCode c = n | n -> c where
   GhcDiagnosticCode "TcRnBadTyConTelescope"                         = 87279
   GhcDiagnosticCode "TcRnPatersonCondFailure"                       = 22979
   GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat"              = 69797
+  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.


=====================================
libraries/base/Data/Tuple.hs
=====================================
@@ -41,7 +41,7 @@ fst (x,_)               =  x
 snd                     :: (a,b) -> b
 snd (_,y)               =  y
 
--- | 'curry' converts an uncurried function to a curried function.
+-- | Convert an uncurried function to a curried function.
 --
 -- ==== __Examples__
 --


=====================================
libraries/base/GHC/Enum.hs
=====================================
@@ -82,9 +82,9 @@ class  Bounded a  where
 -- >              | otherwise                = minBound
 --
 class  Enum a   where
-    -- | the successor of a value.  For numeric types, 'succ' adds 1.
+    -- | Successor of a value. For numeric types, 'succ' adds 1.
     succ                :: a -> a
-    -- | the predecessor of a value.  For numeric types, 'pred' subtracts 1.
+    -- | Predecessor of a value. For numeric types, 'pred' subtracts 1.
     pred                :: a -> a
     -- | Convert from an 'Int'.
     toEnum              :: Int -> a
@@ -92,11 +92,10 @@ class  Enum a   where
     -- It is implementation-dependent what 'fromEnum' returns when
     -- applied to a value that is too large to fit in an 'Int'.
     fromEnum            :: a -> Int
-
     -- | Used in Haskell's translation of @[n..]@ with @[n..] = enumFrom n@,
     --   a possible implementation being @enumFrom n = n : enumFrom (succ n)@.
-    --   For example:
     --
+    --   ==== __Examples__
     --     * @enumFrom 4 :: [Integer] = [4,5,6,7,...]@
     --     * @enumFrom 6 :: [Int] = [6,7,8,9,...,maxBound :: Int]@
     enumFrom            :: a -> [a]
@@ -104,22 +103,28 @@ class  Enum a   where
     --   with @[n,n'..] = enumFromThen n n'@, a possible implementation being
     --   @enumFromThen n n' = n : n' : worker (f x) (f x n')@,
     --   @worker s v = v : worker s (s v)@, @x = fromEnum n' - fromEnum n@ and
-    --   @f n y
+    --
+    --   @
+    --   f n y
     --     | n > 0 = f (n - 1) (succ y)
     --     | n < 0 = f (n + 1) (pred y)
-    --     | otherwise = y@
-    --   For example:
+    --     | otherwise = y
+    --   @
     --
+    --   ==== __Examples__
     --     * @enumFromThen 4 6 :: [Integer] = [4,6,8,10...]@
     --     * @enumFromThen 6 2 :: [Int] = [6,2,-2,-6,...,minBound :: Int]@
     enumFromThen        :: a -> a -> [a]
     -- | Used in Haskell's translation of @[n..m]@ with
     --   @[n..m] = enumFromTo n m@, a possible implementation being
-    --   @enumFromTo n m
+    --
+    --   @
+    --   enumFromTo n m
     --      | n <= m = n : enumFromTo (succ n) m
-    --      | otherwise = []@.
-    --   For example:
+    --      | otherwise = []
+    --   @
     --
+    --   ==== __Examples__
     --     * @enumFromTo 6 10 :: [Int] = [6,7,8,9,10]@
     --     * @enumFromTo 42 1 :: [Integer] = []@
     enumFromTo          :: a -> a -> [a]
@@ -127,15 +132,23 @@ class  Enum a   where
     --   @[n,n'..m] = enumFromThenTo n n' m@, a possible implementation
     --   being @enumFromThenTo n n' m = worker (f x) (c x) n m@,
     --   @x = fromEnum n' - fromEnum n@, @c x = bool (>=) (<=) (x > 0)@
-    --   @f n y
+    --
+    --   @
+    --   f n y
     --      | n > 0 = f (n - 1) (succ y)
     --      | n < 0 = f (n + 1) (pred y)
-    --      | otherwise = y@ and
-    --   @worker s c v m
+    --      | otherwise = y
+    --   @
+    --
+    --   and
+    --
+    --   @
+    --   worker s c v m
     --      | c v m = v : worker s c (s v) m
-    --      | otherwise = []@
-    --   For example:
+    --      | otherwise = []
+    --   @
     --
+    --   ==== __Examples__
     --     * @enumFromThenTo 4 2 -6 :: [Integer] = [4,2,0,-2,-4,-6]@
     --     * @enumFromThenTo 6 8 2 :: [Int] = []@
     enumFromThenTo      :: a -> a -> a -> [a]


=====================================
libraries/base/GHC/Real.hs
=====================================
@@ -212,7 +212,7 @@ denominator (_ :% y)    =  y
 -- 'Foreign.C.Types.CDouble', etc., because these types contain non-finite values,
 -- which cannot be roundtripped through 'Rational'.
 class  (Num a, Ord a) => Real a  where
-    -- | the rational equivalent of its real argument with full precision
+    -- | Rational equivalent of its real argument with full precision.
     toRational          ::  a -> Rational
 
 -- | Integral numbers, supporting integer division.
@@ -233,41 +233,41 @@ class  (Num a, Ord a) => Real a  where
 -- In addition, 'toInteger` should be total, and 'fromInteger' should be a left
 -- inverse for it, i.e. @fromInteger (toInteger i) = i at .
 class  (Real a, Enum a) => Integral a  where
-    -- | integer division truncated toward zero
+    -- | Integer division truncated toward zero.
     --
     -- WARNING: This function is partial (because it throws when 0 is passed as
     -- the divisor) for all the integer types in @base at .
     quot                :: a -> a -> a
-    -- | integer remainder, satisfying
+    -- | Integer remainder, satisfying
     --
     -- > (x `quot` y)*y + (x `rem` y) == x
     --
     -- WARNING: This function is partial (because it throws when 0 is passed as
     -- the divisor) for all the integer types in @base at .
     rem                 :: a -> a -> a
-    -- | integer division truncated toward negative infinity
+    -- | Integer division truncated toward negative infinity.
     --
     -- WARNING: This function is partial (because it throws when 0 is passed as
     -- the divisor) for all the integer types in @base at .
     div                 :: a -> a -> a
-    -- | integer modulus, satisfying
+    -- | Integer modulus, satisfying
     --
     -- > (x `div` y)*y + (x `mod` y) == x
     --
     -- WARNING: This function is partial (because it throws when 0 is passed as
     -- the divisor) for all the integer types in @base at .
     mod                 :: a -> a -> a
-    -- | simultaneous 'quot' and 'rem'
+    -- | Simultaneous 'quot' and 'rem'.
     --
     -- WARNING: This function is partial (because it throws when 0 is passed as
     -- the divisor) for all the integer types in @base at .
     quotRem             :: a -> a -> (a,a)
-    -- | simultaneous 'div' and 'mod'
+    -- | simultaneous 'div' and 'mod'.
     --
     -- WARNING: This function is partial (because it throws when 0 is passed as
     -- the divisor) for all the integer types in @base at .
     divMod              :: a -> a -> (a,a)
-    -- | conversion to 'Integer'
+    -- | Conversion to 'Integer'.
     toInteger           :: a -> Integer
 
     {-# INLINE quot #-}


=====================================
libraries/ghc-bignum/src/GHC/Num/Integer.hs
=====================================
@@ -167,11 +167,11 @@ default ()
 -- Integers are stored in a kind of sign-magnitude form, hence do not expect
 -- two's complement form when using bit operations.
 --
--- If the value is small (fit into an 'Int'), 'IS' constructor is used.
--- Otherwise 'IP' and 'IN' constructors are used to store a 'BigNat'
--- representing respectively the positive or the negative value magnitude.
+-- If the value is small (i.e., fits into an 'Int'), the 'IS' constructor is
+-- used. Otherwise 'IP' and 'IN' constructors are used to store a 'BigNat'
+-- representing the positive or the negative value magnitude, respectively.
 --
--- Invariant: 'IP' and 'IN' are used iff value doesn't fit in 'IS'
+-- Invariant: 'IP' and 'IN' are used iff the value does not fit in 'IS'.
 data Integer
    = IS !Int#    -- ^ iff value in @[minBound::'Int', maxBound::'Int']@ range
    | IP !BigNat# -- ^ iff value in @]maxBound::'Int', +inf[@ range


=====================================
libraries/ghc-prim/GHC/Classes.hs
=====================================
@@ -141,9 +141,6 @@ and @('>=')@ for the types in "GHC.Word" and "GHC.Int".
 -- [__Extensionality__]: if @x == y@ = 'True' and @f@ is a function
 -- whose return type is an instance of 'Eq', then @f x == f y@ = 'True'
 -- [__Negation__]: @x /= y@ = @not (x == y)@
---
--- Minimal complete definition: either '==' or '/='.
---
 class  Eq a  where
     (==), (/=)           :: a -> a -> Bool
 


=====================================
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_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/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


=====================================
testsuite/tests/typecheck/should_compile/T21765.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE UndecidableInstances, FlexibleInstances #-}
+
+{-# OPTIONS_GHC -Wredundant-constraints #-}
+
+module T21765 where
+
+class Functor f => C f where c :: f Int
+
+instance (Functor f, Applicative f) => C f where c = pure 42


=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -847,6 +847,7 @@ test('DeepSubsumption06', normal, compile, ['-XHaskell98'])
 test('DeepSubsumption07', normal, compile, ['-XHaskell2010'])
 test('DeepSubsumption08', normal, compile, [''])
 test('DeepSubsumption09', normal, compile, [''])
+test('T21765', normal, compile, [''])
 test('T21951a', normal, compile, ['-Wredundant-strictness-flags'])
 test('T21951b', normal, compile, ['-Wredundant-strictness-flags'])
 test('T21550', normal, compile, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/106895a64d094fa1b50beda724929c471f23f3d6...cae4eaf2416775d06b04c84444b83b310877f87c

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/106895a64d094fa1b50beda724929c471f23f3d6...cae4eaf2416775d06b04c84444b83b310877f87c
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/20230831/2dc4faf0/attachment-0001.html>


More information about the ghc-commits mailing list