-- | 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]
(Int -> Deriving -> ShowS)
-> (Deriving -> [Char]) -> ([Deriving] -> ShowS) -> Show Deriving
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Deriving -> ShowS
showsPrec :: Int -> Deriving -> ShowS
$cshow :: Deriving -> [Char]
show :: Deriving -> [Char]
$cshowList :: [Deriving] -> ShowS
showList :: [Deriving] -> ShowS
Show

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

deriveFunctor :: Name -> Q [Dec]
deriveFunctor :: Name -> Q [Dec]
deriveFunctor Name
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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q 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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2 [Con]
cs, [Con] -> Q Dec
genLiftA3 [Con]
cs,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2Unsafely [Con]
cs, [Con] -> Q Dec
genLiftA3Unsafely [Con]
cs,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              Name -> Inline -> RuleMatch -> Phases -> Q Dec
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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q 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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q 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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q 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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, Name -> Inline -> RuleMatch -> Phases -> Q 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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType [Dec -> Q Dec
forall a. a -> Q a
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
   [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q [Type] -> TypeQ -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD ([TypeQ] -> Q [Type]
forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt ([TypeQ] -> Q [Type]) -> [TypeQ] -> Q [Type]
forall a b. (a -> b) -> a -> b
$ (Type -> TypeQ) -> [Type] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
              ((Dec -> Q Dec) -> [Dec] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map Dec -> Q Dec
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec]
decs [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. Semigroup a => a -> a -> a
<> [Name -> Inline -> RuleMatch -> Phases -> Q Dec
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]
_   -> (Name, [TyVarBndr ()], Maybe Type, [Con])
-> Q (Name, [TyVarBndr ()], Maybe Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr ()]
tyVars, Maybe Type
kind, [Con]
cs)
      NewtypeD [Type]
_ Name
nm [TyVarBndr ()]
tyVars Maybe Type
kind Con
c [DerivClause]
_ -> (Name, [TyVarBndr ()], Maybe Type, [Con])
-> Q (Name, [TyVarBndr ()], Maybe Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr ()]
tyVars, Maybe Type
kind, [Con
c])
      Dec
_ -> [Char] -> Q (Name, [TyVarBndr ()], Maybe Type, [Con])
forall a. [Char] -> Q a
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 Q Info -> (Info -> TypeQ) -> TypeQ
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Info -> TypeQ
reifySynonymInfo Name
name
       reifySynonyms (AppT Type
t1 Type
t2) = Type -> Type -> Type
AppT (Type -> Type -> Type) -> TypeQ -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> TypeQ
reifySynonyms Type
t1 Q (Type -> Type) -> TypeQ -> TypeQ
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> TypeQ
reifySynonyms Type
t2
       reifySynonyms Type
t = Type -> TypeQ
forall a. a -> Q a
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
_ = Type -> TypeQ
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Type
ConT Name
name)
#if MIN_VERSION_template_haskell(2,17,0)
       reifyTVKindSynonyms :: TyVarBndr flag -> Q (TyVarBndr flag)
reifyTVKindSynonyms (KindedTV Name
v flag
s Type
k) = Name -> flag -> Type -> TyVarBndr flag
forall flag. Name -> flag -> Type -> TyVarBndr flag
KindedTV Name
v flag
s (Type -> TyVarBndr flag) -> TypeQ -> Q (TyVarBndr flag)
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 = TyVarBndr flag -> Q (TyVarBndr flag)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TyVarBndr flag
tv
   TyVarBndr ()
lastVar <- TyVarBndr () -> Q (TyVarBndr ())
forall {flag}. TyVarBndr flag -> Q (TyVarBndr flag)
reifyTVKindSynonyms ([TyVarBndr ()] -> TyVarBndr ()
forall a. HasCallStack => [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           = Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
cls TypeQ -> TypeQ -> TypeQ
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`TH.appT` (TypeQ -> TyVarBndr () -> TypeQ)
-> TypeQ -> [TyVarBndr ()] -> TypeQ
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TyVarBndr () -> TypeQ
forall {m :: * -> *} {flag}.
Quote m =>
m Type -> TyVarBndr flag -> m Type
apply (Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tyConName) ([TyVarBndr ()] -> [TyVarBndr ()]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr ()]
tyVars)
       apply :: m Type -> TyVarBndr flag -> m Type
apply m Type
t (PlainTV Name
name flag
_)    = m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
TH.appT m Type
t (Name -> m Type
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
name)
       apply m Type
t (KindedTV Name
name flag
_ Type
_) = m Type -> m Type -> m Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
TH.appT m Type
t (Name -> m Type
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 -> () -> Q ()
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Type
_ -> [Char] -> Q ()
forall a. [Char] -> Q a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Unexpected result kind: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
forall a. Show a => a -> [Char]
show Type
resultKind)
   Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
   (TypeQ, [Con]) -> Q (TypeQ, [Con])
forall a. a -> Q a
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) <- [([Type], Clause)] -> ([[Type]], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([([Type], Clause)] -> ([[Type]], [Clause]))
-> Q [([Type], Clause)] -> Q ([[Type]], [Clause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Con -> Q ([Type], Clause)) -> [Con] -> Q [([Type], Clause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Type -> Con -> Q ([Type], Clause)
genFmapClause Type
it) [Con]
cs
   ([Type], Dec) -> Q ([Type], Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
constraints, Name -> [Clause] -> Dec
FunD '(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
   ([Type], Dec) -> Q ([Type], Dec)
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
constraints, Name -> [Clause] -> Dec
FunD '(Rank2.<*>) [Clause
clause])

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

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

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

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

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

genCotraverseTraversable :: [Con] -> Q ([Type], Dec)
genCotraverseTraversable :: [Con] -> Q ([Type], Dec)
genCotraverseTraversable [Con
con] = do ([Type]
constraints, Clause
clause) <- Con -> Q ([Type], Clause)
genCotraverseTraversableClause Con
con
                                    ([Type], Dec) -> Q ([Type], Dec)
forall a. a -> Q a
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 = Type -> TypeQ
forall a. a -> Q a
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 <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"p"
      Name
q <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"q"
      ([Type]
constraints, Clause
clause) <- TypeQ -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause TypeQ
recType (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
q) Con
con
      Type
ctx <- [t| Contravariant $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
p) |]
      Type
methodType <- [t| $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
p) ($(TypeQ
recType) $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
q) -> $(TypeQ
recType) $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
q)) -> $(TypeQ
recType) (Compose $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
p) ($(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
q) Rank2.~> $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
q))) |]
      ([Type], [Dec]) -> Q ([Type], [Dec])
