-- | This module exports the templates for automatic instance deriving of "Rank2" type classes. The most common way to
-- use it would be
--
-- > import qualified Rank2.TH
-- > data MyDataType f = ...
-- > $(Rank2.TH.deriveAll ''MyDataType)
--
-- or, if you're picky, you can invoke only 'deriveFunctor' and whichever other instances you need instead.

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

module Rank2.TH (deriveAll, deriveFunctor, deriveApply, unsafeDeriveApply, deriveApplicative,
                 deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable)
where

import Control.Applicative (liftA2, liftA3)
import Control.Monad (replicateM)
import Data.Distributive (cotraverse)
import Data.Monoid ((<>))
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)

import qualified Rank2

data Deriving = Deriving { Deriving -> Name
_derivingConstructor :: Name, Deriving -> Name
_derivingVariable :: Name } deriving Int -> Deriving -> ShowS
[Deriving] -> ShowS
Deriving -> String
(Int -> Deriving -> ShowS)
-> (Deriving -> String) -> ([Deriving] -> ShowS) -> Show Deriving
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Deriving] -> ShowS
$cshowList :: [Deriving] -> ShowS
show :: Deriving -> String
$cshow :: Deriving -> String
showsPrec :: Int -> Deriving -> ShowS
$cshowsPrec :: Int -> Deriving -> ShowS
Show

deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll Name
ty = ((Name -> Q [Dec]) -> Q [Dec] -> Q [Dec])
-> Q [Dec] -> [Name -> Q [Dec]] -> Q [Dec]
forall (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]
deriveApply, Name -> Q [Dec]
deriveApplicative,
                                  Name -> Q [Dec]
deriveFoldable, Name -> Q [Dec]
deriveTraversable, Name -> Q [Dec]
deriveDistributive, Name -> Q [Dec]
deriveDistributiveTraversable]
   where f :: (Name -> f b) -> f b -> f b
