src/Language/Haskell/TH/HideName.hs

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