ghc-9.14.1: GHC/Hs/Dump.hs
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -fno-specialise #-}
-- Don't do type-class specialisation; it goes mad in this module
-- See #25463
-- | Contains a debug function to dump parts of the GHC.Hs 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 GHC.Hs.Dump (
-- * Dumping ASTs
showAstData,
showAstDataFull,
BlankSrcSpan(..),
BlankEpAnnotations(..),
) where
import GHC.Prelude
import GHC.Hs
import GHC.Core.DataCon
import GHC.Data.Bag
import GHC.Data.FastString
import GHC.Types.Name.Set
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Var
import GHC.Types.SourceText
import GHC.Utils.Outputable
import Data.Data hiding (Fixity)
import qualified Data.ByteString as B
import GHC.TypeLits
-- | Should source spans be removed from output.
data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan
deriving (Eq,Show)
-- | Should EpAnnotations be removed from output.
data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations
deriving (Eq,Show)
-- | Show the full AST as the compiler sees it.
showAstDataFull :: Data a => a -> SDoc
showAstDataFull = showAstData NoBlankSrcSpan NoBlankEpAnnotations
-- | 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 -> BlankEpAnnotations -> a -> SDoc
showAstData bs ba a0 = blankLine $$ showAstData' a0
where
showAstData' :: Data a => a -> SDoc
showAstData' =
generic
`ext1Q` list
`extQ` list_epaLocation
`extQ` list_epTokenOpenP
`extQ` list_epTokenCloseP
`extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan
`extQ` annotationModule
`extQ` annotationGrhsAnn
`extQ` annotationAnnList
`extQ` annotationAnnListWhere
`extQ` annotationAnnListCommas
`extQ` annotationAnnListIE
`extQ` annotationEpAnnImportDecl
`extQ` annotationNoEpAnns
`extQ` annotationExprBracket
`extQ` annotationTypedBracket
`extQ` epTokenOC
`extQ` epTokenCC
`extQ` epTokenInstance
`extQ` epTokenForall
`extQ` annParen
`extQ` annClassDecl
`extQ` annSynDecl
`extQ` annDataDefn
`extQ` annFamilyDecl
`extQ` annClsInstDecl
`extQ` lit `extQ` litr `extQ` litt
`extQ` sourceText
`extQ` deltaPos
`extQ` epaLocation
`extQ` maybe_epaLocation
`extQ` bytestring
`extQ` name `extQ` occName `extQ` moduleName `extQ` var
`extQ` dataCon
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
`ext2Q` located
`extQ` srcSpanAnnA
`extQ` srcSpanAnnL
`extQ` srcSpanAnnP
`extQ` srcSpanAnnC
`extQ` srcSpanAnnN
where generic :: Data a => a -> SDoc
generic t = parens $ text (showConstr (toConstr t))
$$ vcat (gmapQ showAstData' t)
string :: String -> SDoc
string = text . normalize_newlines . show
fastString :: FastString -> SDoc
fastString s = braces $
text "FastString:"
<+> text (normalize_newlines . show $ s)
bytestring :: B.ByteString -> SDoc
bytestring = text . normalize_newlines . show
list_epaLocation :: [EpaLocation] -> SDoc
list_epaLocation ls = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "[EpaLocation]"
NoBlankEpAnnotations -> list ls
list_epTokenOpenP :: [EpToken "("] -> SDoc
list_epTokenOpenP ls = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "[EpToken \"(\"]"
NoBlankEpAnnotations -> list ls
list_epTokenCloseP :: [EpToken ")"] -> SDoc
list_epTokenCloseP ls = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "[EpToken \"(\"]"
NoBlankEpAnnotations -> list ls
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 -> 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 -> 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 -> 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 -> SDoc
numericLit tag x s = braces $ hsep [ text tag
, generic x
, generic s ]
sourceText :: SourceText -> SDoc
sourceText NoSourceText = case bs of
BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"
_ -> parens $ text "NoSourceText"
sourceText (SourceText src) = case bs of
BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"
_ -> parens $ text "SourceText" <+> ftext src
epaLocation :: EpaLocation -> SDoc
epaLocation (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s
epaLocation (EpaDelta s d cs) = case ba of
NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> showAstData' cs
BlankEpAnnotations -> parens $ text "EpaDelta" <+> srcSpan s <+> deltaPos d <+> text "blanked"
maybe_epaLocation :: Maybe EpaLocation -> SDoc
maybe_epaLocation ml = case ba of
NoBlankEpAnnotations -> case ml of
Nothing -> parens $ text "Nothing"
Just l -> parens (text "Just" $$ showAstData' l)
BlankEpAnnotations -> parens $ text "Maybe EpaLocation:" <+> text "blanked"
deltaPos :: DeltaPos -> SDoc
deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c
deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c
name :: Name -> SDoc
name nm = braces $ text "Name:" <+> ppr nm
occName n = braces $
text "OccName:"
<+> ftext (occNameFS n)
moduleName :: ModuleName -> SDoc
moduleName m = braces $ text "ModuleName:" <+> ppr m
srcSpan :: SrcSpan -> SDoc
srcSpan ss = case bs of
BlankSrcSpan -> text "{ ss }"
NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '
BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' '
realSrcSpan :: RealSrcSpan -> SDoc
realSrcSpan ss = case bs of
BlankSrcSpan -> text "{ ss }"
NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '
BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' '
annParen :: AnnParen -> SDoc
annParen ap = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen"
NoBlankEpAnnotations -> parens (case ap of
(AnnParens o c) -> text "AnnParens" $$ vcat [showAstData' o, showAstData' c]
(AnnParensHash o c) -> text "AnnParensHash" $$ vcat [showAstData' o, showAstData' c]
(AnnParensSquare o c) -> text "AnnParensSquare" $$ vcat [showAstData' o, showAstData' c]
)
annClassDecl :: AnnClassDecl -> SDoc
annClassDecl (AnnClassDecl c ops cps v w oc cc s) = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnClassDecl"
NoBlankEpAnnotations ->
parens $ text "AnnClassDecl"
$$ vcat [showAstData' c, showAstData' ops, showAstData' cps,
showAstData' v, showAstData' w, showAstData' oc,
showAstData' cc, showAstData' s]
annSynDecl :: AnnSynDecl -> SDoc
annSynDecl (AnnSynDecl ops cps t e) = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnSynDecl"
NoBlankEpAnnotations ->
parens $ text "AnnSynDecl"
$$ vcat [showAstData' ops, showAstData' cps,
showAstData' t, showAstData' e]
annDataDefn :: AnnDataDefn -> SDoc
annDataDefn (AnnDataDefn a b c d e f g h i j k) = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnDataDefn"
NoBlankEpAnnotations ->
parens $ text "AnnDataDefn"
$$ vcat [showAstData' a, showAstData' b, showAstData' c,
showAstData' d, showAstData' e, showAstData' f,
showAstData' g, showAstData' h, showAstData' i,
showAstData' j, showAstData' k]
annFamilyDecl :: AnnFamilyDecl -> SDoc
annFamilyDecl (AnnFamilyDecl a b c d e f g h i j k l) = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"
NoBlankEpAnnotations ->
parens $ text "AnnFamilyDecl"
$$ vcat [showAstData' a, showAstData' b, showAstData' c,
showAstData' d, showAstData' e, showAstData' f,
showAstData' g, showAstData' h, showAstData' i,
showAstData' j, showAstData' k, showAstData' l]
annClsInstDecl :: AnnClsInstDecl -> SDoc
annClsInstDecl (AnnClsInstDecl a b c d e) = case ba of
BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnFamilyDecl"
NoBlankEpAnnotations ->
parens $ text "AnnClsInstDecl"
$$ vcat [showAstData' a, showAstData' b, showAstData' c,
showAstData' d, showAstData' e]
annotationExprBracket :: BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|") -> SDoc
annotationExprBracket = annotationBracket
annotationTypedBracket :: BracketAnn (EpToken "[||") (EpToken "[e||") -> SDoc
annotationTypedBracket = annotationBracket
annotationBracket ::forall n h .(Data n, Data h, Typeable n, Typeable h)
=> BracketAnn n h -> SDoc
annotationBracket a = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "BracketAnn"
NoBlankEpAnnotations ->
parens $ case a of
BracketNoE t -> text "BracketNoE" <+> showAstData' t
BracketHasE t -> text "BracketHasE" <+> showAstData' t
epTokenOC :: EpToken "{" -> SDoc
epTokenOC = epToken'
epTokenCC :: EpToken "}" -> SDoc
epTokenCC = epToken'
epTokenInstance :: EpToken "instance" -> SDoc
epTokenInstance = epToken'
epTokenForall :: TokForall -> SDoc
epTokenForall = epUniToken'
epToken' :: KnownSymbol sym => EpToken sym -> SDoc
epToken' (EpTok s) = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "EpToken"
NoBlankEpAnnotations ->
parens $ text "EpTok" <+> epaLocation s
epToken' NoEpTok = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "EpToken"
NoBlankEpAnnotations ->
parens $ text "NoEpTok"
epUniToken' :: EpUniToken sym1 sym2 -> SDoc
epUniToken' (EpUniTok s f) = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "EpUniToken"
NoBlankEpAnnotations ->
parens $ text "EpUniTok" <+> epaLocation s <+> ppr f
epUniToken' NoEpUniTok = case ba of
BlankEpAnnotations -> parens
$ text "blanked:" <+> text "EpUniToken"
NoBlankEpAnnotations ->
parens $ text "NoEpUniTok"
var :: Var -> SDoc
var v = braces $ text "Var:" <+> ppr v
dataCon :: DataCon -> SDoc
dataCon c = braces $ text "DataCon:" <+> ppr c
bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc
bagRdrName bg = braces $
text "Bag(LocatedA (HsBind GhcPs)):"
$$ (list . bagToList $ bg)
bagName :: Bag (LocatedA (HsBind GhcRn)) -> SDoc
bagName bg = braces $
text "Bag(LocatedA (HsBind Name)):"
$$ (list . bagToList $ bg)
bagVar :: Bag (LocatedA (HsBind GhcTc)) -> SDoc
bagVar bg = braces $
text "Bag(LocatedA (HsBind Var)):"
$$ (list . bagToList $ bg)
nameSet ns = braces $
text "NameSet:"
$$ (list . nameSetElemsStable $ ns)
located :: (Data a, Data b) => GenLocated a b -> SDoc
located (L ss a)
= parens (text "L"
$$ vcat [showAstData' ss, showAstData' a])
-- -------------------------
annotationModule :: EpAnn AnnsModule -> SDoc
annotationModule = annotation' (text "EpAnn AnnsModule")
annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc
annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")
annotationAnnList :: EpAnn (AnnList ()) -> SDoc
annotationAnnList = annotation' (text "EpAnn (AnnList ())")
annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc
annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))")
annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc
annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])")
annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc
annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))")
annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc
annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")
annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc
annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")
annotation' :: forall a .(Data a, Typeable a)
=> SDoc -> EpAnn a -> SDoc
annotation' tag anns = case ba of
BlankEpAnnotations -> parens (text "blanked:" <+> tag)
NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
$$ vcat (gmapQ showAstData' anns)
-- -------------------------
srcSpanAnnA :: EpAnn AnnListItem -> SDoc
srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc
srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")
srcSpanAnnP :: EpAnn AnnPragma -> SDoc
srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
srcSpanAnnC :: EpAnn AnnContext -> SDoc
srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")
srcSpanAnnN :: EpAnn NameAnn -> SDoc
srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
locatedAnn'' :: forall a. (Typeable a, Data a)
=> SDoc -> EpAnn a -> SDoc
locatedAnn'' tag ss = parens $
case cast ss of
Just (ann :: EpAnn a) ->
case ba of
BlankEpAnnotations
-> parens (text "blanked:" <+> tag)
NoBlankEpAnnotations
-> text (showConstr (toConstr ann))
$$ vcat (gmapQ showAstData' ann)
Nothing -> text "locatedAnn:unmatched" <+> tag
<+> (parens $ text (showConstr (toConstr ss)))
normalize_newlines :: String -> String
normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
normalize_newlines (x:xs) = x:normalize_newlines xs
normalize_newlines [] = []
{-
************************************************************************
* *
* 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)