f Name -> f b
derive f b
rest = b -> b -> b
forall a. Semigroup a => a -> a -> a
(<>) (b -> b -> b) -> f b -> f (b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f b
derive Name
ty f (b -> b) -> f b -> f b
forall (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
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Functor Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genFmap [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD '(Rank2.<$>) Inline
Inline RuleMatch
FunLike Phases
AllPhases]]

deriveApply :: Name -> Q [Dec]
deriveApply :: Name -> Q [Dec]
deriveApply Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Apply Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genAp [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2 [Con]
cs, [Con] -> Q Dec
genLiftA3 [Con]
cs,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD 'Rank2.liftA2 Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

-- | This function always succeeds, but the methods it generates may be partial. Use with care.
unsafeDeriveApply :: Name -> Q [Dec]
unsafeDeriveApply :: Name -> Q [Dec]
unsafeDeriveApply Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Apply Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genApUnsafely [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2Unsafely [Con]
cs, [Con] -> Q Dec
genLiftA3Unsafely [Con]
cs,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD 'Rank2.liftA2 Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

deriveApplicative :: Name -> Q [Dec]
deriveApplicative :: Name -> Q [Dec]
deriveApplicative Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Applicative Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genPure [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD 'Rank2.pure Inline
Inline RuleMatch
FunLike Phases
AllPhases]]

deriveFoldable :: Name -> Q [Dec]
deriveFoldable :: Name -> Q [Dec]
deriveFoldable Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Foldable Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genFoldMap [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD 'Rank2.foldMap Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

deriveTraversable :: Name -> Q [Dec]
deriveTraversable :: Name -> Q [Dec]
deriveTraversable Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Traversable Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genTraverse [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD 'Rank2.traverse Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

deriveDistributive :: Name -> Q [Dec]
deriveDistributive :: Name -> Q [Dec]
deriveDistributive Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Distributive Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genCotraverse [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
$ (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
instanceType
             [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q Dec
pragInlD 'Rank2.cotraverse Inline
Inline RuleMatch
FunLike Phases
AllPhases]]

deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.DistributiveTraversable Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genCotraverseTraversable [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
$ (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
instanceType [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors Name
cls Name
ty = do
   (TyConI Dec
tyCon) <- Name -> Q Info
reify Name
ty
   (Name
tyConName, [TyVarBndr]
tyVars, Maybe Type
_kind, [Con]
cs) <- case Dec
tyCon of
      DataD [Type]
_ Name
nm [TyVarBndr]
tyVars Maybe Type
kind [Con]
cs [DerivClause]
_   -> (Name, [TyVarBndr], Maybe Type, [Con])
-> Q (Name, [TyVarBndr], Maybe Type, [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr]
tyVars, Maybe Type
kind, [Con]
cs)
      NewtypeD [Type]
_ Name
nm [TyVarBndr]
tyVars Maybe Type
kind Con
c [DerivClause]
_ -> (Name, [TyVarBndr], Maybe Type, [Con])
-> Q (Name, [TyVarBndr], Maybe Type, [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr]
tyVars, Maybe Type
kind, [Con
c])
      Dec
_ -> String -> Q (Name, [TyVarBndr], Maybe Type, [Con])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"deriveApply: tyCon may not be a type synonym."
 
   let (KindedTV Name
tyVar (AppT (AppT Type
ArrowT Type
StarT) Type
StarT)) = [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
tyVars
       instanceType :: TypeQ
instanceType           = Name -> TypeQ
conT Name
cls TypeQ -> TypeQ -> TypeQ
`appT` (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]
init [TyVarBndr]
tyVars)
       apply :: TypeQ -> TyVarBndr -> TypeQ
apply TypeQ
t (PlainTV Name
name)    = TypeQ -> TypeQ -> TypeQ
appT TypeQ
t (Name -> TypeQ
varT Name
name)
       apply TypeQ
t (KindedTV Name
name Type
_) = TypeQ -> TypeQ -> TypeQ
appT TypeQ
t (Name -> TypeQ
varT Name
name)
 
   Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
   (TypeQ, [Con]) -> Q (TypeQ, [Con])
forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQ
instanceType, [Con]
cs)

genFmap :: [Con] -> Q ([Type], Dec)
genFmap :: [Con] -> Q ([Type], Dec)
genFmap [Con]
cs = do ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q ([Type], Clause)
genFmapClause [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 '(Rank2.<$>) [Clause]
clauses)

genAp :: [Con] -> Q ([Type], Dec)
genAp :: [Con] -> Q ([Type], Dec)
genAp [Con
con] = do ([Type]
constraints, Clause
clause) <- Bool -> Con -> Q ([Type], Clause)
genApClause Bool
False Con
con
                 ([Type], Dec) -> Q ([Type], Dec)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints, Name -> [Clause] -> Dec
FunD '(Rank2.<*>) [Clause
clause])

genLiftA2 :: [Con] -> Q Dec
genLiftA2 :: [Con] -> Q Dec
genLiftA2 [Con
con] = Name -> [ClauseQ] -> Q Dec
funD 'Rank2.liftA2 [Bool -> Con -> ClauseQ
genLiftA2Clause Bool
False Con
con]

genLiftA3 :: [Con] -> Q Dec
genLiftA3 :: [Con] -> Q Dec
genLiftA3 [Con
con] = Name -> [ClauseQ] -> Q Dec
funD 'Rank2.liftA3 [Bool -> Con -> ClauseQ
genLiftA3Clause Bool
False Con
con]

genApUnsafely :: [Con] -> Q ([Type], Dec)
genApUnsafely :: [Con] -> Q ([Type], Dec)
genApUnsafely [Con]
cons = do ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Con -> Q ([Type], Clause)
genApClause Bool
True) [Con]
cons
                        ([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 '(Rank2.<*>) [Clause]
clauses)

genLiftA2Unsafely :: [Con] -> Q Dec
genLiftA2Unsafely :: [Con] -> Q Dec
genLiftA2Unsafely [Con]
cons = Name -> [ClauseQ] -> Q Dec
funD 'Rank2.liftA2 (Bool -> Con -> ClauseQ
genLiftA2Clause Bool
True (Con -> ClauseQ) -> [Con] -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cons)

genLiftA3Unsafely :: [Con] -> Q Dec
genLiftA3Unsafely :: [Con] -> Q Dec
genLiftA3Unsafely [Con]
cons = Name -> [ClauseQ] -> Q Dec
funD 'Rank2.liftA3 (Bool -> Con -> ClauseQ
genLiftA3Clause Bool
True (Con -> ClauseQ) -> [Con] -> [ClauseQ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Con]
cons)

genPure :: [Con] -> Q ([Type], Dec)
genPure :: [Con] -> Q ([Type], Dec)
genPure [Con]
cs = do ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q ([Type], Clause)
genPureClause [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 'Rank2.pure [Clause]
clauses)

genFoldMap :: [Con] -> Q ([Type], Dec)
genFoldMap :: [Con] -> Q ([Type], Dec)
genFoldMap [Con]
cs = do ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q ([Type], Clause)
genFoldMapClause [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 'Rank2.foldMap [Clause]
clauses)

genTraverse :: [Con] -> Q ([Type], Dec)
genTraverse :: [Con] -> Q ([Type], Dec)
genTraverse [Con]
cs = do ([[Type]]
constraints, [Clause]
clauses) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q ([Type], Clause)
genTraverseClause [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 'Rank2.traverse [Clause]
clauses)

genCotraverse :: [Con] -> Q ([Type], Dec)
genCotraverse :: [Con] -> Q ([Type], Dec)
genCotraverse [Con
con] = do ([Type]
constraints, Clause
clause) <- Con -> Q ([Type], Clause)
genCotraverseClause Con
con
                         ([Type], Dec) -> Q ([Type], Dec)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints, Name -> [Clause] -> Dec
FunD 'Rank2.cotraverse [Clause
clause])

