[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 Jun 30 03:08:46 UTC 2023



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


Commits:
8e0c11f6 by Ben Gamari at 2023-06-29T23:08:16-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.

- - - - -


11 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
- + testsuite/tests/interface-stability/base-exports.stdout-mingw32
- + 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.

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

=====================================
utils/dump-decls/Main.hs
=====================================
@@ -0,0 +1,243 @@
+module Main where
+
+import GHC
+import GHC.Core.InstEnv (instEnvElts, instanceHead)
+import GHC.Core.Class (classMinimalDef)
+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, mkDataOcc, mkVarOcc)
+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"
+        ]
+
+ignoredOccNames :: [OccName]
+ignoredOccNames =
+    map mkDataOcc cTypeCons ++
+    map mkVarOcc integerConversionIds
+  where
+    -- Data constructors from Foreign.C.Types whose RHSs are inherently platform-dependent
+    cTypeCons =
+        [ "CBool"
+        , "CChar"
+        , "CClock"
+        , "CDouble"
+        , "CFile"
+        , "CFloat"
+        , "CFpos"
+        , "CInt"
+        , "CIntMax"
+        , "CIntPtr"
+        , "CJmpBuf"
+        , "CLLong"
+        , "CLong"
+        , "CPtrdiff"
+        , "CSChar"
+        , "CSUSeconds"
+        , "CShort"
+        , "CSigAtomic"
+        , "CSize"
+        , "CTime"
+        , "CUChar"
+        , "CUInt"
+        , "CUIntMax"
+        , "CUIntPtr"
+        , "CULLong"
+        , "CULong"
+        , "CUSeconds"
+        , "CUShort"
+        , "CWchar"
+        ]
+
+    -- Conversion functions in GHC.Integer which are only exposed on 32-bit
+    -- platforms
+    integerConversionIds =
+        [ "int64ToInteger"
+        , "integerToInt64"
+        , "integerToWord64"
+        , "word64ToInteger"
+        ]
+
+ignoredOccName :: OccName -> Bool
+ignoredOccName occ = occ `elem` ignoredOccNames
+
+ignoredName :: Name -> Bool
+ignoredName nm
+  | ignoredOccName (getOccName nm)
+  = True
+  | 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 occ = occ `elem` exported_occs
+
+        show_occ :: OccName -> Bool
+        show_occ occ = is_exported occ && not (ignoredOccName occ)
+
+    things <- mapM GHC.lookupName sorted_names
+    let contents = vcat $
+            [ text "-- Safety:" <+> ppr (modInfoSafe mod_info) ] ++
+            [ pprTyThing ss thing $$ extras
+            | 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 show_occ) (AltPpr Nothing)
+                               , ss_forall = ShowForAllMust
+                               }
+            , let extras = case thing of
+                             ATyCon tycon
+                               | Just cls <- tyConClass_maybe tycon
+                               -> nest 2 (text "{-# MINIMAL" <+> ppr (classMinimalDef cls) <+> text "#-}")
+                             _ -> empty
+            ]
+
+    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/-/commit/8e0c11f65c1ae36db50e54001e3645f36a7f8ed7

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8e0c11f65c1ae36db50e54001e3645f36a7f8ed7
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/20230629/7ad21d06/attachment-0001.html>


More information about the ghc-commits mailing list