blob: d064431ec49a3caf153bba24978044dd922f6fbf (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
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
import System.FilePath
import System.IO
usage :: String
usage = unlines
[ "usage: check-ppr (libdir) (file)"
, ""
, "where libdir is the GHC library directory (e.g. the output of"
, "ghc --print-libdir) and file is the file to parse."
]
main :: IO()
main = do
args <- getArgs
case args of
[libdir,fileName] -> testOneFile libdir fileName
_ -> putStrLn usage
-- | N.B. It's important that we write our output as binary lest Windows will
-- change our LF line endings to CRLF, which will show up in the AST when we
-- re-parse.
writeBinFile :: FilePath -> String -> IO()
writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 >> hPutStr h x)
testOneFile :: FilePath -> String -> IO ()
testOneFile libdir fileName = do
p <- parseOneFile libdir fileName
let
origAst = showPprUnsafe
$ showAstData BlankSrcSpan BlankEpAnnotations
$ eraseLayoutInfo (pm_parsed_source p)
pped = pragmas ++ "\n" ++ pp (pm_parsed_source p)
pragmas = getPragmas (pm_parsed_source p)
newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
astFile = fileName <.> "ast"
newAstFile = fileName <.> "ast.new"
writeBinFile astFile origAst
writeBinFile newFile pped
p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = showPprUnsafe
$ showAstData BlankSrcSpan BlankEpAnnotations
$ eraseLayoutInfo (pm_parsed_source p')
writeBinFile newAstFile newAstStr
if origAst == newAstStr
then do
-- putStrLn "ASTs matched"
exitSuccess
else do
putStrLn "ppr AST Match Failed"
putStrLn "\n===================================\nOrig\n\n"
putStrLn origAst
putStrLn "\n===================================\nNew\n\n"
putStrLn newAstStr
exitFailure
parseOneFile :: FilePath -> FilePath -> IO ParsedModule
parseOneFile libdir fileName = do
runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
_ <- setSessionDynFlags dflags2
hsc_env <- getSession
ms <- liftIO $ summariseFile hsc_env [] fileName Nothing Nothing
case ms of
Left _err -> error "parseOneFile"
Right ems -> parseModule (emsModSummary ems)
getPragmas :: Located HsModule -> String
getPragmas (L _ (HsModule { hsmodAnn = anns'})) = pragmaStr
where
tokComment (L _ (EpaComment (EpaBlockComment s) _)) = s
tokComment (L _ (EpaComment (EpaLineComment s) _)) = s
tokComment _ = ""
cmp (L l1 _) (L l2 _) = compare (anchor l1) (anchor l2)
comments' = map tokComment $ sortBy cmp $ priorComments $ epAnnComments anns'
pragmas = filter (\c -> isPrefixOf "{-#" c ) comments'
pragmaStr = intercalate "\n" pragmas
pp :: (Outputable a) => a -> String
pp a = showPprUnsafe a
eraseLayoutInfo :: ParsedSource -> ParsedSource
eraseLayoutInfo = everywhere go
where
go :: forall a. Typeable a => a -> a
go x =
case eqT @a @LayoutInfo of
Nothing -> x
Just Refl -> NoLayoutInfo
-- ---------------------------------------------------------------------
-- Copied from syb for the test
everywhere :: (forall a. Data a => a -> a)
-> (forall a. Data a => a -> a)
everywhere f = go
where
go :: forall a. Data a => a -> a
go = f . gmapT go
|