genCotraverseTraversable :: [Con] -> Q ([Type], Dec)
genCotraverseTraversable :: [Con] -> Q ([Type], Dec)
genCotraverseTraversable [Con
con] = do ([Type]
constraints, Clause
clause) <- Con -> Q ([Type], Clause)
genCotraverseTraversableClause Con
con
                                    ([Type], Dec) -> Q ([Type], Dec)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints, Name -> [Clause] -> Dec
FunD 'Rank2.cotraverseTraversable [Clause
clause])

genFmapClause :: Con -> Q ([Type], Clause)
genFmapClause :: Con -> Q ([Type], Clause)
genFmapClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- String -> Q Name
newName String
"f"
   [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 String
"x")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
f, 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
       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 Name
x (Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (Name -> Q Exp
varE Name
f) Type
fieldType (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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats BodyQ
body []
genFmapClause (RecC Name
name [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName String
"f"
   Name
x <- String -> Q Name
newName String
"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 (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (Name -> Q Exp
varE Name
f) Type
fieldType (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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name
x Name -> PatQ -> PatQ
`asP` Name -> [FieldPatQ] -> PatQ
recP Name
name []] BodyQ
body []
genFmapClause (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFmapClause (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFmapClause (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFmapClause (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFmapClause (ForallC [TyVarBndr]
_vars [Type]
_cxt Con
con) = Con -> Q ([Type], Clause)
genFmapClause Con
con

genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
fieldType Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_  | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain ''Rank2.Functor Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| ($fun Rank2.<$>) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
t2 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 Type
ty Type
_kind -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
fieldAccess

genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause :: Bool -> Con -> ClauseQ
genLiftA2Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- String -> Q Name
newName String
"f"
   [Name]
fieldNames1 <- 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 String
"x")
   Name
y <- String -> Q Name
newName String
"y"
   [Name]
fieldNames2 <- 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 String
"y")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
f, Name -> [PatQ] -> PatQ
conP Name
name ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fieldNames1), Name -> PatQ
varP Name
y]
       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]
: ((Name, Name) -> BangType -> Q Exp)
-> [(Name, Name)] -> [BangType] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q Exp
newField ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [BangType]
fieldTypes
       newField :: (Name, Name) -> BangType -> Q Exp
       newField :: (Name, Name) -> BangType -> Q Exp
newField (Name
x, Name
y) (Bang
_, Type
fieldType) = Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (Name -> Q Exp
varE Name
f) Type
fieldType (Name -> Q Exp
varE Name
x) (Name -> Q Exp
varE Name
y) Q Exp -> Q Exp
forall a. a -> a
id
   [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats BodyQ
body [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (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]
fieldNames2) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
y) []]
genLiftA2Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName String
"f"
   Name
x <- String -> Q Name
newName String
"x"
   Name
y <- String -> Q Name
newName String
"y"
   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
$ (VarBangType -> Q (Name, Exp)) -> [VarBangType] -> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q (Name, Exp)
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q (Name, Exp)
       newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          Name -> Q Exp -> Q (Name, Exp)
fieldExp Name
fieldName (Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (Name -> Q Exp
varE Name
f) Type
fieldType (Name -> Q Exp
getFieldOf Name
x) (Name -> Q Exp
getFieldOf Name
y) Q Exp -> Q Exp
forall a. a -> a
id)
          where getFieldOf :: Name -> Q Exp
getFieldOf = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
fieldName) (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE
   [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name
x Name -> PatQ -> PatQ
`asP` Name -> [FieldPatQ] -> PatQ
recP Name
name [], Name -> PatQ
varP Name
y] BodyQ
body []
genLiftA2Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> ClauseQ
genLiftA2Clause Bool
unsafely (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genLiftA2Clause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> ClauseQ
genLiftA2Clause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genLiftA2Clause Bool
unsafely (ForallC [TyVarBndr]
_vars [Type]
_cxt Con
con) = Bool -> Con -> ClauseQ
genLiftA2Clause Bool
unsafely Con
con

genLiftA2Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field :: Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
fieldType Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(wrap fun) $field1Access $field2Access |]
     AppT Type
_ Type
ty | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA2) fun) $field1Access $field2Access |]
     AppT Type
