Add test for expected dependencies of 'Parser'

2 files changed, 65 insertions, 0 deletions

diff --git a/testsuite/tests/parser/should_run/CountParserDeps.hs b/testsuite/tests/parser/should_run/CountParserDeps.hs
new file mode 100644
index 0000000000..d0de0b9e11
--- /dev/null
+++ b/testsuite/tests/parser/should_run/CountParserDeps.hs
@@ -0,0 +1,61 @@
+module Main(main) where
+
+-- Calculate the number of module dependencies of 'Parser.' If that
+-- number exceeds a threshold, that indicates that the dependencies
+-- have significantly gone up via the commit under test (and the test
+-- is deemed to fail). In that case, this most likely means a cycle
+-- has arisen that pulls in modules for Core generation. The
+-- motivation for not allowing that to happen is so that the
+-- 'ghc-lib-parser' package subset of the GHC API can continue to be
+-- provided with as small a number of modules as possible for when the
+-- need exists to produce ASTs and nothing more.
+
+import HscTypes
+import Module
+import DynFlags
+import HscMain
+import GHC
+import Util
+import Data.Maybe
+import Data.List
+import Control.Monad
+import Control.Monad.IO.Class
+import System.Environment
+import System.Exit
+import UniqSet
+
+main :: IO ()
+main = do
+  [libdir] <- getArgs
+  modules <- parserDeps libdir
+  let num = sizeUniqSet modules
+  unless (num < 160) $ exitWith (ExitFailure num)
+
+parserDeps :: FilePath -> IO (UniqSet ModuleName)
+parserDeps libdir =
+  defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+    runGhc (Just libdir) $ do
+        df <- getSessionDynFlags
+        (df, _, _) <- parseDynamicFlags df [noLoc "-package=ghc"]
+        setSessionDynFlags df
+        env <- getSession
+        loop env emptyUniqSet [mkModuleName "Parser"]
+  where
+    -- Source imports are only guaranteed to show up in the 'mi_deps'
+    -- of modules that import them directly and don’t propagate
+    -- transitively so we loop.
+    loop :: HscEnv -> UniqSet ModuleName -> [ModuleName] -> Ghc (UniqSet ModuleName)
+    loop env modules (m : ms) =
+      if m `elementOfUniqSet` modules
+        then loop env modules ms
+        else do
+          modules <- return (addOneToUniqSet modules m)
+          mi <- liftIO $ hscGetModuleInterface env (mkModule m)
+          loop env modules (ms ++ filter (not . (`elementOfUniqSet` modules)) (modDeps mi))
+    loop _ modules [] = return modules
+
+    mkModule :: ModuleName -> Module
+    mkModule = Module (stringToUnitId "ghc")
+
+    modDeps :: ModIface -> [ModuleName]
+    modDeps mi = map fst $ dep_mods (mi_deps mi)
diff --git a/testsuite/tests/parser/should_run/all.T b/testsuite/tests/parser/should_run/all.T
index 0c9e65fd14..fa639de734 100644
--- a/testsuite/tests/parser/should_run/all.T
+++ b/testsuite/tests/parser/should_run/all.T
@@ -14,3 +14,7 @@ test('NegativeZero', normal, compile_and_run, [''])
 test('HexFloatLiterals', normal, compile_and_run, [''])
 test('NumericUnderscores0', normal, compile_and_run, [''])
 test('NumericUnderscores1', normal, compile_and_run, [''])
+test('CountParserDeps',
+     [ only_ways(['normal']), extra_run_opts('"' + config.libdir + '"') ],
+     compile_and_run,
+     ['-package ghc'])