content: {-
  (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)
  