t1 Type
t2 
        | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
t2 Q Exp
field1Access Q Exp
field2Access (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'liftA2) (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
wrap)
     SigT Type
ty Type
_kind -> Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     Type
_ | Bool
unsafely -> Q Exp
field1Access
       | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String
"Cannot apply liftA2 to field of type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
fieldType)

genLiftA3Clause :: Bool -> Con -> Q Clause
genLiftA3Clause :: Bool -> Con -> ClauseQ
genLiftA3Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- String -> Q Name
newName String
"f"
   [Name]
fieldNames1 <- 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 String
"x")
   Name
y <- String -> Q Name
newName String
"y"
   Name
z <- String -> Q Name
newName String
"z"
   [Name]
fieldNames2 <- 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 String
"y")
   [Name]
fieldNames3 <- 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 String
"z")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
f, Name -> [PatQ] -> PatQ
conP Name
name ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fieldNames1), Name -> PatQ
varP Name
y, Name -> PatQ
varP Name
z]
       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]
: ((Name, Name, Name) -> BangType -> Q Exp)
-> [(Name, Name, Name)] -> [BangType] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name, Name) -> BangType -> Q Exp
newField ([Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fieldNames1 [Name]
fieldNames2 [Name]
fieldNames3) [BangType]
fieldTypes
       newField :: (Name, Name, Name) -> BangType -> Q Exp
       newField :: (Name, Name, Name) -> BangType -> Q Exp
newField (Name
x, Name
y, Name
z) (Bang
_, Type
fieldType) = Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely (Name -> Q Exp
varE Name
f) Type
fieldType (Name -> Q Exp
varE Name
x) (Name -> Q Exp
varE Name
y) (Name -> Q Exp
varE Name
z) Q Exp -> Q Exp
forall a. a -> a
id
   [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats BodyQ
body [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (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]
fieldNames2) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
y) [],
                     PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (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]
fieldNames3) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
z) []]
genLiftA3Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName String
"f"
   Name
