-- | 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 CPP #-}
{-# Language TemplateHaskell #-}
{-# Language TypeOperators #-}
-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial

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

import Control.Applicative (liftA2, liftA3)
import Control.Monad (replicateM)
import Data.Bifunctor (first)
import Data.Distributive (cotraverse)
import Data.Functor.Compose (Compose (Compose))
import Data.Functor.Contravariant (Contravariant, contramap)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH (Q, TypeQ, Name, TyVarBndr(KindedTV, PlainTV), Clause, Dec(..), Con(..), Type(..), Exp(..),
                            Inline(Inlinable, Inline), RuleMatch(FunLike), Phases(AllPhases),
                            appE, conE, conP, conT, instanceD, varE, varP, varT, normalB, pragInlD, recConE, wildP)
import Language.Haskell.TH.Syntax (BangType, VarBangType, Info(TyConI), getQ, putQ, newName)

import qualified Rank2

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

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]
deriveApply, Name -> Q [Dec]
deriveApplicative,
                                  Name -> Q [Dec]
deriveFoldable, Name -> Q [Dec]
deriveTraversable,
                                  Name -> Q [Dec]
deriveDistributive, Name -> Q [Dec]
deriveDistributiveTraversable, Name -> Q [Dec]
deriveLogistic]
   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
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Functor Name
ty
   ([Type]
constraints, Dec
dec) <- TypeQ -> [Con] -> Q ([Type], Dec)
genFmap TypeQ
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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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) <- TypeQ -> [Con] -> Q ([Type], Dec)
genAp TypeQ
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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2 [Con]
cs, [Con] -> Q Dec
genLiftA3 [Con]
cs,
              forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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) <- TypeQ -> [Con] -> Q ([Type], Dec)
genApUnsafely TypeQ
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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2Unsafely [Con]
cs, [Con] -> Q Dec
genLiftA3Unsafely [Con]
cs,
              forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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
   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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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) <- TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap TypeQ
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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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) <- TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse TypeQ
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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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
   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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m 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
   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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

deriveLogistic :: Name -> Q [Dec]
deriveLogistic :: Name -> Q [Dec]
deriveLogistic Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Logistic Name
ty
   ([Type]
constraints, [Dec]
decs) <- TypeQ -> [Con] -> Q ([Type], [Dec])
genDeliver TypeQ
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]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
              (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs forall a. Semigroup a => a -> a -> a
<> [forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD 'Rank2.deliver Inline
Inline RuleMatch
FunLike Phases
AllPhases])]

reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors Name
cls Name
ty = do
   (TyConI Dec
tyCon) <- Name -> Q Info
TH.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 => [Char] -> m a
fail [Char]
"deriveApply: tyCon may not be a type synonym."

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

#if MIN_VERSION_template_haskell(2,17,0)
   let (KindedTV Name
tyVar ()
_ (AppT (AppT Type
ArrowT Type
_) Type
resultKind)) = TyVarBndr ()
lastVar
       instanceType :: TypeQ
instanceType           = forall (m :: * -> *). Quote m => Name -> m Type
conT Name
cls forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`TH.appT` 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]
init [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
TH.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
TH.appT m Type
t (forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name)
#else
   let (KindedTV tyVar (AppT (AppT ArrowT _) resultKind)) = lastVar
       instanceType           = conT cls `TH.appT` foldl apply (conT tyConName) (init tyVars)
       apply t (PlainTV name)    = TH.appT t (varT name)
       apply t (KindedTV name _) = TH.appT t (varT name)
#endif

   case Type
resultKind of
      Type
StarT -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Type
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unexpected result kind: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Type
resultKind)
   forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
   forall (m :: * -> *) a. Monad m => a -> m a
return (TypeQ
instanceType, [Con]
cs)

genFmap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFmap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFmap TypeQ
instanceType [Con]
cs = do
   Type
