9 files changed, 555 insertions, 137 deletions
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 2f1f813ab0..63276b34db 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -313,6 +313,7 @@ Library
         HsSyn
         HsTypes
         HsUtils
+        HsDumpAst
         BinIface
         BinFingerprint
         BuildTyCl
diff --git a/compiler/hsSyn/HsDumpAst.hs b/compiler/hsSyn/HsDumpAst.hs
new file mode 100644
index 0000000000..f735488957
--- /dev/null
+++ b/compiler/hsSyn/HsDumpAst.hs
@@ -0,0 +1,192 @@
+{-
+(c) The University of Glasgow 2006
+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb
+-- traversal which falls back to displaying based on the constructor name, so
+-- can be used to dump anything having a @Data.Data@ instance.
+
+module HsDumpAst (
+        -- * Dumping ASTs
+        showAstData,
+        BlankSrcSpan(..),
+    ) where
+
+import Data.Data hiding (Fixity)
+import Data.List
+import Bag
+import FastString
+import NameSet
+import Name
+import RdrName
+import DataCon
+import SrcLoc
+import HsSyn
+import OccName hiding (occName)
+import Var
+import Module
+import DynFlags
+import Outputable hiding (space)
+
+import qualified Data.ByteString as B
+
+data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
+                  deriving (Eq,Show)
+
+-- | Show a GHC syntax tree. This parameterised because it is also used for
+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
+-- out, to avoid comparing locations, only structure
+showAstData :: Data a => BlankSrcSpan -> a -> String
+showAstData b = showAstData' 0
+  where
+    showAstData' :: Data a => Int -> a -> String
+    showAstData' n =
+      generic
+              `ext1Q` list
+              `extQ` string `extQ` fastString `extQ` srcSpan
+              `extQ` bytestring
+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var
+              `extQ` dataCon
+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
+              `extQ` fixity
+              `ext2Q` located
+      where generic :: Data a => a -> String
+            generic t = indent n ++ "(" ++ showConstr (toConstr t)
+                     ++ space (unwords (gmapQ (showAstData' (n+1)) t)) ++ ")"
+
+            space "" = ""
+            space s  = ' ':s
+
+            indent i = "\n" ++ replicate i ' '
+
+            string :: String -> String
+            string     = normalize_newlines . show
+
+            fastString :: FastString -> String
+            fastString = ("{FastString: "++) . (++"}") . normalize_newlines
+                       . show
+
+            bytestring :: B.ByteString -> String
+            bytestring = normalize_newlines . show
+
+            list l     = indent n ++ "["
+                                ++ intercalate "," (map (showAstData' (n+1)) l)
+                                ++ "]"
+
+            name :: Name -> String
+            name       = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
+
+            occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString
+
+            moduleName :: ModuleName -> String
+            moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
+
+            srcSpan :: SrcSpan -> String
+            srcSpan ss = case b of
+             BlankSrcSpan -> "{ "++ "ss" ++"}"
+             NoBlankSrcSpan ->
+                             "{ "++ showSDoc_ (hang (ppr ss) (n+2)
+                                              -- TODO: show annotations here
+                                                    (text "")
+                                              )
+                          ++"}"
+
+            var  :: Var -> String
+            var        = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr
+
+            dataCon :: DataCon -> String
+            dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr
+
+            bagRdrName:: Bag (Located (HsBind RdrName)) -> String
+            bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}")
+                          . list . bagToList
+
+            bagName   :: Bag (Located (HsBind Name)) -> String
+            bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}")
+                           . list . bagToList
+
+            bagVar    :: Bag (Located (HsBind Var)) -> String
+            bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}")
+                           . list . bagToList
+
+            nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
+
+            fixity :: Fixity -> String
+            fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
+
+            located :: (Data b,Data loc) => GenLocated loc b -> String
+            located (L ss a) =
+              indent n ++ "("
+                ++ case cast ss of
+                        Just (s :: SrcSpan) ->
+                          srcSpan s
+                        Nothing -> "nnnnnnnn"
+                      ++ showAstData' (n+1) a
+                      ++ ")"
+
+normalize_newlines :: String -> String
+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
+normalize_newlines (x:xs)                 = x:normalize_newlines xs
+normalize_newlines []                     = []
+
+showSDoc_ :: SDoc -> String
+showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags
+
+showSDocDebug_ :: SDoc -> String
+showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags
+
+{-
+************************************************************************
+*                                                                      *
+* Copied from syb
+*                                                                      *
+************************************************************************
+-}
+
+
+-- | The type constructor for queries
+newtype Q q x = Q { unQ :: x -> q }
+
+-- | Extend a generic query by a type-specific case
+extQ :: ( Typeable a
+        , Typeable b
+        )
+     => (a -> q)
+     -> (b -> q)
+     -> a
+     -> q
+extQ f g a = maybe (f a) g (cast a)
+
+-- | Type extension of queries for type constructors
+ext1Q :: (Data d, Typeable t)
+      => (d -> q)
+      -> (forall e. Data e => t e -> q)
+      -> d -> q
+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
+
+
+-- | Type extension of queries for type constructors
+ext2Q :: (Data d, Typeable t)
+      => (d -> q)
+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
+      -> d -> q
+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
+
+-- | Flexible type extension
+ext1 :: (Data a, Typeable t)
+     => c a
+     -> (forall d. Data d => c (t d))
+     -> c a
+ext1 def ext = maybe def id (dataCast1 ext)
+
+
+
+-- | Flexible type extension
+ext2 :: (Data a, Typeable t)
+     => c a
+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
+     -> c a
+ext2 def ext = maybe def id (dataCast2 ext)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c8f6e1ed43..41f7235ea3 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -339,6 +339,7 @@ data DumpFlag
    | Opt_D_dump_simpl_trace
    | Opt_D_dump_occur_anal
    | Opt_D_dump_parsed
+   | Opt_D_dump_parsed_ast
    | Opt_D_dump_rn
    | Opt_D_dump_shape
    | Opt_D_dump_simpl
@@ -2780,6 +2781,8 @@ dynamic_flags_deps = [
         (setDumpFlag Opt_D_dump_occur_anal)
   , make_ord_flag defGhcFlag "ddump-parsed"
         (setDumpFlag Opt_D_dump_parsed)
+  , make_ord_flag defGhcFlag "ddump-parsed-ast"
+        (setDumpFlag Opt_D_dump_parsed_ast)
   , make_ord_flag defGhcFlag "ddump-rn"
         (setDumpFlag Opt_D_dump_rn)
   , make_ord_flag defGhcFlag "ddump-simpl"
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index eb56a54209..b163cbbe21 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -81,6 +81,7 @@ module HscMain
     , showModuleIndex
     ) where
 
+import Data.Data hiding (Fixity, TyCon)
 import Id
 import GHCi.RemoteTypes ( ForeignHValue )
 import ByteCodeGen      ( byteCodeGen, coreExprToBCOs )
@@ -98,6 +99,7 @@ import Module
 import Packages
 import RdrName
 import HsSyn
+import HsDumpAst
 import CoreSyn
 import StringBuffer
 import Parser
@@ -330,6 +332,8 @@ hscParse' mod_summary
             logWarningsReportErrors (getMessages pst dflags)
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
                                    ppr rdr_module
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
+                                   text (showAstData NoBlankSrcSpan rdr_module)
             liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
                                    ppSourceStats False rdr_module
 
@@ -1662,10 +1666,11 @@ hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
 hscParseIdentifier hsc_env str =
     runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
 
-hscParseThing :: (Outputable thing) => Lexer.P thing -> String -> Hsc thing
+hscParseThing :: (Outputable thing, Data thing)
+              => Lexer.P thing -> String -> Hsc thing
 hscParseThing = hscParseThingWithLocation "<interactive>" 1
 
-hscParseThingWithLocation :: (Outputable thing) => String -> Int
+hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
                           -> Lexer.P thing -> String -> Hsc thing
 hscParseThingWithLocation source linenumber parser str
   = withTiming getDynFlags
@@ -1684,6 +1689,8 @@ hscParseThingWithLocation source linenumber parser str
         POk pst thing -> do
             logWarningsReportErrors (getMessages pst dflags)
             liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
+                                   text $ showAstData NoBlankSrcSpan thing
             return thing
 
 
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index ba44e60074..b4c20eb8b9 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -38,6 +38,10 @@ Dumping out compiler intermediate structures
 
         Dump parser output
 
+    .. ghc-flag:: -ddump-parsed-ast
+
+        Dump parser output as a syntax tree
+
     .. ghc-flag:: -ddump-rn
 
         Dump renamer output
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.hs b/testsuite/tests/parser/should_compile/DumpParsedAst.hs
new file mode 100644
index 0000000000..a0d65ad8d6
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies #-}
+
+module DumpParsedAst where
+
+data Peano = Zero | Succ Peano
+
+type family Length (as :: [k]) :: Peano where
+  Length (a : as) = Succ (Length as)
+  Length '[]      = Zero
+
+type family Length' (as :: [k]) :: Peano where
+  Length' ((:) a as) = Succ (Length' as)
+  Length' '[]        = Zero
diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
new file mode 100644
index 0000000000..9c08b3e7bd
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr
@@ -0,0 +1,329 @@
+
+==================== Parser AST ====================
+
+({ DumpParsedAst.hs:1:1 }
+ (HsModule 
+  (Just 
+   ({ DumpParsedAst.hs:3:8-20 }{ModuleName: DumpParsedAst})) 
+  (Nothing) 
+  [] 
+  [
+   ({ DumpParsedAst.hs:5:1-30 }
+    (TyClD 
+     (DataDecl 
+      ({ DumpParsedAst.hs:5:6-10 }
+       (Unqual {OccName: Peano})) 
+      (HsQTvs 
+       (PlaceHolder) 
+       [] 
+       (PlaceHolder)) 
+      (Prefix) 
+      (HsDataDefn 
+       (DataType) 
+       ({ <no location info> }
+        []) 
+       (Nothing) 
+       (Nothing) 
+       [
+        ({ DumpParsedAst.hs:5:14-17 }
+         (ConDeclH98 
+          ({ DumpParsedAst.hs:5:14-17 }
+           (Unqual {OccName: Zero})) 
+          (Nothing) 
+          (Just 
+           ({ <no location info> }
+            [])) 
+          (PrefixCon 
+           []) 
+          (Nothing))),
+        ({ DumpParsedAst.hs:5:21-30 }
+         (ConDeclH98 
+          ({ DumpParsedAst.hs:5:21-24 }
+           (Unqual {OccName: Succ})) 
+          (Nothing) 
+          (Just 
+           ({ <no location info> }
+            [])) 
+          (PrefixCon 
+           [
+            ({ DumpParsedAst.hs:5:26-30 }
+             (HsTyVar 
+              (NotPromoted) 
+              ({ DumpParsedAst.hs:5:26-30 }
+               (Unqual {OccName: Peano}))))]) 
+          (Nothing)))] 
+       ({ <no location info> }
+        [])) 
+      (PlaceHolder) 
+      (PlaceHolder)))),
+   ({ DumpParsedAst.hs:7:1-39 }
+    (TyClD 
+     (FamDecl 
+      (FamilyDecl 
+       (ClosedTypeFamily 
+        (Just 
+         [
+          ({ DumpParsedAst.hs:8:3-36 }
+           (TyFamEqn 
+            ({ DumpParsedAst.hs:8:3-8 }
+             (Unqual {OccName: Length})) 
+            (HsIB 
+             (PlaceHolder) 
+             [
+              ({ DumpParsedAst.hs:8:10-17 }
+               (HsParTy 
+                ({ DumpParsedAst.hs:8:11-16 }
+                 (HsAppsTy 
+                  [
+                   ({ DumpParsedAst.hs:8:11 }
+                    (HsAppPrefix 
+                     ({ DumpParsedAst.hs:8:11 }
+                      (HsTyVar 
+                       (NotPromoted) 
+                       ({ DumpParsedAst.hs:8:11 }
+                        (Unqual {OccName: a})))))),
+                   ({ DumpParsedAst.hs:8:13 }
+                    (HsAppInfix 
+                     ({ DumpParsedAst.hs:8:13 }
+                      (Exact {Name: ghc-prim:GHC.Types.:{(w) d 66}})))),
+                   ({ DumpParsedAst.hs:8:15-16 }
+                    (HsAppPrefix 
+                     ({ DumpParsedAst.hs:8:15-16 }
+                      (HsTyVar 
+                       (NotPromoted) 
+                       ({ DumpParsedAst.hs:8:15-16 }
+                        (Unqual {OccName: as}))))))]))))]) 
+            (Prefix) 
+            ({ DumpParsedAst.hs:8:21-36 }
+             (HsAppsTy 
+              [
+               ({ DumpParsedAst.hs:8:21-24 }
+                (HsAppPrefix 
+                 ({ DumpParsedAst.hs:8:21-24 }
+                  (HsTyVar 
+                   (NotPromoted) 
+                   ({ DumpParsedAst.hs:8:21-24 }
+                    (Unqual {OccName: Succ})))))),
+               ({ DumpParsedAst.hs:8:26-36 }
+                (HsAppPrefix 
+                 ({ DumpParsedAst.hs:8:26-36 }
+                  (HsParTy 
+                   ({ DumpParsedAst.hs:8:27-35 }
+                    (HsAppsTy 
+                     [
+                      ({ DumpParsedAst.hs:8:27-32 }
+                       (HsAppPrefix 
+                        ({ DumpParsedAst.hs:8:27-32 }
+                         (HsTyVar 
+                          (NotPromoted) 
+                          ({ DumpParsedAst.hs:8:27-32 }
+                           (Unqual {OccName: Length})))))),
+                      ({ DumpParsedAst.hs:8:34-35 }
+                       (HsAppPrefix 
+                        ({ DumpParsedAst.hs:8:34-35 }
+                         (HsTyVar 
+                          (NotPromoted) 
+                          ({ DumpParsedAst.hs:8:34-35 }
+                           (Unqual {OccName: as}))))))]))))))])))),
+          ({ DumpParsedAst.hs:9:3-24 }
+           (TyFamEqn 
+            ({ DumpParsedAst.hs:9:3-8 }
+             (Unqual {OccName: Length})) 
+            (HsIB 
+             (PlaceHolder) 
+             [
+              ({ DumpParsedAst.hs:9:10-12 }
+               (HsExplicitListTy 
+                (Promoted) 
+                (PlaceHolder) 
+                []))]) 
+            (Prefix) 
+            ({ DumpParsedAst.hs:9:21-24 }
+             (HsAppsTy 
+              [
+               ({ DumpParsedAst.hs:9:21-24 }
+                (HsAppPrefix 
+                 ({ DumpParsedAst.hs:9:21-24 }
+                  (HsTyVar 
+                   (NotPromoted) 
+                   ({ DumpParsedAst.hs:9:21-24 }
+                    (Unqual {OccName: Zero}))))))]))))])) 
+       ({ DumpParsedAst.hs:7:13-18 }
+        (Unqual {OccName: Length})) 
+       (HsQTvs 
+        (PlaceHolder) 
+        [
+         ({ DumpParsedAst.hs:7:20-30 }
+          (KindedTyVar 
+           ({ DumpParsedAst.hs:7:21-22 }
+            (Unqual {OccName: as})) 
+           ({ DumpParsedAst.hs:7:27-29 }
+            (HsAppsTy 
+             [
+              ({ DumpParsedAst.hs:7:27-29 }
+               (HsAppPrefix 
+                ({ DumpParsedAst.hs:7:27-29 }
+                 (HsListTy 
+                  ({ DumpParsedAst.hs:7:28 }
+                   (HsAppsTy 
+                    [
+                     ({ DumpParsedAst.hs:7:28 }
+                      (HsAppPrefix 
+                       ({ DumpParsedAst.hs:7:28 }
+                        (HsTyVar 
+                         (NotPromoted) 
+                         ({ DumpParsedAst.hs:7:28 }
+                          (Unqual {OccName: k}))))))]))))))]))))] 
+        (PlaceHolder)) 
+       (Prefix) 
+       ({ DumpParsedAst.hs:7:32-39 }
+        (KindSig 
+         ({ DumpParsedAst.hs:7:35-39 }
+          (HsAppsTy 
+           [
+            ({ DumpParsedAst.hs:7:35-39 }
+             (HsAppPrefix 
+              ({ DumpParsedAst.hs:7:35-39 }
+               (HsTyVar 
+                (NotPromoted) 
+                ({ DumpParsedAst.hs:7:35-39 }
+                 (Unqual {OccName: Peano}))))))])))) 
+       (Nothing))))),
+   ({ DumpParsedAst.hs:11:1-40 }
+    (TyClD 
+     (FamDecl 
+      (FamilyDecl 
+       (ClosedTypeFamily 
+        (Just 
+         [
+          ({ DumpParsedAst.hs:12:3-40 }
+           (TyFamEqn 
+            ({ DumpParsedAst.hs:12:3-9 }
+             (Unqual {OccName: Length'})) 
+            (HsIB 
+             (PlaceHolder) 
+             [
+              ({ DumpParsedAst.hs:12:11-20 }
+               (HsParTy 
+                ({ DumpParsedAst.hs:12:12-19 }
+                 (HsAppsTy 
+                  [
+                   ({ DumpParsedAst.hs:12:12-14 }
+                    (HsAppPrefix 
+                     ({ DumpParsedAst.hs:12:12-14 }
+                      (HsTyVar 
+                       (NotPromoted) 
+                       ({ DumpParsedAst.hs:12:12-14 }
+                        (Exact {Name: ghc-prim:GHC.Types.:{(w) d 66}})))))),
+                   ({ DumpParsedAst.hs:12:16 }
+                    (HsAppPrefix 
+                     ({ DumpParsedAst.hs:12:16 }
+                      (HsTyVar 
+                       (NotPromoted) 
+                       ({ DumpParsedAst.hs:12:16 }
+                        (Unqual {OccName: a})))))),
+                   ({ DumpParsedAst.hs:12:18-19 }
+                    (HsAppPrefix 
+                     ({ DumpParsedAst.hs:12:18-19 }
+                      (HsTyVar 
+                       (NotPromoted) 
+                       ({ DumpParsedAst.hs:12:18-19 }
+                        (Unqual {OccName: as}))))))]))))]) 
+            (Prefix) 
+            ({ DumpParsedAst.hs:12:24-40 }
+             (HsAppsTy 
+              [
+               ({ DumpParsedAst.hs:12:24-27 }
+                (HsAppPrefix 
+                 ({ DumpParsedAst.hs:12:24-27 }
+                  (HsTyVar 
+                   (NotPromoted) 
+                   ({ DumpParsedAst.hs:12:24-27 }
+                    (Unqual {OccName: Succ})))))),
+               ({ DumpParsedAst.hs:12:29-40 }
+                (HsAppPrefix 
+                 ({ DumpParsedAst.hs:12:29-40 }
+                  (HsParTy 
+                   ({ DumpParsedAst.hs:12:30-39 }
+                    (HsAppsTy 
+                     [
+                      ({ DumpParsedAst.hs:12:30-36 }
+                       (HsAppPrefix 
+                        ({ DumpParsedAst.hs:12:30-36 }
+                         (HsTyVar 
+                          (NotPromoted) 
+                          ({ DumpParsedAst.hs:12:30-36 }
+                           (Unqual {OccName: Length'})))))),
+                      ({ DumpParsedAst.hs:12:38-39 }
+                       (HsAppPrefix 
+                        ({ DumpParsedAst.hs:12:38-39 }
+                         (HsTyVar 
+                          (NotPromoted) 
+                          ({ DumpParsedAst.hs:12:38-39 }
+                           (Unqual {OccName: as}))))))]))))))])))),
+          ({ DumpParsedAst.hs:13:3-27 }
+           (TyFamEqn 
+            ({ DumpParsedAst.hs:13:3-9 }
+             (Unqual {OccName: Length'})) 
+            (HsIB 
+             (PlaceHolder) 
+             [
+              ({ DumpParsedAst.hs:13:11-13 }
+               (HsExplicitListTy 
+                (Promoted) 
+                (PlaceHolder) 
+                []))]) 
+            (Prefix) 
+            ({ DumpParsedAst.hs:13:24-27 }
+             (HsAppsTy 
+              [
+               ({ DumpParsedAst.hs:13:24-27 }
+                (HsAppPrefix 
+                 ({ DumpParsedAst.hs:13:24-27 }
+                  (HsTyVar 
+                   (NotPromoted) 
+                   ({ DumpParsedAst.hs:13:24-27 }
+                    (Unqual {OccName: Zero}))))))]))))])) 
+       ({ DumpParsedAst.hs:11:13-19 }
+        (Unqual {OccName: Length'})) 
+       (HsQTvs 
+        (PlaceHolder) 
+        [
+         ({ DumpParsedAst.hs:11:21-31 }
+          (KindedTyVar 
+           ({ DumpParsedAst.hs:11:22-23 }
+            (Unqual {OccName: as})) 
+           ({ DumpParsedAst.hs:11:28-30 }
+            (HsAppsTy 
+             [
+              ({ DumpParsedAst.hs:11:28-30 }
+               (HsAppPrefix 
+                ({ DumpParsedAst.hs:11:28-30 }
+                 (HsListTy 
+                  ({ DumpParsedAst.hs:11:29 }
+                   (HsAppsTy 
+                    [
+                     ({ DumpParsedAst.hs:11:29 }
+                      (HsAppPrefix 
+                       ({ DumpParsedAst.hs:11:29 }
+                        (HsTyVar 
+                         (NotPromoted) 
+                         ({ DumpParsedAst.hs:11:29 }
+                          (Unqual {OccName: k}))))))]))))))]))))] 
+        (PlaceHolder)) 
+       (Prefix) 
+       ({ DumpParsedAst.hs:11:33-40 }
+        (KindSig 
+         ({ DumpParsedAst.hs:11:36-40 }
+          (HsAppsTy 
+           [
+            ({ DumpParsedAst.hs:11:36-40 }
+             (HsAppPrefix 
+              ({ DumpParsedAst.hs:11:36-40 }
+               (HsTyVar 
+                (NotPromoted) 
+                ({ DumpParsedAst.hs:11:36-40 }
+                 (Unqual {OccName: Peano}))))))])))) 
+       (Nothing)))))] 
+  (Nothing) 
+  (Nothing)))
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 24c562e555..22a952474e 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -105,3 +105,4 @@ test('VtaParse', normal, compile, [''])
 test('T10196', normal, compile, [''])
 test('T10379', normal, compile, [''])
 test('T10582', expect_broken(10582), compile, [''])
+test('DumpParsedAst', normal, compile, ['-ddump-parsed-ast'])
diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs
index c968b837b1..47a95659ff 100644
--- a/utils/check-ppr/Main.hs
+++ b/utils/check-ppr/Main.hs
@@ -1,23 +1,15 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE RankNTypes #-}
 
-import Data.Data hiding (Fixity)
 import Data.List
-import Bag
-import FastString
-import NameSet
 import SrcLoc
-import HsSyn
-import OccName hiding (occName)
 import GHC hiding (moduleName)
-import Var
+import HsDumpAst
 import DynFlags
 import Outputable hiding (space)
 import System.Environment( getArgs )
 import System.Exit
 import System.FilePath
 
-import qualified Data.ByteString as B
 import qualified Data.Map        as Map
 
 usage :: String
@@ -39,7 +31,7 @@ testOneFile :: FilePath -> String -> IO ()
 testOneFile libdir fileName = do
        p <- parseOneFile libdir fileName
        let
-         origAst = showAstData 0 (pm_parsed_source p)
+         origAst = showAstData BlankSrcSpan (pm_parsed_source p)
          pped    = pragmas ++ "\n" ++ pp (pm_parsed_source p)
          anns    = pm_annotations p
          pragmas = getPragmas anns
@@ -53,7 +45,7 @@ testOneFile libdir fileName = do
 
        p' <- parseOneFile libdir newFile
 
-       let newAstStr = showAstData 0 (pm_parsed_source p')
+       let newAstStr = showAstData BlankSrcSpan (pm_parsed_source p')
        writeFile newAstFile newAstStr
 
        if origAst == newAstStr
@@ -108,127 +100,3 @@ pp :: (Outputable a) => a -> String
 pp a = showPpr unsafeGlobalDynFlags a
 
 
--- | Show a GHC AST with SrcSpan's blanked out, to avoid comparing locations,
--- only structure
-showAstData :: Data a => Int -> a -> String
-showAstData n =
-  generic
-          `ext1Q` list
-          `extQ` string `extQ` fastString `extQ` srcSpan
-          `extQ` bytestring
-          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
-          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
-          `extQ` fixity
-          `ext2Q` located
-  where generic :: Data a => a -> String
-        generic t = indent n ++ "(" ++ showConstr (toConstr t)
-                 ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")"
-        space "" = ""
-        space s  = ' ':s
-        indent i = "\n" ++ replicate i ' '
-        string     = normalize_newlines . show :: String -> String
-        fastString = ("{FastString: "++) . (++"}") . normalize_newlines . show
-                   :: FastString -> String
-        bytestring = normalize_newlines . show :: B.ByteString -> String
-        list l     = indent n ++ "["
-                              ++ intercalate "," (map (showAstData (n+1)) l)
-                              ++ "]"
-
-        name       = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
-                  :: Name -> String
-        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString
-        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
-                   :: ModuleName -> String
-
-        srcSpan :: SrcSpan -> String
-        srcSpan _ss = "{ "++ "ss" ++"}"
-
-        var        = ("{Var: "++) . (++"}") . showSDocDebug_ . ppr
-                   :: Var -> String
-        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . ppr
-                   :: DataCon -> String
-
-        bagRdrName:: Bag (Located (HsBind RdrName)) -> String
-        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}")
-                      . list . bagToList
-        bagName   :: Bag (Located (HsBind Name)) -> String
-        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}")
-                       . list . bagToList
-        bagVar    :: Bag (Located (HsBind Var)) -> String
-        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}")
-                       . list . bagToList
-
-        nameSet = ("{NameSet: "++) . (++"}") . list . nameSetElemsStable
-
-        fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . ppr
-               :: Fixity -> String
-
-        located :: (Data b,Data loc) => GenLocated loc b -> String
-        located (L ss a) =
-          indent n ++ "("
-            ++ case cast ss of
-                    Just (s :: SrcSpan) ->
-                      srcSpan s
-                    Nothing -> "nnnnnnnn"
-                  ++ showAstData (n+1) a
-                  ++ ")"
-
-normalize_newlines :: String -> String
-normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
-normalize_newlines (x:xs)                 = x:normalize_newlines xs
-normalize_newlines []                     = []
-
-showSDoc_ :: SDoc -> String
-showSDoc_ = normalize_newlines . showSDoc unsafeGlobalDynFlags
-
-showSDocDebug_ :: SDoc -> String
-showSDocDebug_ = normalize_newlines . showSDocDebug unsafeGlobalDynFlags
-
--- ---------------------------------------------------------------------
-
--- Copied from syb for the test
-
-
--- | The type constructor for queries
-newtype Q q x = Q { unQ :: x -> q }
-
--- | Extend a generic query by a type-specific case
-extQ :: ( Typeable a
-        , Typeable b
-        )
-     => (a -> q)
-     -> (b -> q)
-     -> a
-     -> q
-extQ f g a = maybe (f a) g (cast a)
-
--- | Type extension of queries for type constructors
-ext1Q :: (Data d, Typeable t)
-      => (d -> q)
-      -> (forall e. Data e => t e -> q)
-      -> d -> q
-ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
-
-
--- | Type extension of queries for type constructors
-ext2Q :: (Data d, Typeable t)
-      => (d -> q)
-      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
-      -> d -> q
-ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
-
--- | Flexible type extension
-ext1 :: (Data a, Typeable t)
-     => c a
-     -> (forall d. Data d => c (t d))
-     -> c a
-ext1 def ext = maybe def id (dataCast1 ext)
-
-
-
--- | Flexible type extension
-ext2 :: (Data a, Typeable t)
-     => c a
-     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
-     -> c a
-ext2 def ext = maybe def id (dataCast2 ext)