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

4 files changed, 205 insertions, 2 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