forall a. a -> Q a
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 Maybe Name
forall a. Maybe a
Nothing Con
con
      ([Type], [Dec]) -> Q ([Type], [Dec])
forall a. a -> Q a
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          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (Name -> BangType -> Q ([Type], Exp))
-> [Name] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
newFields
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body []
genFmapClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` Name -> [Q FieldPat] -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_  | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain ''Rank2.Functor Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| ($Q Exp
fun Rank2.<$>) |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
t2 Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '(<$>)))
     SigT Type
ty Type
_kind -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
fieldAccess

genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames1 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   Name
y <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   [Name]
fieldNames2 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames1), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y]
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Name, Name) -> BangType -> Q Exp)
-> [(Name, Name)] -> [BangType] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q Exp
newField ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [BangType]
fieldTypes
       newField :: (Name, Name) -> BangType -> Q Exp
       newField :: (Name, Name) -> BangType -> Q Exp
newField (Name
x, Name
y) (Bang
_, Type
fieldType) = Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) Q Exp -> Q Exp
forall a. a -> a
id
   [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames2) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) []]
genLiftA2Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q (Name, Exp)) -> [VarBangType] -> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q (Name, Exp)
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q (Name, Exp)
       newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          Name -> Q Exp -> Q (Name, Exp)
forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
TH.fieldExp Name
fieldName (Q Exp -> Q (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall a b. (a -> b) -> a -> b
$
             Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (Name -> Q Exp
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) Q Exp -> Q Exp
forall a. a -> a
id
   [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], Name -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q 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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q 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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(Q Exp -> Q Exp
wrap Q Exp
fun) $Q Exp
field1Access $Q Exp
field2Access |]
     AppT Type
_ Type
ty | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.liftA2) Q Exp
fun) $Q Exp
field1Access $Q Exp
field2Access |]
     AppT Type
t1 Type
t2 
        | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
t2 Q Exp
field1Access Q Exp
field2Access (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'liftA2) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp
wrap)
     SigT Type
ty Type
_kind -> Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     Type
_ | Bool
unsafely -> Q Exp
field1Access
       | Bool
otherwise -> [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot apply liftA2 to field of type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
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          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames1 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   Name
y <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   Name
z <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
   [Name]
fieldNames2 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y")
   [Name]
fieldNames3 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames1), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y, Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z]
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((Name, Name, Name) -> BangType -> Q Exp)
-> [(Name, Name, Name)] -> [BangType] -> [Q Exp]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name, Name) -> BangType -> Q Exp
newField ([Name] -> [Name] -> [Name] -> [(Name, Name, Name)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fieldNames1 [Name]
fieldNames2 [Name]
fieldNames3) [BangType]
fieldTypes
       newField :: (Name, Name, Name) -> BangType -> Q Exp
       newField :: (Name, Name, Name) -> BangType -> Q Exp
newField (Name
x, Name
y, Name
z) (Bang
_, Type
fieldType) = Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) Q Exp -> Q Exp
forall a. a -> a
id
   [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames2) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [],
                        Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames3) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) []]
genLiftA3Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   Name
z <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (VarBangType -> Q (Name, Exp)) -> [VarBangType] -> [Q (Name, Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q (Name, Exp)
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q (Name, Exp)
       newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          Name -> Q Exp -> Q (Name, Exp)
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 (Name -> Q Exp
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) Q Exp -> Q Exp
forall a. a -> a
id)
   [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y, Name -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q 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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q 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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_
        | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(Q Exp -> Q Exp
wrap Q Exp
fun) $(Q Exp
field1Access) $(Q Exp
field2Access) $(Q Exp
field3Access) |]
     AppT Type
_ Type
ty
        | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> [| $(Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.liftA3) Q Exp
fun) $(Q Exp
field1Access) $(Q Exp
field2Access) $(Q Exp
field3Access) |]
     AppT Type
t1 Type
t2
        | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar
          -> Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
t2 Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'liftA3) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp
wrap)
     SigT Type
ty Type
_kind -> Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely Q Exp
fun Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp
field3Access Q Exp -> Q Exp
wrap
     Type
_ | Bool
unsafely -> Q Exp
field1Access
       | Bool
otherwise -> [Char] -> Q Exp
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot apply liftA3 to field of type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
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 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   [Name]
fieldNames2 <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y")
   Name
rhsName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"rhs"
   let pats :: [Q Pat]
pats = [Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames1), Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
rhsName]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = ((Name, Name) -> BangType -> Q ([Type], Exp))
-> [(Name, Name)] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q ([Type], Exp)
newField ([Name] -> [Name] -> [(Name, Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: [Q Exp]
newFields
       newField :: (Name, Name) -> BangType -> Q ([Type], Exp)
       newField :: (Name, Name) -> BangType -> Q ([Type], Exp)
newField (Name
x, Name
y) (Bang
_, Type
fieldType) = Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [Q Pat -> Q Body -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ([Q Pat] -> Q Pat) -> [Q Pat] -> Q Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames2) (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rhsName) []]
genApClause Bool
unsafely Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], Name -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(Q Exp -> Q Exp
wrap (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.apply)) $(Q Exp
field1Access) $(Q Exp
field2Access) |]
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Apply Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| $(Q Exp -> Q Exp
wrap (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.ap)) $(Q Exp
field1Access) $(Q Exp
field2Access) |]
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
t2 Q Exp
field1Access Q Exp
field2Access (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'liftA2) (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp
wrap)
     SigT Type
ty Type
_kind -> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
ty Q Exp
field1Access Q Exp
field2Access Q Exp -> Q Exp
wrap
     Type
_ | Bool
unsafely -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
field1Access
       | Bool
otherwise -> [Char] -> Q ([Type], Exp)
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot apply ap to field of type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
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 <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: ((([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields)
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (BangType -> Q ([Type], Exp)) -> [BangType] -> [Q ([Type], Exp)]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Q ([Type], Exp)
newField [BangType]
fieldTypes
       newField :: BangType -> Q ([Type], Exp)
       newField :: BangType -> Q ([Type], Exp)
newField (Bang
_, Type
fieldType) = Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []
genPureClause (RecC Name
name [VarBangType]
fields) = do
   Name
argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) = ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp
wrap Q Exp
pureValue
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain ''Rank2.Applicative Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp
wrap (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.pure) Q Exp
pureValue)
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
t2 Q Exp
pureValue (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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
_ -> [Char] -> Q ([Type], Exp)
forall a. HasCallStack => [Char] -> a
error ([Char]
"Cannot create a pure field of type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Type -> [Char]
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          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (Name -> BangType -> Q ([Type], Exp))
-> [Name] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       body :: Q Exp
body | [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
fieldNames = [| mempty |]
            | Bool
otherwise = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       append :: m Exp -> m Exp -> m Exp
append m Exp
a m Exp
b = [| $(m Exp
a) <> $(m Exp
b) |]
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let body :: Q Exp
body | [VarBangType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| mempty |]
            | Bool
otherwise = (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (VarBangType -> Q ([Type], Exp))
-> [VarBangType] -> [Q ([Type], Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], Exp)
newField [VarBangType]
fields
       append :: m Exp -> m Exp -> m Exp
append m Exp
a m Exp
b = [| $(m Exp
a) <> $(m Exp
b) |]
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) = 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) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` Name -> [Q FieldPat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] (Q Exp -> Q Body
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
funcName) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Foldable Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.foldMap) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
funcName)) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
t2 Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'foldMap))
     SigT Type
