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