ghc-syb (empty) → 0.1

raw patch · 5 files changed

+715/−0 lines, 5 filesdep +basedep +ghcdep +sybsetup-changed

Dependencies added: base, ghc, syb

Files

LICENSE +29/−0
Setup.hs +4/−0
ghc-syb.cabal +27/−0
src/GHC/SYB/Instances.hs +398/−0
src/GHC/SYB/Utils.hs +257/−0

+ LICENSE view

@@ -0,0 +1,29 @@+Copyright 2008, Claus Reinke
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.
+ 
+- Redistributions in binary form must reproduce the above copyright notice,
+this list of conditions and the following disclaimer in the documentation
+and/or other materials provided with the distribution.
+ 
+- Neither name of the author nor the names of its contributors may be
+used to endorse or promote products derived from this software without
+specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR(S) AND THE CONTRIBUTORS "AS
+IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE UNIVERSITY
+COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
+GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
+IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main :: IO ()
+main = defaultMain

+ ghc-syb.cabal view

@@ -0,0 +1,27 @@+name:            ghc-syb
+version:         0.1
+license:         BSD3
+license-file:    LICENSE
+author:          Claus Reinke
+copyright:       (c) Claus Reinke 2008
+maintainer:      Thomas Schilling <nominolo@googlemail.com>
+homepage:        http://github.com/nominolo/ghc-syb
+description:     Scrap Your Boilerplate instances and utils for the GHC API.
+synopsis:        SYB instances for the GHC API
+category:        Development
+stability:       provisional
+build-type:      Simple
+cabal-version:   >= 1.2
+tested-with:     GHC ==6.10.1
+-- extra-source-files: README
+
+library
+  build-depends:   base >= 4 && < 5,
+                   syb >= 0.1 && < 0.2,
+                   ghc >= 6.10 && < 6.12
+  hs-source-dirs:  src
+  extensions:      CPP, TypeSynonymInstances, StandaloneDeriving,
+                   DeriveDataTypeable, ScopedTypeVariables,
+                   RankNTypes
+  exposed-modules: GHC.SYB.Instances,
+                   GHC.SYB.Utils

+ src/GHC/SYB/Instances.hs view