ty Type
_kind -> Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
funcName Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| mempty |]

genTraverseClause :: Type -> Con -> Q ([Type], Clause)
genTraverseClause :: Type -> Con -> Q ([Type], Clause)
genTraverseClause Type
_ (NormalC Name
name []) =
   (,) [] (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat
forall (m :: * -> *). Quote m => m Pat
wildP, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name []] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| pure $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) |]) []
genTraverseClause Type
_ (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([BangType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) ([Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name -> [Q Pat] -> Q Pat
forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name ((Name -> Q Pat) -> [Name] -> [Q Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (Name -> BangType -> Q ([Type], Exp))
-> [Name] -> [BangType] -> [Q ([Type], Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Q Exp, Bool) -> Q Exp
forall a b. (a, b) -> a
fst ((Q Exp, Bool) -> Q Exp) -> (Q Exp, Bool) -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Bool) -> Q Exp -> (Q Exp, Bool))
-> (Q Exp, Bool) -> [Q Exp] -> (Q Exp, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) [Q Exp]
newFields
       apply :: (m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (m Exp
a, Bool
False) m Exp
b = ([| $(m Exp
a) <$> $(m Exp
b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(m Exp
a) <*> $(m Exp
b) |], Bool
True)
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body []
genTraverseClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   Name
f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = (VarBangType -> Q ([Type], Exp))
-> [VarBangType] -> [Q ([Type], Exp)]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], Exp)
newField [VarBangType]
fields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ (Q Exp, Bool) -> Q Exp
forall a b. (a, b) -> a
fst ((Q Exp, Bool) -> Q Exp) -> (Q Exp, Bool) -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((Q Exp, Bool) -> Q Exp -> (Q Exp, Bool))
-> (Q Exp, Bool) -> [Q Exp] -> (Q Exp, Bool)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Q Exp, Bool) -> Q Exp -> (Q Exp, Bool)
forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) ([Q Exp] -> (Q Exp, Bool)) -> [Q Exp] -> (Q Exp, Bool)
forall a b. (a -> b) -> a -> b
$ (([Type], Exp) -> Exp
forall a b. (a, b) -> b
snd (([Type], Exp) -> Exp) -> Q ([Type], Exp) -> Q Exp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], Exp) -> Q Exp) -> [Q ([Type], Exp)] -> [Q Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       apply :: (m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (m Exp
a, Bool
False) m Exp
b = ([| $(m Exp
a) <$> $(m Exp
b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(m Exp
a) <*> $(m Exp
b) |], Bool
True)
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) Q Exp -> Q Exp
forall a. a -> a
id
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], Exp)] -> [[Type]]) -> [([Type], Exp)] -> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], Exp) -> [Type]
forall a b. (a, b) -> a
fst (([Type], Exp) -> [Type]) -> [([Type], Exp)] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], Exp)] -> [Type]) -> Q [([Type], Exp)] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)] -> Q [([Type], Exp)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x Name -> Q Pat -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` Name -> [Q FieldPat] -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      Deriving -> Q ()
forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      let AppT Type
_classType Type
t = Type
instanceType
      ([Type] -> [Type]) -> ([Type], Clause) -> ([Type], Clause)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 (Type -> Type) -> [Type] -> [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Clause) -> ([Type], Clause))
-> Q ([Type], Clause) -> Q ([Type], Clause)
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain ''Rank2.Traversable Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| Rank2.traverse $Q Exp
fun |]) Q Exp
fieldAccess
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
t2 Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'traverse))
     SigT Type
ty Type
_kind -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     ParensT Type
ty -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField Q Exp
fun Type
ty Q Exp
fieldAccess Q Exp -> Q Exp
wrap
     Type
_ -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [| pure $Q Exp
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 <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   Name
argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.Distributive (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.cotraverse) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withName)
                                   Type
fieldType [| $(Name -> Q Exp
projectField Name
fieldName) <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) |] Q Exp -> Q Exp
forall a. a -> a
id)
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
withName, Name -> Q Pat
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 <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   Name
argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.DistributiveTraversable
                                   (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.cotraverseTraversable) (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withName) Type
fieldType
                                   [| $(Name -> Q Exp
projectField Name
fieldName) <$> $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) |] Q Exp -> Q Exp
forall a. a -> a
id)
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
withName, Name -> Q Pat
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 <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = (VarBangType -> Q ([Type], (Name, Exp)))
-> [VarBangType] -> [Q ([Type], (Name, Exp))]
forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Body
body = Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
forall a b. (a -> b) -> a -> b
$ Name -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name ([Q (Name, Exp)] -> Q Exp) -> [Q (Name, Exp)] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (([Type], (Name, Exp)) -> (Name, Exp)
forall a b. (a, b) -> b
snd (([Type], (Name, Exp)) -> (Name, Exp))
-> Q ([Type], (Name, Exp)) -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Q ([Type], (Name, Exp)) -> Q (Name, Exp))
-> [Q ([Type], (Name, Exp))] -> [Q (Name, Exp)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       recExp :: Q Exp -> Q Exp
recExp Q Exp
g = Q Exp -> (Name -> Q Exp) -> Maybe Name -> Q Exp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Q Exp
g (\Name
v-> [|($Q Exp
g :: $(TypeQ
recType) $(Name -> TypeQ
forall (m :: * -> *). Quote m => Name -> m Type
varT Name
v))|]) Maybe Name
typeVar
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName (Exp -> (Name, Exp)) -> ([Type], Exp) -> ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          (([Type], Exp) -> ([Type], (Name, Exp)))
-> Q ([Type], Exp) -> Q ([Type], (Name, Exp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> 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-> $(Q Exp -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
TH.recUpdE (Q Exp -> Q Exp
recExp [|g|]) [(,) Name
fieldName (Exp -> (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| Rank2.apply set |]) (Q Exp -> Name -> Q Exp
getFieldOfE [|g|] Name
fieldName)]) |])
               (\Q Exp -> Q Exp
wrap-> [| \set g-> $(Q Exp -> [Q (Name, Exp)] -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> [m (Name, Exp)] -> m Exp
TH.recUpdE (Q Exp -> Q Exp
recExp [|g|]) [(,) Name
fieldName (Exp -> (Name, Exp)) -> Q Exp -> Q (Name, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap [| set |]) (Q Exp -> Name -> Q Exp
getFieldOfE [|g|] Name
fieldName)]) |])
               (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName)
               Q Exp -> Q Exp
forall a. a -> a
id
               Q Exp -> Q Exp
forall a. a -> a
id)
   [Type]
constraints <- ([[Type]] -> [Type]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Type]] -> [Type])
-> ([([Type], (Name, Exp))] -> [[Type]])
-> [([Type], (Name, Exp))]
-> [Type]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Type], (Name, Exp)) -> [Type]
forall a b. (a, b) -> a
fst (([Type], (Name, Exp)) -> [Type])
-> [([Type], (Name, Exp))] -> [[Type]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) ([([Type], (Name, Exp))] -> [Type])
-> Q [([Type], (Name, Exp))] -> Q [Type]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))] -> Q [([Type], (Name, Exp))]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints (Clause -> ([Type], Clause)) -> Q Clause -> Q ([Type], Clause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name -> Q Pat
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) (Name -> Type -> [Type]
constrain Name
className Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp -> Q Exp -> Q Exp
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 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
                  Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField Name
className Q Exp
method Q Exp
fun Type
t2 Q Exp
fieldAccess (Q Exp -> Q Exp
wrap (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
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) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case Type
fieldType of
     AppT Type
ty Type
_ | Type
ty Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar -> (,) [] (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp
outer (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|Compose|] ([|contramap|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp) -> Q Exp
fieldUpdate Q Exp -> Q Exp
inner Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg))
     AppT Type
t1 Type
t2 | Type
t2 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
typeVar ->
                  (,) (Name -> Type -> [Type]
constrain Name
className Type
t1) (Exp -> ([Type], Exp)) -> Q Exp -> Q ([Type], Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Q Exp
outer (Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [| Rank2.deliver |] ([|contramap|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (Q Exp -> Q Exp) -> Q Exp
subRecordUpdate Q Exp -> Q Exp
inner Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
arg))
     AppT Type
t1 Type
t2 | Type
t1 Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
/= Name -> Type
VarT Name
typeVar ->
                  Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q 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 (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE 'pure)) (Q Exp -> Q Exp
inner (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE '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 Name -> Name -> Bool
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)
  Bool
dotty <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.OverloadedRecordDot
  if Bool
dotty
     then NonEmpty [Char] -> Q Exp
forall (m :: * -> *). Quote m => NonEmpty [Char] -> m Exp
TH.projectionE ([Char] -> NonEmpty [Char]
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> NonEmpty [Char]) -> [Char] -> NonEmpty [Char]
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
TH.nameBase Name
field)
     else Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
field
#else
  varE field
#endif

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

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

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 = Name -> Specificity -> TyVarBndr Specificity
forall flag. Name -> flag -> TyVarBndr flag
TH.PlainTV Name
name Specificity
TH.SpecifiedSpec
#else
binder :: Name -> TyVarBndr
binder = TH.PlainTV
#endif