-- | This module exports the templates for automatic instance deriving of "Transformation.Shallow" type classes. The most
-- common way to use it would be
--
-- > import qualified Transformation.Shallow.TH
-- > data MyDataType f' f = ...
-- > $(Transformation.Shallow.TH.deriveFunctor ''MyDataType)
--

{-# Language CPP, TemplateHaskell #-}
-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial

module Transformation.Shallow.TH (deriveAll, deriveFunctor, deriveFoldable, deriveTraversable)
where

import Control.Applicative (liftA2)
import Control.Monad (replicateM)
import Data.Functor.Compose (Compose(getCompose))
import Data.Functor.Const (Const(getConst))
import Data.Maybe (fromMaybe)
import Data.Monoid (Monoid, (<>))
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)

import qualified Transformation
import qualified Transformation.Shallow


data Deriving = Deriving { Deriving -> Name
_constructor :: Name, Deriving -> Name
_variable :: Name }

deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll Name
ty = ((Name -> Q [Dec]) -> Q [Dec] -> Q [Dec])
-> Q [Dec] -> [Name -> Q [Dec]] -> Q [Dec]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Name -> Q [Dec]) -> Q [Dec] -> Q [Dec]
forall {f :: * -> *} {b}.
(Applicative f, Semigroup b) =>
(Name -> f b) -> f b -> f b
f ([Dec] -> Q [Dec]
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [Name -> Q [Dec]
deriveFunctor, Name -> Q [Dec]
deriveFoldable, Name -> Q [Dec]
deriveTraversable]
   where f :: (Name -> f b) -> f b -> f b
f Name -> f b
derive f b
rest = b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) (b -> b -> b) -> f b -> f (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f b
derive Name
ty f (b -> b) -> f b -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f b
rest

deriveFunctor :: Name -> Q [Dec]
deriveFunctor :: Name -> Q [Dec]
deriveFunctor Name
typeName = do
   Q Type
t <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   (Q Type
instanceType, [Con]
cs) <- Name -> Q (Q Type, [Con])
reifyConstructors Name
typeName
   let shallowConstraint :: Q Type -> Q Type
shallowConstraint Q Type
ty = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Shallow.Functor Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
       baseConstraint :: Q Type -> Q Type
baseConstraint Q Type
ty = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
   ([Type]
constraints, Dec
dec) <- (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genShallowmap Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType [Con]
cs
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt ([Q Type] -> Q [Type]) -> [Q Type] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Transformation) Q Type
t Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints)
                       (Q Type -> Q Type
shallowConstraint Q Type
instanceType)
                       [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

deriveFoldable :: Name -> Q [Dec]
deriveFoldable :: Name -> Q [Dec]
deriveFoldable Name
typeName = do
   Q Type
t <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Q Type
m <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
   (Q Type
instanceType, [Con]
cs) <- Name -> Q (Q Type, [Con])
reifyConstructors Name
typeName
   let shallowConstraint :: Q Type -> Q Type
shallowConstraint Q Type
ty = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Shallow.Foldable Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
       baseConstraint :: Q Type -> Q Type
baseConstraint Q Type
ty = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
   ([Type]
constraints, Dec
dec) <- (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genFoldMap Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType [Con]
cs
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Transformation) Q Type
t Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
:
                             Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
equalityT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Codomain Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t))
                                  (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Const Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
m) Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
:
                             Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Monoid) Q Type
m Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints))
                       (Q Type -> Q Type
shallowConstraint Q Type
instanceType)
                       [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

deriveTraversable :: Name -> Q [Dec]
deriveTraversable :: Name -> Q [Dec]
deriveTraversable Name
typeName = do
   Q Type
t <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Q Type
m <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
   Q Type
f <- Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT (Name -> Q Type) -> Q Name -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
   (Q Type
instanceType, [Con]
cs) <- Name -> Q (Q Type, [Con])
reifyConstructors Name
typeName
   let shallowConstraint :: Q Type -> Q Type
shallowConstraint Q Type
ty = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Shallow.Traversable Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
       baseConstraint :: Q Type -> Q Type
baseConstraint Q Type
ty = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.At Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
   ([Type]
constraints, Dec
dec) <- (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genTraverse Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType [Con]
cs
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Transformation) Q Type
t Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
:
                             Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT Q Type
forall (m :: * -> *). Quote m => m Type
equalityT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Codomain Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t))
                                  (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Compose Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
m Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
f) Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
:
                             Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''Applicative) Q Type
