check-{ppr/exact}: Rewrite more directly to just parse fileswip/check-exact-cleanup

There was quite a large amount of indirection in these tests, so I have
rewritten them to just directly parse the files rather than making a
module graph and entering other twisty packages.

11 files changed, 34 insertions, 265 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 44e09a23ba..0d515a61f6 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1584,25 +1584,26 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
 -- on whether the module is interpreted or not.
 
 
--- Extract the filename, stringbuffer content and dynflags associed to a module
+-- Extract the filename, stringbuffer content and dynflags associed to a ModSummary
+-- Given an initialised GHC session a ModSummary can be retrieved for
+-- a module by using 'getModSummary'
 --
 -- XXX: Explain pre-conditions
-getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)
-getModuleSourceAndFlags mod = do
-  m <- getModSummary (moduleName mod)
+getModuleSourceAndFlags :: ModSummary -> IO (String, StringBuffer, DynFlags)
+getModuleSourceAndFlags m = do
   case ml_hs_file $ ms_location m of
-    Nothing -> do dflags <- getDynFlags
-                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)
+    Nothing -> throwIO $ mkApiErr (ms_hspp_opts m) (text "No source available for module " <+> ppr (ms_mod m))
     Just sourceFile -> do
-        source <- liftIO $ hGetStringBuffer sourceFile
+        source <- hGetStringBuffer sourceFile
         return (sourceFile, source, ms_hspp_opts m)
 
 
 -- | Return module source as token stream, including comments.
 --
--- The module must be in the module graph and its source must be available.
+-- A 'Module' can be turned into a 'ModSummary' using 'getModSummary' if
+-- your session is fully initialised.
 -- Throws a 'GHC.Driver.Env.SourceError' on parse error.
-getTokenStream :: GhcMonad m => Module -> m [Located Token]
+getTokenStream :: ModSummary -> IO [Located Token]
 getTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
@@ -1613,7 +1614,7 @@ getTokenStream mod = do
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
 -- 'showRichTokenStream'.
-getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]
+getRichTokenStream :: ModSummary -> IO [(Located Token, String)]
 getRichTokenStream mod = do
   (sourceFile, source, dflags) <- getModuleSourceAndFlags mod
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index f153e96e37..ee0835cdd7 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -28,6 +28,7 @@ module GHC.Driver.Make (
         ms_home_srcimps, ms_home_imps,
 
         summariseModule,
+        summariseFile,
         hscSourceToIsBoot,
         findExtraSigImports,
         implicitRequirementsShallow,
diff --git a/testsuite/tests/ghc-api/annotations-literals/literals.hs b/testsuite/tests/ghc-api/annotations-literals/literals.hs
index e2c21b5269..296cefa551 100644
--- a/testsuite/tests/ghc-api/annotations-literals/literals.hs
+++ b/testsuite/tests/ghc-api/annotations-literals/literals.hs
@@ -16,6 +16,7 @@ import System.Directory (removeFile)
 import System.Environment( getArgs )
 import qualified Data.Map as Map
 import Data.Dynamic ( fromDynamic,Dynamic )
+import Control.Monad.IO.Class
 
 main::IO()
 main = do
@@ -33,7 +34,7 @@ testOneFile libdir fileName = do
                          , targetContents = Nothing }
         load LoadAllTargets
         modSum <- getModSummary mn
-        toks <- getRichTokenStream (ms_mod modSum)
+        toks <- liftIO $ getRichTokenStream modSum
         return toks
 
     putStrLn (intercalate "\n" [showToks t])