x <- String -> Q Name
newName String
"x"
   Name
y <- String -> Q Name
newName String
"y"
   Name
z <- String -> Q Name
newName String
"z"
   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
$ (VarBangType -> Q (Name, Exp)) -> [VarBangType] -> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q (Name, Exp)
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q (Name, Exp)
       newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          Name -> Q Exp -> Q (Name, Exp)
fieldExp Name
fieldName (Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely (Name -> Q Exp
varE Name
f) Type
fieldType (Name -> Q Exp
getFieldOf Name
x) (Name -> Q Exp
getFieldOf Name
y) (Name -> Q Exp
getFieldOf Name
z) Q Exp -> Q Exp
forall a. a -> a
id)
          where getFieldOf :: Name -> Q Exp
getFieldOf = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
fieldName) (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE
   [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name
x Name -> PatQ -> PatQ
`asP` Name -> [FieldPatQ] -> PatQ
recP Name
name [], Name -> PatQ
varP Name
y, Name -> PatQ
varP Name
z] BodyQ
body []
genLiftA3Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> ClauseQ
genLiftA3Clause Bool
unsafely (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genLiftA3Clause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> ClauseQ
genLiftA3Clause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genLiftA3Clause Bool
unsafely (ForallC [TyVarBndr]
_vars [Type]
_cxt Con
con) = Bool -> Con -> ClauseQ
genLiftA3Clause Bool
unsafely Con
con

genLiftA3Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA3Field :: Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
fieldType Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_
        | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(wrap fun) $(field1Access) $(field2Access) $(field3Access) |]
     AppT Type
_ Type
ty
        | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA3) fun) $(field1Access) $(field2Access) $(field3Access) |]
     AppT Type
t1 Type
t2
        | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar
          -> Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
t2 Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'liftA3) (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
wrap)
     SigT Type
ty Type
_kind -> Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access Q Exp -> Q Exp
wrap
     Type
_ | Bool
unsafely -> Q Exp
field1Access
       | Bool
otherwise -> String -> Q Exp
forall a. HasCallStack => String -> a
error (String
"Cannot apply liftA3 to field of type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
fieldType)

genApClause :: Bool -> Con -> Q ([Type], Clause)
genApClause :: Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   [Name]
fieldNames1 <- 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 String
"x")
   [Name]
fieldNames2 <- 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 String
"y")
   Name
rhsName <- String -> Q Name
newName String
"rhs"
   let pats :: [PatQ]
pats = [Name -> [PatQ] -> PatQ
conP Name
name ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
fieldNames1), Name -> PatQ
varP Name
rhsName]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = ((Name, Name) -> BangType -> Q ([Type], Exp))
-> [(Name, Name)] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q ([Type], Exp)
newField ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [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, Name) -> BangType -> Q ([Type], Exp)
       newField :: (Name, Name) -> BangType -> Q ([Type], Exp)
newField (Name
x, Name
y) (Bang
_, Type
fieldType) = Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType (Name -> Q Exp
varE Name
x) (Name -> Q Exp
varE Name
y) 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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats BodyQ
body [PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD (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]
fieldNames2) (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
rhsName) []]
genApClause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
x <- String -> Q Name
newName String
"x"
   Name
y <- String -> Q Name
newName String
"y"
   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 (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType (Name -> Q Exp
getFieldOf Name
x) (Name -> Q Exp
getFieldOf Name
y) Q Exp -> Q Exp
forall a. a -> a
id
          where getFieldOf :: Name -> Q Exp
getFieldOf = Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
fieldName) (Q Exp -> Q Exp) -> (Name -> Q Exp) -> Name -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE
   [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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name
x Name -> PatQ -> PatQ
`asP` Name -> [FieldPatQ] -> PatQ
recP Name
name [], Name -> PatQ
varP Name
y] BodyQ
body []
genApClause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genApClause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genApClause Bool
unsafely (ForallC [TyVarBndr]
_vars [Type]
_cxt Con
con) = Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely Con
con

