GHC/Hs/Dump.hs

    {-
    (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 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,
            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.Unit.Module
    import GHC.Utils.Outputable

    import Data.Data hiding (Fixity)
    import qualified Data.ByteString as B

    data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan
                      deriving (Eq,Show)

    data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations
                      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 -> BlankEpAnnotations -> a -> SDoc
    showAstData bs ba a0 = blankLine $$ showAstData' a0
      where
        showAstData' :: Data a => a -> SDoc
        showAstData' =
          generic
                  `ext1Q` list
                  `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan
                  `extQ` annotation
                  `extQ` annotationModule
                  `extQ` annotationAddEpAnn
                  `extQ` annotationGrhsAnn
                  `extQ` annotationEpAnnHsCase
                  `extQ` annotationEpAnnHsLet
                  `extQ` annotationAnnList
                  `extQ` annotationEpAnnImportDecl
                  `extQ` annotationAnnParen
                  `extQ` annotationTrailingAnn
                  `extQ` addEpAnn
                  `extQ` lit `extQ` litr `extQ` litt
                  `extQ` sourceText
                  `extQ` deltaPos
                  `extQ` epaAnchor
                  `extQ` bytestring
                  `extQ` name `extQ` occName `extQ` moduleName `extQ` var
                  `extQ` dataCon
                  `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
                  `extQ` fixity
                  `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 []    = 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 = parens $ text "NoSourceText"
                sourceText (SourceText src) = case bs of
                  NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src
                  BlankSrcSpanFile -> parens $ text "SourceText" <+> text src
                  _                -> parens $ text "SourceText" <+> text "blanked"

                epaAnchor :: EpaLocation -> SDoc
                epaAnchor (EpaSpan r)  = parens $ text "EpaSpan" <+> realSrcSpan r
                epaAnchor (EpaDelta d) = parens $ text "EpaDelta" <+> deltaPos d

                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:"
                          <+> text (occNameString 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 ' ' <>
                                 (hang (ppr ss) 1
                                       -- TODO: show annotations here
                                       (text ""))
                 BlankSrcSpanFile -> braces $ char ' ' <>
                                 (hang (pprUserSpan False ss) 1
                                       -- TODO: show annotations here
                                       (text ""))

                realSrcSpan :: RealSrcSpan -> SDoc
                realSrcSpan ss = case bs of
                 BlankSrcSpan -> text "{ ss }"
                 NoBlankSrcSpan -> braces $ char ' ' <>
                                 (hang (ppr ss) 1
                                       -- TODO: show annotations here
                                       (text ""))
                 BlankSrcSpanFile -> braces $ char ' ' <>
                                 (hang (pprUserRealSpan False ss) 1
                                       -- TODO: show annotations here
                                       (text ""))

                addEpAnn :: AddEpAnn -> SDoc
                addEpAnn (AddEpAnn a s) = case ba of
                 BlankEpAnnotations -> parens
                                          $ text "blanked:" <+> text "AddEpAnn"
                 NoBlankEpAnnotations ->
                  parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s

                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)

                fixity :: Fixity -> SDoc
                fixity fx =  braces $
                             text "Fixity:"
                         <+> ppr fx

                located :: (Data a, Data b) => GenLocated a b -> SDoc
                located (L ss a)
                  = parens (text "L"
                            $$ vcat [showAstData' ss, showAstData' a])

                -- -------------------------

                annotation :: EpAnn [AddEpAnn] -> SDoc
                annotation = annotation' (text "EpAnn [AddEpAnn]")

                annotationModule :: EpAnn AnnsModule -> SDoc
                annotationModule = annotation' (text "EpAnn AnnsModule")

                annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc
                annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")

                annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc
                annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")

                annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc
                annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")

                annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc
                annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")

                annotationAnnList :: EpAnn AnnList -> SDoc
                annotationAnnList = annotation' (text "EpAnn AnnList")

                annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc
                annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")

                annotationAnnParen :: EpAnn AnnParen -> SDoc
                annotationAnnParen = annotation' (text "EpAnn AnnParen")

                annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc
                annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")

                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 :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc
                srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")

                srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc
                srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")

                srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc
                srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")

                srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc
                srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")

                srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc
                srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")

                locatedAnn'' :: forall a. (Typeable a, Data a)
                  => SDoc -> SrcSpanAnn' a -> SDoc
                locatedAnn'' tag ss = parens $
                  case cast ss of
                    Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->
                      case ba of
                        BlankEpAnnotations
                          -> parens (text "blanked:" <+> tag)
                        NoBlankEpAnnotations
                          -> text "SrcSpanAnn" <+> showAstData' ann
                                  <+> srcSpan s
                    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)