Simon Peyton Jones pushed to branch wip/spj-reinstallable-base at Glasgow Haskell Compiler / GHC Commits: 89211939 by Simon Peyton Jones at 2026-04-08T17:45:14+01:00 More and more - - - - - 10 changed files: - compiler/GHC/Builtin.hs - compiler/GHC/Builtin/Names.hs - compiler/GHC/Tc/Gen/Default.hs - libraries/base/src/Data/Fixed.hs - libraries/base/src/GHC/KnownKeyNames.hs - libraries/base/src/System/Console/GetOpt.hs - libraries/ghc-internal/src/GHC/Internal/Float.hs - libraries/ghc-internal/src/GHC/Internal/IO.hs - libraries/ghc-internal/src/GHC/Internal/Records.hs - testsuite/tests/th/T26568.stderr Changes: ===================================== compiler/GHC/Builtin.hs ===================================== @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -40,7 +42,9 @@ module GHC.Builtin ( maybeCharLikeCon, maybeIntLikeCon, -- * Class categories - isNumericClass, isStandardClass + isNumericClass, isStandardClass, + numericClassKeys, fractionalClassKeys, standardClassKeys, + derivableClassKeys, interactiveClassKeys ) where @@ -53,8 +57,7 @@ import GHC.Builtin.Types import GHC.Builtin.Types.Literals ( typeNatTyCons ) import GHC.Builtin.Types.Prim import GHC.Builtin.TH ( templateHaskellNames, thKnownKeyTable ) -import GHC.Builtin.Names( basicKnownKeyTable, basicKnownKeyNames ) -import GHC.Builtin.Names( charDataConKey, intDataConKey, numericClassKeys, standardClassKeys ) +import GHC.Builtin.Names import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.DataCon @@ -378,6 +381,92 @@ knownVarOccRdrName :: String -> RdrName knownVarOccRdrName s = knownOccRdrName (mkVarOcc s) + +{- +************************************************************************ +* * + Groups of keys +* * +************************************************************************ + +NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ +even though every numeric class has these two as a superclass, +because the list of ambiguous dictionaries hasn't been simplified. +-} + +numericClassKeys :: [KnownKey] +numericClassKeys + = checkKnownKeys + [ numClassKey + , realClassKey + , integralClassKey + ] + ++ fractionalClassKeys + +fractionalClassKeys :: [KnownKey] +fractionalClassKeys + = checkKnownKeys + [ fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] + +-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), +-- and are: "classes defined in the Prelude or a standard library" +standardClassKeys :: [KnownKey] +standardClassKeys + = derivableClassKeys + ++ numericClassKeys + ++ checkKnownKeys + [ randomClassKey, randomGenClassKey + , functorClassKey + , monadClassKey, monadPlusClassKey, monadFailClassKey + , semigroupClassKey, monoidClassKey + , isStringClassKey + , applicativeClassKey, foldableClassKey + , traversableClassKey, alternativeClassKey + ] + +{- +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@GHC.Tc.Deriv@). +-} + +derivableClassKeys :: [KnownKey] +derivableClassKeys + = checkKnownKeys [ eqClassKey, ordClassKey, enumClassKey, ixClassKey + , boundedClassKey, showClassKey, readClassKey ] + +interactiveClassKeys :: [KnownKey] +-- These are the "interactive classes" that are consulted when doing +-- defaulting. Does not include Num or IsString, which have special +-- handling. +interactiveClassKeys + = checkKnownKeys [ showClassKey, eqClassKey, ordClassKey + , foldableClassKey, traversableClassKey ] + +checkKnownKeys :: [KnownKey] -> [KnownKey] +-- An assertion check, that checks that these alleged known-keys do +-- actually appear in the knownKeyTable. +#ifdef DEBUG +checkKnownKeys keys + | null bad_keys = keys + | otherwise = pprPanic "checkKnownKeys" (vcat (map pprKnownKey bad_keys)) + where + bad_keys = filter (not . (`elemUFM` knownKeyUniqMap)) keys +#else +checkKnownKeys keys = keys +#endif + +isNumericClass, isStandardClass :: Class -> Bool +isNumericClass clas = classKey clas `is_elem` numericClassKeys +isStandardClass clas = classKey clas `is_elem` standardClassKeys + +is_elem :: Eq a => a -> [a] -> Bool +is_elem = isIn "is_X_Class" + + {- ********************************************************************* * * Wired-in things @@ -652,18 +741,3 @@ maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool maybeCharLikeCon con = con `hasKey` charDataConKey maybeIntLikeCon con = con `hasKey` intDataConKey -{- -************************************************************************ -* * - Class predicates -* * -************************************************************************ --} - -isNumericClass, isStandardClass :: Class -> Bool - -isNumericClass clas = classKey clas `is_elem` numericClassKeys -isStandardClass clas = classKey clas `is_elem` standardClassKeys - -is_elem :: Eq a => a -> [a] -> Bool -is_elem = isIn "is_X_Class" ===================================== compiler/GHC/Builtin/Names.hs ===================================== @@ -187,8 +187,6 @@ basicKnownKeyTable , (mkTcOcc "Foldable", foldableClassKey) , (mkTcOcc "Traversable", traversableClassKey) , (mkTcOcc "Bounded", boundedClassKey) - , (mkTcOcc "Integral", integralClassKey) - , (mkTcOcc "Real", realClassKey) , (mkTcOcc "Data", dataClassKey) , (mkTcOcc "Ix", ixClassKey) , (mkTcOcc "Alternative", alternativeClassKey) @@ -216,6 +214,11 @@ basicKnownKeyTable -- Numeric operations , (mkTcOcc "Num", numClassKey) + , (mkTcOcc "Integral", integralClassKey) + , (mkTcOcc "Real", realClassKey) + , (mkTcOcc "Fractional", fractionalClassKey) + , (mkTcOcc "RealFloat", realFloatClassKey) +-- , (mkTcOcc "RealFrac", realFracClassKey) , (mkVarOcc "-", minusClassOpKey) , (mkVarOcc "negate", negateClassOpKey) , (mkVarOcc "fromInteger", fromIntegerClassOpKey) @@ -270,8 +273,7 @@ basicKnownKeyTable , (mkTcOcc "HasField", hasFieldClassKey) , (mkVarOcc "fromLabel", fromLabelClassOpKey) , (mkVarOcc "getField", getFieldClassOpKey) - -- setField is not yet defined in ghc-internal - -- , (mkVarOcc "setField", setFieldClassOpKey) + , (mkVarOcc "setField", setFieldClassOpKey) -- FromList , (mkVarOcc "fromList", fromListClassOpKey) @@ -2149,61 +2151,3 @@ bignatCompareWordIdKey = mkPreludeMiscIdUnique 693 mkRationalBase2IdKey, mkRationalBase10IdKey :: KnownKey mkRationalBase2IdKey = mkPreludeMiscIdUnique 700 mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: KnownKey - -{- -************************************************************************ -* * -\subsection[Class-std-groups]{Standard groups of Prelude classes} -* * -************************************************************************ - -NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ -even though every numeric class has these two as a superclass, -because the list of ambiguous dictionaries hasn't been simplified. --} - -numericClassKeys :: [KnownKey] -numericClassKeys = - [ numClassKey - , realClassKey - , integralClassKey - ] - ++ fractionalClassKeys - -fractionalClassKeys :: [KnownKey] -fractionalClassKeys = - [ fractionalClassKey - , floatingClassKey - , realFracClassKey - , realFloatClassKey - ] - --- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4), --- and are: "classes defined in the Prelude or a standard library" -standardClassKeys :: [KnownKey] -standardClassKeys = derivableClassKeys ++ numericClassKeys - ++ [randomClassKey, randomGenClassKey, - functorClassKey, - monadClassKey, monadPlusClassKey, monadFailClassKey, - semigroupClassKey, monoidClassKey, - isStringClassKey, - applicativeClassKey, foldableClassKey, - traversableClassKey, alternativeClassKey - ] - -{- -@derivableClassKeys@ is also used in checking \tr{deriving} constructs -(@GHC.Tc.Deriv@). --} - -derivableClassKeys :: [KnownKey] -derivableClassKeys - = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, - boundedClassKey, showClassKey, readClassKey ] - -interactiveClassKeys :: [KnownKey] --- These are the "interactive classes" that are consulted when doing --- defaulting. Does not include Num or IsString, which have special --- handling. -interactiveClassKeys = [ showClassKey, eqClassKey, ordClassKey - , foldableClassKey, traversableClassKey ] ===================================== compiler/GHC/Tc/Gen/Default.hs ===================================== @@ -12,7 +12,9 @@ module GHC.Tc.Gen.Default ( tcDefaultDecls, extendDefaultEnvWithLocalDefaults ) import GHC.Prelude import GHC.Hs +import GHC.Builtin( interactiveClassKeys ) import GHC.Builtin.Names + import GHC.Core.Class import GHC.Core.Predicate ( Pred (..), classifyPredType ) ===================================== libraries/base/src/Data/Fixed.hs ===================================== @@ -4,6 +4,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskellQuotes #-} +{-# OPTIONS_GHC -fno-rebindable-known-key-names #-} + -- We are importing Prelude, hence GHC.KnownKeyNames is available + ----------------------------------------------------------------------------- -- | -- Module : Data.Fixed @@ -87,7 +90,6 @@ module Data.Fixed ) where import Prelude -import GHC.KnownKeyNames import GHC.Internal.Data.Data import GHC.Internal.TypeLits (KnownNat, natVal) import GHC.Internal.Read @@ -95,7 +97,6 @@ import GHC.Internal.Text.ParserCombinators.ReadPrec( ReadPrec, pfail ) import GHC.Internal.Text.Read.Lex import qualified GHC.Internal.TH.Monad as TH import qualified GHC.Internal.TH.Lift as TH -import GHC.Internal.TH.Lift( lift ) -- Unqualified for known-occ names import Data.Typeable -- $setup ===================================== libraries/base/src/GHC/KnownKeyNames.hs ===================================== @@ -59,7 +59,7 @@ module GHC.KnownKeyNames , dataToTag# -- Numbers - , Num, Integral, Real, Fractional + , Num, Integral, Real, Fractional, RealFloat , (+), (-), (*), negate, fromInteger , fromRational , mkRationalBase2, mkRationalBase10 @@ -71,7 +71,7 @@ module GHC.KnownKeyNames -- Records , HasField - , fromLabel, getField + , fromLabel, getField, setField -- Overloaded lists , IL.fromList, IL.fromListN, IL.toList @@ -157,13 +157,14 @@ import GHC.Internal.Data.Data import GHC.Internal.Data.String( fromString ) import GHC.Internal.Data.Foldable( Foldable ) import GHC.Internal.Data.Traversable( Traversable ) +import GHC.Internal.Float( RealFloat ) import GHC.Internal.Real( mkRationalBase2, mkRationalBase10 ) import GHC.Internal.Control.Monad( fail, guard ) import GHC.Internal.Control.Monad.Fix( mfix, loop ) import GHC.Internal.Control.Monad.Zip( mzip ) import GHC.Internal.Control.Arrow( arr, (>>>), first, app, (|||) ) import GHC.Internal.OverloadedLabels( fromLabel ) -import GHC.Internal.Records( HasField, getField ) +import GHC.Internal.Records import GHC.Internal.CString as CS import GHC.Internal.TypeError( Unsatisfiable, unsatisfiable ) import GHC.Internal.System.IO( print ) ===================================== libraries/base/src/System/Console/GetOpt.hs ===================================== @@ -1,5 +1,7 @@ {-# LANGUAGE Safe #-} +{-# OPTIONS_GHC -fno-rebindable-known-key-names #-} + -- We are importing Prelude, hence GHC.KnownKeyNames is available ----------------------------------------------------------------------------- -- | -- Module : System.Console.GetOpt @@ -62,8 +64,7 @@ module System.Console.GetOpt ( -- $example2 ) where -import Prelude hiding( foldr ) -import GHC.KnownKeyNames +import Prelude import GHC.Internal.Data.List ( isPrefixOf, find ) -- |What to do with options following non-options ===================================== libraries/ghc-internal/src/GHC/Internal/Float.hs ===================================== @@ -9,6 +9,10 @@ {-# LANGUAGE CApiFFI #-} -- We believe we could deorphan this module, by moving lots of things -- around, but we haven't got there yet: + +{-# OPTIONS_GHC -fdefines-known-key-names #-} + -- Defines RealFloat + {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} ===================================== libraries/ghc-internal/src/GHC/Internal/IO.hs ===================================== @@ -50,14 +50,12 @@ module GHC.Internal.IO ( ) where import GHC.Internal.Base -import GHC.Internal.Magic ( lazy ) import GHC.Internal.Maybe ( Maybe(..) ) import GHC.Internal.Prim ( RealWorld, State#, catch#, getMaskingState#, maskAsyncExceptions#, maskUninterruptible#, raiseIO#, unmaskAsyncExceptions#, ) import GHC.Internal.ST -import GHC.Internal.Types ( Char, IO(..) ) import GHC.Internal.Exception import GHC.Internal.Exception.Type (NoBacktrace(..), whileHandling, WhileHandling(..), HasExceptionContext, ExceptionWithContext(..)) import GHC.Internal.Show ===================================== libraries/ghc-internal/src/GHC/Internal/Records.hs ===================================== @@ -6,6 +6,7 @@ {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-unused-foralls #-} {-# OPTIONS_GHC -fdefines-known-key-names #-} -- Defines GetField ----------------------------------------------------------------------------- @@ -26,10 +27,11 @@ ----------------------------------------------------------------------------- module GHC.Internal.Records - ( HasField(..) + ( HasField(..), setField ) where -import GHC.Internal.Types (TYPE, Constraint) +import GHC.Internal.Types (TYPE, Type, Constraint) +import GHC.Internal.Err( error ) -- | Constraint representing the fact that the field @x@ belongs to -- the record type @r@ and has field type @a@. This will be solved @@ -45,3 +47,13 @@ type HasField :: forall {k} {r_rep} {a_rep} . k -> TYPE r_rep -> TYPE a_rep -> C class HasField x r a | x r -> a where -- | Selector function to extract the field from the record. getField :: r -> a + + +setField :: forall {k} (x::k) (r :: Type) (a :: Type). a -> r -> r +-- This setField is never used +-- -XRebindableSyntax is required if -XOverloadedRecordUpdate is enabled +-- But we still want to export setField from GHC.KnownKeyNames, so that +-- * We can have a known-key for setField (see uses of setFieldClassOpKey) +-- * The assertion check that GHC.KnownKeyNames exports every known-key +-- should not fail +setField = error "Yikes! setField is not implemented yet" ===================================== testsuite/tests/th/T26568.stderr ===================================== @@ -1,7 +1,7 @@ T26568.hs:5:3: error: [GHC-28914] • Level error: instance for ‘GHC.Internal.Base.Monad GHC.Internal.TH.Monad.Q’ - is bound at levels {} but used at level -1 + is bound at level 0 but used at level -1 • In a stmt of a 'do' block: _ <- _ In the expression: do _ <- _ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89211939e63204398b45cb72e1337960... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89211939e63204398b45cb72e1337960... You're receiving this email because of your account on gitlab.haskell.org.