[Git][ghc/ghc][wip/base-stability] 10 commits: compiler: Rework ShowSome

Ben Gamari (@bgamari) gitlab at gitlab.haskell.org
Sun May 21 17:47:03 UTC 2023



Ben Gamari pushed to branch wip/base-stability at Glasgow Haskell Compiler / GHC


Commits:
8dde41ea by Ben Gamari at 2023-05-21T13:41:18-04:00
compiler: Rework ShowSome

Previously the field used to filter the sub-declarations to show
was rather ad-hoc and was only able to show at most one sub-declaration.

- - - - -
a063fb2c by Ben Gamari at 2023-05-21T13:41:18-04:00
testsuite: Add test to catch changes in core libraries

This adds testing infrastructure to ensure that changes in core
libraries (e.g. `base` and `ghc-prim`) are caught in CI.

- - - - -
2cbb61fa by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Introduce Data.Enum

- - - - -
d368d293 by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Add export list to GHC.Num.Integer

- - - - -
031ead73 by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Add export list to GHC.Num

- - - - -
a0cbafc5 by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Add export list to GHC.Num.Natural

- - - - -
287ecd5c by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Introduce Data.Show

- - - - -
7580336e by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Add export list to GHC.Float

- - - - -
52e78847 by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Add export list to GHC.Real

- - - - -
075cc9eb by Ben Gamari at 2023-05-21T13:46:46-04:00
base: Eliminate module reexport in GHC.Exception

- - - - -


23 changed files:

- compiler/GHC/Iface/Syntax.hs
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Types/TyThing/Ppr.hs
- hadrian/src/Packages.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings/Default.hs
- + libraries/base/Data/Enum.hs
- + libraries/base/Data/Show.hs
- libraries/base/GHC/Exception.hs
- libraries/base/GHC/Float.hs
- libraries/base/GHC/Num.hs
- libraries/base/GHC/Real.hs
- libraries/base/base.cabal
- libraries/ghc-bignum/src/GHC/Num/Integer.hs
- libraries/ghc-bignum/src/GHC/Num/Natural.hs
- testsuite/mk/boilerplate.mk
- testsuite/tests/ghci/scripts/ghci008.stdout
- + testsuite/tests/interface-stability/Makefile
- + testsuite/tests/interface-stability/README.mkd
- + testsuite/tests/interface-stability/all.T
- + testsuite/tests/interface-stability/base-exports.stdout
- + utils/dump-decls/Main.hs
- + utils/dump-decls/dump-decls.cabal


Changes:

=====================================
compiler/GHC/Iface/Syntax.hs
=====================================
@@ -762,10 +762,13 @@ When printing an interface file (--show-iface), we want to print
 everything unqualified, so we can just print the OccName directly.
 -}
 
+-- | Show a declaration but not its RHS.
 showToHeader :: ShowSub
 showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing
                        , ss_forall = ShowForAllWhen }
 
+-- | Show declaration and its RHS, including GHc-internal information (e.g.
+-- for @--show-iface@).
 showToIface :: ShowSub
 showToIface = ShowSub { ss_how_much = ShowIface
                       , ss_forall = ShowForAllWhen }
@@ -776,18 +779,20 @@ ppShowIface _                                     _   = Outputable.empty
 
 -- show if all sub-components or the complete interface is shown
 ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition]
-ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc
-ppShowAllSubs (ShowSub { ss_how_much = ShowIface })     doc = doc
-ppShowAllSubs _                                         _   = Outputable.empty
+ppShowAllSubs (ShowSub { ss_how_much = ShowSome Nothing _ }) doc
+                                                        = doc
+ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc
+ppShowAllSubs _                                     _   = Outputable.empty
 
 ppShowRhs :: ShowSub -> SDoc -> SDoc
 ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _   = Outputable.empty
 ppShowRhs _                                        doc = doc
 
 showSub :: HasOccName n => ShowSub -> n -> Bool
-showSub (ShowSub { ss_how_much = ShowHeader _ })     _     = False
-showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing
-showSub (ShowSub { ss_how_much = _ })              _     = True
+showSub (ShowSub { ss_how_much = ShowHeader _ }) _     = False
+showSub (ShowSub { ss_how_much = ShowSome (Just f) _ }) thing
+                                                       = f (occName thing)
+showSub (ShowSub { ss_how_much = _ })            _     = True
 
 ppr_trim :: [Maybe SDoc] -> [SDoc]
 -- Collapse a group of Nothings to a single "..."


=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -1328,21 +1328,18 @@ data ShowSub
 newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))
 
 data ShowHowMuch