it <- TypeQ
instanceType
   ([[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 (Type -> Con -> Q ([Type], Clause)
genFmapClause Type
it) [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 '(Rank2.<$>) [Clause]
clauses)

genAp :: TypeQ -> [Con] -> Q ([Type], Dec)
genAp :: TypeQ -> [Con] -> Q ([Type], Dec)
genAp TypeQ
instanceType [Con
con] = do
   Type
it <- TypeQ
instanceType
   ([Type]
constraints, Clause
clause) <- Bool -> Type -> Con -> Q ([Type], Clause)
genApClause Bool
False Type
it Con
con
   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] = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'Rank2.liftA2 [Bool -> Con -> Q Clause
genLiftA2Clause Bool
False Con
con]

genLiftA3 :: [Con] -> Q Dec
genLiftA3 :: [Con] -> Q Dec
genLiftA3 [Con
con] = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'Rank2.liftA3 [Bool -> Con -> Q Clause
genLiftA3Clause Bool
False Con
con]

genApUnsafely :: TypeQ -> [Con] -> Q ([Type], Dec)
genApUnsafely :: TypeQ -> [Con] -> Q ([Type], Dec)
genApUnsafely TypeQ
instanceType [Con]
cons = do
   Type
it <- TypeQ
instanceType
   ([[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 (Bool -> Type -> Con -> Q ([Type], Clause)
genApClause Bool
True Type
it) [Con]
cons
   forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'Rank2.liftA2 (Bool -> Con -> Q Clause
genLiftA2Clause Bool
True 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 = forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
TH.funD 'Rank2.liftA3 (Bool -> Con -> Q Clause
genLiftA3Clause Bool
True 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) <- 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 Con -> Q ([Type], Clause)
genPureClause [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 'Rank2.pure [Clause]
clauses)

genFoldMap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap TypeQ
instanceType [Con]
cs = do
   Type
it <- TypeQ
instanceType
   ([[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 (Type -> Con -> Q ([Type], Clause)
genFoldMapClause Type
it) [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 'Rank2.foldMap [Clause]
clauses)

genTraverse :: TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse :: TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse TypeQ
instanceType [Con]
cs = do
   Type
it <- TypeQ
instanceType
   ([[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 (Type -> Con -> Q ([Type], Clause)
genTraverseClause Type
it) [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 '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
                         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
                                    forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints, Name -> [Clause] -> Dec
FunD 'Rank2.cotraverseTraversable [Clause
clause])

genDeliver :: TypeQ -> [Con] -> Q ([Type], [Dec])
genDeliver :: TypeQ -> [Con] -> Q ([Type], [Dec])
genDeliver TypeQ
instanceType [Con
con] = do
   Type
it <- TypeQ
instanceType
   let AppT Type
_classType Type
rt = Type
it
       recType :: TypeQ
recType = forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rt
   Bool
signable <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.InstanceSigs
   Bool
scopable <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.ScopedTypeVariables
   if Bool
signable Bool -> Bool -> Bool
&& Bool
scopable then do
      Name
p <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"p"
      Name
q <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"q"
      ([Type]
constraints, Clause
clause) <- TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause TypeQ
recType (forall a. a -> Maybe a
Just Name
q) Con
con
      Type
ctx <- [t| Contravariant $(varT p) |]
      Type
methodType <- [t| $(varT p) ($(recType) $(varT q) -> $(recType) $(varT q)) -> $(recType) (Compose $(varT p) ($(varT q) Rank2.~> $(varT q))) |]
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints,
              [Name -> Type -> Dec
SigD 'Rank2.deliver ([TyVarBndr Specificity] -> [Type] -> Type -> Type
ForallT [Name -> TyVarBndr Specificity
binder Name
p, Name -> TyVarBndr Specificity
binder Name
q] [Type
ctx] Type
methodType),
               Name -> [Clause] -> Dec
FunD 'Rank2.deliver [Clause
clause]])
   else do
      ([Type]
constraints, Clause
clause) <- TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause TypeQ
recType forall a. Maybe a
Nothing Con
con
      forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints, [Name -> [Clause] -> Dec
FunD 'Rank2.deliver [Clause
clause]])


genFmapClause :: Type -> Con -> Q ([Type], Clause)
genFmapClause :: Type -> Con -> Q ([Type], Clause)
genFmapClause Type
_ (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [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 => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, 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
       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
TH.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) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (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
TH.clause [Q Pat]
pats Q Body
body []
genFmapClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"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
<$> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] Q Body
body []
genFmapClause Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Con -> Q ([Type], Clause)
genFmapClause Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFmapClause Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Con -> Q ([Type], Clause)
genFmapClause Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFmapClause Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Type -> Con -> Q ([Type], Clause)
genFmapClause Type
instanceType 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_  | 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 (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain ''Rank2.Functor Type
t1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| ($fun Rank2.<$>) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 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 -> 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
_ -> (,) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
fieldAccess

genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames1 <- 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 => [Char] -> m Name
newName [Char]
"x")
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   [Name]
fieldNames2 <- 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 => [Char] -> m Name
newName [Char]
"y")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, 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]
fieldNames1), forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y]
       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
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q Exp
newField (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 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) forall a. a -> a
id
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (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]
fieldNames2) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) []]
genLiftA2Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   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) -> [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) =
          forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
