Commit 1ff3c588 authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

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
parent 9d67f04d
......@@ -313,6 +313,7 @@ Library
HsSyn
HsTypes
HsUtils
HsDumpAst
BinIface
BinFingerprint
BuildTyCl
......
{-
(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)
......@@ -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"
......
......@@ -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
......
......@@ -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
......
{-# 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
==================== 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)))))]