[Git][ghc/ghc][wip/ci-interface-stability] testsuite: Add test to catch changes in core libraries
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri May 12 18:01:07 UTC 2023
Ben Gamari pushed to branch wip/ci-interface-stability at Glasgow Haskell Compiler / GHC
Commits:
d272ff9b by Ben Gamari at 2023-05-12T10:41:44-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.
- - - - -
10 changed files:
- hadrian/src/Packages.hs
- hadrian/src/Rules/Test.hs
- hadrian/src/Settings/Default.hs
- testsuite/mk/boilerplate.mk
- + 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:
=====================================
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.
=====================================
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/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,202 @@
+module Main where
+
+import GHC
+import GHC.Core.InstEnv (instEnvElts, instanceHead)
+import GHC.Core.TyCo.FVs (tyConsOfType, tyConsOfTypes)
+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.Ppr (pprTyThing)
+import GHC.Types.Name (nameOccName, nameModule_maybe, stableNameCmp, isDataConName)
+import GHC.Unit.External (eps_inst_env)
+import GHC.Iface.Syntax (showToHeader)
+
+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"]
+ 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"
+ -- Javascript backend
+ , "GHC.JS.Prim"
+ , "GHC.JS.Foreign.Callback"
+ -- Event manager
+ , "GHC.Event.Manager"
+ , "GHC.Event.TimerManager"
+ , "GHC.Event.Internal.Types"
+ ]
+ platformDependentModules =
+ [ "System.Posix.Types"
+ , "Foreign.C.Types"
+ ]
+
+ignoredOccNames :: [OccName]
+ignoredOccNames =
+ -- These only exist on 32-bit platforms
+ map mkVarOcc
+ [ "int64ToInteger"
+ , "integerToInt64"
+ , "integerToWord64"
+ , "word64ToInteger"
+ ]
+
+ignoredName :: Name -> Bool
+ignoredName nm
+ | nameOccName nm `elem` ignoredOccNames
+ = True
+ | Just md <- nameModule_maybe nm
+ , moduleName md `elem` ignoredModules
+ = True
+ | otherwise
+ = False
+
+ignoredTyThing :: TyThing -> Bool
+ignoredTyThing thing
+ -- Ignore the RHSs of Foreign.C.Types' data constructors as they are
+ -- platform dependent
+ | mod_nm == foreignCTypes
+ , isDataConName nm = True
+ | otherwise = False
+ where
+ nm = getName thing
+ mod_nm = moduleName $ nameModule nm
+ foreignCTypes = mkModuleName "Foreign.C.Types"
+
+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
+ things <- mapM GHC.lookupName sorted_names
+ let contents = vcat $
+ [ text "-- Safety:" <+> ppr (modInfoSafe mod_info) ] ++
+ [ pprTyThing showToHeader thing
+ | Just thing <- things
+ , not $ ignoredTyThing thing
+ ]
+
+ 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
+ ]
+
+-- | This is a fairly ad-hoc ordering to mostly ensure determinism.
+compareInstances :: ClsInst -> ClsInst -> Ordering
+compareInstances inst1 inst2 = mconcat
+ [ stableNameCmp (getName cls1) (getName cls2)
+ , compareListsWith stableNameCmp
+ (sorted_tycons tys1)
+ (sorted_tycons tys2)
+ ]
+ where
+ sorted_tycons =
+ sortBy stableNameCmp . map getName . nonDetEltsUniqSet . tyConsOfTypes
+ (_, cls1, tys1) = instanceHead inst1
+ (_, cls2, tys2) = instanceHead inst2
+
+compareListsWith :: (a -> a -> Ordering) -> [a] -> [a] -> Ordering
+compareListsWith cmp = go
+ where
+ go (x:xs) (y:ys) = cmp x y `mappend` go xs ys
+ go [] (_:_) = LT
+ go (_:_) [] = GT
+ go [] [] = EQ
=====================================
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/-/commit/d272ff9b6e52c9e52925d298cfdcfb7f58276c13
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d272ff9b6e52c9e52925d298cfdcfb7f58276c13
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/20230512/328838ed/attachment-0001.html>
More information about the ghc-commits
mailing list