m Q Type -> [Q Type] -> [Q Type]
forall a. a -> [a] -> [a]
: (Type -> Q Type) -> [Type] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints))
                       (Q Type -> Q Type
shallowConstraint Q Type
instanceType)
                       [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

substitute :: Type -> Q Type -> Q Type -> Q Type
substitute :: Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType = (Type -> Type -> Type) -> Q Type -> Q Type -> Q Type
forall a b c. (a -> b -> c) -> Q a -> Q b -> Q c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Type -> Type -> Type
substitute'
   where substitute' :: Type -> Type -> Type
substitute' Type
instanceType Type
argumentType =
            [(Name, Name)] -> Type -> Type
substituteVars (Type -> Type -> [(Name, Name)]
substitutions Type
resultType Type
instanceType) Type
argumentType
         substitutions :: Type -> Type -> [(Name, Name)]
substitutions (AppT Type
t1 (VarT Name
name1)) (AppT Type
t2 (VarT Name
name2)) = (Name
name1, Name
name2) (Name, Name) -> [(Name, Name)] -> [(Name, Name)]
forall a. a -> [a] -> [a]
: Type -> Type -> [(Name, Name)]
substitutions Type
t1 Type
t2
         substitutions Type
_t1 Type
_t2 = []
         substituteVars :: [(Name, Name)] -> Type -> Type
substituteVars [(Name, Name)]
subs (VarT Name
name) = Name -> Type
VarT (Name -> Maybe Name -> Name
forall a. a -> Maybe a -> a
fromMaybe Name
name (Maybe Name -> Name) -> Maybe Name -> Name
forall a b. (a -> b) -> a -> b
$ Name -> [(Name, Name)] -> Maybe Name
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
name [(Name, Name)]
subs)
         substituteVars [(Name, Name)]
subs (AppT Type
t1 Type
t2) = Type -> Type -> Type
AppT ([(Name, Name)] -> Type -> Type
substituteVars [(Name, Name)]
subs Type
t1) ([(Name, Name)] -> Type -> Type
substituteVars [(Name, Name)]
subs Type
t2)
         substituteVars [(Name, Name)]
_ Type
t = Type
t

reifyConstructors :: Name -> Q (TypeQ, [Con])
reifyConstructors :: Name -> Q (Q Type, [Con])
reifyConstructors Name
ty = do
   (TyConI Dec
tyCon) <- Name -> Q Info
reify Name
ty
   (Name
tyConName, [TyVarBndr ()]
tyVars, Maybe Type
_kind, [Con]
cs) <- case Dec
tyCon of
      DataD [Type]
_ Name
nm [TyVarBndr ()]
tyVars Maybe Type
kind [Con]
cs [DerivClause]
_   -> (Name, [TyVarBndr ()], Maybe Type, [Con])
-> Q (Name, [TyVarBndr ()], Maybe Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr ()]
tyVars, Maybe Type
kind, [Con]
cs)
      NewtypeD [Type]
_ Name
nm [TyVarBndr ()]
tyVars Maybe Type
kind Con
c [DerivClause]
_ -> (Name, [TyVarBndr ()], Maybe Type, [Con])
-> Q (Name, [TyVarBndr ()], Maybe Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr ()]
tyVars, Maybe Type
kind, [Con
c])
      Dec
_ -> String -> Q (Name, [TyVarBndr ()], Maybe Type, [Con])
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"deriveApply: tyCon may not be a type synonym."

   let reifySynonyms :: Type -> Q Type
reifySynonyms (ConT Name
name) = Name -> Q Info
TH.reify Name
name Q Info -> (Info -> Q Type) -> Q Type
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Info -> Q Type
reifySynonymInfo Name
name
       reifySynonyms (AppT Type
t1 Type
t2) = Type -> Type -> Type
AppT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
reifySynonyms Type
t1 Q (Type -> Type) -> Q Type -> Q Type
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
reifySynonyms Type
t2
       reifySynonyms Type
t = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t
       reifySynonymInfo :: Name -> Info -> Q Type
reifySynonymInfo Name
_ (TyConI (TySynD Name
_ [] Type
t)) = Type -> Q Type
reifySynonyms Type
t
       reifySynonymInfo Name
name Info
_ = Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
ConT Name
name)
#if MIN_VERSION_template_haskell(2,17,0)
       reifyTVKindSynonyms :: TyVarBndr flag -> Q (TyVarBndr flag)