TH.fieldExp Name
fieldName forall a b. (a -> b) -> a -> b
$
             Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
y Name
fieldName) forall a. a -> a
id
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] Q Body
body []
genLiftA2Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (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)
      Bool -> Con -> Q Clause
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) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genLiftA2Clause Bool
unsafely (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Bool -> Con -> Q Clause
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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(wrap fun) $field1Access $field2Access |]
     AppT Type
_ Type
ty | Type
ty 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 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 (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'liftA2) 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 -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot apply liftA2 to field of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Type
fieldType)

genLiftA3Clause :: Bool -> Con -> Q Clause
genLiftA3Clause :: Bool -> Con -> Q Clause
genLiftA3Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames1 <- 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 => [Char] -> m Name
newName [Char]
"x")
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   Name
z <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
   [Name]
fieldNames2 <- 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 => [Char] -> m Name
newName [Char]
"y")
   [Name]
fieldNames3 <- 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 => [Char] -> m Name
newName [Char]
"z")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, 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]
fieldNames1), forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z]
       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
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name, Name) -> BangType -> Q Exp
newField (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 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) forall a. a -> a
id
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (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]
fieldNames2) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [],
                        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (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]
fieldNames3) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) []]
genLiftA3Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   Name
z <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
   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) -> [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) =
          forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
TH.fieldExp Name
fieldName
             (Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
y Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
z Name
fieldName) forall a. a -> a
id)
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z] Q Body
body []
genLiftA3Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (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)
      Bool -> Con -> Q Clause
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) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q Clause
genLiftA3Clause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genLiftA3Clause Bool
unsafely (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Bool -> Con -> Q Clause
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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_
        | Type
ty forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(wrap fun) $(field1Access) $(field2Access) $(field3Access) |]
     AppT Type
_ Type
ty
        | Type
ty 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 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 (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'liftA3) 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 -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot apply liftA3 to field of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Type
fieldType)

genApClause :: Bool -> Type -> Con -> Q ([Type], Clause)
genApClause :: Bool -> Type -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely Type
_ (NormalC Name
name [BangType]
fieldTypes) = do
   [Name]
fieldNames1 <- 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 => [Char] -> m Name
newName [Char]
"x")
   [Name]
fieldNames2 <- 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 => [Char] -> m Name
newName [Char]
"y")
   Name
rhsName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"rhs"
   let pats :: [Q Pat]
pats = [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]
fieldNames1), forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
rhsName]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q ([Type], Exp)
newField (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [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
TH.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, 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 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) 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
TH.clause [Q Pat]
pats Q Body
body [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (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]
fieldNames2) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rhsName) []]
genApClause Bool
unsafely Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   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
<$> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
y Name
fieldName) 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
TH.clause [Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] Q Body
body []
genApClause Bool
unsafely Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Type -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genApClause Bool
unsafely Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Type -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genApClause Bool
unsafely Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Bool -> Type -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely Type
instanceType 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | 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
<$> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |]
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Apply Type
t1) 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 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 (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'liftA2) 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 -> (,) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
field1Access
       | Bool
otherwise -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot apply ap to field of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Type
fieldType)

genPureClause :: Con -> Q ([Type], Clause)
genPureClause :: Con -> Q ([Type], Clause)
genPureClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   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 => [m Exp] -> m Exp
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: ((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 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 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []
genPureClause (RecC Name
name [VarBangType]
fields) = do
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   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
<$> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | 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
<$> Q Exp -> Q Exp
wrap Q Exp
pureValue
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain ''Rank2.Applicative Type
t1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp
wrap (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.pure) Q Exp
pureValue)
     AppT Type
t1 Type
t2 | Type
t1 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 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 '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
_ -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot create a pure field of type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Type
fieldType)

