hsSyn/HsDumpAst.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 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 BasicTypes
    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` lit
                  `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)
                                    ++ "]"

                -- Eliminate word-size dependence
                lit :: HsLit -> String
                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

                numericLit :: String -> Integer -> SourceText -> String
                numericLit tag x s = indent n ++ unwords [ "{" ++ tag
                                                         , generic x
                                                         , generic s ++ "}" ]

                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)