Implement user-supplied ignore list of modules

.github/workflows/ci.yml

@@ -20,7 +20,7 @@ jobs:
           ubuntu-version: 'latest'
           macos-version: 'latest'
           version: 0.1.7.1
-  tests:
+  builds:
     name: ${{ matrix.ghc }} on ${{ matrix.os }}
     needs: generate-matrix
     runs-on: ${{ matrix.os }}
@@ -122,15 +122,21 @@ jobs:
       - name: Build
         run: cabal build --project-file=cabal.static.project
 
-      - name: Test
-        run: cabal test --project-file=cabal.static.project all
-
       - name: Install
         run: |
           bin=$(cabal -v0 --project-file=cabal.static.project list-bin print-api)
           mkdir distribution
           cp ${bin} distribution/print-api
 
+      - 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/print-api
 
@@ -153,7 +159,7 @@ jobs:
   prerelease-head:
     name: Create a GitHub prerelease with the binary artifacts
     runs-on: ubuntu-latest
-    needs: ['tests', 'build-alpine']
+    needs: ['builds', 'build-alpine']
 
     steps:
     - uses: actions/download-artifact@v3

.gitignore

@@ -4,3 +4,4 @@ tags.mtime
 .hpc
 *.tix
 *.local
+servant-client-actual-api.txt

CHANGELOG.md