genFoldMapClause :: Type -> Con -> Q ([Type], Clause)
genFoldMapClause :: Type -> Con -> Q ([Type], Clause)
genFoldMapClause Type
_ (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [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 => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, 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) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (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
TH.clause [Q Pat]
pats (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"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) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Con -> Q ([Type], Clause)
genFoldMapClause Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFoldMapClause Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Con -> Q ([Type], Clause)
genFoldMapClause Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFoldMapClause Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Type -> Con -> Q ([Type], Clause)
genFoldMapClause Type
instanceType 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | 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 (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
funcName) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Foldable Type
t1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.foldMap) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
funcName)) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 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 -> 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
_ -> (,) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| mempty |]

genTraverseClause :: Type -> Con -> Q ([Type], Clause)
genTraverseClause :: Type -> Con -> Q ([Type], Clause)
genTraverseClause Type
_ (NormalC Name
name []) =
   (,) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| pure $(conE name) |]) []
genTraverseClause Type
_ (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [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 => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, 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
       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 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) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (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
TH.clause [Q Pat]
pats Q Body
body []
genTraverseClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], Exp)
newField [VarBangType]
fields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ 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) 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
       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 :: 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 (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] Q Body
body []
genTraverseClause Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Con -> Q ([Type], Clause)
genTraverseClause Type
instanceType (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genTraverseClause Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (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)
      let AppT Type
_classType Type
t = Type
instanceType
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> Type -> Type -> Type
renameConstraintVars Type
t Type
initType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Con -> Q ([Type], Clause)
genTraverseClause Type
instanceType (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genTraverseClause Type
instanceType (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Type -> Con -> Q ([Type], Clause)
genTraverseClause Type
instanceType 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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | 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 (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Traversable Type
t1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| Rank2.traverse $fun |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 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 -> 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
_ -> (,) [] 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 <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   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 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
       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
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.Distributive (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.cotraverse) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withName)
                                   Type
fieldType [| $(projectField fieldName) <$> $(varE argName) |] 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
withName, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
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 <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   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 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
       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
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.DistributiveTraversable
                                   (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.cotraverseTraversable) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withName) Type
fieldType
                                   [| $(projectField fieldName) <$> $(varE argName) |] 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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
withName, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []

genDeliverClause :: TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause :: TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause TypeQ
recType Maybe Name
typeVar (NormalC Name
name []) = TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause TypeQ
recType Maybe Name
typeVar (Name -> [VarBangType] -> Con
RecC Name
name [])
genDeliverClause TypeQ
recType Maybe Name
typeVar (RecC Name
name [VarBangType]
fields) = do
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   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 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
       recExp :: Q Exp -> Q Exp
recExp Q Exp
g = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Q Exp
g (\Name
v-> [|($g :: $(recType) $(varT v))|]) Maybe Name
typeVar
       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
<$> (Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField ''Rank2.Logistic Type
fieldType
               (\Q Exp -> Q Exp
wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| Rank2.apply set |]) (getFieldOfE [|g|] fieldName)]) |])
               (\Q Exp -> Q Exp
wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| set |]) (getFieldOfE [|g|] fieldName)]) |])
               (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName)
               forall a. a -> a
id
               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
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
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) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | 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 (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain Name
className Type
t1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE Q Exp
method Q Exp
fun) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 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 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 '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

genDeliverField :: Name
                -> Type
                -> ((Q Exp -> Q Exp) -> Q Exp)
                -> ((Q Exp -> Q Exp) -> Q Exp)
                -> Q Exp
                -> (Q Exp -> Q Exp)
                -> (Q Exp -> Q Exp)
                -> Q ([Type], Exp)
genDeliverField :: Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField Name
className Type
fieldType (Q Exp -> Q Exp) -> Q Exp
fieldUpdate (Q Exp -> Q Exp) -> Q Exp
subRecordUpdate Q Exp
arg Q Exp -> Q Exp
outer Q Exp -> Q Exp
inner = do
   Just (Deriving Name
_ Name
typeVar) <- forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | 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
<$> Q Exp -> Q Exp
outer (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Compose|] ([|contramap|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp) -> Q Exp
fieldUpdate Q Exp -> Q Exp
inner forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg))
     AppT Type
