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

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

module Transformation.Deep.TH (deriveAll, deriveFunctor, deriveTraversable)
where

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

import qualified Transformation
import qualified Transformation.Deep
import qualified Transformation.Full
import qualified Rank2.TH


data Deriving = Deriving { Deriving -> Name
_constructor :: Name, Deriving -> Name
_variableN :: Name, Deriving -> Name
_variable1 :: Name }

deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll ty :: Name
ty = ((Name -> Q [Dec]) -> Q [Dec] -> Q [Dec])
-> Q [Dec] -> [Name -> Q [Dec]] -> Q [Dec]
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 (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 derive :: Name -> f b
derive rest :: 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 (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f b
rest

deriveFunctor :: Name -> Q [Dec]
deriveFunctor :: Name -> Q [Dec]
deriveFunctor ty :: Name
ty = do
   TypeQ
t <- Name -> TypeQ
varT (Name -> TypeQ) -> Q Name -> Q TypeQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Q Name
newName "t"
   (instanceType :: TypeQ
instanceType, cs :: [Con]
cs) <- Name -> Q (TypeQ, [Con])
reifyConstructors Name
ty
   let deepConstraint :: TypeQ -> TypeQ
deepConstraint ty :: TypeQ
ty = Name -> TypeQ
conT ''Transformation.Deep.Functor TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
t TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
ty
       fullConstraint :: TypeQ -> TypeQ
fullConstraint ty :: TypeQ
ty = Name -> TypeQ
conT ''Transformation.Full.Functor TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
t TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
ty
   (constraints :: [Type]
constraints, dec :: Dec
dec) <- (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> [Con] -> Q ([Type], Dec)
genDeepmap TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
instanceType [Con]
cs
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt ([TypeQ] -> CxtQ) -> [TypeQ] -> CxtQ
forall a b. (a -> b) -> a -> b
$ TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Transformation.Transformation) TypeQ
t TypeQ -> [TypeQ] -> [TypeQ]
forall a. a -> [a] -> [a]
: (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints)
                       (TypeQ -> TypeQ
deepConstraint TypeQ
instanceType)
                       [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

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

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

substitute :: Type -> Q Type -> Q Type -> Q Type
substitute :: Type -> TypeQ -> TypeQ -> TypeQ
substitute resultType :: Type
resultType = (Type -> Type -> Type) -> TypeQ -> TypeQ -> TypeQ
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' instanceType :: Type
instanceType argumentType :: 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 t1 :: Type
t1 (VarT name1 :: Name
name1)) (AppT t2 :: Type
t2 (VarT name2 :: 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 _t1 :: Type
_t1 _t2 :: Type
_t2 = []
         substituteVars :: [(Name, Name)] -> Type -> Type
substituteVars subs :: [(Name, Name)]
subs (VarT name :: 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 subs :: [(Name, Name)]
subs (AppT t1 :: Type
t1 t2 :: 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 _ t :: Type
t = Type
t

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

   let (KindedTV tyVar :: Name
tyVar  (AppT (AppT ArrowT StarT) StarT) :
        KindedTV tyVar' :: Name
tyVar' (AppT (AppT ArrowT StarT) StarT) : _) = [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
reverse [TyVarBndr]
tyVars
       instanceType :: TypeQ
instanceType           = (TypeQ -> TyVarBndr -> TypeQ) -> TypeQ -> [TyVarBndr] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TyVarBndr -> TypeQ
apply (Name -> TypeQ
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 2 ([TyVarBndr] -> [TyVarBndr]) -> [TyVarBndr] -> [TyVarBndr]
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
reverse [TyVarBndr]
tyVars)
       apply :: TypeQ -> TyVarBndr -> TypeQ
apply t :: TypeQ
t (PlainTV name :: Name
name)    = TypeQ -> TypeQ -> TypeQ
appT TypeQ
t (Name -> TypeQ
varT Name
name)
       apply t :: TypeQ
t (KindedTV name :: Name
name _) = TypeQ -> TypeQ -> TypeQ
appT TypeQ
t (Name -> TypeQ
varT Name
name)

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

genDeepmap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genDeepmap :: (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> [Con] -> Q ([Type], Dec)
genDeepmap deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType cs :: [Con]
cs = do
   (constraints :: [[Type]]
constraints, clauses :: [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)
mapM ((TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genDeepmapClause TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
instanceType) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
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.Deep.<$>) [Clause]
clauses)

genFoldMap :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genFoldMap :: (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType cs :: [Con]
cs = do
   (constraints :: [[Type]]
constraints, clauses :: [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)
mapM ((TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genFoldMapClause TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
instanceType) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
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.Deep.foldMap [Clause]
clauses)

genTraverse :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> [Con] -> Q ([Type], Dec)
genTraverse :: (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType cs :: [Con]
cs = do
   (constraints :: [[Type]]
constraints, clauses :: [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)
mapM (GenTraverseFieldType
-> (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ)
-> TypeQ
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genTraverseField TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
instanceType) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
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.Deep.traverse [Clause]
clauses)

genDeepmapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genDeepmapClause :: (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genDeepmapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (NormalC name :: Name
name fieldTypes :: [BangType]
fieldTypes) = do
   Name
t          <- String -> Q Name
newName "t"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (String -> Q Name
newName "x")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
t, PatQ -> PatQ
parensP (Name -> [PatQ] -> PatQ
conP Name
name ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
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 :: BodyQ
body = Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q 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 x :: Name
x (_, fieldType :: Type
fieldType) = GenTraverseFieldType
genDeepmapField (Name -> Q Exp
varE Name
t) Type
fieldType TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint (Name -> Q 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)] -> CxtQ
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)
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
<$> [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [PatQ]
pats BodyQ
body []
genDeepmapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (RecC name :: Name
name fields :: [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName "f"
   Name
x <- String -> Q Name
newName "x"
   let body :: BodyQ
body = Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q 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 (fieldName :: Name
fieldName, _, fieldType :: 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
genDeepmapField (Name -> Q Exp
varE Name
f) Type
fieldType TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
fieldName) (Name -> Q 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], (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))] -> CxtQ
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)
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
<$> [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
x] BodyQ
body []
genDeepmapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType
                 (GadtC [name :: Name
name] fieldTypes :: [BangType]
fieldTypes (AppT (AppT resultType :: Type
resultType (VarT tyVar' :: Name
tyVar')) (VarT tyVar :: Name
tyVar))) =
   do Just (Deriving tyConName :: Name
tyConName _tyVar' :: Name
_tyVar' _tyVar :: Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar' Name
tyVar)
      (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genDeepmapClause (TypeQ -> TypeQ
deepConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       (TypeQ -> TypeQ
fullConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       TypeQ
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genDeepmapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType
                 (RecGadtC [name :: Name
name] fields :: [VarBangType]
fields (AppT (AppT resultType :: Type
resultType (VarT tyVar' :: Name
tyVar')) (VarT tyVar :: Name
tyVar))) =
   do Just (Deriving tyConName :: Name
tyConName _tyVar' :: Name
_tyVar' _tyVar :: Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar' Name
tyVar)
      (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genDeepmapClause (TypeQ -> TypeQ
deepConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       (TypeQ -> TypeQ
fullConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       TypeQ
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genDeepmapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (ForallC _vars :: [TyVarBndr]
_vars _cxt :: [Type]
_cxt con :: Con
con) =
   (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genDeepmapClause TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
instanceType Con
con

genFoldMapClause :: (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Type -> Con -> Q ([Type], Clause)
genFoldMapClause :: (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genFoldMapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (NormalC name :: Name
name fieldTypes :: [BangType]
fieldTypes) = do
   Name
t          <- String -> Q Name
newName "t"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (String -> Q Name
newName "x")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
t, Name -> [PatQ] -> PatQ
conP Name
name ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
fieldNames = [| mempty |]
            | Bool
otherwise = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q 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 :: Q Exp -> Q Exp -> Q Exp
append a :: Q Exp
a b :: Q Exp
b = [| $(a) <> $(b) |]
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField x :: Name
x (_, fieldType :: Type
fieldType) = GenTraverseFieldType
genFoldMapField (Name -> Q Exp
varE Name
t) Type
fieldType TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint (Name -> Q 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)] -> CxtQ
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)
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
<$> [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [PatQ]
pats (Q Exp -> BodyQ
normalB Q Exp
body) []
genFoldMapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (RecC _name :: Name
_name fields :: [VarBangType]
fields) = do
   Name
t <- String -> Q Name
newName "t"
   Name
x <- String -> Q Name
newName "x"
   let body :: Q Exp
body | [VarBangType] -> 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 (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q 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 :: Q Exp -> Q Exp -> Q Exp
append a :: Q Exp
a b :: Q Exp
b = [| $(a) <> $(b) |]
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (fieldName :: Name
fieldName, _, fieldType :: Type
fieldType) =
          GenTraverseFieldType
genFoldMapField (Name -> Q Exp
varE Name
t) Type
fieldType TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
fieldName) (Name -> Q 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)] -> CxtQ
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)
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
<$> [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [Name -> PatQ
varP Name
t, PatQ -> PatQ
bangP (Name -> PatQ
varP Name
x)] (Q Exp -> BodyQ
normalB Q Exp
body) []
genFoldMapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType
                 (GadtC [name :: Name
name] fieldTypes :: [BangType]
fieldTypes (AppT (AppT resultType :: Type
resultType (VarT tyVar' :: Name
tyVar')) (VarT tyVar :: Name
tyVar))) =
   do Just (Deriving tyConName :: Name
tyConName _tyVar' :: Name
_tyVar' _tyVar :: Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar' Name
tyVar)
      (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genFoldMapClause (TypeQ -> TypeQ
deepConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       (TypeQ -> TypeQ
fullConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       TypeQ
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFoldMapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType
                 (RecGadtC [name :: Name
name] fields :: [VarBangType]
fields (AppT (AppT resultType :: Type
resultType (VarT tyVar' :: Name
tyVar')) (VarT tyVar :: Name
tyVar))) =
   do Just (Deriving tyConName :: Name
tyConName _tyVar' :: Name
_tyVar' _tyVar :: Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar' Name
tyVar)
      (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genFoldMapClause (TypeQ -> TypeQ
deepConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       (TypeQ -> TypeQ
fullConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                       TypeQ
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFoldMapClause deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (ForallC _vars :: [TyVarBndr]
_vars _cxt :: [Type]
_cxt con :: Con
con) =
   (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ) -> TypeQ -> Con -> Q ([Type], Clause)
genFoldMapClause TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
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
-> (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ)
-> TypeQ
-> Con
-> Q ([Type], Clause)
genTraverseClause genTraverseField :: GenTraverseFieldType
genTraverseField deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (NormalC name :: Name
name fieldTypes :: [BangType]
fieldTypes) = do
   Name
t          <- String -> Q Name
newName "t"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (String -> Q Name
newName "x")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
t, PatQ -> PatQ
parensP (Name -> [PatQ] -> PatQ
conP Name
name ([PatQ] -> PatQ) -> [PatQ] -> PatQ
forall a b. (a -> b) -> a -> b
$ (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [BangType]
fieldTypes = [| pure $(conE 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
apply (Name -> Q Exp
conE Name
name, Bool
False) [Q Exp]
newFields
       apply :: (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
apply (a :: Q Exp
a, False) b :: Q Exp
b = ([| $(a) <$> $(b) |], Bool
True)
       apply (a :: Q Exp
a, True) b :: Q Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField x :: Name
x (_, fieldType :: Type
fieldType) = GenTraverseFieldType
genTraverseField (Name -> Q Exp
varE Name
t) Type
fieldType TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint (Name -> Q 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)] -> CxtQ
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)
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
<$> [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [PatQ]
pats (Q Exp -> BodyQ
normalB Q Exp
body) []
genTraverseClause genTraverseField :: GenTraverseFieldType
genTraverseField deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (RecC name :: Name
name fields :: [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName "f"
   Name
x <- String -> Q Name
newName "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 (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| pure $(conE 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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
apply (Name -> Q 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 :: (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
apply (a :: Q Exp
a, False) b :: Q Exp
b = ([| $(a) <$> $(b) |], Bool
True)
       apply (a :: Q Exp
a, True) b :: Q Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (fieldName :: Name
fieldName, _, fieldType :: 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
genTraverseField (Name -> Q Exp
varE Name
f) Type
fieldType TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
fieldName) (Name -> Q 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], (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))] -> CxtQ
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)
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
<$> [PatQ] -> BodyQ -> [Q Dec] -> Q Clause
clause [Name -> PatQ
varP Name
f, Name -> PatQ
varP Name
x] (Q Exp -> BodyQ
normalB Q Exp
body) []
genTraverseClause genTraverseField :: GenTraverseFieldType
genTraverseField deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType
                  (GadtC [name :: Name
name] fieldTypes :: [BangType]
fieldTypes (AppT (AppT resultType :: Type
resultType (VarT tyVar' :: Name
tyVar')) (VarT tyVar :: Name
tyVar))) =
   do Just (Deriving tyConName :: Name
tyConName _tyVar' :: Name
_tyVar' _tyVar :: Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar' Name
tyVar)
      GenTraverseFieldType
-> (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ)
-> TypeQ
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genTraverseField
        (TypeQ -> TypeQ
deepConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
        (TypeQ -> TypeQ
fullConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
        TypeQ
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genTraverseClause genTraverseField :: GenTraverseFieldType
genTraverseField deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType
                  (RecGadtC [name :: Name
name] fields :: [VarBangType]
fields (AppT (AppT resultType :: Type
resultType (VarT tyVar' :: Name
tyVar')) (VarT tyVar :: Name
tyVar))) =
   do Just (Deriving tyConName :: Name
tyConName _tyVar' :: Name
_tyVar' _tyVar :: Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar' Name
tyVar)
      GenTraverseFieldType
-> (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ)
-> TypeQ
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genTraverseField
                        (TypeQ -> TypeQ
deepConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                        (TypeQ -> TypeQ
fullConstraint (TypeQ -> TypeQ) -> (TypeQ -> TypeQ) -> TypeQ -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TypeQ -> TypeQ -> TypeQ
substitute Type
resultType TypeQ
instanceType)
                        TypeQ
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genTraverseClause genTraverseField :: GenTraverseFieldType
genTraverseField deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint instanceType :: TypeQ
instanceType (ForallC _vars :: [TyVarBndr]
_vars _cxt :: [Type]
_cxt con :: Con
con) =
   GenTraverseFieldType
-> (TypeQ -> TypeQ)
-> (TypeQ -> TypeQ)
-> TypeQ
-> Con
-> Q ([Type], Clause)
genTraverseClause GenTraverseFieldType
genTraverseField TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint TypeQ
instanceType Con
con

genDeepmapField :: Q Exp -> Type -> (Q Type -> Q Type) -> (Q Type -> Q Type) -> Q Exp -> (Q Exp -> Q Exp)
                -> Q ([Type], Exp)
genDeepmapField :: GenTraverseFieldType
genDeepmapField trans :: Q Exp
trans fieldType :: Type
fieldType deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint fieldAccess :: Q Exp
fieldAccess wrap :: Q Exp -> Q Exp
wrap = do
   Just (Deriving _ typeVarN :: Name
typeVarN typeVar1 :: Name
typeVar1) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT ty :: Type
ty (AppT (AppT con :: Type
con v1 :: Type
v1) v2 :: Type
v2) | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1, Type
v1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN, Type
v2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> CxtQ -> 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]) -> TypeQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> TypeQ
fullConstraint (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
con))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| ($trans Transformation.Full.<$>) |]) Q Exp
fieldAccess
     AppT ty :: Type
ty _  | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1 ->
                  (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Exp -> Q Exp
wrap (Name -> Q Exp
varE '(Transformation.$) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
trans) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
fieldAccess)
     AppT (AppT con :: Type
con v1 :: Type
v1) v2 :: Type
v2 | Type
v1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN, Type
v2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1 ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> CxtQ -> 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]) -> TypeQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> TypeQ
deepConstraint (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
con))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| Transformation.Deep.fmap $trans |]) Q Exp
fieldAccess
     AppT t1 :: Type
t1 t2 :: Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar1 ->
        GenTraverseFieldType
genDeepmapField Q Exp
trans Type
t2 TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint 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
appE (Name -> Q Exp
varE '(<$>)))
     SigT ty :: Type
ty _kind :: Type
_kind -> GenTraverseFieldType
genDeepmapField Q Exp
trans Type
ty TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT ty :: Type
ty -> GenTraverseFieldType
genDeepmapField Q Exp
trans Type
ty TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     _ -> (,) [] (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 trans :: Q Exp
trans fieldType :: Type
fieldType deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint fieldAccess :: Q Exp
fieldAccess wrap :: Q Exp -> Q Exp
wrap = do
   Just (Deriving _ typeVarN :: Name
typeVarN typeVar1 :: Name
typeVar1) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT ty :: Type
ty (AppT (AppT con :: Type
con v1 :: Type
v1) v2 :: Type
v2) | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1, Type
v1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN, Type
v2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> CxtQ -> 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]) -> TypeQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> TypeQ
fullConstraint (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
con))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| Transformation.Full.foldMap $trans |]) Q Exp
fieldAccess
     AppT ty :: Type
ty _  | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1 ->
                  (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Exp -> Q Exp
wrap (Name -> Q Exp
varE '(Transformation.$) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
trans) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
fieldAccess)
     AppT (AppT con :: Type
con v1 :: Type
v1) v2 :: Type
v2 | Type
v1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN, Type
v2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1 ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> CxtQ -> 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]) -> TypeQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> TypeQ
deepConstraint (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
con))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| Transformation.Deep.foldMap $trans |]) Q Exp
fieldAccess
     AppT t1 :: Type
t1 t2 :: Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar1 ->
        GenTraverseFieldType
genFoldMapField Q Exp
trans Type
t2 TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint 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
appE (Name -> Q Exp
varE 'foldMap))
     SigT ty :: Type
ty _kind :: Type
_kind -> GenTraverseFieldType
genFoldMapField Q Exp
trans Type
ty TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT ty :: Type
ty -> GenTraverseFieldType
genFoldMapField Q Exp
trans Type
ty TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     _ -> (,) [] (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 trans :: Q Exp
trans fieldType :: Type
fieldType deepConstraint :: TypeQ -> TypeQ
deepConstraint fullConstraint :: TypeQ -> TypeQ
fullConstraint fieldAccess :: Q Exp
fieldAccess wrap :: Q Exp -> Q Exp
wrap = do
   Just (Deriving _ typeVarN :: Name
typeVarN typeVar1 :: Name
typeVar1) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT ty :: Type
ty (AppT (AppT con :: Type
con v1 :: Type
v1) v2 :: Type
v2) | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1, Type
v1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN, Type
v2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> CxtQ -> 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]) -> TypeQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> TypeQ
fullConstraint (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
con))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| Transformation.Full.traverse $trans |]) Q Exp
fieldAccess
     AppT ty :: Type
ty _  | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1 ->
                  (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Q Exp -> Q Exp
wrap (Name -> Q Exp
varE '(Transformation.$) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
trans) Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
fieldAccess)
     AppT (AppT con :: Type
con v1 :: Type
v1) v2 :: Type
v2 | Type
v1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVarN, Type
v2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar1 ->
        (,) ([Type] -> Exp -> ([Type], Exp))
-> CxtQ -> 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]) -> TypeQ -> CxtQ
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeQ -> TypeQ
deepConstraint (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
con))
            Q (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| Transformation.Deep.traverse $trans |]) Q Exp
fieldAccess
     AppT t1 :: Type
t1 t2 :: Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar1 ->
        GenTraverseFieldType
genTraverseField Q Exp
trans Type
t2 TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint 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
appE (Name -> Q Exp
varE 'traverse))
     SigT ty :: Type
ty _kind :: Type
_kind -> GenTraverseFieldType
genTraverseField Q Exp
trans Type
ty TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT ty :: Type
ty -> GenTraverseFieldType
genTraverseField Q Exp
trans Type
ty TypeQ -> TypeQ
deepConstraint TypeQ -> TypeQ
fullConstraint Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     _ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| pure $fieldAccess |]