diff --git a/testsuite/tests/printer/T13199.stdout b/testsuite/tests/printer/T13199.stdout
deleted file mode 100644
index b1cb7c384f..0000000000
--- a/testsuite/tests/printer/T13199.stdout
+++ /dev/null
@@ -1,72 +0,0 @@
-T13199.hs:(14,2)-(15,7): Splicing declarations
-    [d| instance C (Maybe a) (Maybe b) c |]
-  ======>
-    instance C (Maybe a) (Maybe b) c
-T13199.hs:21:2-45: Splicing declarations
-    [d| g (a :: (Int -> Int) -> Int) = True |]
-  ======>
-    g (a :: (Int -> Int) -> Int) = True
-T13199.hs:24:2-28: Splicing declarations
-    [d| h (id -> x) = True |] ======> h (id -> x) = True
-T13199.hs:27:2-38: Splicing declarations
-    [d| f (Just (Just False)) = True |]
-  ======>
-    f (Just (Just False)) = True
-T13199.hs:30:2-34: Splicing declarations
-    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
-T13199.hs:33:2-30: Splicing declarations
-    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
-T13199.hs:36:2-29: Splicing declarations
-    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
-T13199.hs:38:2-59: Splicing declarations
-    [d| l = case Just 'a' of Just a -> Just ((\ x -> x) a) |]
-  ======>
-    l = case Just 'a' of Just a -> Just ((\ x -> x) a)
-T13199.ppr.hs:11:2-42: Splicing declarations
-    [d| instance C (Maybe a) (Maybe b) c |]
-  ======>
-    instance C (Maybe a) (Maybe b) c
-T13199.ppr.hs:12:2-45: Splicing declarations
-    [d| g (a :: (Int -> Int) -> Int) = True |]
-  ======>
-    g (a :: (Int -> Int) -> Int) = True
-T13199.ppr.hs:13:2-28: Splicing declarations
-    [d| h (id -> x) = True |] ======> h (id -> x) = True
-T13199.ppr.hs:14:2-38: Splicing declarations
-    [d| f (Just (Just False)) = True |]
-  ======>
-    f (Just (Just False)) = True
-T13199.ppr.hs:15:2-34: Splicing declarations
-    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
-T13199.ppr.hs:16:2-29: Splicing declarations
-    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
-T13199.ppr.hs:17:2-29: Splicing declarations
-    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
-T13199.ppr.hs:18:2-60: Splicing declarations
-    [d| l = case Just 'a' of Just a -> Just ((\ x -> x) a) |]
-  ======>
-    l = case Just 'a' of Just a -> Just ((\ x -> x) a)
-T13199.ppr.hs:(14,2)-(15,7): Splicing declarations
-    [d| instance C (Maybe a) (Maybe b) c |]
-  ======>
-    instance C (Maybe a) (Maybe b) c
-T13199.ppr.hs:21:2-45: Splicing declarations
-    [d| g (a :: (Int -> Int) -> Int) = True |]
-  ======>
-    g (a :: (Int -> Int) -> Int) = True
-T13199.ppr.hs:24:2-28: Splicing declarations
-    [d| h (id -> x) = True |] ======> h (id -> x) = True
-T13199.ppr.hs:27:2-38: Splicing declarations
-    [d| f (Just (Just False)) = True |]
-  ======>
-    f (Just (Just False)) = True
-T13199.ppr.hs:30:2-34: Splicing declarations
-    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
-T13199.ppr.hs:33:2-30: Splicing declarations
-    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
-T13199.ppr.hs:36:2-29: Splicing declarations
-    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
-T13199.ppr.hs:38:2-59: Splicing declarations
-    [d| l = case Just 'a' of Just a -> Just ((\ x -> x) a) |]
-  ======>
-    l = case Just 'a' of Just a -> Just ((\ x -> x) a)
diff --git a/testsuite/tests/printer/T13550.stdout b/testsuite/tests/printer/T13550.stdout
deleted file mode 100644
index b3173f8612..0000000000
--- a/testsuite/tests/printer/T13550.stdout
+++ /dev/null
@@ -1,33 +0,0 @@
-T13550.hs:(6,2)-(11,7): Splicing declarations
-    [d| type family Foo a b
-        data family Bar a b
-        
-        type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
-        data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |]
-  ======>
-    type family Foo a b
-    type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
-    data family Bar a b
-    data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
-T13550.ppr.hs:(5,2)-(8,70): Splicing declarations
-    [d| type family Foo a b
-        data family Bar a b
-        
-        type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
-        data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |]
-  ======>
-    type family Foo a b
-    type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
-    data family Bar a b
-    data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
-T13550.ppr.hs:(6,2)-(11,7): Splicing declarations
-    [d| type family Foo a b
-        data family Bar a b
-        
-        type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
-        data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b) |]
-  ======>
-    type family Foo a b
-    type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)
-    data family Bar a b
-    data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
diff --git a/testsuite/tests/printer/T13942.stdout b/testsuite/tests/printer/T13942.stdout
deleted file mode 100644
index 8c80afa15f..0000000000
--- a/testsuite/tests/printer/T13942.stdout
+++ /dev/null
@@ -1,18 +0,0 @@
-T13942.hs:(5,2)-(7,7): Splicing declarations
-    [d| f :: Either Int (Int -> Int)
-        f = undefined |]
-  ======>
-    f :: Either Int (Int -> Int)
-    f = undefined
-T13942.ppr.hs:(4,2)-(5,23): Splicing declarations
-    [d| f :: Either Int (Int -> Int)
-        f = undefined |]
-  ======>
-    f :: Either Int (Int -> Int)
-    f = undefined
-T13942.ppr.hs:(5,2)-(7,7): Splicing declarations
-    [d| f :: Either Int (Int -> Int)
-        f = undefined |]
-  ======>
-    f :: Either Int (Int -> Int)
-    f = undefined
diff --git a/testsuite/tests/printer/T14289.stdout b/testsuite/tests/printer/T14289.stdout
deleted file mode 100644
index ab7eb04a84..0000000000
--- a/testsuite/tests/printer/T14289.stdout
+++ /dev/null
@@ -1,32 +0,0 @@
-T14289.hs:10:2-43: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (C a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C a)
-T14289.ppr.hs:(7,2)-(9,26): Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (C a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C a)
-T14289.hs:10:2-43: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (C a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C a)
-T14289.ppr.hs:10:2-43: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (C a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C a)
diff --git a/testsuite/tests/printer/T14289b.stdout b/testsuite/tests/printer/T14289b.stdout
deleted file mode 100644
index e3d163aa86..0000000000
--- a/testsuite/tests/printer/T14289b.stdout
+++ /dev/null
@@ -1,32 +0,0 @@
-T14289b.hs:11:2-47: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (y `C` z) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C y z)
-T14289b.ppr.hs:(8,2)-(10,30): Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (y `C` z) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C y z)
-T14289b.hs:11:2-47: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (y `C` z) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C y z)
-T14289b.ppr.hs:11:2-47: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (y `C` z) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (C y z)
diff --git a/testsuite/tests/printer/T14289c.stdout b/testsuite/tests/printer/T14289c.stdout
deleted file mode 100644
index 66704d3402..0000000000
--- a/testsuite/tests/printer/T14289c.stdout
+++ /dev/null
@@ -1,32 +0,0 @@
-T14289c.hs:9:2-45: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (a ~ a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (a ~ a)
-T14289c.ppr.hs:(7,2)-(9,28): Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (a ~ a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (a ~ a)
-T14289c.hs:9:2-45: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (a ~ a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (a ~ a)
-T14289c.ppr.hs:9:2-45: Splicing declarations
-    [d| data Foo a
-          = Foo a
-          deriving (a ~ a) |]
-  ======>
-    data Foo a
-      = Foo a
-      deriving (a ~ a)
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index d0971dac65..04ec500e8b 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -10,9 +10,12 @@ import Data.List (intercalate)
 import Data.Data
 import GHC.Types.Name.Occurrence
 import GHC.Types.Name.Reader
+import GHC.Unit.Module.ModSummary
+import Control.Monad.IO.Class
 import GHC hiding (moduleName)
 import GHC.Driver.Ppr
 import GHC.Driver.Session
+import GHC.Driver.Make
 import GHC.Hs.Dump
 import GHC.Data.Bag
 import System.Environment( getArgs )
@@ -334,29 +337,19 @@ ppAst :: Data a => a -> String
 ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast
 
 parseOneFile :: FilePath -> FilePath -> IO (ParsedModule, [Located Token])
-parseOneFile libdir fileName = do
-       let modByFile m =
-             case ml_hs_file $ ms_location m of
-               Nothing -> False
-               Just fn -> fn == fileName
+parseOneFile libdir fileName =
        runGhc (Just libdir) $ do
          dflags <- getSessionDynFlags
          let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
          _ <- setSessionDynFlags dflags2
-         addTarget Target { targetId = TargetFile fileName Nothing
-                          , targetUnitId = homeUnitId_ dflags
-                          , targetAllowObjCode = True
-                          , targetContents = Nothing }
-         _ <- load LoadAllTargets
-         graph <- getModuleGraph
-         let
-           modSum = case filter modByFile (mgModSummaries graph) of
-                     [x] -> x
-                     xs -> error $ "Can't find module, got:"
-                              ++ show (map (ml_hs_file . ms_location) xs)
-         pm <- GHC.parseModule modSum
-         toks <- getTokenStream (ms_mod modSum)
-         return (pm, toks)
+         hsc_env <- getSession
+         emodSum <- liftIO $ summariseFile hsc_env [] fileName Nothing True Nothing
+         case emsModSummary <$> emodSum of
+           Left _err -> error "parseOneFile"
+           Right modSum -> do
+            pm <- GHC.parseModule modSum
+            toks <- liftIO $ getTokenStream modSum
+            return (pm, toks)
 
 
 -- ---------------------------------------------------------------------
diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs
index 542a35780e..80828874f6 100644
--- a/utils/check-ppr/Main.hs
+++ b/utils/check-ppr/Main.hs
@@ -5,11 +5,14 @@
 
 import Data.List
 import Data.Data
+import Control.Monad.IO.Class
 import GHC.Types.SrcLoc
 import GHC hiding (moduleName)
 import GHC.Hs.Dump
 import GHC.Driver.Session
 import GHC.Driver.Ppr
+import GHC.Driver.Make
+import GHC.Unit.Module.ModSummary
 import GHC.Utils.Outputable hiding (space)
 import System.Environment( getArgs )
 import System.Exit
@@ -77,26 +80,15 @@ testOneFile libdir fileName = do
 
 parseOneFile :: FilePath -> FilePath -> IO ParsedModule
 parseOneFile libdir fileName = do
-       let modByFile m =
-             case ml_hs_file $ ms_location m of
-               Nothing -> False
-               Just fn -> fn == fileName
        runGhc (Just libdir) $ do
          dflags <- getSessionDynFlags
          let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
          _ <- setSessionDynFlags dflags2
-         addTarget Target { targetId = TargetFile fileName Nothing
-                          , targetAllowObjCode = True
-                          , targetUnitId = homeUnitId_ dflags
-                          , targetContents = Nothing }
-         _ <- load LoadAllTargets
-         graph <- getModuleGraph
-         let
-           modSum = case filter modByFile (mgModSummaries graph) of
-                     [x] -> x
-                     xs -> error $ "Can't find module, got:"
-                              ++ show (map (ml_hs_file . ms_location) xs)
-         parseModule modSum
+         hsc_env <- getSession
+         ms <- liftIO $ summariseFile hsc_env [] fileName Nothing True Nothing
+         case ms of
+           Left _err -> error "parseOneFile"
+           Right ems -> parseModule (emsModSummary ems)
 
 getPragmas :: Located HsModule -> String
 getPragmas (L _ (HsModule { hsmodAnn = anns'})) = pragmaStr