genApField :: Bool -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField :: Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |]
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Apply Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(wrap (varE 'Rank2.ap)) $(field1Access) $(field2Access) |]
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
t2 Q Exp
field1Access Q Exp
field2Access (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'liftA2) (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
wrap)
     SigT Type
ty Type
_kind -> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     Type
_ | Bool
unsafely -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
field1Access
       | Bool
otherwise -> String -> Q ([Type], Exp)
forall a. HasCallStack => String -> a
error (String
"Cannot apply ap to field of type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
fieldType)

genPureClause :: Con -> Q ([Type], Clause)
genPureClause :: Con -> Q ([Type], Clause)
genPureClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
argName <- String -> Q Name
newName String
"f"
   let 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]
: ((([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 = (BangType -> Q ([Type], Exp)) -> [BangType] -> [Q ([Type], Exp)]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Q ([Type], Exp)
newField [BangType]
fieldTypes
       newField :: BangType -> Q ([Type], Exp)
       newField :: BangType -> Q ([Type], Exp)
newField (Bang
_, Type
fieldType) = Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (Name -> Q Exp
varE Name
argName) 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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
argName] BodyQ
body []
genPureClause (RecC Name
name [VarBangType]
fields) = do
   Name
argName <- String -> Q Name
newName String
"f"
   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 (Name
fieldName, Bang
_, Type
fieldType) = ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (Name -> Q Exp
varE Name
argName) 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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
argName] BodyQ
body []

genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType Q Exp
pureValue Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (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 Q Exp
pureValue
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain ''Rank2.Applicative Type
t1) (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 (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'Rank2.pure) Q Exp
pureValue)
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
t2 Q Exp
pureValue (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 'pure))
     SigT Type
ty Type
_kind -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
ty Q Exp
pureValue Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
ty Q Exp
pureValue Q Exp -> Q Exp
wrap
     Type
_ -> String -> Q ([Type], Exp)
forall a. HasCallStack => String -> a
error (String
"Cannot create a pure field of type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> String
forall a. Show a => a -> String
show Type
fieldType)

genFoldMapClause :: Con -> Q ([Type], Clause)
genFoldMapClause :: Con -> Q ([Type], Clause)
genFoldMapClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- String -> Q Name
newName String
"f"
   [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 String
"x")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
f, 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 Q Exp
a Q Exp
b = [| $(a) <> $(b) |]
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats (Q Exp -> BodyQ
normalB Q Exp
body) []
genFoldMapClause (RecC Name
name [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName String
"f"
   Name
x <- String -> Q Name
newName String
"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 Q Exp
a Q Exp
b = [| $(a) <> $(b) |]
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name
x Name -> PatQ -> PatQ
`asP` Name -> [FieldPatQ] -> PatQ
recP Name
name []] (Q Exp -> BodyQ
normalB Q Exp
body) []
genFoldMapClause (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFoldMapClause (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFoldMapClause (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFoldMapClause (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFoldMapClause (ForallC [TyVarBndr]
_vars [Type]
_cxt Con
con) = Con -> Q ([Type], Clause)
genFoldMapClause Con
con

genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
fieldType Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
funcName) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Foldable Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE 'Rank2.foldMap) (Name -> Q Exp
varE Name
funcName)) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
t2 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 Type
ty Type
_kind -> Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| mempty |]

genTraverseClause :: Con -> Q ([Type], Clause)
genTraverseClause :: Con -> Q ([Type], Clause)
genTraverseClause (NormalC Name
name []) =
   (,) [] (Clause -> ([Type], Clause)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP, PatQ
wildP] (Q Exp -> BodyQ
normalB [| pure $(conE name) |]) []
genTraverseClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- String -> Q Name
newName String
"f"
   [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 String
"x")
   let pats :: [PatQ]
pats = [Name -> PatQ
varP Name
f, 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
       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, 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 (Q Exp
a, Bool
False) Q Exp
b = ([| $(a) <$> $(b) |], Bool
True)
       apply (Q Exp
a, Bool
True) Q Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (Name -> Q Exp
varE Name
f) Type
fieldType (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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats BodyQ
body []
genTraverseClause (RecC Name
name [VarBangType]
fields) = do
   Name
f <- String -> Q Name
newName String
"f"
   Name
x <- String -> Q Name
newName String
"x"
   let 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
       body :: BodyQ
body = Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ (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] -> (Q Exp, Bool)) -> [Q Exp] -> (Q Exp, Bool)
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
       apply :: (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
apply (Q Exp
a, Bool
False) Q Exp
b = ([| $(a) <$> $(b) |], Bool
True)
       apply (Q Exp
a, Bool
True) Q Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (Name -> Q Exp
varE Name
f) Type
fieldType (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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
f, Name
x Name -> PatQ -> PatQ
`asP` Name -> [FieldPatQ] -> PatQ
recP Name
name []] BodyQ
body []
genTraverseClause (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genTraverseClause (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genTraverseClause (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genTraverseClause (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genTraverseClause (ForallC [TyVarBndr]
_vars [Type]
_cxt Con
con) = Con -> Q ([Type], Clause)
genTraverseClause Con
con

genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
fieldType Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Traversable Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap [| Rank2.traverse $fun |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
t2 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 Type
ty Type
_kind -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| pure $fieldAccess |]

genCotraverseClause :: Con -> Q ([Type], Clause)
genCotraverseClause :: Con -> Q ([Type], Clause)
genCotraverseClause (NormalC Name
name []) = Con -> Q ([Type], Clause)
genCotraverseClause (Name -> [VarBangType] -> Con
RecC Name
name [])
genCotraverseClause (RecC Name
name [VarBangType]
fields) = do
   Name
withName <- String -> Q Name
newName String
"w"
   Name
argName <- String -> Q Name
newName String
"f"
   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 :: 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
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.Distributive (Name -> Q Exp
varE 'Rank2.cotraverse) (Name -> Q Exp
varE Name
withName)
                                   Type
fieldType [| $(varE fieldName) <$> $(varE argName) |] 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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
withName, Name -> PatQ
varP Name
argName] BodyQ
body []

genCotraverseTraversableClause :: Con -> Q ([Type], Clause)
genCotraverseTraversableClause :: Con -> Q ([Type], Clause)
genCotraverseTraversableClause (NormalC Name
name []) = Con -> Q ([Type], Clause)
genCotraverseTraversableClause (Name -> [VarBangType] -> Con
RecC Name
name [])
genCotraverseTraversableClause (RecC Name
name [VarBangType]
fields) = do
   Name
withName <- String -> Q Name
newName String
"w"
   Name
argName <- String -> Q Name
newName String
"f"
   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 :: 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
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.DistributiveTraversable
                                   (Name -> Q Exp
varE 'Rank2.cotraverseTraversable) (Name -> Q Exp
varE Name
withName) Type
fieldType
                                   [| $(varE fieldName) <$> $(varE argName) |] 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)) -> ClauseQ -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
withName, Name -> PatQ
varP Name
argName] BodyQ
body []

genCotraverseField :: Name -> Q Exp -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genCotraverseField :: Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField Name
className Q Exp
method Q Exp
fun Type
fieldType Q Exp
fieldAccess Q Exp -> Q Exp
wrap = do
   Just (Deriving Name
_ Name
typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain Name
className Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
appE Q Exp
method Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
                  Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField Name
className Q Exp
method Q Exp
fun Type
t2 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 'cotraverse))
     SigT Type
ty Type
_kind -> Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField Name
className Q Exp
method Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField Name
className Q Exp
method Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap

constrain :: Name -> Type -> [Type]
constrain :: Name -> Type -> [Type]
constrain Name
_ ConT{} = []
constrain Name
cls Type
t = [Name -> Type
ConT Name
cls Type -> Type -> Type
`AppT` Type
t]