reifyTVKindSynonyms (KindedTV Name
v flag
s Type
k) = Name -> flag -> Type -> TyVarBndr flag
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
v flag
s (Type -> TyVarBndr flag) -> Q Type -> Q (TyVarBndr flag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
reifySynonyms Type
k
#else
       reifyTVKindSynonyms (KindedTV v k) = KindedTV v <$> reifySynonyms k
#endif
       reifyTVKindSynonyms TyVarBndr flag
tv = TyVarBndr flag -> Q (TyVarBndr flag)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr flag
tv
   [TyVarBndr ()]
tyVars' <- (TyVarBndr () -> Q (TyVarBndr ()))
-> [TyVarBndr ()] -> Q [TyVarBndr ()]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse TyVarBndr () -> Q (TyVarBndr ())
forall {flag}. TyVarBndr flag -> Q (TyVarBndr flag)
reifyTVKindSynonyms [TyVarBndr ()]
tyVars

#if MIN_VERSION_template_haskell(2,17,0)
   let (KindedTV Name
tyVar ()
_ (AppT (AppT Type
ArrowT Type
_) Type
StarT) : [TyVarBndr ()]
_) = [TyVarBndr ()] -> [TyVarBndr ()]
forall a. [a] -> [a]
reverse [TyVarBndr ()]
tyVars'
       instanceType :: Q Type
instanceType           = (Q Type -> TyVarBndr () -> Q Type)
-> Q Type -> [TyVarBndr ()] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> TyVarBndr () -> Q Type
forall {m :: * -> *} {flag}.
Quote m =>
m Type -> TyVarBndr flag -> m Type
apply (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tyConName) ([TyVarBndr ()] -> [TyVarBndr ()]
forall a. [a] -> [a]
reverse ([TyVarBndr ()] -> [TyVarBndr ()])
-> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> a -> b
$ Int -> [TyVarBndr ()] -> [TyVarBndr ()]
forall a. Int -> [a] -> [a]
drop Int
1 ([TyVarBndr ()] -> [TyVarBndr ()])
-> [TyVarBndr ()] -> [TyVarBndr ()]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr ()] -> [TyVarBndr ()]
forall a. [a] -> [a]
reverse [TyVarBndr ()]
tyVars')
       apply :: m Type -> TyVarBndr flag -> m Type
apply m Type
t (PlainTV Name
name flag
_)    = m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT m Type
t (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name)
       apply m Type
t (KindedTV Name
name flag
_ Type
_) = m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT m Type
t (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name)
#else
   let (KindedTV tyVar  (AppT (AppT ArrowT _) StarT) : _) = reverse tyVars'
       instanceType           = foldl apply (conT tyConName) (reverse $ drop 1 $ reverse tyVars')
       apply t (PlainTV name)    = appT t (varT name)
       apply t (KindedTV name _) = appT t (varT name)
#endif

   Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
   (Q Type, [Con]) -> Q (Q Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Q Type
instanceType, [Con]
cs)

genShallowmap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genShallowmap :: (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genShallowmap Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType [Con]
cs = do
   ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
constraints, Name -> [Clause] -> Dec
FunD '(Transformation.Shallow.<$>) [Clause]
clauses)

genFoldMap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genFoldMap :: (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genFoldMap Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType [Con]
cs = do
   ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
constraints, Name -> [Clause] -> Dec
FunD 'Transformation.Shallow.foldMap [Clause]
clauses)

genTraverse :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genTraverse :: (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genTraverse Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType [Con]
cs = do
   ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip
     ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (GenTraverseFieldType
-> (Q Type -> Q Type)
-> (Q Type -> Q Type)
-> Q Type
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genTraverseField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
constraints, Name -> [Clause] -> Dec
FunD 'Transformation.Shallow.traverse [Clause]
clauses)

genShallowmapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genShallowmapClause :: (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
_instanceType (NormalC Name
name [BangType]
fieldTypes) = do
   Name
t          <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (Name -> BangType -> Q ([Type], Exp))
-> [Name] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
newFields
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = GenTraverseFieldType
genShallowmapField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats Q Body
body []
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
_instanceType (RecC Name
name [VarBangType]
fields) = do
   Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTraverseFieldType
genShallowmapField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
name []] Q Body
body []
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType
                    (GadtC [Name
name] [BangType]
fieldTypes (AppT Type
resultType (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genShallowmapClause (Q Type -> Q Type
shallowConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       (Q Type -> Q Type
baseConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       Q Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType
                    (RecGadtC [Name
name] [VarBangType]
fields (AppT Type
resultType (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genShallowmapClause (Q Type -> Q Type
shallowConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       (Q Type -> Q Type
baseConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       Q Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) =
   (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genShallowmapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType Con
con

genFoldMapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause :: (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
_instanceType (NormalC Name
name [BangType]
fieldTypes) = do
   Name
t          <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (Name -> BangType -> Q ([Type], Exp))
-> [Name] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       body :: Q Exp
body | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
fieldNames = [| mempty |]
            | Bool
otherwise = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
append ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       append :: m Exp -> m Exp -> m Exp
append m Exp
a m Exp
b = [| $(m Exp
a) <> $(m Exp
b) |]
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = GenTraverseFieldType
genFoldMapField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
_instanceType (RecC Name
name [VarBangType]
fields) = do
   Name
t <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
   let body :: Q Exp
body | [VarBangType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| mempty |]
            | Bool
otherwise = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
append ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (VarBangType -> Q ([Type], Exp))
-> [VarBangType] -> [Q ([Type], Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], Exp)
newField [VarBangType]
fields
       append :: m Exp -> m Exp -> m Exp
append m Exp
a m Exp
b = [| $(m Exp
a) <> $(m Exp
b) |]
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) =
          GenTraverseFieldType
genFoldMapField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
name []] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType
                 (GadtC [Name
name] [BangType]
fieldTypes (AppT Type
resultType (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause (Q Type -> Q Type
shallowConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       (Q Type -> Q Type
baseConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       Q Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType
                 (RecGadtC [Name
name] [VarBangType]
fields (AppT Type
resultType (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause (Q Type -> Q Type
shallowConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       (Q Type -> Q Type
baseConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                       Q Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) =
   (Q Type -> Q Type)
-> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType Con
con

type GenTraverseFieldType = Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
                            -> Q ([Type], Exp)

genTraverseClause :: GenTraverseFieldType -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con
                  -> Q ([Type], Clause)
genTraverseClause :: GenTraverseFieldType
-> (Q Type -> Q Type)
-> (Q Type -> Q Type)
-> Q Type
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
_instanceType (NormalC Name
name [BangType]
fieldTypes) = do
   Name
t          <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Q Pat -> Q Pat
forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (Name -> BangType -> Q ([Type], Exp))
-> [Name] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Exp
body | [BangType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BangType]
fieldTypes = [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) |]
            | Bool
otherwise = (Q Exp, Bool) -> Q Exp
forall a b. (a, b) -> a
fst ((Q Exp, Bool) -> Q Exp) -> (Q Exp, Bool) -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Bool) -> Q Exp -> (Q Exp, Bool))
-> (Q Exp, Bool) -> [Q Exp] -> (Q Exp, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) [Q Exp]
newFields
       apply :: (m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (m Exp
a, Bool
False) m Exp
b = ([| $(m Exp
a) <$> $(m Exp
b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(m Exp
a) <*> $(m Exp
b) |], Bool
True)
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = GenTraverseFieldType
genField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genTraverseClause GenTraverseFieldType
genField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
_instanceType (RecC Name
name [VarBangType]
fields) = do
   Name
f <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
   Name
x <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Exp
body | [VarBangType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) |]
            | Bool
otherwise = (Q Exp, Bool) -> Q Exp
forall a b. (a, b) -> a
fst (((Q Exp, Bool) -> Q Exp -> (Q Exp, Bool))
-> (Q Exp, Bool) -> [Q Exp] -> (Q Exp, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) ([Q Exp] -> (Q Exp, Bool)) -> [Q Exp] -> (Q Exp, Bool)
forall a b. (a -> b) -> a -> b
$ (Q ([Type], (Name, Exp)) -> Q Exp)
-> [Q ([Type], (Name, Exp))] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map ((Name, Exp) -> Exp
forall a b. (a, b) -> b
snd ((Name, Exp) -> Exp)
-> (([Type], (Name, Exp)) -> (Name, Exp))
-> ([Type], (Name, Exp))
-> Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> Exp) -> Q ([Type], (Name, Exp)) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], (Name, Exp))]
constraintsAndFields)
       apply :: (m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (m Exp
a, Bool
False) m Exp
b = ([| $(m Exp
a) <$> $(m Exp
b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(m Exp
a) <*> $(m Exp
b) |], Bool
True)
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTraverseFieldType
genField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
name []] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genTraverseClause GenTraverseFieldType
genField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType
                  (GadtC [Name
name] [BangType]
fieldTypes (AppT Type
resultType (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      GenTraverseFieldType
-> (Q Type -> Q Type)
-> (Q Type -> Q Type)
-> Q Type
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genField
        (Q Type -> Q Type
shallowConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
        (Q Type -> Q Type
baseConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
        Q Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genTraverseClause GenTraverseFieldType
genField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType
                  (RecGadtC [Name
name] [VarBangType]
fields (AppT Type
resultType (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      GenTraverseFieldType
-> (Q Type -> Q Type)
-> (Q Type -> Q Type)
-> Q Type
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genField
                        (Q Type -> Q Type
shallowConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                        (Q Type -> Q Type
baseConstraint (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Q Type -> Q Type -> Q Type
substitute Type
resultType Q Type
instanceType)
                        Q Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genTraverseClause GenTraverseFieldType
genField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) =
   GenTraverseFieldType
-> (Q Type -> Q Type)
-> (Q Type -> Q Type)
-> Q Type
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genField Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Type
instanceType Con
con

genShallowmapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
                -> Q ([Type], Exp)
genShallowmapField :: GenTraverseFieldType
genShallowmapField Q Exp
trans Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
a | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> Q [Type] -> Q (Exp -> ([Type], Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[]) (Type -> [Type]) -> Q Type -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type
baseConstraint (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp
wrap (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(Transformation.$) Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
trans) Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
fieldAccess)
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) ([Type] -> Exp -> ([Type], Exp))
-> Q [Type] -> Q (Exp -> ([Type], Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Type -> Q Type) -> [Q Type] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Q Type -> Q Type
shallowConstraint [Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t1]
                                            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| ($Q Exp
trans Transformation.Shallow.<$>) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
        GenTraverseFieldType
genShallowmapField Q Exp
trans Type
t2 Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<$>)))
     SigT Type
ty Type
_kind -> GenTraverseFieldType
genShallowmapField Q Exp
trans Type
ty Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> GenTraverseFieldType
genShallowmapField Q Exp
trans Type
ty Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
fieldAccess

genFoldMapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
                -> Q ([Type], Exp)
genFoldMapField :: GenTraverseFieldType
genFoldMapField Q Exp
trans Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
a | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> Q [Type] -> Q (Exp -> ([Type], Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[]) (Type -> [Type]) -> Q Type -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type
baseConstraint (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp
wrap (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.) Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'getConst Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(Transformation.$) Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
trans))
                 Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
fieldAccess)
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) ([Type] -> Exp -> ([Type], Exp))
-> Q [Type] -> Q (Exp -> ([Type], Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Type -> Q Type) -> [Q Type] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Q Type -> Q Type
shallowConstraint [Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t1]
                                            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| (Transformation.Shallow.foldMap $Q Exp
trans) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
                  GenTraverseFieldType
genFoldMapField Q Exp
trans Type
t2 Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'foldMap))
     SigT Type
ty Type
_kind -> GenTraverseFieldType
genFoldMapField Q Exp
trans Type
ty Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> GenTraverseFieldType
genFoldMapField Q Exp
trans Type
ty Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| mempty |]

genTraverseField :: GenTraverseFieldType
genTraverseField :: GenTraverseFieldType
genTraverseField Q Exp
trans Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
a  | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> Q [Type] -> Q (Exp -> ([Type], Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
:[]) (Type -> [Type]) -> Q Type -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type
baseConstraint (Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp
wrap (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.) Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'getCompose Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(Transformation.$) Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
trans))
                 Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
fieldAccess)
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) ([Type] -> Exp -> ([Type], Exp))
-> Q [Type] -> Q (Exp -> ([Type], Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Type -> Q Type) -> [Q Type] -> Q [Type]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Q Type -> Q Type
shallowConstraint [Type -> Q Type
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t1]
                                            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| (Transformation.Shallow.traverse $Q Exp
trans) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
        GenTraverseFieldType
genTraverseField Q Exp
trans Type
t2 Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'traverse))
     SigT Type
ty Type
_kind -> GenTraverseFieldType
genTraverseField Q Exp
trans Type
ty Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> GenTraverseFieldType
genTraverseField Q Exp
trans Type
ty Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| pure $Q Exp
fieldAccess |]

getFieldOf :: Name -> Name -> Q Exp
getFieldOf :: Name -> Name -> Q Exp
getFieldOf = Q Exp -> Name -> Q Exp
getFieldOfE (Q Exp -> Name -> Q Exp)
-> (Name -> Q Exp) -> Name -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE

getFieldOfE :: Q Exp -> Name -> Q Exp
getFieldOfE :: Q Exp -> Name -> Q Exp
getFieldOfE Q Exp
record Name
field = do
#if MIN_VERSION_template_haskell(2,19,0)
  Bool
dotty <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.OverloadedRecordDot
  if Bool
dotty
     then Q Exp -> String -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> String -> m Exp
TH.getFieldE Q Exp
record (Name -> String
TH.nameBase Name
field)
     else Q Exp -> Q Exp -> Q Exp
forall {m :: * -> *}. Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
field) Q Exp
record
#else
  appE (varE field) record
#endif