-  = ShowHeader AltPpr -- ^Header information only, not rhs
-  | ShowSome [OccName] AltPpr
-  -- ^ Show only some sub-components. Specifically,
-  --
-  -- [@\[\]@] Print all sub-components.
-  -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;
-  -- elide other sub-components to @...@
-  -- May 14: the list is max 1 element long at the moment
+  = ShowHeader AltPpr -- ^ Header information only, not rhs
+  | ShowSome (Maybe (OccName -> Bool)) AltPpr
+  -- ^ Show the declaration and its RHS. The @Maybe@ predicate
+  -- allows filtering of the sub-components which should be printing;
+  -- any sub-components filtered out will be elided with @... at .
   | ShowIface
-  -- ^Everything including GHC-internal information (used in --show-iface)
+  -- ^ Everything including GHC-internal information (used in --show-iface)
 
 instance Outputable ShowHowMuch where
-  ppr (ShowHeader _)    = text "ShowHeader"
-  ppr ShowIface         = text "ShowIface"
-  ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs
+  ppr (ShowHeader _) = text "ShowHeader"
+  ppr ShowIface      = text "ShowIface"
+  ppr (ShowSome _ _) = text "ShowSome"
 
 pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc
 pprIfaceSigmaType show_forall ty


=====================================
compiler/GHC/Types/TyThing/Ppr.hs
=====================================
@@ -145,16 +145,24 @@ pprTyThingHdr = pprTyThing showToHeader
 -- parts omitted.
 pprTyThingInContext :: ShowSub -> TyThing -> SDoc
 pprTyThingInContext show_sub thing
-  = go [] thing
+  = case parents thing of
+      -- If there are no parents print everything.
+      [] -> print_it Nothing thing
+      -- If `thing` has a parent, print the parent and only its child `thing`
+      thing':rest -> let subs = map getOccName (thing:rest)
+                         filt = (`elem` subs)
+                     in print_it (Just filt) thing'
   where
-    go ss thing
-      = case tyThingParent_maybe thing of
-          Just parent ->
-            go (getOccName thing : ss) parent
-          Nothing ->
-            pprTyThing
-              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })
-              thing
+    parents = go
+      where
+        go thing =
+          case tyThingParent_maybe thing of
+            Just parent -> parent : go parent
+            Nothing     -> []
+
+    print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc
+    print_it mb_filt thing =
+      pprTyThing (show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) thing
 
 -- | Like 'pprTyThingInContext', but adds the defining location.
 pprTyThingInContextLoc :: TyThing -> SDoc
@@ -171,8 +179,8 @@ pprTyThing ss ty_thing
       pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)
   where
     ss' = case ss_how_much ss of
