blob: 29505817b6feff413aa597c7c40f2da413ffba5c (
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 (sortBy, intercalate, isPrefixOf)
import Data.Data
import Control.Monad.IO.Class
import GHC.Types.SrcLoc
import GHC hiding (moduleName)
import GHC.Hs.Dump
import GHC.Driver.Env
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Driver.Make
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
mms <- liftIO $ summariseFile hsc_env (hsc_home_unit hsc_env) mempty fileName Nothing Nothing
case mms of
Left _err -> error "parseOneFile"
Right ms -> parseModule ms
getPragmas :: Located (HsModule GhcPs) -> String
getPragmas (L _ (HsModule { hsmodExt = XModulePs { 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 GhcPs) 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
|
