[Git][ghc/ghc][wip/ci-interface-stability] 2 commits: compiler: Rework ShowSome
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Sun May 21 17:41:25 UTC 2023
Ben Gamari pushed to branch wip/ci-interface-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.
- - - - -
14 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
- 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.
=====================================
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/4969745069e658978e74b8b6a99cf8d601413963...a063fb2c31f0633f7c75b65d244913a575949eeb
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4969745069e658978e74b8b6a99cf8d601413963...a063fb2c31f0633f7c75b65d244913a575949eeb
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/a4f36a02/attachment-0001.html>
More information about the ghc-commits
mailing list