-- | 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
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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {f :: * -> *} {b}.
(Applicative f, Semigroup b) =>
(Name -> f b) -> f b -> f b
f (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 = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f b
derive Name
ty 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 <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Shallow.Functor forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
       baseConstraint :: Q Type -> Q Type
baseConstraint Q Type
ty = forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.At forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t 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
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Transformation) Q Type
t forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints)
                       (Q Type -> Q Type
shallowConstraint Q Type
instanceType)
                       [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 <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Q Type
m <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Shallow.Foldable forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
       baseConstraint :: Q Type -> Q Type
baseConstraint Q Type
ty = forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.At forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t 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
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Transformation) Q Type
t forall a. a -> [a] -> [a]
:
                             forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT forall (m :: * -> *). Quote m => m Type
equalityT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Codomain forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t))
                                  (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Const forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
m) forall a. a -> [a] -> [a]
:
                             forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Monoid) Q Type
m forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints))
                       (Q Type -> Q Type
shallowConstraint Q Type
instanceType)
                       [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 <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Q Type
m <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => String -> m Name
newName String
"m"
   Q Type
f <- forall (m :: * -> *). Quote m => Name -> m Type
varT forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Shallow.Traversable forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
ty
       baseConstraint :: Q Type -> Q Type
baseConstraint Q Type
ty = forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.At forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t 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
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
cxt (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Transformation) Q Type
t forall a. a -> [a] -> [a]
:
                             forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT forall (m :: * -> *). Quote m => m Type
equalityT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Transformation.Codomain forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
t))
                                  (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Compose forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
m forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
f) forall a. a -> [a] -> [a]
:
                             forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Applicative) Q Type
m forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints))
                       (Q Type -> Q Type
shallowConstraint Q Type
instanceType)
                       [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 = 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) 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 (forall a. a -> Maybe a -> a
fromMaybe Name
name forall a b. (a -> b) -> a -> b
$ 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]
_   -> 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]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr ()]
tyVars, Maybe Type
kind, [Con
c])
      Dec
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"deriveApply: tyCon may not be a type synonym."

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

   forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
   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) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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
   forall (m :: * -> *) a. Monad m => a -> m a
return (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) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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
   forall (m :: * -> *) a. Monad m => a -> m a
return (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) <- forall a b. [(a, b)] -> ([a], [b])
unzip
     forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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
   forall (m :: * -> *) a. Monad m => a -> m a
return (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          <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   [Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name 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 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTraverseFieldType
genShallowmapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` 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) <- forall a. Typeable a => Q (Maybe a)
getQ
      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 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 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) <- forall a. Typeable a => Q (Maybe a)
getQ
      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 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 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          <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   [Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
fieldNames = [| mempty |]
            | Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) 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 = [| $(a) <> $(b) |]
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = GenTraverseFieldType
genFoldMapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
   let body :: Q Exp
body | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| mempty |]
            | Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = 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 = [| $(a) <> $(b) |]
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) =
          GenTraverseFieldType
genFoldMapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
name []] (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) <- forall a. Typeable a => Q (Maybe a)
getQ
      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 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 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) <- forall a. Typeable a => Q (Maybe a)
getQ
      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 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 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          <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"t"
   [Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => String -> m Name
newName String
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
t, forall (m :: * -> *). Quote m => m Pat -> m Pat
parensP (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = 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 = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Exp
body | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BangType]
fieldTypes = [| pure $(conE name) |]
            | Bool
otherwise = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (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 = ([| $(a) <$> $(b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = GenTraverseFieldType
genField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
t) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (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 <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"f"
   Name
x <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"x"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Exp
body | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| pure $(conE name) |]
            | Bool
otherwise = forall a b. (a, b) -> a
fst (forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd 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 = ([| $(a) <$> $(b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenTraverseFieldType
genField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType Q Type -> Q Type
shallowConstraint Q Type -> Q Type
baseConstraint (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fieldName) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
recP Name
name []] (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) <- forall a. Typeable a => Q (Maybe a)
getQ
      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 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 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) <- forall a. Typeable a => Q (Maybe a)
getQ
      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 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 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
a | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type
baseConstraint (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp
wrap (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(Transformation.$) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
trans) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
fieldAccess)
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Q Type -> Q Type
shallowConstraint [forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t1]
                                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| ($trans Transformation.Shallow.<$>) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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
_ -> (,) [] 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
a | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type
baseConstraint (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp
wrap (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE 'getConst forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(Transformation.$) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
trans))
                 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
fieldAccess)
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Q Type -> Q Type
shallowConstraint [forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t1]
                                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| (Transformation.Shallow.foldMap $trans) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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
_ -> (,) [] 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
a  | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Type -> Q Type
baseConstraint (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
a))
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Q Exp -> Q Exp
wrap (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(.) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE 'getCompose forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE '(Transformation.$) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
trans))
                 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
fieldAccess)
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Q Type -> Q Type
shallowConstraint [forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
t1]
                                            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| (Transformation.Shallow.traverse $trans) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (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
_ -> (,) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| pure $fieldAccess |]