t1 Type
t2 | Type
t2 forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain Name
className Type
t1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp
outer (forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| Rank2.deliver |] ([|contramap|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp) -> Q Exp
subRecordUpdate Q Exp -> Q Exp
inner forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg))
     AppT Type
t1 Type
t2 | Type
t1 forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
                  Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField Name
className Type
t2 (Q Exp -> Q Exp) -> Q Exp
fieldUpdate (Q Exp -> Q Exp) -> Q Exp
subRecordUpdate Q Exp
arg (Q Exp -> Q Exp
outer 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 'pure)) (Q Exp -> Q Exp
inner 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 'fmap))
     SigT Type
ty Type
_kind -> Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField Name
className Type
ty (Q Exp -> Q Exp) -> Q Exp
fieldUpdate (Q Exp -> Q Exp) -> Q Exp
subRecordUpdate Q Exp
arg Q Exp -> Q Exp
outer Q Exp -> Q Exp
inner
     ParensT Type
ty -> Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField Name
className Type
ty (Q Exp -> Q Exp) -> Q Exp
fieldUpdate (Q Exp -> Q Exp) -> Q Exp
subRecordUpdate Q Exp
arg Q Exp -> Q Exp
outer Q Exp -> Q Exp
inner

renameConstraintVars :: Type -> Type -> Type -> Type
renameConstraintVars :: Type -> Type -> Type -> Type
renameConstraintVars (AppT Type
instanceType (VarT Name
instanceVar)) (AppT Type
returnType (VarT Name
returnVar)) Type
constrainedType =
   Type -> Type -> Type -> Type
renameConstraintVars Type
instanceType Type
returnType (Name -> Name -> Type -> Type
renameConstraintVar Name
returnVar Name
instanceVar Type
constrainedType)
renameConstraintVars (AppT Type
instanceType Type
_) (AppT Type
returnType Type
_) Type
constrainedType =
   Type -> Type -> Type -> Type
renameConstraintVars Type
instanceType Type
returnType Type
constrainedType
renameConstraintVars Type
_ Type
_ Type
constrainedType = Type
constrainedType

renameConstraintVar :: Name -> Name -> Type -> Type
renameConstraintVar :: Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to (VarT Name
name)
   | Name
name forall a. Eq a => a -> a -> Bool
== Name
from = Name -> Type
VarT Name
to
   | Bool
otherwise = Name -> Type
VarT Name
name
renameConstraintVar Name
from Name
to (AppT Type
a Type
b) = Type -> Type -> Type
AppT (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
a) (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
b)
#if MIN_VERSION_template_haskell(2,15,0)
renameConstraintVar Name
from Name
to (AppKindT Type
t Type
k) = Type -> Type -> Type
AppT (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
t) (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
k)
#endif
renameConstraintVar Name
from Name
to (InfixT Type
a Name
op Type
b) = Type -> Name -> Type -> Type
InfixT (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
a) Name
op (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
b)
renameConstraintVar Name
from Name
to (UInfixT Type
a Name
op Type
b) = Type -> Name -> Type -> Type
UInfixT (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
a) Name
op (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
b)
renameConstraintVar Name
from Name
to (SigT Type
t Type
k) = Type -> Type -> Type
SigT (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
t) (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
k)
renameConstraintVar Name
from Name
to (ParensT Type
t) = Type -> Type
ParensT (Name -> Name -> Type -> Type
renameConstraintVar Name
from Name
to Type
t)
renameConstraintVar Name
_ Name
_ Type
t = Type
t

projectField :: Name -> Q Exp
projectField :: Name -> Q Exp
projectField Name
field = do
#if MIN_VERSION_template_haskell(2,19,0)
  dotty <- TH.isExtEnabled TH.OverloadedRecordDot
  if dotty
     then TH.projectionE (pure $ TH.nameBase field)
     else varE field
#else
  forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
field
#endif

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

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

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]

#if MIN_VERSION_template_haskell(2,17,0)
binder :: Name -> TyVarBndr TH.Specificity
binder :: Name -> TyVarBndr Specificity
binder Name
name = forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Name
name Specificity
TH.SpecifiedSpec
#else
binder :: Name -> TyVarBndr
binder = TH.PlainTV
#endif