-- to get reproductible dumps of TemplateHaskell slices.
module Language.Haskell.TH.HideName where
+import Data.Bifunctor (bimap)
+import Data.Maybe (Maybe (..))
import Data.Bool (Bool(..))
import Data.Function (id)
import Data.Functor ((<$>))
-- cases where resetting 'TH.counter' is not enough
-- to get deterministic 'TH.Name's.
hideName :: a -> a
+instance HideName a => HideName (Maybe a) where
+ hideName = (hideName <$>)
+instance (HideName a, HideName b) => HideName (a,b) where
+ hideName = bimap hideName hideName
instance HideName Body where
hideName (GuardedB gs) = GuardedB ((\(g, e) -> (hideName g, hideName e)) <$> gs)
hideName (NormalB e) = NormalB (hideName e)
instance HideName Dec where
hideName (FunD f cs) = FunD (hideName f) (hideName <$> cs)
hideName (ValD p r ds) = ValD (hideName p) (hideName r) (hideName <$> ds)
- -- Other alternatives are not used by Symantic.Parser, hence don't bother.
+ -- FIXME: completing is not likely useful since Symantic.Parser is only using __Typed__ Template Haskell
+ --hideName (DataD cxt n bs mk cs dcs) = DataD (hideName cxt) (hideName n) (hideName bs) (hideName mk) (hideName cs) (hideName dcs)
hideName _ = undefined
+-- | NewtypeD Cxt Name [TyVarBndr ()]
+-- (Maybe Kind) -- Kind signature
+-- Con [DerivClause] -- ^ @{ newtype Cxt x => T x = A (B x)
+-- -- deriving (Z,W Q)
+-- -- deriving stock Eq }@
+-- | TypeDataD Name [TyVarBndr ()]
+-- (Maybe Kind) -- Kind signature (allowed only for GADTs)
+-- [Con] -- ^ @{ type data T x = A x | B (T x) }@
+-- | TySynD Name [TyVarBndr ()] Type -- ^ @{ type T x = (x,x) }@
+-- | ClassD Cxt Name [TyVarBndr ()]
+-- [FunDep] [Dec] -- ^ @{ class Eq a => Ord a where ds }@
+-- | InstanceD (Maybe Overlap) Cxt Type [Dec]
+-- -- ^ @{ instance {\-\# OVERLAPS \#-\}
+-- -- Show w => Show [w] where ds }@
+-- | SigD Name Type -- ^ @{ length :: [a] -> Int }@
+-- | KiSigD Name Kind -- ^ @{ type TypeRep :: k -> Type }@
+-- | ForeignD Foreign -- ^ @{ foreign import ... }
+-- --{ foreign export ... }@
+--
+-- | InfixD Fixity Name -- ^ @{ infix 3 foo }@
+-- | DefaultD [Type] -- ^ @{ default (Integer, Double) }@
+--
+-- -- | pragmas
+-- | PragmaD Pragma -- ^ @{ {\-\# INLINE [1] foo \#-\} }@
+--
+-- -- | data families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
+-- | DataFamilyD Name [TyVarBndr ()]
+-- (Maybe Kind)
+-- -- ^ @{ data family T a b c :: * }@
+--
+-- | DataInstD Cxt (Maybe [TyVarBndr ()]) Type
+-- (Maybe Kind) -- Kind signature
+-- [Con] [DerivClause] -- ^ @{ data instance Cxt x => T [x]
+-- -- = A x | B (T x)
+-- -- deriving (Z,W)
+-- -- deriving stock Eq }@
+--
+-- | NewtypeInstD Cxt (Maybe [TyVarBndr ()]) Type -- Quantified type vars
+-- (Maybe Kind) -- Kind signature
+-- Con [DerivClause] -- ^ @{ newtype instance Cxt x => T [x]
+-- -- = A (B x)
+-- -- deriving (Z,W)
+-- -- deriving stock Eq }@
+-- | TySynInstD TySynEqn -- ^ @{ type instance ... }@
+--
+-- -- | open type families (may also appear in [Dec] of 'ClassD' and 'InstanceD')
+-- | OpenTypeFamilyD TypeFamilyHead
+-- -- ^ @{ type family T a b c = (r :: *) | r -> a b }@
+--
+-- | ClosedTypeFamilyD TypeFamilyHead [TySynEqn]
+-- -- ^ @{ type family F a b = (r :: *) | r -> a where ... }@
+--
+-- | RoleAnnotD Name [Role] -- ^ @{ type role T nominal representational }@
+-- | StandaloneDerivD (Maybe DerivStrategy) Cxt Type
+-- -- ^ @{ deriving stock instance Ord a => Ord (Foo a) }@
+-- | DefaultSigD Name Type -- ^ @{ default size :: Data a => a -> Int }@
+--
+-- -- | Pattern Synonyms
+-- | PatSynD Name PatSynArgs PatSynDir Pat
+-- -- ^ @{ pattern P v1 v2 .. vn <- p }@ unidirectional or
+-- -- @{ pattern P v1 v2 .. vn = p }@ implicit bidirectional or
+-- -- @{ pattern P v1 v2 .. vn <- p
+-- -- where P v1 v2 .. vn = e }@ explicit bidirectional
+-- --
+-- -- also, besides prefix pattern synonyms, both infix and record
+-- -- pattern synonyms are supported. See 'PatSynArgs' for details
+--
+-- | PatSynSigD Name PatSynType -- ^ A pattern synonym's type signature.
+--
+-- | ImplicitParamBindD String Exp
+-- -- ^ @{ ?x = expr }@
+-- --
+-- -- Implicit parameter binding declaration. Can only be used in let
+-- -- and where clauses which consist entirely of implicit bindings.
+
instance HideName Exp where
hideName (AppE e1 e2) = AppE (hideName e1) (hideName e2)
hideName (AppTypeE e t) = AppTypeE (hideName e) (hideName t)
hideName (UnboxedSumE e alt arity) = UnboxedSumE (hideName e) alt arity
hideName (UnboxedTupE es) = UnboxedTupE ((hideName <$>) <$> es)
hideName (VarE v) = VarE (hideName v)
+ hideName (GetFieldE e n) = GetFieldE (hideName e) n
+ hideName (ProjectionE ns) = ProjectionE ns
instance HideName Guard where
hideName (NormalG e) = NormalG (hideName e)
hideName (PatG ss) = PatG (hideName <$> ss)
instance HideName Pat where
hideName (AsP v p) = AsP (hideName v) (hideName p)
hideName (BangP p) = BangP (hideName p)
- hideName (ConP s ps) = ConP (hideName s) (hideName <$> ps)
+ hideName (ConP n ts ps) = ConP (hideName n) (hideName <$> ts) (hideName <$> ps)
hideName (InfixP p1 n p2) = InfixP (hideName p1) (hideName n) (hideName p2)
hideName (ListP ps) = ListP (hideName <$> ps)
hideName (LitP l) = LitP (hideName l)
sourcephile / git / haskell / symantic-parser.git / blobdiff