From 59aaf29583d133feb94b6a31cb1123d9bbf4ffa5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C3=A9cate?= Date: Fri, 6 Dec 2024 10:26:05 +0100 Subject: [PATCH] Haddock attributes of a module to determine the visibility (#20) --- .github/workflows/ci.yml | 2 + .github/workflows/release.yml | 22 ++++ app/print-api/Main.hs | 13 ++ cabal.project | 5 + compat/9.8.2/GHC/Compat.hs | 2 +- print-api.cabal | 7 +- src/PrintApi/CLI/Cmd/Dump.hs | 222 ++++++++++++++++++++++++---------- src/PrintApi/CLI/Types.hs | 34 +++--- test/IgnoreList.hs | 2 +- 9 files changed, 225 insertions(+), 84 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 65d34d6..ff960b5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -6,6 +6,7 @@ on: branches: ['main'] jobs: + generate-matrix: name: 'Generate matrix from cabal' outputs: @@ -184,6 +185,7 @@ jobs: done echo "$GITHUB_WORKSPACE/distribution" >> "$GITHUB_PATH" echo "REPORT_NAME=report-${{ env.KERNEL }}-static-ghc-${{ matrix.ghc }}" >> $GITHUB_ENV + echo "$GITHUB_WORKSPACE/distribution" >> "$GITHUB_PATH" - name: Test run: cabal test --project-file=cabal.static.project --test-options "--xml=../print-api/${REPORT_NAME}.xml" all diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index 215ef8b..8d817a8 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -93,6 +93,17 @@ jobs: if: success() || failure() # always run even if the previous step fails with: report_paths: "report.xml" + cp ${bin} distribution/print-api + echo "$GITHUB_WORKSPACE/distribution" >> "$GITHUB_PATH" + + - name: Test + run: cabal test --project-file=cabal.static.project --test-options "--xml=../print-api/report.xml" all + + - name: Publish Test Report + uses: mikepenz/action-junit-report@v4 + if: success() || failure() # always run even if the previous step fails + with: + report_paths: "report.xml" - name: File type run: file distribution/* @@ -180,6 +191,17 @@ jobs: if: success() || failure() # always run even if the previous step fails with: report_paths: "report.xml" + cp ${bin} distribution/print-api + echo "$GITHUB_WORKSPACE/distribution" >> "$GITHUB_PATH" + + - name: Test + run: cabal test --project-file=cabal.static.project --test-options "--xml=../print-api/report.xml" all + + - name: Publish Test Report + uses: mikepenz/action-junit-report@v4 + if: success() || failure() # always run even if the previous step fails + with: + report_paths: "report.xml" - name: File type run: file distribution/* diff --git a/app/print-api/Main.hs b/app/print-api/Main.hs index 3d0aa74..aa13c18 100644 --- a/app/print-api/Main.hs +++ b/app/print-api/Main.hs @@ -1,8 +1,14 @@ +{-# LANGUAGE CPP #-} + module Main where +import Data.ByteString.Lazy.Char8 qualified as ByteString +import Data.List.Extra qualified as List import Options.Applicative +import PrintApi.Utils import System.IO +import PrintApi.CLI.Cmd.Dump (run) import PrintApi.CLI.Types main :: IO () @@ -10,3 +16,10 @@ main = do hSetBuffering stdout LineBuffering parseResult <- execParser (parseOptions `withInfo` "Export the declarations of a Haskell package") runOptions parseResult + +runOptions + :: Options + -> IO () +runOptions (Options packageName mIgnoreList usePublicOnly) = do + stdOut <- readCabalizedProcess (Just TOOL_VERSION_ghc) "ghc" ["--print-libdir"] + run (List.trimEnd $ ByteString.unpack stdOut) mIgnoreList usePublicOnly packageName diff --git a/cabal.project b/cabal.project index 26e417a..fa0fe96 100644 --- a/cabal.project +++ b/cabal.project @@ -4,6 +4,11 @@ tests: True write-ghc-environment-files: always +package print-api + ghc-options: -haddock + +documentation: True + allow-newer: tasty-test-reporter:mtl , tasty-test-reporter:ansi-terminal diff --git a/compat/9.8.2/GHC/Compat.hs b/compat/9.8.2/GHC/Compat.hs index 1270c76..b9b5627 100644 --- a/compat/9.8.2/GHC/Compat.hs +++ b/compat/9.8.2/GHC/Compat.hs @@ -3,7 +3,7 @@ module GHC.Compat where import GHC (ModuleInfo) import GHC.Iface.Syntax (AltPpr (..), ShowForAllFlag (..), ShowHowMuch (..), ShowSub (..)) -import PrintApi.IgnoredDeclarations +import PrintApi.IgnoredDeclarations () mkShowSub :: ModuleInfo -> ShowSub mkShowSub _ = diff --git a/print-api.cabal b/print-api.cabal index a01e511..f2da264 100644 --- a/print-api.cabal +++ b/print-api.cabal @@ -1,5 +1,6 @@ cabal-version: 2.4 name: print-api + -- For the purpose of release and pre-release versioning, we use the following scheme: -- EPOCH.MAJOR.MINOR.PATCH -- with the MINOR member being even for releases and odd for pre-releases @@ -54,12 +55,14 @@ common print-api-common -- main-is: Main.hs build-depends: , base + , bytestring + , extra , ghc , ghc-paths , optparse-applicative , print-api - default-language: Haskell2010 + default-language: GHC2021 library import: extensions @@ -89,11 +92,13 @@ library build-depends: , base , bytestring + , containers , extra , filepath , ghc , ghc-boot , ghc-paths + , haddock-library , optparse-applicative , process , text diff --git a/src/PrintApi/CLI/Cmd/Dump.hs b/src/PrintApi/CLI/Cmd/Dump.hs index 851ac50..b12569c 100644 --- a/src/PrintApi/CLI/Cmd/Dump.hs +++ b/src/PrintApi/CLI/Cmd/Dump.hs @@ -1,52 +1,105 @@ +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use mapMaybe" #-} +{-# HLINT ignore "Functor law" #-} + +-- | +-- Module : PrintApi.CLI.Cmd.Dump +-- Copyright : © Hécate, 2024 +-- License : MIT +-- Maintainer : hecate@glitchbra.in +-- Visibility : Public +-- +-- The processing of package information module PrintApi.CLI.Cmd.Dump where import Control.Monad.IO.Class -import Data.Function (on) +import Data.Function (on, (&)) import Data.List qualified as List import Data.List.Extra qualified as List +import Data.Maybe +import Data.Maybe qualified as Maybe +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TE import GHC -import GHC.Compat + ( ModuleInfo + , getModuleInfo + , getNamePprCtx + , lookupName + , lookupQualifiedModule + , mkNamePprCtxForModule + , modInfoExports + , modInfoIface + , parseDynamicFlags + , runGhc + , setProgramDynFlags + ) +import GHC.Compat as Compat import GHC.Core.Class (classMinimalDef) -import GHC.Core.InstEnv (instEnvElts, instanceHead) +import GHC.Core.InstEnv (ClsInst, instEnvElts, instanceHead) import GHC.Data.FastString (fsLit) import GHC.Driver.Env (hscEPS, hsc_units) +import GHC.Driver.Monad (Ghc, getSession, getSessionDynFlags) import GHC.Driver.Ppr (showSDocForUser) -import GHC.Types.Name (nameOccName, stableNameCmp) -import GHC.Types.TyThing (tyThingParent_maybe) +import GHC.Hs.Doc (Docs (..), WithHsDocIdentifiers (..)) +import GHC.Hs.DocString (HsDocStringChunk (..), docStringChunks) +import GHC.Plugins (ModIface_ (mi_docs), PkgQual (..), tyConClass_maybe) +import GHC.Types.Name (NamedThing (..), nameOccName, stableNameCmp) +import GHC.Types.SrcLoc (Located, noLoc, unLoc) +import GHC.Types.TyThing (TyThing (..), tyThingParent_maybe) import GHC.Types.TyThing.Ppr (pprTyThing) import GHC.Unit.External (eps_inst_env) import GHC.Unit.Info (PackageName (..), UnitInfo, unitExposedModules, unitId) +import GHC.Unit.Module (ModuleName, mkModuleName) import GHC.Unit.State (lookupPackageName, lookupUnitId) import GHC.Unit.Types (UnitId) +import GHC.Utils.Logger (HasLogger (..)) import GHC.Utils.Outputable + ( Depth (..) + , IsDoc (..) + , IsLine (..) + , IsOutput (..) + , Outputable (..) + , SDoc + , hang + , nest + , withUserStyle + ) import System.IO qualified as System -import System.OsPath (OsPath) import System.OsPath qualified as OsPath import Prelude hiding ((<>)) +import Data.Functor ((<&>)) import PrintApi.IgnoredDeclarations +import System.OsPath (OsPath) run :: FilePath -> Maybe OsPath + -> Bool -> String -> IO () -run root mModuleIgnoreList packageName = do - userIgnoredModules <- case mModuleIgnoreList of - Nothing -> pure [] +run root mIgnoreList usePublicOnly packageName = do + case mIgnoreList of + Nothing -> do + rendered <- computePackageAPI usePublicOnly root [] packageName + liftIO $ putStrLn rendered Just ignoreListPath -> do - ignoreListFilePath <- liftIO $ OsPath.decodeFS ignoreListPath - modules <- lines <$> liftIO (System.readFile ignoreListFilePath) - pure $ List.map mkModuleName modules - rendered <- computePackageAPI root userIgnoredModules packageName - liftIO $ putStrLn rendered + userIgnoredModules <- do + ignoreListFilePath <- liftIO $ OsPath.decodeFS ignoreListPath + modules <- lines <$> liftIO (System.readFile ignoreListFilePath) + pure $ List.map mkModuleName modules + rendered <- computePackageAPI usePublicOnly root userIgnoredModules packageName + liftIO $ putStrLn rendered computePackageAPI - :: FilePath + :: Bool + -> FilePath -> [ModuleName] -> String -> IO String -computePackageAPI root userIgnoredModules packageName = runGhc (Just root) $ do +computePackageAPI usePublicOnly root userIgnoredModules packageName = runGhc (Just root) $ do let args :: [Located String] = map noLoc @@ -64,71 +117,77 @@ computePackageAPI root userIgnoredModules packageName = runGhc (Just root) $ do _ <- setProgramDynFlags dflags unit_state <- hsc_units <$> getSession - unit_id <- case lookupPackageName unit_state (PackageName $ fsLit packageName) of - Just unit_id -> pure unit_id + unitId <- case lookupPackageName unit_state (PackageName $ fsLit packageName) of + Just unitId -> pure unitId Nothing -> fail "failed to find package" - unit_info <- case lookupUnitId unit_state unit_id of - Just unit_info -> pure unit_info + unitInfo <- case lookupUnitId unit_state unitId of + Just unitInfo -> pure unitInfo Nothing -> fail "unknown package" - decls_doc <- reportUnitDecls userIgnoredModules unit_info + decls_doc <- reportUnitDecls usePublicOnly userIgnoredModules unitInfo insts_doc <- reportInstances name_ppr_ctx <- GHC.getNamePprCtx pure $ List.trim $ showSDocForUser dflags unit_state name_ppr_ctx (vcat [decls_doc, insts_doc]) -ignoredTyThing :: TyThing -> Bool -ignoredTyThing _ = False - -reportUnitDecls :: [ModuleName] -> UnitInfo -> Ghc SDoc -reportUnitDecls userIgnoredModules unit_info = do +reportUnitDecls :: Bool -> [ModuleName] -> UnitInfo -> Ghc SDoc +reportUnitDecls usePublicOnly userIgnoredModules unitInfo = do let exposed :: [ModuleName] - exposed = map fst (unitExposedModules unit_info) - vcat <$> mapM (reportModuleDecls userIgnoredModules $ unitId unit_info) exposed + exposed = map fst (unitExposedModules unitInfo) + vcat <$> mapM (reportModuleDecls usePublicOnly userIgnoredModules $ unitId unitInfo) exposed -reportModuleDecls :: [ModuleName] -> UnitId -> ModuleName -> Ghc SDoc -reportModuleDecls userIgnoredModules unit_id modl_nm - | modl_nm `elem` (userIgnoredModules ++ ignoredModules) = do - pure $ vcat [mod_header, text "-- ignored", text ""] +reportModuleDecls :: Bool -> [ModuleName] -> UnitId -> ModuleName -> Ghc SDoc +reportModuleDecls usePublicOnly userIgnoredModules unitId moduleName + | moduleName `elem` (userIgnoredModules ++ ignoredModules) = do + pure $ vcat [modHeader moduleName, text "-- ignored", text ""] | otherwise = do - modl <- GHC.lookupQualifiedModule (OtherPkg unit_id) modl_nm + modl <- GHC.lookupQualifiedModule (OtherPkg unitId) moduleName mb_mod_info <- GHC.getModuleInfo modl mod_info <- case mb_mod_info of Nothing -> fail "Failed to find module" Just mod_info -> pure mod_info + let mDocs = + mod_info + & modInfoIface + & Maybe.fromJust + & mi_docs + case mDocs of + Nothing -> pure empty + Just docs -> do + if usePublicOnly + then + if isVisible docs + then extractModuleDeclarations moduleName mod_info + else pure empty + else extractModuleDeclarations moduleName mod_info - Just name_ppr_ctx <- mkNamePprCtxForModule mod_info - let names = GHC.modInfoExports mod_info - let sorted_names = List.sortBy (compare `on` nameOccName) names - things <- mapM GHC.lookupName sorted_names - let contents = - vcat $ - [ pprTyThing ss thing $$ extras - | Just thing <- things - , case tyThingParent_maybe thing of - Just parent - | isExported mod_info (getOccName parent) -> False - _ -> True - , not $ ignoredTyThing thing - , let ss = mkShowSub mod_info - , let extras = case thing of - ATyCon tycon - | Just cls <- tyConClass_maybe tycon -> - nest 2 (text "{-# MINIMAL" <+> ppr (classMinimalDef cls) <+> text "#-}") - _ -> empty - ] - - pure $ - withUserStyle name_ppr_ctx AllTheWay $ - hang mod_header 2 contents - <> text "" - where - mod_header = - vcat - [ text "" - , text "module" <+> ppr modl_nm <+> text "where" - , text "" - ] +extractModuleDeclarations :: ModuleName -> ModuleInfo -> Ghc SDoc +extractModuleDeclarations moduleName mod_info = do + Just name_ppr_ctx <- mkNamePprCtxForModule mod_info + let names = modInfoExports mod_info + let sorted_names = List.sortBy (compare `on` nameOccName) names + things <- + sorted_names + & mapM lookupName + <&> catMaybes + <&> filter + ( \e -> case tyThingParent_maybe e of + Just parent + | isExported mod_info (getOccName parent) -> False + _ -> True + ) + let contents = + vcat $ + [ pprTyThing ss thing $$ extras + | thing <- things + , let ss = mkShowSub mod_info + , let extras = case thing of + ATyCon tycon + | Just cls <- tyConClass_maybe tycon -> + nest 2 (text "{-# MINIMAL" <+> ppr (classMinimalDef cls) <+> text "#-}") + _ -> empty + ] + pure $ withUserStyle name_ppr_ctx AllTheWay $ hang (modHeader moduleName) 2 contents <> text "" reportInstances :: Ghc SDoc reportInstances = do @@ -154,3 +213,36 @@ compareInstances inst1 inst2 = where (_, cls1, _tys1) = instanceHead inst1 (_, cls2, _tys2) = instanceHead inst2 + +modHeader :: ModuleName -> SDoc +modHeader moduleName = + vcat + [ text "" + , text "module" <+> ppr moduleName <+> text "where" + , text "" + ] + +isVisible :: Docs -> Bool +isVisible moduleDocs = + let mModuleHeader = moduleDocs.docs_mod_hdr + in case mModuleHeader of + Nothing -> False + Just hsDoc -> + let chunks = unLoc <$> docStringChunks hsDoc.hsDocString + fields' = fmap (\(HsDocStringChunk bs) -> TE.decodeUtf8 bs) chunks + fields = + fields' + & filter (not . Text.null) + & fmap parseField + & Maybe.catMaybes + in List.elem ("visibility", "public") fields + +parseField :: Text -> Maybe (Text, Text) +parseField source = + let pairs = source & Text.splitOn ":" + in case pairs of + (x : y : _) -> Just (transformField x, transformField y) + _ -> Nothing + +transformField :: Text -> Text +transformField = Text.toLower . Text.strip diff --git a/src/PrintApi/CLI/Types.hs b/src/PrintApi/CLI/Types.hs index 89966be..eabfc86 100644 --- a/src/PrintApi/CLI/Types.hs +++ b/src/PrintApi/CLI/Types.hs @@ -1,28 +1,36 @@ -{-# LANGUAGE CPP #-} - +-- | +-- Module : PrintApi.CLI.Types +-- Copyright : © Hécate, 2024 +-- License : MIT +-- Maintainer : hecate@glitchbra.in +-- Visibility : Public +-- +-- The option parsing for the CLI module PrintApi.CLI.Types ( Options (..) + , RunMode (..) , parseOptions - , runOptions , withInfo ) where -import Data.ByteString.Lazy.Char8 qualified as ByteString -import Data.List.Extra qualified as List import Data.Version (showVersion) import Options.Applicative import System.OsPath (OsPath) import System.OsPath qualified as OsPath import Paths_print_api qualified -import PrintApi.CLI.Cmd.Dump (run) -import PrintApi.Utils data Options = Options { packageName :: String - , moduleIgnoreList :: Maybe OsPath + , ignoreList :: Maybe OsPath + , haddockMetadata :: Bool } - deriving stock (Show, Eq) + deriving stock (Show, Ord, Eq) + +data RunMode + = IgnoreList OsPath + | HaddockMetadata + deriving stock (Show, Ord, Eq) parseOptions :: Parser Options parseOptions = @@ -32,13 +40,7 @@ parseOptions = (long "package-name" <> short 'p' <> metavar "PACKAGE NAME" <> help "Name of the package") <*> optional (option osPathOption (long "modules-ignore-list" <> metavar "FILE" <> help "Read the file for a list of ignored modules (one per line)")) - -runOptions - :: Options - -> IO () -runOptions (Options packageName mModuleIgnoreList) = do - stdOut <- readCabalizedProcess (Just TOOL_VERSION_ghc) "ghc" ["--print-libdir"] - run (List.trimEnd $ ByteString.unpack stdOut) mModuleIgnoreList packageName + <*> switch (long "public-only") withInfo :: Parser a -> String -> ParserInfo a withInfo opts desc = diff --git a/test/IgnoreList.hs b/test/IgnoreList.hs index 396e54c..4723c76 100644 --- a/test/IgnoreList.hs +++ b/test/IgnoreList.hs @@ -48,7 +48,7 @@ generateVectorAPIWithIgnoreList = do ignoreListFilePath <- liftIO $ OsPath.decodeUtf ignoreListPath modules <- lines <$> liftIO (System.readFile ignoreListFilePath) let ignoredModules = List.map mkModuleName modules - actualAPI <- liftIO $ Dump.computePackageAPI (List.trimEnd $ C8.unpack stdOut) ignoredModules "vector" + actualAPI <- liftIO $ Dump.computePackageAPI False (List.trimEnd $ C8.unpack stdOut) ignoredModules "vector" actualApiPath <- liftIO $ Directory.makeAbsolute "../print-api/test/golden/vector-actual-api.txt" liftIO $ System.writeFile actualApiPath actualAPI liftIO $ ByteString.readFile actualApiPath