Add dump-parsed-ast flag and functionality

Summary:
This flag causes a dump of the ParsedSource as an AST in textual form, similar
to the ghc-dump-tree on hackage.

Test Plan: ./validate

Reviewers: mpickering, bgamari, austin

Reviewed By: mpickering

Subscribers: nominolo, thomie

Differential Revision: https://phabricator.haskell.org/D2958

GHC Trac Issues: #11140

1 files changed, 3 insertions, 135 deletions

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)