-      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }
-      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }
+      ShowHeader (AltPpr Nothing)    -> ss { ss_how_much = ShowHeader ppr' }
+      ShowSome filt (AltPpr Nothing) -> ss { ss_how_much = ShowSome filt ppr' }
       _                   -> ss
 
     ppr' = AltPpr $ ppr_bndr $ getName ty_thing


=====================================
hadrian/src/Packages.hs
=====================================
@@ -3,7 +3,7 @@ module Packages (
     -- * GHC packages
     array, base, binary, bytestring, cabal, cabalSyntax, checkPpr,
     checkExact, countDeps,
-    compareSizes, compiler, containers, deepseq, deriveConstants, directory,
+    compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls,
     exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
     ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline,
     hsc2hs, hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy,
@@ -35,7 +35,7 @@ import Oracles.Setting
 ghcPackages :: [Package]
 ghcPackages =
     [ array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps
-    , compareSizes, compiler, containers, deepseq, deriveConstants, directory
+    , compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls
     , exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh
     , ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs
     , hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, libffi, mtl
@@ -51,7 +51,7 @@ isGhcPackage = (`elem` ghcPackages)
 
 -- | Package definitions, see 'Package'.
 array, base, binary, bytestring, cabalSyntax, cabal, checkPpr, checkExact, countDeps,
-  compareSizes, compiler, containers, deepseq, deriveConstants, directory,
+  compareSizes, compiler, containers, deepseq, deriveConstants, directory, dumpDecls,
   exceptions, filepath, genapply, genprimopcode, ghc, ghcBignum, ghcBoot, ghcBootTh,
   ghcCompact, ghcConfig, ghcHeap, ghci, ghciWrapper, ghcPkg, ghcPrim, haddock, haskeline, hsc2hs,
   hp2ps, hpc, hpcBin, integerGmp, integerSimple, iserv, iservProxy, remoteIserv, libffi, mtl,
@@ -75,6 +75,7 @@ containers          = lib  "containers"      `setPath` "libraries/containers/con
 deepseq             = lib  "deepseq"
 deriveConstants     = util "deriveConstants"
 directory           = lib  "directory"
+dumpDecls           = util "dump-decls"
 exceptions          = lib  "exceptions"
 filepath            = lib  "filepath"
 genapply            = util "genapply"


=====================================
hadrian/src/Rules/Test.hs
=====================================
@@ -40,6 +40,12 @@ countDepsSourcePath = "utils/count-deps/Main.hs"
 countDepsExtra :: [String]
 countDepsExtra = ["-iutils/count-deps"]
 
+dumpDeclsProgPath, dumpDeclsSourcePath :: FilePath
+dumpDeclsProgPath = "test/bin/dump-decls" <.> exe
+dumpDeclsSourcePath = "utils/dump-decls/Main.hs"
+dumpDeclsExtra :: [String]
+dumpDeclsExtra = []
+
 noteLinterProgPath, noteLinterSourcePath :: FilePath
 noteLinterProgPath = "test/bin/lint-notes" <.> exe
 noteLinterSourcePath = "linters/lint-notes/Main.hs"
@@ -67,6 +73,7 @@ checkPrograms =
     [ CheckProgram "test:check-ppr" checkPprProgPath checkPprSourcePath checkPprExtra checkPpr id id
     , CheckProgram "test:check-exact" checkExactProgPath checkExactSourcePath checkExactExtra checkExact id id
     , CheckProgram "test:count-deps" countDepsProgPath countDepsSourcePath countDepsExtra countDeps id id
+    , CheckProgram "test:dump-decls" dumpDeclsProgPath dumpDeclsSourcePath dumpDeclsExtra dumpDecls id id
     , CheckProgram "lint:notes" noteLinterProgPath  noteLinterSourcePath  noteLinterExtra  lintNotes  (const stage0Boot)  id
     , CheckProgram "lint:whitespace"  whitespaceLinterProgPath  whitespaceLinterSourcePath  whitespaceLinterExtra  lintWhitespace  (const stage0Boot)  (filter (/= lintersCommon))
     ]
@@ -260,6 +267,7 @@ testRules = do
 
             setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath)
             setEnv "CHECK_EXACT" (top -/- root -/- checkExactProgPath)
+            setEnv "DUMP_DECLS" (top -/- root -/- dumpDeclsProgPath)
             setEnv "COUNT_DEPS" (top -/- root -/- countDepsProgPath)
             setEnv "LINT_NOTES" (top -/- root -/- noteLinterProgPath)
             setEnv "LINT_WHITESPACE" (top -/- root -/- whitespaceLinterProgPath)


=====================================
hadrian/src/Settings/Default.hs
=====================================
@@ -167,7 +167,7 @@ stage2Packages = stage1Packages
 
 -- | Packages that are built only for the testsuite.
 testsuitePackages :: Action [Package]
-testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, ghcConfig ])
+testsuitePackages = return ([ timeout | windowsHost ] ++ [ checkPpr, checkExact, countDeps, ghcConfig, dumpDecls ])
 
 -- | Default build ways for library packages:
 -- * We always build 'vanilla' way.


=====================================
libraries/base/Data/Enum.hs
=====================================
@@ -0,0 +1,22 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Enum
+-- Copyright   :  (c) The University of Glasgow, 1992-2002
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc at haskell.org
+-- Stability   :  stable
+-- Portability :  non-portable (GHC extensions)
+--
+-- The 'Enum' and 'Bounded' classes.
+--
+-----------------------------------------------------------------------------
+
+module Data.Enum
+    ( Bounded(..)
+    , Enum(..)
+    ) where
+
+import GHC.Enum


=====================================
libraries/base/Data/Show.hs
=====================================
@@ -0,0 +1,28 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Show
+-- Copyright   :  (c) The University of Glasgow, 1992-2002
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc at haskell.org
+-- Stability   :  stable
+-- Portability :  non-portable (GHC extensions)
+--
+-- The 'Show' class.
+--
+-----------------------------------------------------------------------------
+
+module Data.Show
+    ( Show(..)
+      -- * 'ShowS'
+    , ShowS
+    , shows
+    , showChar, showString, showMultiLineString
+    , showParen, showCommaSpace, showSpace
+    , showLitChar, showLitString
+    ) where
+
+import GHC.Show
+


=====================================
libraries/base/GHC/Exception.hs
=====================================
@@ -23,16 +23,33 @@
 -----------------------------------------------------------------------------
 
 module GHC.Exception
-       ( module GHC.Exception.Type
-       , throw
-       , ErrorCall(..,ErrorCall)
-       , errorCallException
-       , errorCallWithCallStackException
-         -- re-export CallStack and SrcLoc from GHC.Types
-       , CallStack, fromCallSiteList, getCallStack, prettyCallStack
-       , prettyCallStackLines, showCCSStack
-       , SrcLoc(..), prettySrcLoc
-       ) where
+    ( -- * 'Exception' class
+      Exception(..)
+
+      -- * 'SomeException'
+    , SomeException(..)
+
+      -- * Throwing
+    , throw
+
+      -- * Concrete exceptions
+      -- ** Arithmetic exceptions
+    , ArithException(..)
+    , divZeroException
+    , overflowException
+    , ratioZeroDenomException
+    , underflowException
+      -- ** 'ErrorCall'
+    , ErrorCall(..,ErrorCall)
+    , errorCallException
+    , errorCallWithCallStackException
+
+      -- * Reexports
+      -- Re-export CallStack and SrcLoc from GHC.Types
+    , CallStack, fromCallSiteList, getCallStack, prettyCallStack
+    , prettyCallStackLines, showCCSStack
+    , SrcLoc(..), prettySrcLoc
+    ) where
 
 import GHC.Base
 import GHC.Show


=====================================
libraries/base/GHC/Float.hs
=====================================
@@ -45,14 +45,109 @@
 
 
 module GHC.Float
-   ( module GHC.Float
-   , Float(..), Double(..), Float#, Double#
-   , double2Int, int2Double, float2Int, int2Float
-
-    -- * Monomorphic equality operators
-    -- | See GHC.Classes#matching_overloaded_methods_in_rules
-   , eqFloat, eqDouble
-   ) where
+    ( -- * Classes
+      Floating(..)
+    , RealFloat(..)
+
+      -- * 'Float'
+    , Float(..), Float#
+      -- ** Conversion
+    , float2Int
+    , int2Float
+    , word2Float
+    , integerToFloat#
+    , naturalToFloat#
+    , rationalToFloat
+    , castWord32ToFloat
+    , castFloatToWord32
+    , float2Double
+      -- ** Operations
+      -- | See GHC.Classes#matching_overloaded_methods_in_rules
+    , floorFloat
+    , ceilingFloat
+    , truncateFloat
+    , roundFloat
+    , properFractionFloat
+      -- ** Predicate
+    , isFloatDenormalized
+    , isFloatFinite
+    , isFloatInfinite
+    , isFloatNaN
+    , isFloatNegativeZero
+      -- ** Comparison
+    , eqFloat, gtFloat, geFloat, leFloat, ltFloat
+      -- ** Arithmetic
+    , plusFloat, minusFloat, timesFloat, divideFloat
+    , negateFloat
+    , powerFloat
+    , expFloat, expm1Float
+    , logFloat, log1pFloat, sqrtFloat, fabsFloat
+    , sinFloat, cosFloat, tanFloat
+    , asinFloat, acosFloat, atanFloat
+    , sinhFloat, coshFloat, tanhFloat
+    , asinhFloat, acoshFloat, atanhFloat
+
+      -- * 'Double'
+    , Double(..)
+    , Double#
+      -- ** Conversion
+    , double2Int
+    , int2Double
+    , word2Double
+    , integerToDouble#
+    , naturalToDouble#
+    , rationalToDouble
+    , castWord64ToDouble
+    , castDoubleToWord64
+    , double2Float
+      -- ** Operations
+      -- | See GHC.Classes#matching_overloaded_methods_in_rules
+    , floorDouble
+    , ceilingDouble
+    , truncateDouble
+    , roundDouble
+    , properFractionDouble
+      -- ** Predicate
+    , isDoubleDenormalized
+    , isDoubleFinite
+    , isDoubleInfinite
+    , isDoubleNaN
+    , isDoubleNegativeZero
+      -- ** Comparison
+    , eqDouble, gtDouble, geDouble, leDouble, ltDouble
+      -- ** Arithmetic
+    , plusDouble, minusDouble, timesDouble, divideDouble
+    , negateDouble
+    , powerDouble
+    , expDouble, expm1Double
+    , logDouble, log1pDouble, sqrtDouble, fabsDouble
+    , sinDouble, cosDouble, tanDouble
+    , asinDouble, acosDouble, atanDouble
+    , sinhDouble, coshDouble, tanhDouble
+    , asinhDouble, acoshDouble, atanhDouble
+
+      -- * Formatting
+    , showFloat
+    , FFFormat(..)
+    , formatRealFloat
+    , formatRealFloatAlt
+    , showSignedFloat
+
+      -- * Operations
+    , log1mexpOrd
+    , roundTo
+    , floatToDigits
+    , integerToBinaryFloat'
+    , fromRat
+    , fromRat'
+    , roundingMode#
+
+      -- * Internal
+    , stgFloatToWord32
+    , stgWord32ToFloat
+    , stgDoubleToWord64
+    , stgWord64ToDouble
+    ) where
 
 import Data.Maybe
 


=====================================
libraries/base/GHC/Num.hs
=====================================
@@ -18,7 +18,9 @@
 
 
 module GHC.Num
-   ( module GHC.Num
+   ( Num(..)
+   , subtract
+   , quotRemInteger
    , module GHC.Num.Integer
    , module GHC.Num.Natural
     -- reexported for backward compatibility


=====================================
libraries/base/GHC/Real.hs
=====================================
@@ -18,7 +18,68 @@
 --
 -----------------------------------------------------------------------------
 
-module GHC.Real where
+module GHC.Real
+    ( -- * Classes
+      Real(..)
+    , Integral(..)
+    , Fractional(..)
+    , RealFrac(..)
+
+      -- * Conversion
+    , fromIntegral
+    , realToFrac
+
+      -- * Formatting
+    , showSigned
+
+      -- * Predicates
+    , even
+    , odd
+
+      -- * Arithmetic
+    , (^)
+    , (^^)
+    , gcd
+    , lcm
+
+      -- * 'Ratio'
+    , Ratio(..)
+    , Rational
+    , infinity
+    , notANumber
+
+      -- * 'Enum' helpers
+    , numericEnumFrom
+    , numericEnumFromThen
+    , numericEnumFromTo
+    , numericEnumFromThenTo
+    , integralEnumFrom
+    , integralEnumFromThen
+    , integralEnumFromTo
+    , integralEnumFromThenTo
+
+      -- ** Construction
+    , (%)
+
+      -- ** Projection
+    , numerator
+    , denominator
+
+      -- ** Operations
+    , reduce
+
+      -- * Internal
+    , ratioPrec
+    , ratioPrec1
+    , divZeroError
+    , ratioZeroDenominatorError
+    , overflowError
+    , underflowError
+    , mkRationalBase2
+    , mkRationalBase10
+    , mkRationalWithExponentBase
+    , FractionalExponentBase(..)
+    ) where
 
 #include "MachDeps.h"
 


=====================================
libraries/base/base.cabal
=====================================
@@ -127,6 +127,7 @@ Library
         Data.Dynamic
         Data.Either
         Data.Eq
+        Data.Enum
         Data.Fixed
         Data.Foldable
         Data.Foldable1
@@ -151,6 +152,7 @@ Library
         Data.Proxy
         Data.Ratio
         Data.Semigroup
+        Data.Show
         Data.STRef
         Data.STRef.Lazy
         Data.STRef.Strict


=====================================
libraries/ghc-bignum/src/GHC/Num/Integer.hs
=====================================
@@ -20,7 +20,131 @@
 --
 -- The 'Integer' type.
 
-module GHC.Num.Integer where
+module GHC.Num.Integer
+    ( Integer(..)
+    , integerCheck
+    , integerCheck#
+
+      -- * Useful constants
+    , integerZero
+    , integerOne
+
+      -- * Conversion with...
+      -- ** 'Int'
+    , integerFromInt#
+    , integerFromInt
+    , integerToInt#
+    , integerToInt
+      -- ** 'BigNat'
+    , integerFromBigNat#
+    , integerFromBigNatNeg#
+    , integerFromBigNatSign#
+    , integerToBigNatSign#
+    , integerToBigNatClamp#
+      -- ** 'Word'
+    , integerFromWord#
+    , integerFromWord
+    , integerFromWordNeg#
+    , integerFromWordSign#
+    , integerToWord#
+    , integerToWord
+      -- ** 'Natural'
+    , integerFromNatural
+    , integerToNaturalClamp
+    , integerToNatural
+    , integerToNaturalThrow
+      -- ** 'Int64'/'Word64'
+    , integerFromInt64#
+    , integerFromWord64#
+    , integerToInt64#
+    , integerToWord64#
+      -- ** Floating-point
+    , integerDecodeDouble#
+    , integerEncodeDouble#
+    , integerEncodeDouble
+    , integerEncodeFloat#
+      -- ** 'Addr#'
+    , integerToAddr#
+    , integerToAddr
+    , integerFromAddr#
+    , integerFromAddr
+      -- ** Limbs
+    , integerFromWordList
+    , integerToMutableByteArray#
+    , integerToMutableByteArray
+    , integerFromByteArray#
+    , integerFromByteArray
+
+      -- * Predicates
+    , integerIsNegative#
+    , integerIsNegative
+    , integerIsZero
+    , integerIsOne
+
+      -- * Comparison
+    , integerNe
+    , integerEq
+    , integerLe
+    , integerLt
+    , integerGt
+    , integerGe
+    , integerEq#
+    , integerNe#
+    , integerGt#
+    , integerLe#
+    , integerLt#
+    , integerGe#
+    , integerCompare
+
+      -- * Arithmetic
+    , integerSub
+    , integerAdd
+    , integerMul
+    , integerNegate
+    , integerAbs
+    , integerSignum
+    , integerSignum#
+    , integerQuotRem#
+    , integerQuotRem
+    , integerQuot
+    , integerRem
+    , integerDivMod#
+    , integerDivMod
+    , integerDiv
+    , integerMod
+    , integerGcd
+    , integerLcm
+    , integerSqr
+    , integerLog2#
+    , integerLog2
+    , integerLogBaseWord#
+    , integerLogBaseWord
+    , integerLogBase#
+    , integerLogBase
+    , integerIsPowerOf2#
+    , integerGcde#
+    , integerGcde
+    , integerRecipMod#
+    , integerPowMod#
+
+      -- * Bit operations
+    , integerPopCount#
+    , integerBit#
+    , integerBit
+    , integerTestBit#
+    , integerTestBit
+    , integerShiftR#
+    , integerShiftR
+    , integerShiftL#
+    , integerShiftL
+    , integerOr
+    , integerXor
+    , integerAnd
+    , integerComplement
+
+      -- * Miscellaneous
+    , integerSizeInBase#
+    ) where
 
 #include "MachDeps.h"
 #include "WordSize.h"


=====================================
libraries/ghc-bignum/src/GHC/Num/Natural.hs
=====================================
@@ -8,7 +8,109 @@
 #include "MachDeps.h"
 #include "WordSize.h"
 
-module GHC.Num.Natural where
+module GHC.Num.Natural
+    ( Natural(..)
+    , naturalCheck#
+    , naturalCheck
+
+      -- * Useful constants
+    , naturalZero
+    , naturalOne
+
+      -- * Predicates
+    , naturalIsZero
+    , naturalIsOne
+    , naturalIsPowerOf2#
+
+      -- * Conversion with...
+      -- ** 'BigNat'
+    , naturalFromBigNat#
+    , naturalToBigNat#
+      -- ** 'Word'
+    , naturalFromWord#
+    , naturalFromWord2#
+    , naturalFromWord
+    , naturalToWord#
+    , naturalToWord
+    , naturalToWordClamp#
+    , naturalToWordClamp
+    , naturalToWordMaybe#
+      -- ** Limbs
+    , naturalFromWordList
+    , naturalToMutableByteArray#
+    , naturalFromByteArray#
+      -- ** Floating point
+    , naturalEncodeDouble#
+    , naturalEncodeFloat#
+      -- ** 'Addr#'
+    , naturalToAddr#
+    , naturalToAddr
+    , naturalFromAddr#
+    , naturalFromAddr
+
+      -- * Comparison
+    , naturalEq#
+    , naturalEq
+    , naturalNe#
+    , naturalNe
+    , naturalGe#
+    , naturalGe
+    , naturalLe#
+    , naturalLe
+    , naturalGt#
+    , naturalGt
+    , naturalLt#
+    , naturalLt
+    , naturalCompare
+
+      -- * Bit operations
+    , naturalPopCount#
+    , naturalPopCount
+    , naturalShiftR#
+    , naturalShiftR
+    , naturalShiftL#
+    , naturalShiftL
+    , naturalAnd
+    , naturalAndNot
+    , naturalOr
+    , naturalXor
+    , naturalTestBit#
+    , naturalTestBit
+    , naturalBit#
+    , naturalBit
+    , naturalSetBit#
+    , naturalSetBit
+    , naturalClearBit#
+    , naturalClearBit
+    , naturalComplementBit#
+    , naturalComplementBit
+
+      -- * Arithmetic
+    , naturalAdd
+    , naturalSub
+    , naturalSubThrow
+    , naturalSubUnsafe
+    , naturalMul
+    , naturalSqr
+    , naturalSignum
+    , naturalNegate
+    , naturalQuotRem#
+    , naturalQuotRem
+    , naturalQuot
+    , naturalRem
+    , naturalGcd
+    , naturalLcm
+    , naturalLog2#
+    , naturalLog2
+    , naturalLogBaseWord#
+    , naturalLogBaseWord
+    , naturalLogBase#
+    , naturalLogBase
+    , naturalPowMod
+
+      -- * Miscellaneous
+    , naturalSizeInBase#
+    ) where
 
 import GHC.Prim
 import GHC.Types


=====================================
testsuite/mk/boilerplate.mk
=====================================
@@ -227,6 +227,10 @@ ifeq "$(CHECK_EXACT)" ""
 CHECK_EXACT := $(abspath $(TOP)/../inplace/bin/check-exact)
 endif
 
+ifeq "$(DUMP_DECLS)" ""
+DUMP_DECLS := $(abspath $(TOP)/../inplace/bin/dump-decls)
+endif
+
 ifeq "$(COUNT_DEPS)" ""
 COUNT_DEPS := $(abspath $(TOP)/../inplace/bin/count-deps)
 endif


=====================================
testsuite/tests/ghci/scripts/ghci008.stdout
=====================================
@@ -40,5 +40,5 @@ class (RealFrac a, Floating a) => RealFloat a where
   	-- Defined in ‘GHC.Float’
 instance RealFloat Double -- Defined in ‘GHC.Float’
 instance RealFloat Float -- Defined in ‘GHC.Float’
-base-4.16.0.0:Data.OldList.isPrefixOf :: Eq a => [a] -> [a] -> Bool
-  	-- Defined in ‘base-4.16.0.0:Data.OldList’
+base-4.18.0.0:Data.OldList.isPrefixOf :: Eq a => [a] -> [a] -> Bool
+  	-- Defined in ‘base-4.18.0.0:Data.OldList’


=====================================
testsuite/tests/interface-stability/Makefile
=====================================
@@ -0,0 +1,6 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+exports_% :
+	"$(DUMP_DECLS)" "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" $*


=====================================
testsuite/tests/interface-stability/README.mkd
=====================================
@@ -0,0 +1,11 @@
+# Interface stability testing
+
+The tests in this directory verify that the interfaces of exposed by GHC's
+core libraries do not inadvertently change. They use the `utils/dump-decls`
+utility to dump all exported declarations of all exposed modules for the
+following packages:
+
+  * base
+
+These are compared against the expected exports in the test's corresponding
+`.stdout` file.


=====================================
testsuite/tests/interface-stability/all.T
=====================================
@@ -0,0 +1,7 @@
+def check_package(pkg_name):
+    test(f'{pkg_name}-exports',
+         req_hadrian_deps(['test:dump-decls']),
+         makefile_test,
+         [f'exports_{pkg_name}'])
+
+check_package('base')


=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
The diff for this file was not included because it is too large.

=====================================
utils/dump-decls/Main.hs
=====================================
@@ -0,0 +1,182 @@
+module Main where
+
+import GHC
+import GHC.Core.InstEnv (instEnvElts, instanceHead)
+import GHC.Core.TyCo.FVs (tyConsOfType)
+import GHC.Driver.Ppr (showSDocForUser)
+import GHC.Unit.State (lookupUnitId, lookupPackageName)
+import GHC.Unit.Info (UnitInfo, unitExposedModules, PackageName(..))
+import GHC.Data.FastString (fsLit)
+import GHC.Driver.Env (hsc_units, hscEPS)
+import GHC.Utils.Outputable
+import GHC.Types.Unique.Set (nonDetEltsUniqSet)
+import GHC.Types.TyThing (tyThingParent_maybe)
+import GHC.Types.TyThing.Ppr (pprTyThing)
+import GHC.Types.Name (nameOccName, nameModule_maybe, stableNameCmp)
+import GHC.Types.Name.Occurrence (OccName)
+import GHC.Unit.External (eps_inst_env)
+import GHC.Iface.Syntax (ShowSub(..), ShowHowMuch(..), AltPpr(..))
+import GHC.Iface.Type (ShowForAllFlag(..))
+
+import Data.Function (on)
+import Data.List (sortBy)
+import Control.Monad.IO.Class
+import System.Environment (getArgs)
+import Prelude hiding ((<>))
+
+main :: IO ()
+main = do
+    ghcRoot:pkg_names <- getArgs
+    mapM_ (run ghcRoot) pkg_names
+
+run :: FilePath -> String -> IO ()
+run root pkg_nm = runGhc (Just root) $ do
+    let args = map noLoc
+            [ "-package=" ++ pkg_nm
+            , "-dppr-cols=1000"
+            , "-fprint-explicit-runtime-reps"
+            , "-fprint-explicit-foralls"
+            ]
+    dflags <- do
+        dflags <- getSessionDynFlags
+        logger <- getLogger
+        (dflags', _fileish_args, _dynamicFlagWarnings) <-
+          GHC.parseDynamicFlags logger dflags args
+        return dflags'
+
+    _ <- setProgramDynFlags dflags
+    unit_state <- hsc_units <$> getSession
+    unit_id <- case lookupPackageName unit_state (PackageName $ fsLit pkg_nm) of
+                    Just unit_id -> return unit_id
+                    Nothing -> fail "failed to find package"
+    unit_info <- case lookupUnitId unit_state unit_id of
+      Just unit_info -> return unit_info
+      Nothing -> fail "unknown package"
+
+    decls_doc <- reportUnitDecls unit_info
+    insts_doc <- reportInstances
+
+    name_ppr_ctx <- GHC.getNamePprCtx
+    let rendered = showSDocForUser dflags unit_state name_ppr_ctx (vcat [decls_doc, insts_doc])
+    liftIO $ putStrLn rendered
+
+ignoredModules :: [ModuleName]
+ignoredModules =
+    map mkModuleName $ concat
+    [ unstableModules
+    , platformDependentModules
+    ]
+  where
+    unstableModules =
+        [ "GHC.Prim"
+        , "GHC.Conc.POSIX"
+        , "GHC.Conc.IO"
+        ]
+    platformDependentModules =
+        [ "System.Posix.Types"
+        , "Foreign.C.Types"
+        ]
+
+ignoredName :: Name -> Bool
+ignoredName nm
+  | Just md <- nameModule_maybe nm
+  , moduleName md `elem` ignoredModules
+  = True
+  | otherwise
+  = False
+
+ignoredTyThing :: TyThing -> Bool
+ignoredTyThing _ = False
+
+ignoredTyCon :: TyCon -> Bool
+ignoredTyCon = ignoredName . getName
+
+ignoredType :: Type -> Bool
+ignoredType = any ignoredTyCon . nonDetEltsUniqSet . tyConsOfType
+
+-- | Ignore instances whose heads mention ignored types.
+ignoredInstance :: ClsInst -> Bool
+ignoredInstance inst
+  | ignoredName $ getName cls
+  = True
+  | any ignoredType tys
+  = True
+  | otherwise
+  = False
+  where
+    (_, cls, tys) = instanceHead inst
+
+reportUnitDecls :: UnitInfo -> Ghc SDoc
+reportUnitDecls unit_info = do
+    let exposed :: [ModuleName]
+        exposed = map fst (unitExposedModules unit_info)
+    vcat <$> mapM reportModuleDecls exposed
+
+reportModuleDecls :: ModuleName -> Ghc SDoc
+reportModuleDecls modl_nm
+  | modl_nm `elem` ignoredModules = do
+      return $ vcat [ mod_header, text "-- ignored", text "" ]
+  | otherwise = do
+    modl <- GHC.lookupQualifiedModule NoPkgQual modl_nm
+    mb_mod_info <- GHC.getModuleInfo modl
+    mod_info <- case mb_mod_info of
+      Nothing -> fail "Failed to find module"
+      Just mod_info -> return mod_info
+
+    Just name_ppr_ctx <- mkNamePprCtxForModule mod_info
+    let names = GHC.modInfoExports mod_info
+        sorted_names = sortBy (compare `on` nameOccName) names
+
+        exported_occs :: [OccName]
+        exported_occs = map nameOccName names
+
+        is_exported :: OccName -> Bool
+        is_exported = (`elem` exported_occs)
+
+    things <- mapM GHC.lookupName sorted_names
+    let contents = vcat $
+            [ text "-- Safety:" <+> ppr (modInfoSafe mod_info) ] ++
+            [ pprTyThing ss thing
+            | Just thing <- things
+            , case tyThingParent_maybe thing of
+                Just parent
+                  | is_exported (getOccName parent) -> False
+                _ -> True
+            , not $ ignoredTyThing thing
+            , let ss = ShowSub { ss_how_much = ShowSome (Just is_exported) (AltPpr Nothing)
+                               , ss_forall = ShowForAllMust
+                               }
+            ]
+
+    return $ withUserStyle name_ppr_ctx AllTheWay $
+        hang mod_header 2 contents <>
+        text ""
+  where
+    mod_header = vcat
+        [ text ""
+        , text "module" <+> ppr modl_nm <+> text "where"
+        , text ""
+        ]
+
+reportInstances :: Ghc SDoc
+reportInstances = do
+    hsc_env <- getSession
+    eps <- liftIO $ hscEPS hsc_env
+    let instances = eps_inst_env eps
+    return $ vcat $
+        [ text ""
+        , text ""
+        , text "-- Instances:"
+        ] ++
+        [ ppr inst
+        | inst <- sortBy compareInstances (instEnvElts instances)
+        , not $ ignoredInstance inst
+        ]
+
+compareInstances :: ClsInst -> ClsInst -> Ordering
+compareInstances inst1 inst2 = mconcat
+    [ stableNameCmp (getName cls1) (getName cls2)
+    ]
+  where
+      (_, cls1, _tys1) = instanceHead inst1
+      (_, cls2, _tys2) = instanceHead inst2


=====================================
utils/dump-decls/dump-decls.cabal
=====================================
@@ -0,0 +1,13 @@
+cabal-version:      2.4
+name:               dump-decls
+version:            0.1.0.0
+synopsis:           Dump the declarations of a package.
+license:            BSD-3-Clause
+author:             Ben Gamari
+maintainer:         ben at smart-cactus.org
+copyright:          (c) 2023 Ben Gamari
+
+executable dump-decls
+    main-is:          Main.hs
+    build-depends:    base, ghc
+    default-language: Haskell2010



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/437a38c2edad016c8841327f3884177b00312b38...075cc9ebe94795f8661c4ff1085e514e2f58c5b3

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/437a38c2edad016c8841327f3884177b00312b38...075cc9ebe94795f8661c4ff1085e514e2f58c5b3
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/20230521/663400ec/attachment-0001.html>


More information about the ghc-commits mailing list