@@ -0,0 +1,398 @@+{- | "GHC.Syb.Instances" provides instances of Data\/Typeable
+     for Ghc Api types, using standalone deriving.
+
+Most instances are standard; to provide 'Data' instances 
+abstract types, we use one of two schemes:
+
+- no traversal: 'SrcSpan', 'Module', 'ModuleName', 'OccName', 'Name', 
+                'FastString', 'DataCon', 'Var', 'TyCon', 'Class'
+
+@
+    abstractConstr   n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
+    abstractDataType n = mkDataType n [abstractConstr n]
+@
+
+@
+    instance Data SrcSpan where
+      -- don't traverse?
+      toConstr _   = abstractConstr "SrcSpan"
+      gunfold _ _  = error "gunfold"
+      dataTypeOf _ = mkNorepType "SrcSpan"
+@
+
+- abstract traversal: 'NameSet', 'Bag'
+
+@
+    instance Data NameSet where
+      gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly
+      toConstr _   = abstractConstr "NameSet"
+      gunfold _ _  = error "gunfold"
+      dataTypeOf _ = mkNorepType "NameSet"
+@
+
+Please report any issues, either with these abstract instances or with
+these modules going out of sync with GHC head, to the package maintainer.
+
+-}
+module GHC.SYB.Instances where
+
+import GHC hiding(TyCon)
+import SrcLoc
+import RdrName
+import OccName
+import FastString
+import Bag
+import Module
+import BasicTypes
+import Var
+import ForeignCall
+
+import Data.Data
+import NameSet
+import TypeRep
+import qualified TyCon
+
+#include "Typeable.h"
+
+#ifdef __HADDOCK__
+#else
+
+-- TODO: good for generalized show, but is this sound in general?
+abstractConstr   n = mkConstr (abstractDataType n) ("{abstract:"++n++"}") [] Prefix
+abstractDataType n = mkDataType n [abstractConstr n]
+
+-- Typeable0
+
+INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan")
+instance Data SrcSpan where
+  -- don't traverse?
+  toConstr _   = abstractConstr "SrcSpan"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "SrcSpan"
+
+INSTANCE_TYPEABLE0(Module,moduleTc,"Module")
+instance Data Module where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Module"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Module"
+
+INSTANCE_TYPEABLE0(ModuleName,moduleNameTc,"ModuleName")
+instance Data ModuleName where
+  -- don't traverse?
+  toConstr _   = abstractConstr "ModuleName"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "ModuleName"
+
+deriving instance Typeable RdrName
+deriving instance Data RdrName
+
+INSTANCE_TYPEABLE0(OccName,occNameTc,"OccName")
+instance Data OccName where
+  -- don't traverse?
+  toConstr _   = abstractConstr "OccName"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "OccName"
+
+INSTANCE_TYPEABLE0(Name,nameTc,"Name")
+instance Data Name where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Name"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Name"
+
+deriving instance Typeable FastString
+instance Data FastString where
+  -- don't traverse?
+  toConstr _   = abstractConstr "FastString"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "FastString"
+
+deriving instance Typeable HsExplicitForAll
+deriving instance Data HsExplicitForAll
+
+deriving instance Typeable HsBang
+deriving instance Data HsBang
+
+deriving instance Typeable Boxity
+deriving instance Data Boxity
+
+deriving instance Typeable OverLitVal
+deriving instance Data OverLitVal
+
+deriving instance Typeable RecFlag
+deriving instance Data RecFlag
+
+deriving instance Typeable BasicTypes.Fixity
+deriving instance Data BasicTypes.Fixity
+
+deriving instance Typeable HsArrAppType
+deriving instance Data HsArrAppType
+
+deriving instance Typeable FixityDirection
+deriving instance Data FixityDirection
+
+INSTANCE_TYPEABLE0(DataCon,dataConTc,"DataCon")
+instance Data DataCon where
+  -- don't traverse?
+  toConstr _   = abstractConstr "DataCon"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "DataCon"
+
+INSTANCE_TYPEABLE0(Var,varTc,"Var")
+instance Data Var where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Var"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Var"
+
+deriving instance Typeable InlineSpec
+deriving instance Data InlineSpec
+
+deriving instance Typeable ForeignImport
+deriving instance Data ForeignImport
+
+deriving instance Typeable ForeignExport
+deriving instance Data ForeignExport
+
+deriving instance Typeable CImportSpec
+deriving instance Data CImportSpec
+
+deriving instance Typeable CExportSpec
+deriving instance Data CExportSpec
+
+deriving instance Typeable DNCallSpec
+deriving instance Data DNCallSpec
+
+deriving instance Typeable Safety
+deriving instance Data Safety
+
+deriving instance Typeable CCallConv
+deriving instance Data CCallConv
+
+deriving instance Typeable DNKind
+deriving instance Data DNKind
+
+deriving instance Typeable DNType
+deriving instance Data DNType
+
+deriving instance Typeable CCallTarget
+deriving instance Data CCallTarget
+
+deriving instance Typeable Activation
+deriving instance Data Activation
+
+INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet")
+instance Data NameSet where
+  gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly
+  toConstr _   = abstractConstr "NameSet"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "NameSet"
+
+deriving instance Typeable FoType
+deriving instance Data FoType
+
+deriving instance Typeable FamilyFlavour
+deriving instance Data FamilyFlavour
+
+deriving instance Typeable NewOrData
+deriving instance Data NewOrData
+
+INSTANCE_TYPEABLE0(TyCon.TyCon,tyConTc,"TyCon")
+instance Data TyCon.TyCon where
+  -- don't traverse?
+  toConstr _   = abstractConstr "TyCon.TyCon"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "TyCon.TyCon"
+
+INSTANCE_TYPEABLE0(Class,classTc,"Class")
+instance Data Class where
+  -- don't traverse?
+  toConstr _   = abstractConstr "Class"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Class"
+
+deriving instance Typeable Prag
+deriving instance Data Prag
+
+deriving instance Typeable HsWrapper
+deriving instance Data HsWrapper
+
+deriving instance Typeable PredType
+deriving instance Data PredType
+
+deriving instance Typeable Type
+deriving instance Data Type
+
+deriving instance Typeable HsLit
+deriving instance Data HsLit
+
+-- Typeable1
+
+deriving instance Typeable1 Located
+deriving instance Data e => Data (Located e)
+
+deriving instance Typeable1 HsModule
+deriving instance Data a => Data (HsModule a)
+
+deriving instance Typeable1 HsDoc
+deriving instance Data a => Data (HsDoc a)
+
+deriving instance Typeable1 HaddockModInfo
+deriving instance Data a => Data (HaddockModInfo a)
+
+deriving instance Typeable1 HsDecl
+deriving instance Data a => Data (HsDecl a)
+
+deriving instance Typeable1 ImportDecl
+deriving instance Data a => Data (ImportDecl a)
+
+deriving instance Typeable1 IE
+deriving instance Data a => Data (IE a)
+
+deriving instance Typeable1 TyClDecl
+deriving instance Data a => Data (TyClDecl a)
+
+deriving instance Typeable1 DocDecl
+deriving instance Data a => Data (DocDecl a)
+
+deriving instance Typeable1 SpliceDecl
+deriving instance Data a => Data (SpliceDecl a)
+
+deriving instance Typeable1 RuleDecl
+deriving instance Data a => Data (RuleDecl a)
+
+deriving instance Typeable WarningTxt
+deriving instance Data WarningTxt
+
+deriving instance Typeable1 WarnDecl
+deriving instance Data a => Data (WarnDecl a)
+
+deriving instance Typeable1 ForeignDecl
+deriving instance Data a => Data (ForeignDecl a)
+
+deriving instance Typeable1 DefaultDecl
+deriving instance Data a => Data (DefaultDecl a)
+
+deriving instance Typeable1 Sig
+deriving instance Data a => Data (Sig a)
+
+deriving instance Typeable1 DerivDecl
+deriving instance Data a => Data (DerivDecl a)
+
+deriving instance Typeable1 InstDecl
+deriving instance Data a => Data (InstDecl a)
+
+deriving instance Typeable1 HsPred
+deriving instance Data a => Data (HsPred a)
+
+deriving instance Typeable1 HsType
+deriving instance Data a => Data (HsType a)
+
+deriving instance Typeable1 ConDecl
+deriving instance Data a => Data (ConDecl a)
+
+INSTANCE_TYPEABLE1(Bag,bagTc,"Bag")
+instance Data a => Data (Bag a) where
+  gfoldl k z b = z listToBag `k` bagToList b -- traverse abstract type abstractly
+  toConstr _   = abstractConstr $ "Bag("++show (typeOf (undefined::a))++")"
+  gunfold _ _  = error "gunfold"
+  dataTypeOf _ = mkNorepType "Bag"
+
+deriving instance Typeable1 HsTyVarBndr
+deriving instance Data a => Data (HsTyVarBndr a)
+
+deriving instance Typeable1 ResType
+deriving instance Data a => Data (ResType a)
+
+deriving instance Typeable1 HsSplice
+deriving instance Data a => Data (HsSplice a)
+
+deriving instance Typeable1 ConDeclField
+deriving instance Data a => Data (ConDeclField a)
+
+deriving instance Typeable1 IPName
+deriving instance Data a => Data (IPName a)
+
+deriving instance Typeable1 MatchGroup
+deriving instance Data a => Data (MatchGroup a)
+
+deriving instance Typeable1 Pat
+deriving instance Data a => Data (Pat a)
+
+deriving instance Typeable1 GRHSs
+deriving instance Data a => Data (GRHSs a)
+
+deriving instance Typeable1 HsExpr
+deriving instance Data a => Data (HsExpr a)
+
+deriving instance Typeable1 HsQuasiQuote
+deriving instance Data a => Data (HsQuasiQuote a)
+
+deriving instance Typeable1 HsOverLit
+deriving instance Data a => Data (HsOverLit a)
+
+deriving instance Typeable1 ArithSeqInfo
+deriving instance Data a => Data (ArithSeqInfo a)
+
+deriving instance Typeable1 HsBracket
+deriving instance Data a => Data (HsBracket a)
+
+deriving instance Typeable1 HsCmdTop
+deriving instance Data a => Data (HsCmdTop a)
+
+deriving instance Typeable1 HsGroup
+deriving instance Data a => Data (HsGroup a)
+
+deriving instance Typeable1 FixitySig
+deriving instance Data a => Data (FixitySig a)
+
+deriving instance Typeable1 HsIPBinds
+deriving instance Data a => Data (HsIPBinds a)
+
+deriving instance Typeable1 IPBind
+deriving instance Data a => Data (IPBind a)
+
+deriving instance Typeable1 GroupByClause
+deriving instance Data a => Data (GroupByClause a)
+
+deriving instance Typeable1 HsStmtContext
+deriving instance Data a => Data (HsStmtContext a)
+
+deriving instance Typeable1 HsMatchContext
+deriving instance Data a => Data (HsMatchContext a)
+
+deriving instance Typeable1 GRHS
+deriving instance Data a => Data (GRHS a)
+
+deriving instance Typeable1 Match
+deriving instance Data a => Data (Match a)
+
+deriving instance Typeable1 RuleBndr
+deriving instance Data a => Data (RuleBndr a)
+
+-- Typeable2
+
+deriving instance Typeable2 HsBindLR
+deriving instance (Data a,Data b) => Data (HsBindLR a b)
+
+deriving instance Typeable2 StmtLR
+deriving instance (Data a,Data b) => Data (StmtLR a b)
+
+deriving instance Typeable2 HsLocalBindsLR
+deriving instance (Data a,Data b) => Data (HsLocalBindsLR a b)
+
+deriving instance Typeable2 HsValBindsLR
+deriving instance (Data a,Data b) => Data (HsValBindsLR a b)
+
+deriving instance Typeable2 HsConDetails
+deriving instance (Data a,Data b) => Data (HsConDetails a b)
+
+deriving instance Typeable2 HsRecFields
+deriving instance (Data a,Data b) => Data (HsRecFields a b)
+
+deriving instance Typeable2 HsRecField
+deriving instance (Data a,Data b) => Data (HsRecField a b)
+
+#endif 
+

