summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC.hs21
-rw-r--r--compiler/GHC/Driver/Make.hs1
-rw-r--r--testsuite/tests/ghc-api/annotations-literals/literals.hs3
-rw-r--r--testsuite/tests/printer/T13199.stdout72
-rw-r--r--testsuite/tests/printer/T13550.stdout33
-rw-r--r--testsuite/tests/printer/T13942.stdout18
-rw-r--r--testsuite/tests/printer/T14289.stdout32
-rw-r--r--testsuite/tests/printer/T14289b.stdout32
-rw-r--r--testsuite/tests/printer/T14289c.stdout32
-rw-r--r--utils/check-exact/Main.hs31
-rw-r--r--utils/check-ppr/Main.hs24
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 e73b3fb39d..30920ced1d 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 4316f2bea0..4789f5188b 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 )
@@ -336,29 +339,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
View Lorry Controller Status