]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Language/Haskell/TH/HideName.hs
grammar: add precedence to showCode
[haskell/symantic-parser.git] / src / Language / Haskell / TH / HideName.hs
1 -- | This module enables to 'hideName'
2 -- to get reproductible dumps of TemplateHaskell slices.
3 module Language.Haskell.TH.HideName where
4
5 import Data.Functor ((<$>))
6 import Language.Haskell.TH
7 import Language.Haskell.TH.Syntax
8 import Prelude (undefined)
9
10 class HideName a where
11 -- | Map all 'Name's to a constant in order to overcome
12 -- cases where resetting 'TH.counter' is not enough
13 -- to get deterministic 'TH.Name's.
14 hideName :: a -> a
15 instance HideName Body where
16 hideName (GuardedB gs) = GuardedB ((\(g, e) -> (hideName g, hideName e)) <$> gs)
17 hideName (NormalB e) = NormalB (hideName e)
18 instance HideName Clause where
19 hideName (Clause ps b ds) = Clause (hideName <$> ps) (hideName b) (hideName <$> ds)
20 instance HideName Dec where
21 hideName (FunD f cs) = FunD (hideName f) (hideName <$> cs)
22 hideName (ValD p r ds) = ValD (hideName p) (hideName r) (hideName <$> ds)
23 -- Other alternatives are not used by Symantic.Parser, hence don't bother.
24 hideName _ = undefined
25 instance HideName Exp where
26 hideName (AppE e1 e2) = AppE (hideName e1) (hideName e2)
27 hideName (AppTypeE e t) = AppTypeE (hideName e) (hideName t)
28 hideName (ArithSeqE d) = ArithSeqE (hideName d)
29 hideName (CaseE e ms) = CaseE (hideName e) (hideName <$> ms)
30 hideName (CompE ss) = CompE (hideName <$> ss)
31 hideName (ConE c) = ConE (hideName c)
32 hideName (CondE guard true false) = CondE (hideName guard) (hideName true) (hideName false)
33 hideName (DoE m ss) = DoE (hideName <$> m) (hideName <$> ss)
34 hideName (ImplicitParamVarE n) = ImplicitParamVarE n
35 hideName (InfixE e1 op e2) = InfixE (hideName <$> e1) (hideName op) (hideName <$> e2)
36 hideName (LabelE s) = LabelE s
37 hideName (LamCaseE ms) = LamCaseE (hideName <$> ms)
38 hideName (LamE ps e) = LamE (hideName <$> ps) (hideName e)
39 hideName (LetE ds e) = LetE (hideName <$> ds) (hideName e)
40 hideName (ListE es) = ListE (hideName <$> es)
41 hideName (LitE l) = LitE l
42 hideName (MDoE m ss) = MDoE (hideName <$> m) (hideName <$> ss)
43 hideName (MultiIfE alts) = MultiIfE ((\(g, e) -> (hideName g, hideName e)) <$> alts)
44 hideName (ParensE e) = ParensE (hideName e)
45 hideName (RecConE nm fs) = RecConE (hideName nm) ((\(n, e) -> (hideName n, hideName e)) <$> fs)
46 hideName (RecUpdE e fs) = RecUpdE (hideName e) ((\(n, ee) -> (hideName n, hideName ee)) <$> fs)
47 hideName (SigE e t) = SigE (hideName e) (hideName t)
48 hideName (StaticE e) = StaticE (hideName e)
49 hideName (TupE es) = TupE ((hideName <$>) <$> es)
50 hideName (UInfixE e1 op e2) = UInfixE (hideName e1) (hideName op) (hideName e2)
51 hideName (UnboundVarE v) = UnboundVarE (hideName v)
52 hideName (UnboxedSumE e alt arity) = UnboxedSumE (hideName e) alt arity
53 hideName (UnboxedTupE es) = UnboxedTupE ((hideName <$>) <$> es)
54 hideName (VarE v) = VarE (hideName v)
55 instance HideName Guard where
56 hideName (NormalG e) = NormalG (hideName e)
57 hideName (PatG ss) = PatG (hideName <$> ss)
58 instance HideName Lit where
59 hideName x = x
60 instance HideName Match where
61 hideName (Match p b ds) = Match (hideName p) (hideName b) (hideName <$> ds)
62 instance HideName ModName where
63 hideName (ModName n) = ModName n
64 instance HideName Name where
65 -- This is the hidding
66 hideName (Name (OccName on) (NameU _u)) = Name (OccName on) NameS
67 hideName (Name (OccName on) (NameL _u)) = Name (OccName on) NameS
68 hideName (Name on n) = Name (hideName on) (hideName n)
69 instance HideName NameFlavour where
70 hideName (NameG n p m) = NameG n p m
71 hideName (NameL n) = NameL n
72 hideName (NameQ n) = NameQ n
73 hideName NameS = NameS
74 hideName (NameU n) = NameU n
75 instance HideName OccName where
76 hideName (OccName n) = OccName n
77 instance HideName Range where
78 hideName (FromR e) = FromR (hideName e)
79 hideName (FromThenR f t) = FromThenR (hideName f) (hideName t)
80 hideName (FromToR f t) = FromToR (hideName f) (hideName t)
81 hideName (FromThenToR f t to) = FromThenToR (hideName f) (hideName t) (hideName to)
82 instance HideName Stmt where
83 hideName (BindS p e) = BindS (hideName p) (hideName e)
84 hideName (LetS ds) = LetS (hideName <$> ds)
85 hideName (NoBindS e) = NoBindS (hideName e)
86 hideName (ParS ss) = ParS ((hideName <$>) <$> ss)
87 hideName (RecS ss) = RecS (hideName <$> ss)
88 instance HideName (TyVarBndr f) where
89 hideName (PlainTV n f) = PlainTV (hideName n) f
90 hideName (KindedTV n f k) = KindedTV (hideName n) f (hideName k)
91 instance HideName Type where
92 hideName (ForallT vs ctx t) = ForallT (hideName <$> vs) (hideName <$> ctx) (hideName t)
93 hideName (ForallVisT vs t) = ForallVisT (hideName <$> vs) (hideName t)
94 hideName (AppT t x) = AppT (hideName t) (hideName x)
95 hideName (AppKindT t k) = AppKindT (hideName t) (hideName k)
96 hideName (SigT t k) = SigT (hideName t) (hideName k)
97 hideName (VarT n) = VarT (hideName n)
98 hideName (ConT n) = ConT (hideName n)
99 hideName (PromotedT n) = PromotedT (hideName n)
100 hideName (InfixT x n y) = InfixT (hideName x) (hideName n) (hideName y)
101 hideName (UInfixT x n y) = UInfixT (hideName x) (hideName n) (hideName y)
102 hideName (ParensT t) = ParensT (hideName t)
103 hideName (TupleT x) = TupleT x
104 hideName (UnboxedTupleT x) = UnboxedTupleT x
105 hideName (UnboxedSumT x) = UnboxedSumT x
106 hideName (ArrowT) = ArrowT
107 hideName (MulArrowT) = MulArrowT
108 hideName (EqualityT) = EqualityT
109 hideName (ListT) = ListT
110 hideName (PromotedTupleT x) = PromotedTupleT x
111 hideName (PromotedNilT) = PromotedNilT
112 hideName (PromotedConsT) = PromotedConsT
113 hideName (StarT) = StarT
114 hideName (ConstraintT) = ConstraintT
115 hideName (LitT t) = LitT t
116 hideName (WildCardT) = WildCardT
117 hideName (ImplicitParamT n t) = ImplicitParamT n (hideName t)
118 instance HideName Pat where
119 hideName (AsP v p) = AsP (hideName v) (hideName p)
120 hideName (BangP p) = BangP (hideName p)
121 hideName (ConP s ps) = ConP (hideName s) (hideName <$> ps)
122 hideName (InfixP p1 n p2) = InfixP (hideName p1) (hideName n) (hideName p2)
123 hideName (ListP ps) = ListP (hideName <$> ps)
124 hideName (LitP l) = LitP (hideName l)
125 hideName (ParensP p) = ParensP (hideName p)
126 hideName (RecP nm fs) = RecP (nm) ((\(n,p) -> (hideName n, hideName p)) <$> fs)
127 hideName (SigP p t) = SigP (hideName p) (hideName t)
128 hideName (TildeP p) = TildeP (hideName p)
129 hideName (TupP ps) = TupP (hideName <$> ps)
130 hideName (UInfixP p1 n p2) = UInfixP (hideName p1) (hideName n) (hideName p2)
131 hideName (UnboxedSumP p alt arity) = UnboxedSumP (hideName p) alt arity
132 hideName (UnboxedTupP ps) = UnboxedTupP (hideName <$> ps)
133 hideName (VarP v) = VarP (hideName v)
134 hideName (ViewP e p) = ViewP (hideName e) (hideName p)
135 hideName WildP = WildP