never executed always true always false
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 -}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7
8 -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb
9 -- traversal which falls back to displaying based on the constructor name, so
10 -- can be used to dump anything having a @Data.Data@ instance.
11
12 module GHC.Hs.Dump (
13 -- * Dumping ASTs
14 showAstData,
15 BlankSrcSpan(..),
16 BlankEpAnnotations(..),
17 ) where
18
19 import GHC.Prelude
20
21 import GHC.Hs
22
23 import GHC.Core.DataCon
24
25 import GHC.Data.Bag
26 import GHC.Data.FastString
27 import GHC.Types.Name.Set
28 import GHC.Types.Name
29 import GHC.Types.SrcLoc
30 import GHC.Types.Var
31 import GHC.Types.SourceText
32 import GHC.Unit.Module
33 import GHC.Utils.Outputable
34
35 import Data.Data hiding (Fixity)
36 import qualified Data.ByteString as B
37
38 data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan
39 deriving (Eq,Show)
40
41 data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations
42 deriving (Eq,Show)
43
44 -- | Show a GHC syntax tree. This parameterised because it is also used for
45 -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
46 -- out, to avoid comparing locations, only structure
47 showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
48 showAstData bs ba a0 = blankLine $$ showAstData' a0
49 where
50 showAstData' :: Data a => a -> SDoc
51 showAstData' =
52 generic
53 `ext1Q` list
54 `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan
55 `extQ` annotation
56 `extQ` annotationModule
57 `extQ` annotationAddEpAnn
58 `extQ` annotationGrhsAnn
59 `extQ` annotationEpAnnHsCase
60 `extQ` annotationAnnList
61 `extQ` annotationEpAnnImportDecl
62 `extQ` annotationAnnParen
63 `extQ` annotationTrailingAnn
64 `extQ` annotationEpaLocation
65 `extQ` annotationNoEpAnns
66 `extQ` addEpAnn
67 `extQ` lit `extQ` litr `extQ` litt
68 `extQ` sourceText
69 `extQ` deltaPos
70 `extQ` epaAnchor
71 `extQ` bytestring
72 `extQ` name `extQ` occName `extQ` moduleName `extQ` var
73 `extQ` dataCon
74 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
75 `extQ` fixity
76 `ext2Q` located
77 `extQ` srcSpanAnnA
78 `extQ` srcSpanAnnL
79 `extQ` srcSpanAnnP
80 `extQ` srcSpanAnnC
81 `extQ` srcSpanAnnN
82
83 where generic :: Data a => a -> SDoc
84 generic t = parens $ text (showConstr (toConstr t))
85 $$ vcat (gmapQ showAstData' t)
86
87 string :: String -> SDoc
88 string = text . normalize_newlines . show
89
90 fastString :: FastString -> SDoc
91 fastString s = braces $
92 text "FastString:"
93 <+> text (normalize_newlines . show $ s)
94
95 bytestring :: B.ByteString -> SDoc
96 bytestring = text . normalize_newlines . show
97
98 list [] = brackets empty
99 list [x] = brackets (showAstData' x)
100 list (x1 : x2 : xs) = (text "[" <> showAstData' x1)
101 $$ go x2 xs
102 where
103 go y [] = text "," <> showAstData' y <> text "]"
104 go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
105
106 -- Eliminate word-size dependence
107 lit :: HsLit GhcPs -> SDoc
108 lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
109 lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
110 lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
111 lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
112 lit l = generic l
113
114 litr :: HsLit GhcRn -> SDoc
115 litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
116 litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
117 litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
118 litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
119 litr l = generic l
120
121 litt :: HsLit GhcTc -> SDoc
122 litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
123 litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
124 litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
125 litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
126 litt l = generic l
127
128 numericLit :: String -> Integer -> SourceText -> SDoc
129 numericLit tag x s = braces $ hsep [ text tag
130 , generic x
131 , generic s ]
132
133 sourceText :: SourceText -> SDoc
134 sourceText NoSourceText = parens $ text "NoSourceText"
135 sourceText (SourceText src) = case bs of
136 NoBlankSrcSpan -> parens $ text "SourceText" <+> text src
137 BlankSrcSpanFile -> parens $ text "SourceText" <+> text src
138 _ -> parens $ text "SourceText" <+> text "blanked"
139
140 epaAnchor :: EpaLocation -> SDoc
141 epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r
142 epaAnchor (EpaDelta d cs) = case ba of
143 NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs
144 BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"
145
146 deltaPos :: DeltaPos -> SDoc
147 deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c
148 deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c
149
150 name :: Name -> SDoc
151 name nm = braces $ text "Name:" <+> ppr nm
152
153 occName n = braces $
154 text "OccName:"
155 <+> text (occNameString n)
156
157 moduleName :: ModuleName -> SDoc
158 moduleName m = braces $ text "ModuleName:" <+> ppr m
159
160 srcSpan :: SrcSpan -> SDoc
161 srcSpan ss = case bs of
162 BlankSrcSpan -> text "{ ss }"
163 NoBlankSrcSpan -> braces $ char ' ' <>
164 (hang (ppr ss) 1
165 -- TODO: show annotations here
166 (text ""))
167 BlankSrcSpanFile -> braces $ char ' ' <>
168 (hang (pprUserSpan False ss) 1
169 -- TODO: show annotations here
170 (text ""))
171
172 realSrcSpan :: RealSrcSpan -> SDoc
173 realSrcSpan ss = case bs of
174 BlankSrcSpan -> text "{ ss }"
175 NoBlankSrcSpan -> braces $ char ' ' <>
176 (hang (ppr ss) 1
177 -- TODO: show annotations here
178 (text ""))
179 BlankSrcSpanFile -> braces $ char ' ' <>
180 (hang (pprUserRealSpan False ss) 1
181 -- TODO: show annotations here
182 (text ""))
183
184
185 addEpAnn :: AddEpAnn -> SDoc
186 addEpAnn (AddEpAnn a s) = case ba of
187 BlankEpAnnotations -> parens
188 $ text "blanked:" <+> text "AddEpAnn"
189 NoBlankEpAnnotations ->
190 parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s
191
192 var :: Var -> SDoc
193 var v = braces $ text "Var:" <+> ppr v
194
195 dataCon :: DataCon -> SDoc
196 dataCon c = braces $ text "DataCon:" <+> ppr c
197
198 bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc
199 bagRdrName bg = braces $
200 text "Bag(LocatedA (HsBind GhcPs)):"
201 $$ (list . bagToList $ bg)
202
203 bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc
204 bagName bg = braces $
205 text "Bag(LocatedA (HsBind Name)):"
206 $$ (list . bagToList $ bg)
207
208 bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc
209 bagVar bg = braces $
210 text "Bag(LocatedA (HsBind Var)):"
211 $$ (list . bagToList $ bg)
212
213 nameSet ns = braces $
214 text "NameSet:"
215 $$ (list . nameSetElemsStable $ ns)
216
217 fixity :: Fixity -> SDoc
218 fixity fx = braces $
219 text "Fixity:"
220 <+> ppr fx
221
222 located :: (Data a, Data b) => GenLocated a b -> SDoc
223 located (L ss a)
224 = parens (text "L"
225 $$ vcat [showAstData' ss, showAstData' a])
226
227
228 -- -------------------------
229
230 annotation :: EpAnn [AddEpAnn] -> SDoc
231 annotation = annotation' (text "EpAnn [AddEpAnn]")
232
233 annotationModule :: EpAnn AnnsModule -> SDoc
234 annotationModule = annotation' (text "EpAnn AnnsModule")
235
236 annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc
237 annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")
238
239 annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc
240 annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")
241
242 annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc
243 annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")
244
245 annotationAnnList :: EpAnn AnnList -> SDoc
246 annotationAnnList = annotation' (text "EpAnn AnnList")
247
248 annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc
249 annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")
250
251 annotationAnnParen :: EpAnn AnnParen -> SDoc
252 annotationAnnParen = annotation' (text "EpAnn AnnParen")
253
254 annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc
255 annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")
256
257 annotationEpaLocation :: EpAnn EpaLocation -> SDoc
258 annotationEpaLocation = annotation' (text "EpAnn EpaLocation")
259
260 annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc
261 annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")
262
263 annotation' :: forall a .(Data a, Typeable a)
264 => SDoc -> EpAnn a -> SDoc
265 annotation' tag anns = case ba of
266 BlankEpAnnotations -> parens (text "blanked:" <+> tag)
267 NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
268 $$ vcat (gmapQ showAstData' anns)
269
270 -- -------------------------
271
272 srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc
273 srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
274
275 srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc
276 srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")
277
278 srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc
279 srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
280
281 srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc
282 srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")
283
284 srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc
285 srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
286
287 locatedAnn'' :: forall a. (Typeable a, Data a)
288 => SDoc -> SrcSpanAnn' a -> SDoc
289 locatedAnn'' tag ss = parens $
290 case cast ss of
291 Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->
292 case ba of
293 BlankEpAnnotations
294 -> parens (text "blanked:" <+> tag)
295 NoBlankEpAnnotations
296 -> text "SrcSpanAnn" <+> showAstData' ann
297 <+> srcSpan s
298 Nothing -> text "locatedAnn:unmatched" <+> tag
299 <+> (parens $ text (showConstr (toConstr ss)))
300
301
302 normalize_newlines :: String -> String
303 normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
304 normalize_newlines (x:xs) = x:normalize_newlines xs
305 normalize_newlines [] = []
306
307 {-
308 ************************************************************************
309 * *
310 * Copied from syb
311 * *
312 ************************************************************************
313 -}
314
315
316 -- | The type constructor for queries
317 newtype Q q x = Q { unQ :: x -> q }
318
319 -- | Extend a generic query by a type-specific case
320 extQ :: ( Typeable a
321 , Typeable b
322 )
323 => (a -> q)
324 -> (b -> q)
325 -> a
326 -> q
327 extQ f g a = maybe (f a) g (cast a)
328
329 -- | Type extension of queries for type constructors
330 ext1Q :: (Data d, Typeable t)
331 => (d -> q)
332 -> (forall e. Data e => t e -> q)
333 -> d -> q
334 ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
335
336
337 -- | Type extension of queries for type constructors
338 ext2Q :: (Data d, Typeable t)
339 => (d -> q)
340 -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
341 -> d -> q
342 ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
343
344 -- | Flexible type extension
345 ext1 :: (Data a, Typeable t)
346 => c a
347 -> (forall d. Data d => c (t d))
348 -> c a
349 ext1 def ext = maybe def id (dataCast1 ext)
350
351
352
353 -- | Flexible type extension
354 ext2 :: (Data a, Typeable t)
355 => c a
356 -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
357 -> c a
358 ext2 def ext = maybe def id (dataCast2 ext)