Add Template Haskell support for overloaded labels
[ghc.git] / compiler / hsSyn / HsDumpAst.hs
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 hsSyn 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 HsDumpAst (
13 -- * Dumping ASTs
14 showAstData,
15 BlankSrcSpan(..),
16 ) where
17
18 import Data.Data hiding (Fixity)
19 import Data.List
20 import Bag
21 import BasicTypes
22 import FastString
23 import NameSet
24 import Name
25 import DataCon
26 import SrcLoc
27 import HsSyn
28 import OccName hiding (occName)
29 import Var
30 import Module
31 import DynFlags
32 import Outputable hiding (space)
33
34 import qualified Data.ByteString as B
35
36 data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
37 deriving (Eq,Show)
38
39 -- | Show a GHC syntax tree. This parameterised because it is also used for
40 -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
41 -- out, to avoid comparing locations, only structure
42 showAstData :: Data a => BlankSrcSpan -> a -> String
43 showAstData b = showAstData' 0
44 where
45 showAstData' :: Data a => Int -> a -> String
46 showAstData' n =
47 generic
48 `ext1Q` list
49 `extQ` string `extQ` fastString `extQ` srcSpan
50 `extQ` lit `extQ` litr `extQ` litt
51 `extQ` bytestring
52 `extQ` name `extQ` occName `extQ` moduleName `extQ` var
53 `extQ` dataCon
54 `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
55 `extQ` fixity
56 `ext2Q` located
57 where generic :: Data a => a -> String
58 generic t = indent n ++ "(" ++ showConstr (toConstr t)
59 ++ space (unwords (gmapQ (showAstData' (n+1)) t)) ++ ")"
60
61 space "" = ""
62 space s = ' ':s
63
64 indent i = "\n" ++ replicate i ' '
65
66 string :: String -> String
67 string = normalize_newlines . show
68
69 fastString :: FastString -> String
70 fastString = ("{FastString: "++) . (++"}") . normalize_newlines
71 . show
72
73 bytestring :: B.ByteString -> String
74 bytestring = normalize_newlines . show
75
76 list l = indent n ++ "["
77 ++ intercalate "," (map (showAstData' (n+1)) l)
78 ++ "]"
79
80 -- Eliminate word-size dependence
81 lit :: HsLit GhcPs -> String
82 lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
83 lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
84 lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
85 lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
86 lit l = generic l
87
88 litr :: HsLit GhcRn -> String
89 litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
90 litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
91 litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
92 litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
93 litr l = generic l
94
95 litt :: HsLit GhcTc -> String
96 litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
97 litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
98 litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
99 litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
100 litt l = generic l
101
102 numericLit :: String -> Integer -> SourceText -> String
103 numericLit tag x s = indent n ++ unwords [ "{" ++ tag
104 , generic x
105 , generic s ++ "}" ]
106
107 name :: Name -> String
108 name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
109
110 occName = ("{OccName: "++) . (++"}") . OccName.occNameString
111
112 moduleName :: ModuleName -> String
113 moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
114
115 srcSpan :: SrcSpan -> String
116 srcSpan ss = case b of
117 BlankSrcSpan -> "{ "++ "ss" ++"}"
118 NoBlankSrcSpan ->
119 "{ "++ showSDoc_ (hang (ppr ss) (n+2)
120 -- TODO: show annotations here
121 (text "")
122 )
123 ++"}"
124
125 var :: Var -> String
126 var = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr
127
128 dataCon :: DataCon -> String
129 dataCon = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr
130
131 bagRdrName:: Bag (Located (HsBind GhcPs)) -> String
132 bagRdrName = ("{Bag(Located (HsBind GhcPs)): "++) . (++"}")
133 . list . bagToList
134
135 bagName :: Bag (Located (HsBind GhcRn)) -> String
136 bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}")
137 . list . bagToList
138
139 bagVar :: Bag (Located (HsBind GhcTc)) -> String
140 bagVar = ("{Bag(Located (HsBind Var)): "++) . (++"}")
141 . list . bagToList
142
143 nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
144
145 fixity :: Fixity -> String
146 fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
147
148 located :: (Data b,Data loc) => GenLocated loc b -> String
149 located (L ss a) =
150 indent n ++ "("
151 ++ case cast ss of
152 Just (s :: SrcSpan) ->
153 srcSpan s
154 Nothing -> "nnnnnnnn"
155 ++ showAstData' (n+1) a
156 ++ ")"
157
158 normalize_newlines :: String -> String
159 normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
160 normalize_newlines (x:xs) = x:normalize_newlines xs
161 normalize_newlines [] = []
162
163 showSDoc_ :: SDoc -> String
164 showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags
165
166 showSDocDebug_ :: SDoc -> String
167 showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags
168
169 {-
170 ************************************************************************
171 * *
172 * Copied from syb
173 * *
174 ************************************************************************
175 -}
176
177
178 -- | The type constructor for queries
179 newtype Q q x = Q { unQ :: x -> q }
180
181 -- | Extend a generic query by a type-specific case
182 extQ :: ( Typeable a
183 , Typeable b
184 )
185 => (a -> q)
186 -> (b -> q)
187 -> a
188 -> q
189 extQ f g a = maybe (f a) g (cast a)
190
191 -- | Type extension of queries for type constructors
192 ext1Q :: (Data d, Typeable t)
193 => (d -> q)
194 -> (forall e. Data e => t e -> q)
195 -> d -> q
196 ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
197
198
199 -- | Type extension of queries for type constructors
200 ext2Q :: (Data d, Typeable t)
201 => (d -> q)
202 -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
203 -> d -> q
204 ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
205
206 -- | Flexible type extension
207 ext1 :: (Data a, Typeable t)
208 => c a
209 -> (forall d. Data d => c (t d))
210 -> c a
211 ext1 def ext = maybe def id (dataCast1 ext)
212
213
214
215 -- | Flexible type extension
216 ext2 :: (Data a, Typeable t)
217 => c a
218 -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
219 -> c a
220 ext2 def ext = maybe def id (dataCast2 ext)