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.Bifunctor (bimap)
   7 import Data.Maybe (Maybe (..))
   8 import Data.Bool (Bool(..))
   9 import Data.Function (id)
  10 import Data.Functor ((<$>))
  11 import Language.Haskell.TH
  12 import Language.Haskell.TH.Syntax
  13 import Prelude (undefined)
  14
  15 -- ** Type 'HideableName'
  16 -- | Useful on golden unit tests because 'Name's
  17 -- change often when changing unrelated source code
  18 -- or even when changing basic GHC or executable flags.
  19 class HideableName (showNames::Bool) where
  20   hideableName :: HideName a => a -> a
  21 -- | Like 'id'.
  22 instance HideableName 'True where
  23   hideableName = id
  24 -- | Like 'hideName'.
  25 instance HideableName 'False where
  26   hideableName = hideName
  27
  28 -- * Class 'HideName'
  29 class HideName a where
  30   -- | Map all 'Name's to a constant in order to overcome
  31   -- cases where resetting 'TH.counter' is not enough
  32   -- to get deterministic 'TH.Name's.
  33   hideName :: a -> a
  34 instance HideName a => HideName (Maybe a) where
  35   hideName = (hideName <$>)
  36 instance (HideName a, HideName b) => HideName (a,b) where
  37   hideName = bimap hideName hideName
  38 instance HideName Body where
  39   hideName (GuardedB gs) = GuardedB ((\(g, e) -> (hideName g, hideName e)) <$> gs)
  40   hideName (NormalB e) = NormalB (hideName e)
  41 instance HideName Clause where
  42   hideName (Clause ps b ds) = Clause (hideName <$> ps) (hideName b) (hideName <$> ds)
  43 instance HideName Dec where
  44   hideName (FunD f cs) = FunD (hideName f) (hideName <$> cs)
  45   hideName (ValD p r ds) = ValD (hideName p) (hideName r) (hideName <$> ds)
  46   -- FIXME: completing is not likely useful since Symantic.Parser is only using __Typed__ Template Haskell
  47   --hideName (DataD cxt n bs mk cs dcs) = DataD (hideName cxt) (hideName n) (hideName bs) (hideName mk) (hideName cs) (hideName dcs)
  48   hideName _ = undefined
  49 --   | NewtypeD Cxt Name [TyVarBndr ()]
  50 --              (Maybe Kind)         -- Kind signature
  51 --              Con [DerivClause]    -- ^ @{ newtype Cxt x => T x = A (B x)
  52 --                                   --       deriving (Z,W Q)
  53 --                                   --       deriving stock Eq }@
  54 --   | TypeDataD Name [TyVarBndr ()]
  55 --           (Maybe Kind)            -- Kind signature (allowed only for GADTs)
  56 --           [Con]                   -- ^ @{ type data T x = A x | B (T x) }@
  57 --   | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@
  58 --   | ClassD Cxt Name [TyVarBndr ()]
  59 --          [FunDep] [Dec]           -- ^ @{ class Eq a => Ord a where ds }@
  60 --   | InstanceD (Maybe Overlap) Cxt Type [Dec]
  61 --                                   -- ^ @{ instance {\-\# OVERLAPS \#-\}
  62 --                                   --        Show w => Show [w] where ds }@
  63 --   | SigD Name Type                -- ^ @{ length :: [a] -> Int }@
  64 --   | KiSigD Name Kind              -- ^ @{ type TypeRep :: k -> Type }@
  65 --   | ForeignD Foreign              -- ^ @{ foreign import ... }
  66 --                                   --{ foreign export ... }@
  67 --
  68 --   | InfixD Fixity Name            -- ^ @{ infix 3 foo }@
  69 --   | DefaultD [Type]               -- ^ @{ default (Integer, Double) }@
  70 --
  71 --   -- | pragmas
  72 --   | PragmaD Pragma                -- ^ @{ {\-\# INLINE [1] foo \#-\} }@
  73 --
  74 --   -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
  75 --   | DataFamilyD Name [TyVarBndr ()]
  76 --                (Maybe Kind)
  77 --          -- ^ @{ data family T a b c :: * }@
  78 --
  79 --   | DataInstD Cxt (Maybe [TyVarBndr ()]) Type
  80 --              (Maybe Kind)         -- Kind signature
  81 --              [Con] [DerivClause]  -- ^ @{ data instance Cxt x => T [x]
  82 --                                   --       = A x | B (T x)
  83 --                                   --       deriving (Z,W)
  84 --                                   --       deriving stock Eq }@
  85 --
  86 --   | NewtypeInstD Cxt (Maybe [TyVarBndr ()]) Type -- Quantified type vars
  87 --                  (Maybe Kind)      -- Kind signature
  88 --                  Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]
  89 --                                    --        = A (B x)
  90 --                                    --        deriving (Z,W)
  91 --                                    --        deriving stock Eq }@
  92 --   | TySynInstD TySynEqn            -- ^ @{ type instance ... }@
  93 --
  94 --   -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
  95 --   | OpenTypeFamilyD TypeFamilyHead
  96 --          -- ^ @{ type family T a b c = (r :: *) | r -> a b }@
  97 --
  98 --   | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]
  99 --        -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
 100 --
 101 --   | RoleAnnotD Name [Role]     -- ^ @{ type role T nominal representational }@
 102 --   | StandaloneDerivD (Maybe DerivStrategy) Cxt Type
 103 --        -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@
 104 --   | DefaultSigD Name Type      -- ^ @{ default size :: Data a => a -> Int }@
 105 --
 106 --   -- | Pattern Synonyms
 107 --   | PatSynD Name PatSynArgs PatSynDir Pat
 108 --       -- ^ @{ pattern P v1 v2 .. vn <- p }@  unidirectional           or
 109 --       --   @{ pattern P v1 v2 .. vn = p  }@  implicit bidirectional   or
 110 --       --   @{ pattern P v1 v2 .. vn <- p
 111 --       --        where P v1 v2 .. vn = e  }@  explicit bidirectional
 112 --       --
 113 --       -- also, besides prefix pattern synonyms, both infix and record
 114 --       -- pattern synonyms are supported. See 'PatSynArgs' for details
 115 --
 116 --   | PatSynSigD Name PatSynType  -- ^ A pattern synonym's type signature.
 117 --
 118 --   | ImplicitParamBindD String Exp
 119 --       -- ^ @{ ?x = expr }@
 120 --       --
 121 --       -- Implicit parameter binding declaration. Can only be used in let
 122 --       -- and where clauses which consist entirely of implicit bindings.
 123
 124 instance HideName Exp where
 125   hideName (AppE e1 e2) = AppE (hideName e1) (hideName e2)
 126   hideName (AppTypeE e t) = AppTypeE (hideName e) (hideName t)
 127   hideName (ArithSeqE d) = ArithSeqE (hideName d)
 128   hideName (CaseE e ms) = CaseE (hideName e) (hideName <$> ms)
 129   hideName (CompE ss) = CompE (hideName <$> ss)
 130   hideName (ConE c) = ConE (hideName c)
 131   hideName (CondE guard true false) = CondE (hideName guard) (hideName true) (hideName false)
 132   hideName (DoE m ss) = DoE (hideName <$> m) (hideName <$> ss)
 133   hideName (ImplicitParamVarE n) = ImplicitParamVarE n
 134   hideName (InfixE e1 op e2) = InfixE (hideName <$> e1) (hideName op) (hideName <$> e2)
 135   hideName (LabelE s) = LabelE s
 136   hideName (LamCaseE ms) = LamCaseE (hideName <$> ms)
 137   hideName (LamE ps e) = LamE (hideName <$> ps) (hideName e)
 138   hideName (LetE ds e) = LetE (hideName <$> ds) (hideName e)
 139   hideName (ListE es) = ListE (hideName <$> es)
 140   hideName (LitE l) = LitE l
 141   hideName (MDoE m ss) = MDoE (hideName <$> m) (hideName <$> ss)
 142   hideName (MultiIfE alts) = MultiIfE ((\(g, e) -> (hideName g, hideName e)) <$> alts)
 143   hideName (ParensE e) = ParensE (hideName e)
 144   hideName (RecConE nm fs) = RecConE (hideName nm) ((\(n, e) -> (hideName n, hideName e)) <$> fs)
 145   hideName (RecUpdE e fs) = RecUpdE (hideName e) ((\(n, ee) -> (hideName n, hideName ee)) <$> fs)
 146   hideName (SigE e t) = SigE (hideName e) (hideName t)
 147   hideName (StaticE e) = StaticE (hideName e)
 148   hideName (TupE es) = TupE ((hideName <$>) <$> es)
 149   hideName (UInfixE e1 op e2) = UInfixE (hideName e1) (hideName op) (hideName e2)
 150   hideName (UnboundVarE v) = UnboundVarE (hideName v)
 151   hideName (UnboxedSumE e alt arity) = UnboxedSumE (hideName e) alt arity
 152   hideName (UnboxedTupE es) = UnboxedTupE ((hideName <$>) <$> es)
 153   hideName (VarE v) = VarE (hideName v)
 154 instance HideName Guard where
 155   hideName (NormalG e) = NormalG (hideName e)
 156   hideName (PatG ss) = PatG (hideName <$> ss)
 157 instance HideName Lit where
 158   hideName x = x
 159 instance HideName Match where
 160   hideName (Match p b ds) = Match (hideName p) (hideName b) (hideName <$> ds)
 161 instance HideName ModName where
 162   hideName (ModName n) = ModName n
 163 instance HideName Name where
 164   -- This is the hidding
 165   hideName (Name (OccName on) (NameU _u)) = Name (OccName on) NameS
 166   hideName (Name (OccName on) (NameL _u)) = Name (OccName on) NameS
 167   hideName (Name on n) = Name (hideName on) (hideName n)
 168 instance HideName NameFlavour where
 169   hideName (NameG n p m) = NameG n p m
 170   hideName (NameL n) = NameL n
 171   hideName (NameQ n) = NameQ n
 172   hideName NameS = NameS
 173   hideName (NameU n) = NameU n
 174 instance HideName OccName where
 175   hideName (OccName n) = OccName n
 176 instance HideName Range where
 177   hideName (FromR e) = FromR (hideName e)
 178   hideName (FromThenR f t) = FromThenR (hideName f) (hideName t)
 179   hideName (FromToR f t) = FromToR (hideName f) (hideName t)
 180   hideName (FromThenToR f t to) = FromThenToR (hideName f) (hideName t) (hideName to)
 181 instance HideName Stmt where
 182   hideName (BindS p e) = BindS (hideName p) (hideName e)
 183   hideName (LetS ds) = LetS (hideName <$> ds)
 184   hideName (NoBindS e) = NoBindS (hideName e)
 185   hideName (ParS ss) = ParS ((hideName <$>) <$> ss)
 186   hideName (RecS ss) = RecS (hideName <$> ss)
 187 instance HideName (TyVarBndr f) where
 188   hideName (PlainTV n f) = PlainTV (hideName n) f
 189   hideName (KindedTV n f k) = KindedTV (hideName n) f (hideName k)
 190 instance HideName Type where
 191   hideName (ForallT vs ctx t) = ForallT (hideName <$> vs) (hideName <$> ctx) (hideName t)
 192   hideName (ForallVisT vs t) = ForallVisT (hideName <$> vs) (hideName t)
 193   hideName (AppT t x) = AppT (hideName t) (hideName x)
 194   hideName (AppKindT t k) = AppKindT (hideName t) (hideName k)
 195   hideName (SigT t k) = SigT (hideName t) (hideName k)
 196   hideName (VarT n) = VarT (hideName n)
 197   hideName (ConT n) = ConT (hideName n)
 198   hideName (PromotedT n) = PromotedT (hideName n)
 199   hideName (InfixT x n y) = InfixT (hideName x) (hideName n) (hideName y)
 200   hideName (UInfixT x n y) = UInfixT (hideName x) (hideName n) (hideName y)
 201   hideName (ParensT t) = ParensT (hideName t)
 202   hideName (TupleT x) = TupleT x
 203   hideName (UnboxedTupleT x) = UnboxedTupleT x
 204   hideName (UnboxedSumT x) = UnboxedSumT x
 205   hideName (ArrowT) = ArrowT
 206   hideName (MulArrowT) = MulArrowT
 207   hideName (EqualityT) = EqualityT
 208   hideName (ListT) = ListT
 209   hideName (PromotedTupleT x) = PromotedTupleT x
 210   hideName (PromotedNilT) = PromotedNilT
 211   hideName (PromotedConsT) = PromotedConsT
 212   hideName (StarT) = StarT
 213   hideName (ConstraintT) = ConstraintT
 214   hideName (LitT t) = LitT t
 215   hideName (WildCardT) = WildCardT
 216   hideName (ImplicitParamT n t) = ImplicitParamT n (hideName t)
 217 instance HideName Pat where
 218   hideName (AsP v p) = AsP (hideName v) (hideName p)
 219   hideName (BangP p) = BangP (hideName p)
 220   hideName (ConP n ts ps) = ConP (hideName n) (hideName <$> ts) (hideName <$> ps)
 221   hideName (InfixP p1 n p2) = InfixP (hideName p1) (hideName n) (hideName p2)
 222   hideName (ListP ps) = ListP (hideName <$> ps)
 223   hideName (LitP l) = LitP (hideName l)
 224   hideName (ParensP p) = ParensP (hideName p)
 225   hideName (RecP nm fs) = RecP (nm) ((\(n,p) -> (hideName n, hideName p)) <$> fs)
 226   hideName (SigP p t) = SigP (hideName p) (hideName t)
 227   hideName (TildeP p) = TildeP (hideName p)
 228   hideName (TupP ps) = TupP (hideName <$> ps)
 229   hideName (UInfixP p1 n p2) = UInfixP (hideName p1) (hideName n) (hideName p2)
 230   hideName (UnboxedSumP p alt arity) = UnboxedSumP (hideName p) alt arity
 231   hideName (UnboxedTupP ps) = UnboxedTupP (hideName <$> ps)
 232   hideName (VarP v) = VarP (hideName v)
 233   hideName (ViewP e p) = ViewP (hideName e) (hideName p)
 234   hideName WildP = WildP
 235 instance HideName a => HideName [a] where
 236   hideName = (hideName <$>)