blob: 0559e20f100ebc309fc5fc635ca377188ea4e473 (
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
127
|
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
import Data.List
import Data.Data
import GHC.Types.SrcLoc
import GHC hiding (moduleName)
import GHC.Hs.Dump
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Utils.Outputable hiding (space)
import System.Environment( getArgs )
import System.Exit
import System.FilePath
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
testOneFile :: FilePath -> String -> IO ()
testOneFile libdir fileName = do
p <- parseOneFile libdir fileName
let
origAst = showPprUnsafe
$ showAstData BlankSrcSpan BlankApiAnnotations
$ eraseLayoutInfo (pm_parsed_source p)
pped = pragmas ++ "\n" ++ pp (pm_parsed_source p)
anns' = pm_annotations p
pragmas = getPragmas anns'
newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
astFile = fileName <.> "ast"
newAstFile = fileName <.> "ast.new"
writeFile astFile origAst
writeFile newFile pped
p' <- parseOneFile libdir newFile
let newAstStr :: String
newAstStr = showPprUnsafe
$ showAstData BlankSrcSpan BlankApiAnnotations
$ eraseLayoutInfo (pm_parsed_source p')
writeFile 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
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
, 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
getPragmas :: ApiAnns -> String
getPragmas anns' = pragmaStr
where
tokComment (L _ (AnnComment (AnnBlockComment s) _)) = s
tokComment (L _ (AnnComment (AnnLineComment s) _)) = s
tokComment _ = ""
cmp (L l1 _) (L l2 _) = compare (anchor l1) (anchor l2)
comments' = map tokComment $ sortBy cmp $ apiAnnRogueComments 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
|