Commit 29da01e0 authored by David Feuer's avatar David Feuer Committed by David Feuer

Make parsed AST dump output lazily

Previously, `showAstData` produced a `String`. That `String` would
then be converted to a `Doc` using `text` to implement
`-ddump-parsed-ast`. But rendering `text` calculates the length
of the `String` before doing anything else. Since the AST can be
very large, this was bad: the whole dump string (potentially hundreds
of millions of `Char`s) was accumulated in memory.

Now, `showAstData` produces a `Doc` directly, which seems to work
a lot better. As an extra bonus, the code is simpler and cleaner.
The formatting has changed a bit, as the previous ad hoc approach
didn't really match the pretty printer too well. If someone cares
enough to request adjustments, we can surely make them.

Reviewers: austin, bgamari, mpickering, alanz

Reviewed By: bgamari

Subscribers: mpickering, rwbarton, thomie

GHC Trac Issues: #14161

Differential Revision: https://phabricator.haskell.org/D3894
parent 682e8e6e
......@@ -16,7 +16,6 @@ module HsDumpAst (
) where
import Data.Data hiding (Fixity)
import Data.List
import Bag
import BasicTypes
import FastString
......@@ -28,8 +27,7 @@ import HsSyn
import OccName hiding (occName)
import Var
import Module
import DynFlags
import Outputable hiding (space)
import Outputable
import qualified Data.ByteString as B
......@@ -39,11 +37,11 @@ data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan
-- | 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
showAstData :: Data a => BlankSrcSpan -> a -> SDoc
showAstData b a0 = blankLine $$ showAstData' a0
where
showAstData' :: Data a => Int -> a -> String
showAstData' n =
showAstData' :: Data a => a -> SDoc
showAstData' =
generic
`ext1Q` list
`extQ` string `extQ` fastString `extQ` srcSpan
......@@ -54,118 +52,118 @@ showAstData b = showAstData' 0
`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
where generic :: Data a => a -> SDoc
generic t = parens $ text (showConstr (toConstr t))
$$ vcat (gmapQ showAstData' t)
indent i = "\n" ++ replicate i ' '
string :: String -> SDoc
string = text . normalize_newlines . show
string :: String -> String
string = normalize_newlines . show
fastString :: FastString -> SDoc
fastString s = braces $
text "FastString: "
<> text (normalize_newlines . show $ s)
fastString :: FastString -> String
fastString = ("{FastString: "++) . (++"}") . normalize_newlines
. show
bytestring :: B.ByteString -> SDoc
bytestring = text . normalize_newlines . show
bytestring :: B.ByteString -> String
bytestring = normalize_newlines . show
list l = indent n ++ "["
++ intercalate "," (map (showAstData' (n+1)) l)
++ "]"
list [] = brackets empty
list [x] = brackets (showAstData' x)
list (x1 : x2 : xs) = (text "[" <> showAstData' x1)
$$ go x2 xs
where
go y [] = text "," <> showAstData' y <> text "]"
go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
-- Eliminate word-size dependence
lit :: HsLit GhcPs -> String
lit :: HsLit GhcPs -> SDoc
lit (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
lit (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
lit (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
lit l = generic l
litr :: HsLit GhcRn -> String
litr :: HsLit GhcRn -> SDoc
litr (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
litr (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
litr (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
litr l = generic l
litt :: HsLit GhcTc -> String
litt :: HsLit GhcTc -> SDoc
litt (HsWordPrim s x) = numericLit "HsWord{64}Prim" x s
litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
litt (HsIntPrim s x) = numericLit "HsInt{64}Prim" x s
litt (HsInt64Prim s x) = numericLit "HsInt{64}Prim" x s
litt l = generic l
numericLit :: String -> Integer -> SourceText -> String
numericLit tag x s = indent n ++ unwords [ "{" ++ tag
, generic x
, generic s ++ "}" ]
numericLit :: String -> Integer -> SourceText -> SDoc
numericLit tag x s = braces $ hsep [ text tag
, generic x
, generic s ]
name :: Name -> String
name = ("{Name: "++) . (++"}") . showSDocDebug_ . ppr
name :: Name -> SDoc
name nm = braces $ text "Name: " <> ppr nm
occName = ("{OccName: "++) . (++"}") . OccName.occNameString
occName n = braces $
text "OccName: "
<> text (OccName.occNameString n)
moduleName :: ModuleName -> String
moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . ppr
moduleName :: ModuleName -> SDoc
moduleName m = braces $ text "ModuleName: " <> ppr m
srcSpan :: SrcSpan -> String
srcSpan :: SrcSpan -> SDoc
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 GhcPs)) -> String
bagRdrName = ("{Bag(Located (HsBind GhcPs)): "++) . (++"}")
. list . bagToList
bagName :: Bag (Located (HsBind GhcRn)) -> String
bagName = ("{Bag(Located (HsBind Name)): "++) . (++"}")
. list . bagToList
bagVar :: Bag (Located (HsBind GhcTc)) -> 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
BlankSrcSpan -> text "{ ss }"
NoBlankSrcSpan -> braces $ char ' ' <>
(hang (ppr ss) 1
-- TODO: show annotations here
(text ""))
var :: Var -> SDoc
var v = braces $ text "Var: " <> ppr v
dataCon :: DataCon -> SDoc
dataCon c = braces $ text "DataCon: " <> ppr c
bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc
bagRdrName bg = braces $
text "Bag(Located (HsBind GhcPs)):"
$$ (list . bagToList $ bg)
bagName :: Bag (Located (HsBind GhcRn)) -> SDoc
bagName bg = braces $
text "Bag(Located (HsBind Name)):"
$$ (list . bagToList $ bg)
bagVar :: Bag (Located (HsBind GhcTc)) -> SDoc
bagVar bg = braces $
text "Bag(Located (HsBind Var)):"
$$ (list . bagToList $ bg)
nameSet ns = braces $
text "NameSet:"
$$ (list . nameSetElemsStable $ ns)
fixity :: Fixity -> SDoc
fixity fx = braces $
text "Fixity: "
<> ppr fx
located :: (Data b,Data loc) => GenLocated loc b -> SDoc
located (L ss a) = parens $
case cast ss of
Just (s :: SrcSpan) ->
srcSpan s
Nothing -> "nnnnnnnn"
++ showAstData' (n+1) a
++ ")"
Nothing -> text "nnnnnnnn"
$$ showAstData' 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
{-
************************************************************************
* *
......
......@@ -340,7 +340,7 @@ hscParse' mod_summary
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)
showAstData NoBlankSrcSpan rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
......@@ -1713,7 +1713,7 @@ hscParseThingWithLocation source linenumber parser str
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
showAstData NoBlankSrcSpan thing
return thing
......
......@@ -2514,7 +2514,7 @@ rnDump :: (Outputable a, Data a) => a -> TcRn ()
-- Dump, with a banner, if -ddump-rn
rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn))
; traceOptTcRn Opt_D_dump_rn_ast
(mkDumpDoc "Renamer" (text (showAstData NoBlankSrcSpan rn))) }
(mkDumpDoc "Renamer" (showAstData NoBlankSrcSpan rn)) }
tcDump :: TcGblEnv -> TcRn ()
tcDump env
......@@ -2535,7 +2535,7 @@ tcDump env
full_dump = pprLHsBinds (tcg_binds env)
-- NB: foreign x-d's have undefined's in their types;
-- hence can't show the tc_fords
ast_dump = text (showAstData NoBlankSrcSpan (tcg_binds env))
ast_dump = showAstData NoBlankSrcSpan (tcg_binds env)
-- It's unpleasant having both pprModGuts and pprModDetails here
pprTcGblEnv :: TcGblEnv -> SDoc
......
......@@ -2,236 +2,243 @@
==================== Parser AST ====================
({ DumpParsedAst.hs:1:1 }
(HsModule
(Just
({ DumpParsedAst.hs:3:8-20 }{ModuleName: DumpParsedAst}))
(Nothing)
[]
[
({ DumpParsedAst.hs:5:1-30 }
(TyClD
(DataDecl
(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)
(Unqual
{OccName: Peano}))
(HsQTvs
(PlaceHolder)
[]
(PlaceHolder))
(Prefix)
(HsDataDefn
(DataType)
({ <no location info> }
[])
(Nothing)
(Nothing)
[
({ DumpParsedAst.hs:5:14-17 }
(ConDeclH98
[])
(Nothing)
(Nothing)
[({ DumpParsedAst.hs:5:14-17 }
(ConDeclH98
({ DumpParsedAst.hs:5:14-17 }
(Unqual {OccName: Zero}))
(Nothing)
(Just
(Unqual
{OccName: Zero}))
(Nothing)
(Just
({ <no location info> }
[]))
(PrefixCon
[])
(Nothing))),
({ DumpParsedAst.hs:5:21-30 }
(ConDeclH98
[]))
(PrefixCon
[])
(Nothing)))
,({ DumpParsedAst.hs:5:21-30 }
(ConDeclH98
({ DumpParsedAst.hs:5:21-24 }
(Unqual {OccName: Succ}))
(Nothing)
(Just
(Unqual
{OccName: Succ}))
(Nothing)
(Just
({ <no location info> }
[]))
(PrefixCon
[
({ DumpParsedAst.hs:5:26-30 }
(HsTyVar
(NotPromoted)
[]))
(PrefixCon
[({ DumpParsedAst.hs:5:26-30 }
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:5:26-30 }
(Unqual {OccName: Peano}))))])
(Nothing)))]
(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
[]))
(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
(Unqual
{OccName: Length}))
(HsIB
(PlaceHolder)
[({ DumpParsedAst.hs:8:10-17 }
(HsParTy
({ DumpParsedAst.hs:8:11-16 }
(HsAppsTy
[
({ DumpParsedAst.hs:8:11 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:8:11 }
(HsAppPrefix
({ DumpParsedAst.hs:8:11 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:11 }
(Unqual {OccName: a})))))),
({ DumpParsedAst.hs:8:13 }
(HsAppInfix
(Unqual
{OccName: a}))))))
,({ DumpParsedAst.hs:8:13 }
(HsAppInfix
({ DumpParsedAst.hs:8:13 }
(Exact {Name: ghc-prim:GHC.Types.:{(w) d}})))),
({ DumpParsedAst.hs:8:15-16 }
(HsAppPrefix
(Exact
{Name: :}))))
,({ DumpParsedAst.hs:8:15-16 }
(HsAppPrefix
({ DumpParsedAst.hs:8:15-16 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:15-16 }
(Unqual {OccName: as}))))))]))))]
(PlaceHolder))
(Prefix)
(Unqual
{OccName: as}))))))]))))]
(PlaceHolder))
(Prefix)
({ DumpParsedAst.hs:8:21-36 }
(HsAppsTy
[
({ DumpParsedAst.hs:8:21-24 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:8:21-24 }
(HsAppPrefix
({ DumpParsedAst.hs:8:21-24 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:21-24 }
(Unqual {OccName: Succ})))))),
({ DumpParsedAst.hs:8:26-36 }
(HsAppPrefix
(Unqual
{OccName: Succ}))))))
,({ DumpParsedAst.hs:8:26-36 }
(HsAppPrefix
({ DumpParsedAst.hs:8:26-36 }
(HsParTy
(HsParTy
({ DumpParsedAst.hs:8:27-35 }
(HsAppsTy
[
({ DumpParsedAst.hs:8:27-32 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:8:27-32 }
(HsAppPrefix
({ DumpParsedAst.hs:8:27-32 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:27-32 }
(Unqual {OccName: Length})))))),
({ DumpParsedAst.hs:8:34-35 }
(HsAppPrefix
(Unqual
{OccName: Length}))))))
,({ DumpParsedAst.hs:8:34-35 }
(HsAppPrefix
({ DumpParsedAst.hs:8:34-35 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:8:34-35 }
(Unqual {OccName: as}))))))]))))))])))),
({ DumpParsedAst.hs:9:3-24 }
(TyFamEqn
(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)
[]))]
(PlaceHolder))
(Prefix)
(Unqual
{OccName: Length}))
(HsIB
(PlaceHolder)
[({ DumpParsedAst.hs:9:10-12 }
(HsExplicitListTy
(Promoted)
(PlaceHolder)
[]))]
(PlaceHolder))
(Prefix)
({ DumpParsedAst.hs:9:21-24 }
(HsAppsTy
[
({ DumpParsedAst.hs:9:21-24 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:9:21-24 }
(HsAppPrefix
({ DumpParsedAst.hs:9:21-24 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:9:21-24 }
(Unqual {OccName: Zero}))))))]))))]))
(Unqual
{OccName: Zero}))))))]))))]))
({ DumpParsedAst.hs:7:13-18 }
(Unqual {OccName: Length}))
(HsQTvs
(PlaceHolder)
[
({ DumpParsedAst.hs:7:20-30 }
(KindedTyVar
(Unqual
{OccName: Length}))
(HsQTvs
(PlaceHolder)
[({ DumpParsedAst.hs:7:20-30 }
(KindedTyVar
({ DumpParsedAst.hs:7:21-22 }
(Unqual {OccName: as}))
(Unqual
{OccName: as}))
({ DumpParsedAst.hs:7:27-29 }
(HsAppsTy
[
({ DumpParsedAst.hs:7:27-29 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:7:27-29 }
(HsAppPrefix
({ DumpParsedAst.hs:7:27-29 }
(HsListTy
(HsListTy
({ DumpParsedAst.hs:7:28 }
(HsAppsTy
[
({ DumpParsedAst.hs:7:28 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:7:28 }
(HsAppPrefix
({ DumpParsedAst.hs:7:28 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:7:28 }
(Unqual {OccName: k}))))))]))))))]))))]
(PlaceHolder))
(Prefix)
(Unqual
{OccName: k}))))))]))))))]))))]
(PlaceHolder))
(Prefix)
({ DumpParsedAst.hs:7:32-39 }
(KindSig
(KindSig
({ DumpParsedAst.hs:7:35-39 }
(HsAppsTy
[
({ DumpParsedAst.hs:7:35-39 }
(HsAppPrefix
(HsAppsTy
[({ DumpParsedAst.hs:7:35-39 }
(HsAppPrefix
({ DumpParsedAst.hs:7:35-39 }
(HsTyVar
(NotPromoted)
(HsTyVar
(NotPromoted)
({ DumpParsedAst.hs:7:35-39 }
(Unqual {OccName: Peano}))))))]))))
(Nothing))))),
({ DumpParsedAst.hs:11:1-23 }
(ValD
(FunBind
(Unqual
{OccName: Peano}))))))]))))