c9fac7dc33f5fb8344433ba8643f99a8530dd008
[ghc.git] / utils / check-ppr / Main.hs
1 {-# LANGUAGE ScopedTypeVariables #-}
2 {-# LANGUAGE RankNTypes #-}
3
4 import Control.Monad (when)
5 import Data.Data hiding (Fixity)
6 import Data.List
7 import Bag
8 import FastString
9 import NameSet
10 import SrcLoc
11 import HsSyn
12 import OccName hiding (occName)
13 import GHC hiding (moduleName)
14 import Var
15 import DynFlags
16 import Outputable hiding (space)
17 import System.Environment( getArgs )
18 import System.Exit
19 import System.FilePath
20
21 import qualified Data.ByteString as B
22 import qualified Data.Map as Map
23
24 usage :: String
25 usage = unlines
26 [ "usage: check-ppr [--dump] (libdir) (file)"
27 , ""
28 , "where libdir is the GHC library directory (e.g. the output of"
29 , "ghc --print-libdir) and file is the file to parse."
30 , "The --dump flag causes check-ppr to produce .new and .old files"
31 , "containing dumps of the new and old ASTs in the event of a match"
32 , "failure."
33 ]
34
35 main :: IO()
36 main = do
37 args <- getArgs
38 case args of
39 [libdir,fileName] -> testOneFile libdir fileName False
40 ["--dump", libdir,fileName] -> testOneFile libdir fileName True
41 _ -> putStrLn usage
42
43 testOneFile :: FilePath -> String -> Bool -> IO ()
44 testOneFile libdir fileName dumpOldNew = do
45 p <- parseOneFile libdir fileName
46 let
47 origAst = showAstData 0 (pm_parsed_source p)
48 pped = pragmas ++ "\n" ++ pp (pm_parsed_source p)
49 anns = pm_annotations p
50 pragmas = getPragmas anns
51
52 newFile = dropExtension fileName <.> "ppr" <.> takeExtension fileName
53 astFile = fileName <.> "ast"
54
55 writeFile astFile origAst
56 writeFile newFile pped
57
58 p' <- parseOneFile libdir newFile
59
60 let newAstStr = showAstData 0 (pm_parsed_source p')
61
62 if origAst == newAstStr
63 then do
64 -- putStrLn "ASTs matched"
65 exitSuccess
66 else do
67 putStrLn "AST Match Failed"
68 putStrLn "\n===================================\nOrig\n\n"
69 putStrLn origAst
70 putStrLn "\n===================================\nNew\n\n"
71 putStrLn newAstStr
72 when dumpOldNew $ do
73 writeFile (fileName <.> "old") origAst
74 writeFile (fileName <.> "new") newAstStr
75 exitFailure
76
77
78 parseOneFile :: FilePath -> FilePath -> IO ParsedModule
79 parseOneFile libdir fileName = do
80 let modByFile m =
81 case ml_hs_file $ ms_location m of
82 Nothing -> False
83 Just fn -> fn == fileName
84 runGhc (Just libdir) $ do
85 dflags <- getSessionDynFlags
86 let dflags2 = dflags `gopt_set` Opt_KeepRawTokenStream
87 _ <- setSessionDynFlags dflags2
88 addTarget Target { targetId = TargetFile fileName Nothing
89 , targetAllowObjCode = True
90 , targetContents = Nothing }
91 _ <- load LoadAllTargets
92 graph <- getModuleGraph
93 let
94 modSum = case filter modByFile graph of
95 [x] -> x
96 xs -> error $ "Can't find module, got:"
97 ++ show (map (ml_hs_file . ms_location) xs)
98 parseModule modSum
99
100 getPragmas :: ApiAnns -> String
101 getPragmas anns = pragmaStr
102 where
103 tokComment (L _ (AnnBlockComment s)) = s
104 tokComment (L _ (AnnLineComment s)) = s
105 tokComment _ = ""
106
107 comments = case Map.lookup noSrcSpan (snd anns) of
108 Nothing -> []
109 Just cl -> map tokComment $ sortLocated cl
110 pragmas = filter (\c -> isPrefixOf "{-#" c ) comments
111 pragmaStr = intercalate "\n" pragmas
112
113 pp :: (Outputable a) => a -> String
114 pp a = showPpr unsafeGlobalDynFlags a
115
116
117 -- | Show a GHC AST with SrcSpan's blanked out, to avoid comparing locations,
118 -- only structure
119 showAstData :: Data a => Int -> a -> String
120 showAstData n =
121 generic
122 `ext1Q` list
123 `extQ` string `extQ` fastString `extQ` srcSpan
124 `extQ` bytestring
125 `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
126 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
127 `extQ` fixity
128 `ext2Q` located
129 where generic :: Data a => a -> String
130 generic t = indent n ++ "(" ++ showConstr (toConstr t)
131 ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")"
132 space "" = ""
133 space s = ' ':s
134 indent i = "\n" ++ replicate i ' '
135 string = normalize_newlines . show :: String -> String
136 fastString = ("{FastString: "++) . (++"}") . normalize_newlines . show
137 :: FastString -> String
138 bytestring = normalize_newlines . show :: B.ByteString -> String
139 list l = indent n ++ "["
140 ++ intercalate "," (map (showAstData (n+1)) l)
141 ++ "]"
142
143 name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
144 :: Name -> String
145 occName = ("{OccName: "++) . (++"}") . OccName.occNameString
146 moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
147 :: ModuleName -> String
148
149 srcSpan :: SrcSpan -> String
150 srcSpan _ss = "{ "++ "ss" ++"}"
151
152 var = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr
153 :: Var -> String
154 dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr
155 :: DataCon -> String
156
157 bagRdrName:: Bag (Located (HsBind RdrName)) -> String
158 bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}")
159 . list . bagToList
160 bagName :: Bag (Located (HsBind Name)) -> String
161 bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}")
162 . list . bagToList
163 bagVar :: Bag (Located (HsBind Var)) -> String
164 bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}")
165 . list . bagToList
166
167 nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
168
169 fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
170 :: Fixity -> String
171
172 located :: (Data b,Data loc) => GenLocated loc b -> String
173 located (L ss a) =
174 indent n ++ "("
175 ++ case cast ss of
176 Just (s :: SrcSpan) ->
177 srcSpan s
178 Nothing -> "nnnnnnnn"
179 ++ showAstData (n+1) a
180 ++ ")"
181
182 normalize_newlines :: String -> String
183 normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
184 normalize_newlines (x:xs) = x:normalize_newlines xs
185 normalize_newlines [] = []
186
187 showSDoc_ :: SDoc -> String
188 showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags
189
190 showSDocDebug_ :: SDoc -> String
191 showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags
192
193 -- ---------------------------------------------------------------------
194
195 -- Copied from syb for the test
196
197
198 -- | The type constructor for queries
199 newtype Q q x = Q { unQ :: x -> q }
200
201 -- | Extend a generic query by a type-specific case
202 extQ :: ( Typeable a
203 , Typeable b
204 )
205 => (a -> q)
206 -> (b -> q)
207 -> a
208 -> q
209 extQ f g a = maybe (f a) g (cast a)
210
211 -- | Type extension of queries for type constructors
212 ext1Q :: (Data d, Typeable t)
213 => (d -> q)
214 -> (forall e. Data e => t e -> q)
215 -> d -> q
216 ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
217
218
219 -- | Type extension of queries for type constructors
220 ext2Q :: (Data d, Typeable t)
221 => (d -> q)
222 -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
223 -> d -> q
224 ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
225
226 -- | Flexible type extension
227 ext1 :: (Data a, Typeable t)
228 => c a
229 -> (forall d. Data d => c (t d))
230 -> c a
231 ext1 def ext = maybe def id (dataCast1 ext)
232
233
234
235 -- | Flexible type extension
236 ext2 :: (Data a, Typeable t)
237 => c a
238 -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
239 -> c a
240 ext2 def ext = maybe def id (dataCast2 ext)