@@ -0,0 +1,3 @@
+## 0.1.1.0
+
+* Add support for user-supplied ignore lists of modules ([#18](https://github.com/Kleidukos/print-api/pull/18))

Makefile

@@ -2,7 +2,7 @@ deps: ## Install the dependencies of the backend
 	@cabal build --only-dependencies
 
 build: ## Build the project in fast mode
-	@cabal build
+	@cabal build -j
 
 clean: ## Remove compilation artifacts
 	@cabal clean
@@ -11,7 +11,7 @@ repl: ## Start a REPL
 	@cabal repl
 
 test: ## Run the test suite
-	@cabal test
+	@cabal test -j
 
 lint: ## Run the code linter (HLint)
 	@find app src compat -name "*.hs" | xargs -P $(PROCS) -I {} hlint --refactor-options="-i" --refactor {}

cabal.project

@@ -1 +1,23 @@
 packages: ./
+
+tests: True
+
+allow-newer:
+    tasty-test-reporter:mtl
+  , tasty-test-reporter:ansi-terminal
+  , tasty-test-reporter:text
+  , tasty-test-reporter:tasty
+  , tasty-test-reporter:containers
+  , tasty-test-reporter:filepath
+  , tasty-test-reporter:base
+
+allow-newer:
+  , tasty-coverage:text
+  , tasty-coverage:containers
+  , tasty-coverage:filepath
+  , tasty-coverage:base
+
+source-repository-package
+  type: git
+  location: https://github.com/goodlyrottenapple/tasty-test-reporter 
+  tag: b704130

print-api.cabal

@@ -68,6 +68,7 @@ library
     , base
     , bytestring
     , extra
+    , filepath
     , ghc
     , ghc-boot
     , ghc-paths
@@ -76,16 +77,40 @@ library
     , typed-process
 
 executable print-api
-  import:           extensions
-  import:           ghc-options
-  import:           rts-options
-  hs-source-dirs:   app
-  main-is:          Main.hs
+  import:         extensions
+  import:         ghc-options
+  import:         rts-options
+  hs-source-dirs: app
+  main-is:        Main.hs
   build-depends:
     , base
     , ghc
     , ghc-paths
     , optparse-applicative
     , print-api
 
-  default-language: Haskell2010
+test-suite print-api-test
+  import:         extensions
+  import:         ghc-options
+  import:         rts-options
+  type:           exitcode-stdio-1.0
+  hs-source-dirs: test
+  main-is:        Main.hs
+  other-modules:
+    IgnoreList
+    Utils
+
+  build-depends:
+    , base
+    , bytestring
+    , directory
+    , extra
+    , filepath
+    , ghc
+    , print-api
+    , tasty
+    , tasty-coverage
+    , tasty-golden
+    , tasty-hunit
+    , tasty-test-reporter
+    , typed-process

src/PrintApi/CLI/Cmd/Dump.hs

@@ -2,8 +2,10 @@ module PrintApi.CLI.Cmd.Dump where
 
 import Control.Monad.IO.Class
 import Data.Function (on)
-import Data.List (sortBy)
+import Data.List qualified as List
+import Data.List.Extra qualified as List
 import GHC
+import GHC.Compat
 import GHC.Core.Class (classMinimalDef)
 import GHC.Core.InstEnv (instEnvElts, instanceHead)
 import GHC.Data.FastString (fsLit)
@@ -17,16 +19,34 @@ import GHC.Unit.Info (PackageName (..), UnitInfo, unitExposedModules, unitId)
 import GHC.Unit.State (lookupPackageName, lookupUnitId)
 import GHC.Unit.Types (UnitId)
 import GHC.Utils.Outputable
+import System.IO qualified as System
+import System.OsPath (OsPath)
+import System.OsPath qualified as OsPath
 import Prelude hiding ((<>))
 
-import GHC.Compat
 import PrintApi.IgnoredDeclarations
 
 run
   :: FilePath
+  -> Maybe OsPath
   -> String
   -> IO ()
-run root packageName = runGhc (Just root) $ do
+run root mModuleIgnoreList packageName = do
+  userIgnoredModules <- case mModuleIgnoreList of
+    Nothing -> pure []
+    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
+
+computePackageAPI
+  :: FilePath
+  -> [ModuleName]
+  -> String
+  -> IO String
+computePackageAPI root userIgnoredModules packageName = runGhc (Just root) $ do
   let args :: [Located String] =
         map
           noLoc
@@ -51,25 +71,24 @@ run root packageName = runGhc (Just root) $ do
     Just unit_info -> pure unit_info
     Nothing -> fail "unknown package"
 
-  decls_doc <- reportUnitDecls unit_info
+  decls_doc <- reportUnitDecls userIgnoredModules 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
+  pure $ List.trim $ showSDocForUser dflags unit_state name_ppr_ctx (vcat [decls_doc, insts_doc])
 
 ignoredTyThing :: TyThing -> Bool
 ignoredTyThing _ = False
 
-reportUnitDecls :: UnitInfo -> Ghc SDoc
-reportUnitDecls unit_info = do
+reportUnitDecls :: [ModuleName] -> UnitInfo -> Ghc SDoc
+reportUnitDecls userIgnoredModules unit_info = do
   let exposed :: [ModuleName]
       exposed = map fst (unitExposedModules unit_info)
-  vcat <$> mapM (reportModuleDecls $ unitId unit_info) exposed
+  vcat <$> mapM (reportModuleDecls userIgnoredModules $ unitId unit_info) exposed
 
-reportModuleDecls :: UnitId -> ModuleName -> Ghc SDoc
-reportModuleDecls unit_id modl_nm
-  | modl_nm `elem` ignoredModules = do
+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 ""]
   | otherwise = do
       modl <- GHC.lookupQualifiedModule (OtherPkg unit_id) modl_nm
@@ -80,7 +99,7 @@ reportModuleDecls unit_id modl_nm
 
       Just name_ppr_ctx <- mkNamePprCtxForModule mod_info
       let names = GHC.modInfoExports mod_info
-      let sorted_names = sortBy (compare `on` nameOccName) names
+      let sorted_names = List.sortBy (compare `on` nameOccName) names
       things <- mapM GHC.lookupName sorted_names
       let contents =
             vcat $
@@ -123,7 +142,7 @@ reportInstances = do
       , text "-- Instances:"
       ]
         ++ [ ppr inst
-           | inst <- sortBy compareInstances (instEnvElts instances)
+           | inst <- List.sortBy compareInstances (instEnvElts instances)
            , not $ ignoredInstance inst
            ]
 

src/PrintApi/CLI/Types.hs

@@ -4,13 +4,17 @@ import Data.ByteString.Lazy.Char8 qualified as ByteString
 import Data.List.Extra qualified as List
 import Data.Version (showVersion)
 import Options.Applicative
-import Paths_print_api (version)
-import PrintApi.CLI.Cmd.Dump (run)
+import System.OsPath (OsPath)
+import System.OsPath qualified as OsPath
 import System.Process.Typed (ExitCode (..))
 import System.Process.Typed qualified as Process
 
+import Paths_print_api (version)
+import PrintApi.CLI.Cmd.Dump (run)
+
 data Options = Options
   { packageName :: String
+  , moduleIgnoreList :: Maybe OsPath
   }
   deriving stock (Show, Eq)
 
@@ -20,15 +24,17 @@ parseOptions =
     <$> option
       str
       (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) = do
+runOptions (Options packageName mModuleIgnoreList) = do
   (exitCode, stdOut, stdErr) <- Process.readProcess $ Process.shell "cabal exec -v0 -- ghc --print-libdir"
   case exitCode of
     ExitSuccess ->
