[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