never executed always true always false
    1 {-
    2 (c) The University of Glasgow 2006
    3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    4 -}
    5 {-# LANGUAGE RankNTypes #-}
    6 {-# LANGUAGE ScopedTypeVariables #-}
    7 
    8 -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb
    9 -- traversal which falls back to displaying based on the constructor name, so
   10 -- can be used to dump anything having a @Data.Data@ instance.
   11 
   12 module GHC.Hs.Dump (
   13         -- * Dumping ASTs
   14         showAstData,
   15         BlankSrcSpan(..),
   16         BlankEpAnnotations(..),
   17     ) where
   18 
   19 import GHC.Prelude
   20 
   21 import GHC.Hs
   22 
   23 import GHC.Core.DataCon
   24 
   25 import GHC.Data.Bag
   26 import GHC.Data.FastString
   27 import GHC.Types.Name.Set
   28 import GHC.Types.Name
   29 import GHC.Types.SrcLoc
   30 import GHC.Types.Var
   31 import GHC.Types.SourceText
   32 import GHC.Unit.Module
   33 import GHC.Utils.Outputable
   34 
   35 import Data.Data hiding (Fixity)
   36 import qualified Data.ByteString as B
   37 
   38 data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan
   39                   deriving (Eq,Show)
   40 
   41 data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations
   42                   deriving (Eq,Show)
   43 
   44 -- | Show a GHC syntax tree. This parameterised because it is also used for
   45 -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked
   46 -- out, to avoid comparing locations, only structure
   47 showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
   48 showAstData bs ba a0 = blankLine $$ showAstData' a0
   49   where
   50     showAstData' :: Data a => a -> SDoc
   51     showAstData' =
   52       generic
   53               `ext1Q` list
   54               `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan
   55               `extQ` annotation
   56               `extQ` annotationModule
   57               `extQ` annotationAddEpAnn
   58               `extQ` annotationGrhsAnn
   59               `extQ` annotationEpAnnHsCase
   60               `extQ` annotationAnnList
   61               `extQ` annotationEpAnnImportDecl
   62               `extQ` annotationAnnParen
   63               `extQ` annotationTrailingAnn
   64               `extQ` annotationEpaLocation
   65               `extQ` annotationNoEpAnns
   66               `extQ` addEpAnn
   67               `extQ` lit `extQ` litr `extQ` litt
   68               `extQ` sourceText
   69               `extQ` deltaPos
   70               `extQ` epaAnchor
   71               `extQ` bytestring
   72               `extQ` name `extQ` occName `extQ` moduleName `extQ` var
   73               `extQ` dataCon
   74               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
   75               `extQ` fixity
   76               `ext2Q` located
   77               `extQ` srcSpanAnnA
   78               `extQ` srcSpanAnnL
   79               `extQ` srcSpanAnnP
   80               `extQ` srcSpanAnnC
   81               `extQ` srcSpanAnnN
   82 
   83       where generic :: Data a => a -> SDoc
   84             generic t = parens $ text (showConstr (toConstr t))
   85                                   $$ vcat (gmapQ showAstData' t)
   86 
   87             string :: String -> SDoc
   88             string     = text . normalize_newlines . show
   89 
   90             fastString :: FastString -> SDoc
   91             fastString s = braces $
   92                             text "FastString:"
   93                         <+> text (normalize_newlines . show $ s)
   94 
   95             bytestring :: B.ByteString -> SDoc
   96             bytestring = text . normalize_newlines . show
   97 
   98             list []    = brackets empty
   99             list [x]   = brackets (showAstData' x)
  100             list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)
  101                                 $$ go x2 xs
  102               where
  103                 go y [] = text "," <> showAstData' y <> text "]"
  104                 go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys
  105 
  106             -- Eliminate word-size dependence
  107             lit :: HsLit GhcPs -> SDoc
  108             lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
  109             lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
  110             lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
  111             lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
  112             lit l                  = generic l
  113 
  114             litr :: HsLit GhcRn -> SDoc
  115             litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
  116             litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
  117             litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
  118             litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
  119             litr l                  = generic l
  120 
  121             litt :: HsLit GhcTc -> SDoc
  122             litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s
  123             litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s
  124             litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s
  125             litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s
  126             litt l                  = generic l
  127 
  128             numericLit :: String -> Integer -> SourceText -> SDoc
  129             numericLit tag x s = braces $ hsep [ text tag
  130                                                , generic x
  131                                                , generic s ]
  132 
  133             sourceText :: SourceText -> SDoc
  134             sourceText NoSourceText = parens $ text "NoSourceText"
  135             sourceText (SourceText src) = case bs of
  136               NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src
  137               BlankSrcSpanFile -> parens $ text "SourceText" <+> text src
  138               _                -> parens $ text "SourceText" <+> text "blanked"
  139 
  140             epaAnchor :: EpaLocation -> SDoc
  141             epaAnchor (EpaSpan r)  = parens $ text "EpaSpan" <+> realSrcSpan r
  142             epaAnchor (EpaDelta d cs) = case ba of
  143               NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs
  144               BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"
  145 
  146             deltaPos :: DeltaPos -> SDoc
  147             deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c
  148             deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c
  149 
  150             name :: Name -> SDoc
  151             name nm    = braces $ text "Name:" <+> ppr nm
  152 
  153             occName n  =  braces $
  154                           text "OccName:"
  155                       <+> text (occNameString n)
  156 
  157             moduleName :: ModuleName -> SDoc
  158             moduleName m = braces $ text "ModuleName:" <+> ppr m
  159 
  160             srcSpan :: SrcSpan -> SDoc
  161             srcSpan ss = case bs of
  162              BlankSrcSpan -> text "{ ss }"
  163              NoBlankSrcSpan -> braces $ char ' ' <>
  164                              (hang (ppr ss) 1
  165                                    -- TODO: show annotations here
  166                                    (text ""))
  167              BlankSrcSpanFile -> braces $ char ' ' <>
  168                              (hang (pprUserSpan False ss) 1
  169                                    -- TODO: show annotations here
  170                                    (text ""))
  171 
  172             realSrcSpan :: RealSrcSpan -> SDoc
  173             realSrcSpan ss = case bs of
  174              BlankSrcSpan -> text "{ ss }"
  175              NoBlankSrcSpan -> braces $ char ' ' <>
  176                              (hang (ppr ss) 1
  177                                    -- TODO: show annotations here
  178                                    (text ""))
  179              BlankSrcSpanFile -> braces $ char ' ' <>
  180                              (hang (pprUserRealSpan False ss) 1
  181                                    -- TODO: show annotations here
  182                                    (text ""))
  183 
  184 
  185             addEpAnn :: AddEpAnn -> SDoc
  186             addEpAnn (AddEpAnn a s) = case ba of
  187              BlankEpAnnotations -> parens
  188                                       $ text "blanked:" <+> text "AddEpAnn"
  189              NoBlankEpAnnotations ->
  190               parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s
  191 
  192             var  :: Var -> SDoc
  193             var v      = braces $ text "Var:" <+> ppr v
  194 
  195             dataCon :: DataCon -> SDoc
  196             dataCon c  = braces $ text "DataCon:" <+> ppr c
  197 
  198             bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc
  199             bagRdrName bg =  braces $
  200                              text "Bag(LocatedA (HsBind GhcPs)):"
  201                           $$ (list . bagToList $ bg)
  202 
  203             bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc
  204             bagName bg  =  braces $
  205                            text "Bag(LocatedA (HsBind Name)):"
  206                         $$ (list . bagToList $ bg)
  207 
  208             bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc
  209             bagVar bg  =  braces $
  210                           text "Bag(LocatedA (HsBind Var)):"
  211                        $$ (list . bagToList $ bg)
  212 
  213             nameSet ns =  braces $
  214                           text "NameSet:"
  215                        $$ (list . nameSetElemsStable $ ns)
  216 
  217             fixity :: Fixity -> SDoc
  218             fixity fx =  braces $
  219                          text "Fixity:"
  220                      <+> ppr fx
  221 
  222             located :: (Data a, Data b) => GenLocated a b -> SDoc
  223             located (L ss a)
  224               = parens (text "L"
  225                         $$ vcat [showAstData' ss, showAstData' a])
  226 
  227 
  228             -- -------------------------
  229 
  230             annotation :: EpAnn [AddEpAnn] -> SDoc
  231             annotation = annotation' (text "EpAnn [AddEpAnn]")
  232 
  233             annotationModule :: EpAnn AnnsModule -> SDoc
  234             annotationModule = annotation' (text "EpAnn AnnsModule")
  235 
  236             annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc
  237             annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")
  238 
  239             annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc
  240             annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")
  241 
  242             annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc
  243             annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")
  244 
  245             annotationAnnList :: EpAnn AnnList -> SDoc
  246             annotationAnnList = annotation' (text "EpAnn AnnList")
  247 
  248             annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc
  249             annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")
  250 
  251             annotationAnnParen :: EpAnn AnnParen -> SDoc
  252             annotationAnnParen = annotation' (text "EpAnn AnnParen")
  253 
  254             annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc
  255             annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")
  256 
  257             annotationEpaLocation :: EpAnn EpaLocation -> SDoc
  258             annotationEpaLocation = annotation' (text "EpAnn EpaLocation")
  259 
  260             annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc
  261             annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")
  262 
  263             annotation' :: forall a .(Data a, Typeable a)
  264                        => SDoc -> EpAnn a -> SDoc
  265             annotation' tag anns = case ba of
  266              BlankEpAnnotations -> parens (text "blanked:" <+> tag)
  267              NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))
  268                                                $$ vcat (gmapQ showAstData' anns)
  269 
  270             -- -------------------------
  271 
  272             srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc
  273             srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")
  274 
  275             srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc
  276             srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")
  277 
  278             srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc
  279             srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")
  280 
  281             srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc
  282             srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")
  283 
  284             srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc
  285             srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")
  286 
  287             locatedAnn'' :: forall a. (Typeable a, Data a)
  288               => SDoc -> SrcSpanAnn' a -> SDoc
  289             locatedAnn'' tag ss = parens $
  290               case cast ss of
  291                 Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->
  292                   case ba of
  293                     BlankEpAnnotations
  294                       -> parens (text "blanked:" <+> tag)
  295                     NoBlankEpAnnotations
  296                       -> text "SrcSpanAnn" <+> showAstData' ann
  297                               <+> srcSpan s
  298                 Nothing -> text "locatedAnn:unmatched" <+> tag
  299                            <+> (parens $ text (showConstr (toConstr ss)))
  300 
  301 
  302 normalize_newlines :: String -> String
  303 normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs
  304 normalize_newlines (x:xs)                 = x:normalize_newlines xs
  305 normalize_newlines []                     = []
  306 
  307 {-
  308 ************************************************************************
  309 *                                                                      *
  310 * Copied from syb
  311 *                                                                      *
  312 ************************************************************************
  313 -}
  314 
  315 
  316 -- | The type constructor for queries
  317 newtype Q q x = Q { unQ :: x -> q }
  318 
  319 -- | Extend a generic query by a type-specific case
  320 extQ :: ( Typeable a
  321         , Typeable b
  322         )
  323      => (a -> q)
  324      -> (b -> q)
  325      -> a
  326      -> q
  327 extQ f g a = maybe (f a) g (cast a)
  328 
  329 -- | Type extension of queries for type constructors
  330 ext1Q :: (Data d, Typeable t)
  331       => (d -> q)
  332       -> (forall e. Data e => t e -> q)
  333       -> d -> q
  334 ext1Q def ext = unQ ((Q def) `ext1` (Q ext))
  335 
  336 
  337 -- | Type extension of queries for type constructors
  338 ext2Q :: (Data d, Typeable t)
  339       => (d -> q)
  340       -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)
  341       -> d -> q
  342 ext2Q def ext = unQ ((Q def) `ext2` (Q ext))
  343 
  344 -- | Flexible type extension
  345 ext1 :: (Data a, Typeable t)
  346      => c a
  347      -> (forall d. Data d => c (t d))
  348      -> c a
  349 ext1 def ext = maybe def id (dataCast1 ext)
  350 
  351 
  352 
  353 -- | Flexible type extension
  354 ext2 :: (Data a, Typeable t)
  355      => c a
  356      -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))
  357      -> c a
  358 ext2 def ext = maybe def id (dataCast2 ext)