-      run (List.trimEnd $ ByteString.unpack stdOut) packageName
+      run (List.trimEnd $ ByteString.unpack stdOut) mModuleIgnoreList packageName
     ExitFailure int -> do
       putStrLn $ "`cabal exec -v0 -- ghc --print-libdir` exited with error code " <> show int
       error $ ByteString.unpack stdErr
@@ -41,3 +47,6 @@ withInfo opts desc =
         <*> opts
     )
     $ progDesc desc
+
+osPathOption :: ReadM OsPath
+osPathOption = maybeReader OsPath.encodeUtf

src/PrintApi/IgnoredDeclarations.hs

@@ -9,6 +9,7 @@ module PrintApi.IgnoredDeclarations
   ) where
 
 import Data.List (isPrefixOf)
+import Data.List qualified as List
 import GHC (ModuleInfo, modInfoExports)
 import GHC.Core.InstEnv (ClsInst, instanceHead)
 import GHC.Core.TyCon (TyCon)
@@ -96,7 +97,7 @@ ignoredType = any ignoredTyCon . nonDetEltsUniqSet . tyConsOfType
 
 ignoredModules :: [ModuleName]
 ignoredModules =
-  map
+  List.map
     mkModuleName
     (unstableModules ++ platformDependentModules)
   where

test/IgnoreList.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE QuasiQuotes #-}
+module IgnoreList where
+
+import Control.Monad.IO.Class
+import Data.ByteString.Lazy (LazyByteString)
+import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.List.Extra qualified as List
+import Language.Haskell.Syntax.Module.Name (mkModuleName)
+import System.Process.Typed qualified as Process
+import Test.Tasty
+import System.OsPath
+import Test.Tasty.Golden
+import Utils
+import qualified Data.ByteString.Lazy as ByteString
+import qualified System.Directory as Directory 
+
+import qualified PrintApi.CLI.Cmd.Dump as Dump
+import qualified System.Directory.OsPath as OsPath
+import qualified System.IO as System
+import qualified System.OsPath as OsPath
+
+diffCmd :: String -> String -> [String]
+diffCmd ref new = ["diff", "-u", ref, new]
+
+spec :: TestTree
+spec = testGroup "Ignore list"
+  [ goldenVsStringDiff
+        "User-supplied ignore list"
+        diffCmd
+        "test/golden/servant-client-expected-api.txt"
+        generateServantClientAPIWithIgnoreList
+  ]
+
+generateServantClientAPIWithIgnoreList :: (MonadIO m) => m LazyByteString
+generateServantClientAPIWithIgnoreList = do
+  (exitCode, stdOut, _stdErr) <- Process.readProcess $ Process.shell "cabal exec -v0 -- ghc --print-libdir"
+  assertExitSuccess "`cabal exec -v0 -- ghc --print-libdir`" exitCode
+  assertExitSuccess "Fetch the archive of servant-client" =<< Process.runProcess (Process.shell "cabal get servant-client-0.20 --destdir=../")
+  liftIO $ Directory.setCurrentDirectory "../servant-client-0.20"
+  let buildServantClient = Process.shell "cabal build -j --allow-newer --write-ghc-environment-files=always"
+  assertExitSuccess "Build servant-client" =<< Process.runProcess buildServantClient
+  ignoreListPath <- liftIO $ OsPath.makeAbsolute [osp|../print-api/test/golden/servant-client-ignore-list.txt|]
+  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 "servant-client"
+  actualApiPath <- liftIO $ Directory.makeAbsolute "../print-api/test/golden/servant-client-actual-api.txt"
+  liftIO $ System.writeFile actualApiPath actualAPI
+  liftIO $ ByteString.readFile actualApiPath

test/Main.hs

@@ -0,0 +1,20 @@
+module Main (main) where
+
+import System.IO
+import Test.Tasty
+import Test.Tasty.Runners.Reporter qualified as Reporter
+
+import IgnoreList qualified
+
+main :: IO ()
+main = do
+  hSetBuffering stdout LineBuffering
+  defaultMainWithIngredients
+    [Reporter.ingredient]
+    $ testGroup
+      "print-api tests"
+      specs
+
+specs :: [TestTree]
+specs =
+  [ IgnoreList.spec ]

test/Utils.hs

@@ -0,0 +1,9 @@
+module Utils where
+
+import Test.Tasty.HUnit
+import System.Process.Typed
+import Control.Monad.IO.Class
+
+assertExitSuccess :: (MonadIO m) => String -> ExitCode -> m ()
+assertExitSuccess _ ExitSuccess = pure ()
+assertExitSuccess desc (ExitFailure n) = liftIO $ assertFailure $ desc <> ": Unexpected process failure (exit code " <> show n <> ")"