+ src/GHC/SYB/Utils.hs view

@@ -0,0 +1,257 @@+{- | "GHC.Syb.Utils" provides common utilities for the Ghc Api,
+     either based on Data\/Typeable or for use with Data.Generics
+     over Ghc Api types.
+
+example output of 'showData' on 'parsedSource', 'renamedSource', and
+'typecheckedSource' for a trivial @HelloWorld@ module, compared with
+'ppr' output:
+
+@
+------------------------- pretty-printed parsedSource
+module HelloWorld where
+main = putStrLn "Hello, World!"
+------------------------- pretty-printed renamedSource
+Just (HelloWorld.main = System.IO.putStrLn "Hello, World!",
+      [import Prelude],
+      Nothing,
+      Nothing,
+
+(HaddockModInfo
+ (Nothing)
+ (Nothing)
+ (Nothing)
+ (Nothing)))
+------------------------- pretty-printed typecheckedSource
+Just <AbsBinds [] [] [HelloWorld.main <= [] main]
+        HelloWorld.main :: GHC.IOBase.IO ()
+        []
+        { main = System.IO.putStrLn "Hello, World!" }>
+------------------------- shown parsedSource
+
+(L {HelloWorld.hs:1:0}
+ (HsModule
+  (Just
+   (L {HelloWorld.hs:1:7-16} {ModuleName: HelloWorld}))
+  (Nothing)
+  []
+  [
+   (L {HelloWorld.hs:2:0-30}
+    (ValD
+     (FunBind
+      (L {HelloWorld.hs:2:0-3}
+       (Unqual {OccName: main}))
+      (False)
+      (MatchGroup
+       [
+        (L {HelloWorld.hs:2:0-30}
+         (Match
+          []
+          (Nothing)
+          (GRHSs
+           [
+            (L {HelloWorld.hs:2:7-30}
+             (GRHS
+              []
+              (L {HelloWorld.hs:2:7-30}
+               (HsApp
+                (L {HelloWorld.hs:2:7-14}
+                 (HsVar
+                  (Unqual {OccName: putStrLn})))
+                (L {HelloWorld.hs:2:16-30}
+                 (HsLit
+                  (HsString {FastString: "Hello, World!"})))))))]
+           (EmptyLocalBinds))))] {!type placeholder here?!})
+      (WpHole) {!NameSet placeholder here!}
+      (Nothing))))]
+  (Nothing)
+  (HaddockModInfo
+   (Nothing)
+   (Nothing)
+   (Nothing)
+   (Nothing))
+  (Nothing)))
+------------------------- shown renamedSource
+
+((,,,,)
+ (HsGroup
+  (ValBindsOut
+   [
+    ((,)
+     (NonRecursive) {Bag(Located (HsBind Name)):
+     [
+      (L {HelloWorld.hs:2:0-30}
+       (FunBind
+        (L {HelloWorld.hs:2:0-3} {Name: HelloWorld.main})
+        (False)
+        (MatchGroup
+         [
+          (L {HelloWorld.hs:2:0-30}
+           (Match
+            []
+            (Nothing)
+            (GRHSs
+             [
+              (L {HelloWorld.hs:2:7-30}
+               (GRHS
+                []
+                (L {HelloWorld.hs:2:7-30}
+                 (HsApp
+                  (L {HelloWorld.hs:2:7-14}
+                   (HsVar {Name: System.IO.putStrLn}))
+                  (L {HelloWorld.hs:2:16-30}
+                   (HsLit
+                    (HsString {FastString: "Hello, World!"})))))))]
+             (EmptyLocalBinds))))] {!type placeholder here?!})
+        (WpHole) {NameSet:
+        [{Name: System.IO.putStrLn}]}
+        (Nothing)))]})]
+   [])
+  []
+  []
+  []
+  []
+  []
+  []
+  []
+  []
+  [])
+ [
+  (L {Implicit import declaration}
+   (ImportDecl
+    (L {Implicit import declaration} {ModuleName: Prelude})
+    (False)
+    (False)
+    (Nothing)
+    (Nothing)))]
+ (Nothing)
+ (Nothing)
+ (HaddockModInfo
+  (Nothing)
+  (Nothing)
+  (Nothing)
+  (Nothing)))
+------------------------- shown typecheckedSource
+{Bag(Located (HsBind Var)):
+[
+ (L {HelloWorld.hs:2:0-30}
+  (AbsBinds
+   []
+   []
+   [
+    ((,,,)
+     [] {Var: HelloWorld.main} {Var: main}
+     [])] {Bag(Located (HsBind Var)):
+   [
+    (L {HelloWorld.hs:2:0-30}
+     (FunBind
+      (L {HelloWorld.hs:2:0-3} {Var: main})
+      (False)
+      (MatchGroup
+       [
+        (L {HelloWorld.hs:2:0-30}
+         (Match
+          []
+          (Nothing)
+          (GRHSs
+           [
+            (L {HelloWorld.hs:2:7-30}
+             (GRHS
+              []
+              (L {HelloWorld.hs:2:7-30}
+               (HsApp
+                (L {HelloWorld.hs:2:7-14}
+                 (HsVar {Var: System.IO.putStrLn}))
+                (L {HelloWorld.hs:2:16-30}
+                 (HsLit
+                  (HsString {FastString: "Hello, World!"})))))))]
+           (EmptyLocalBinds))))] GHC.IOBase.IO ())
+      (WpHole) {!NameSet placeholder here!}
+      (Nothing)))]}))]}
+@
+-}
+module GHC.SYB.Utils where
+
+import Data.Generics
+
+-- import qualified GHC.Paths
+import PprTyThing
+import DynFlags
+import GHC
+import Outputable
+import SrcLoc
+import qualified OccName(occNameString)
+import Bag(Bag,bagToList)
+import Var(Var)
+import FastString(FastString)
+import NameSet(NameSet,nameSetToList)
+
+import GHC.SYB.Instances
+import Data.List
+
+-- | Ghc Ast types tend to have undefined holes, to be filled
+--   by later compiler phases. We tag Asts with their source,
+--   so that we can avoid such holes based on who generated the Asts.
+data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
+
+-- | Generic Data-based show, with special cases for GHC Ast types,
+--   and simplistic indentation-based layout (the 'Int' parameter); 
+--   showing abstract types abstractly and avoiding known potholes 
+--   (based on the 'Stage' that generated the Ast)
+showData :: Data a => Stage -> Int -> a -> String
+showData stage n = 
+  generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan 
+          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
+          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
+          `extQ` postTcType `extQ` fixity
+  where generic :: Data a => a -> String
+        generic t = indent n ++ "(" ++ showConstr (toConstr t)
+                 ++ space (concat (intersperse " " (gmapQ (showData stage (n+1)) t))) ++ ")"
+        space "" = ""
+        space s  = ' ':s
+        indent n = "\n" ++ replicate n ' ' 
+        string     = show :: String -> String
+        fastString = ("{FastString: "++) . (++"}") . show :: FastString -> String
+        list l     = indent n ++ "[" 
+                              ++ concat (intersperse "," (map (showData stage (n+1)) l)) ++ "]"
+
+        name       = ("{Name: "++) . (++"}") . showSDoc . ppr :: Name -> String
+        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString 
+        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc . ppr :: ModuleName -> String
+        srcSpan    = ("{"++) . (++"}") . showSDoc . ppr :: SrcSpan -> String
+        var        = ("{Var: "++) . (++"}") . showSDoc . ppr :: Var -> String
+        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc . ppr :: DataCon -> String
+
+        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 | stage `elem` [Parser,TypeChecker] 
+                = const ("{!NameSet placeholder here!}") :: NameSet -> String
+                | otherwise     
+                = ("{NameSet: "++) . (++"}") . list . nameSetToList 
+
+        postTcType | stage<TypeChecker = const "{!type placeholder here?!}" :: PostTcType -> String
+                   | otherwise     = showSDoc . ppr :: Type -> String
+
+        fixity | stage<Renamer = const "{!fixity placeholder here?!}" :: GHC.Fixity -> String
+               | otherwise     = ("{Fixity: "++) . (++"}") . showSDoc . ppr :: GHC.Fixity -> String
+
+-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
+--   generated the Ast.
+everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+everythingStaged stage k z f x 
+  | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
+  | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
+  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
+        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
+        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
+
+-- | A variation of 'everything', using a 'GenericQ Bool' to skip
+--   parts of the input 'Data'.
+everythingBut :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
+everythingBut q k z f x 
+  | q x       = z
+  | otherwise = foldl k (f x) (gmapQ (everythingBut q k z f) x)