GhcApiAstTraversals: Utils.hs

File Utils.hs, 3.7 KB (added by claus, 6 years ago)

Data-based show and queries

Line 
1{-# LANGUAGE RankNTypes #-}
2module Utils where
3
4import Data.Generics
5
6-- import qualified GHC.Paths
7import PprTyThing
8import DynFlags
9import GHC
10import Outputable
11import SrcLoc
12import qualified OccName(occNameString)
13import Bag(Bag,bagToList)
14import Var(Var)
15import FastString(FastString)
16import NameSet(NameSet,nameSetToList)
17
18import Instances
19import Data.List
20
21-- for tagging data with its source
22data Stage = Parser | Renamer | TypeChecker deriving (Eq,Ord,Show)
23
24-- generic Data-based show, with special cases for GHC Ast types,
25-- showing abstract types abstractly and avoiding known potholes
26showData :: Data a => Stage -> Int -> a -> String
27showData stage n = 
28  generic `ext1Q` list `extQ` string `extQ` fastString `extQ` srcSpan
29          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
30          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
31          `extQ` postTcType `extQ` fixity
32  where generic :: Data a => a -> String
33        generic t = indent n ++ "(" ++ showConstr (toConstr t)
34                 ++ space (concat (intersperse " " (gmapQ (showData stage (n+1)) t))) ++ ")"
35        space "" = ""
36        space s  = ' ':s
37        indent n = "\n" ++ replicate n ' ' 
38        string     = show :: String -> String
39        fastString = ("{FastString: "++) . (++"}") . show :: FastString -> String
40        list l     = indent n ++ "[" 
41                              ++ concat (intersperse "," (map (showData stage (n+1)) l)) ++ "]"
42
43        name       = ("{Name: "++) . (++"}") . showSDoc . ppr :: Name -> String
44        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString
45        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc . ppr :: ModuleName -> String
46        srcSpan    = ("{"++) . (++"}") . showSDoc . ppr :: SrcSpan -> String
47        var        = ("{Var: "++) . (++"}") . showSDoc . ppr :: Var -> String
48        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc . ppr :: DataCon -> String
49
50        bagRdrName:: Bag (Located (HsBind RdrName)) -> String
51        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . bagToList
52        bagName   :: Bag (Located (HsBind Name)) -> String
53        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . bagToList
54        bagVar    :: Bag (Located (HsBind Var)) -> String
55        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . bagToList
56
57        nameSet | stage `elem` [Parser,TypeChecker] 
58                = const ("{!NameSet placeholder here!}") :: NameSet -> String
59                | otherwise     
60                = ("{NameSet: "++) . (++"}") . list . nameSetToList
61
62        postTcType | stage<TypeChecker = const "{!type placeholder here?!}" :: PostTcType -> String
63                   | otherwise     = showSDoc . ppr :: Type -> String
64
65        fixity | stage<Renamer = const "{!fixity placeholder here?!}" :: GHC.Fixity -> String
66               | otherwise     = ("{Fixity: "++) . (++"}") . showSDoc . ppr :: GHC.Fixity -> String
67
68-- like everything, but avoid known potholes
69everythingStaged :: Stage -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
70everythingStaged stage k z f x
71  | (const False `extQ` postTcType `extQ` fixity `extQ` nameSet) x = z
72  | otherwise = foldl k (f x) (gmapQ (everythingStaged stage k z f) x)
73  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
74        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool
75        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
76
77everythingBut :: GenericQ Bool -> (r -> r -> r) -> r -> GenericQ r -> GenericQ r
78everythingBut q k z f x
79  | q x       = z
80  | otherwise = foldl k (f x) (gmapQ (everythingBut q k z f) x)