-- | 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.Distributive (cotraverse)
import Data.Functor.Compose (Compose (Compose))
import Data.Functor.Contravariant (Contravariant, contramap)
import qualified Language.Haskell.TH as TH
import Language.Haskell.TH (Q, TypeQ, Name, TyVarBndr(KindedTV, PlainTV), Clause, Dec(..), Con(..), Type(..), Exp(..),
                            Inline(Inlinable, Inline), RuleMatch(FunLike), Phases(AllPhases),
                            appE, conE, conP, conT, instanceD, varE, varP, varT, normalB, pragInlD, recConE, wildP)
import Language.Haskell.TH.Syntax (BangType, VarBangType, Info(TyConI), getQ, putQ, newName)

import qualified Rank2

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

deriveAll :: Name -> Q [Dec]
deriveAll :: Name -> Q [Dec]
deriveAll Name
ty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {f :: * -> *} {b}.
(Applicative f, Semigroup b) =>
(Name -> f b) -> f b -> f b
f (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) [Name -> Q [Dec]
deriveFunctor, Name -> Q [Dec]
deriveApply, Name -> Q [Dec]
deriveApplicative,
                                  Name -> Q [Dec]
deriveFoldable, Name -> Q [Dec]
deriveTraversable,
                                  Name -> Q [Dec]
deriveDistributive, Name -> Q [Dec]
deriveDistributiveTraversable, Name -> Q [Dec]
deriveLogistic]
   where f :: (Name -> f b) -> f b -> f b
f Name -> f b
derive f b
rest = forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> f b
derive Name
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f b
rest

deriveFunctor :: Name -> Q [Dec]
deriveFunctor :: Name -> Q [Dec]
deriveFunctor Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Functor Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genFmap [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD '(Rank2.<$>) Inline
Inline RuleMatch
FunLike Phases
AllPhases]]

deriveApply :: Name -> Q [Dec]
deriveApply :: Name -> Q [Dec]
deriveApply Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Apply Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genAp [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, [Con] -> Q Dec
genLiftA2 [Con]
cs, [Con] -> Q Dec
genLiftA3 [Con]
cs,
              forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD '(Rank2.<*>) Inline
Inlinable RuleMatch
FunLike Phases
AllPhases,
              forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD 'Rank2.liftA2 Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

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

deriveApplicative :: Name -> Q [Dec]
deriveApplicative :: Name -> Q [Dec]
deriveApplicative Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Applicative Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genPure [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD 'Rank2.pure Inline
Inline RuleMatch
FunLike Phases
AllPhases]]

deriveFoldable :: Name -> Q [Dec]
deriveFoldable :: Name -> Q [Dec]
deriveFoldable Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Foldable Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genFoldMap [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD 'Rank2.foldMap Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

deriveTraversable :: Name -> Q [Dec]
deriveTraversable :: Name -> Q [Dec]
deriveTraversable Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Traversable Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genTraverse [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD 'Rank2.traverse Inline
Inlinable RuleMatch
FunLike Phases
AllPhases]]

deriveDistributive :: Name -> Q [Dec]
deriveDistributive :: Name -> Q [Dec]
deriveDistributive Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Distributive Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genCotraverse [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType
             [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec, forall (m :: * -> *).
Quote m =>
Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD 'Rank2.cotraverse Inline
Inline RuleMatch
FunLike Phases
AllPhases]]

deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable Name
ty = do
   (TypeQ
instanceType, [Con]
cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.DistributiveTraversable Name
ty
   ([Type]
constraints, Dec
dec) <- [Con] -> Q ([Type], Dec)
genCotraverseTraversable [Con]
cs
   forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [forall (m :: * -> *).
Quote m =>
m [Type] -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *). Quote m => [m Type] -> m [Type]
TH.cxt forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Type]
constraints) TypeQ
instanceType [forall (f :: * -> *) a. Applicative f => a -> f a
pure Dec
dec]]

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

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

genFmap :: [Con] -> Q ([Type], Dec)
genFmap :: [Con] -> Q ([Type], Dec)
genFmap [Con]
cs = do ([[Type]]
constraints, [Clause]
clauses) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q ([Type], Clause)
genFmapClause [Con]
cs
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
constraints, Name -> [Clause] -> Dec
FunD '(Rank2.<$>) [Clause]
clauses)

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

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

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

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

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

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

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

genFoldMap :: [Con] -> Q ([Type], Dec)
genFoldMap :: [Con] -> Q ([Type], Dec)
genFoldMap [Con]
cs = do ([[Type]]
constraints, [Clause]
clauses) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Con -> Q ([Type], Clause)
genFoldMapClause [Con]
cs
                   forall (m :: * -> *) a. Monad m => a -> m a
return (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Type]]
constraints, Name -> [Clause] -> Dec
FunD 'Rank2.foldMap [Clause]
clauses)

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

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

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

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


genFmapClause :: Con -> Q ([Type], Clause)
genFmapClause :: Con -> Q ([Type], Clause)
genFmapClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: [Q Exp]
newFields
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body []
genFmapClause (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFmapField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] Q Body
body []
genFmapClause (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFmapClause (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFmapClause (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFmapClause (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFmapClause (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Con -> Q ([Type], Clause)
genFmapClause Con
con

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

genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause :: Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames1 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   [Name]
fieldNames2 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames1), forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y]
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q Exp
newField (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [BangType]
fieldTypes
       newField :: (Name, Name) -> BangType -> Q Exp
       newField :: (Name, Name) -> BangType -> Q Exp
newField (Name
x, Name
y) (Bang
_, Type
fieldType) = Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) forall a. a -> a
id
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames2) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) []]
genLiftA2Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q (Name, Exp)
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q (Name, Exp)
       newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
TH.fieldExp Name
fieldName forall a b. (a -> b) -> a -> b
$
             Bool
-> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp
genLiftA2Field Bool
unsafely (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
y Name
fieldName) forall a. a -> a
id
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] Q Body
body []
genLiftA2Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genLiftA2Clause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genLiftA2Clause Bool
unsafely (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Bool -> Con -> Q Clause
genLiftA2Clause Bool
unsafely Con
con

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

genLiftA3Clause :: Bool -> Con -> Q Clause
genLiftA3Clause :: Bool -> Con -> Q Clause
genLiftA3Clause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames1 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   Name
z <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
   [Name]
fieldNames2 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y")
   [Name]
fieldNames3 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames1), forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z]
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name, Name) -> BangType -> Q Exp
newField (forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Name]
fieldNames1 [Name]
fieldNames2 [Name]
fieldNames3) [BangType]
fieldTypes
       newField :: (Name, Name, Name) -> BangType -> Q Exp
       newField :: (Name, Name, Name) -> BangType -> Q Exp
newField (Name
x, Name
y, Name
z) (Bang
_, Type
fieldType) = Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) forall a. a -> a
id
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames2) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) [],
                        forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames3) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
z) []]
genLiftA3Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   Name
z <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"z"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q (Name, Exp)
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q (Name, Exp)
       newNamedField :: VarBangType -> Q (Name, Exp)
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          forall (m :: * -> *). Quote m => Name -> m Exp -> m (Name, Exp)
TH.fieldExp Name
fieldName
             (Bool
-> Q Exp
-> Type
-> Q Exp
-> Q Exp
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q Exp
genLiftA3Field Bool
unsafely (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
y Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
z Name
fieldName) forall a. a -> a
id)
   forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
z] Q Body
body []
genLiftA3Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q Clause
genLiftA3Clause Bool
unsafely (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genLiftA3Clause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q Clause
genLiftA3Clause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genLiftA3Clause Bool
unsafely (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Bool -> Con -> Q Clause
genLiftA3Clause Bool
unsafely Con
con

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

genApClause :: Bool -> Con -> Q ([Type], Clause)
genApClause :: Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely (NormalC Name
name [BangType]
fieldTypes) = do
   [Name]
fieldNames1 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   [Name]
fieldNames2 <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y")
   Name
rhsName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"rhs"
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames1), forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
rhsName]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Name, Name) -> BangType -> Q ([Type], Exp)
newField (forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
fieldNames1 [Name]
fieldNames2) [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: [Q Exp]
newFields
       newField :: (Name, Name) -> BangType -> Q ([Type], Exp)
       newField :: (Name, Name) -> BangType -> Q ([Type], Exp)
newField (Name
x, Name
y) (Bang
_, Type
fieldType) = Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
y) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body [forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
TH.valD (forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames2) (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
rhsName) []]
genApClause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   Name
y <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genApField Bool
unsafely Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) (Name -> Name -> Q Exp
getFieldOf Name
y Name
fieldName) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name [], forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
y] Q Body
body []
genApClause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genApClause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genApClause Bool
unsafely (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Bool -> Con -> Q ([Type], Clause)
genApClause Bool
unsafely Con
con

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

genPureClause :: Con -> Q ([Type], Clause)
genPureClause :: Con -> Q ([Type], Clause)
genPureClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => [m Exp] -> m Exp
TH.appsE forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name forall a. a -> [a] -> [a]
: ((forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields)
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map BangType -> Q ([Type], Exp)
newField [BangType]
fieldTypes
       newField :: BangType -> Q ([Type], Exp)
       newField :: BangType -> Q ([Type], Exp)
newField (Bang
_, Type
fieldType) = Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []
genPureClause (RecC Name
name [VarBangType]
fields) = do
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) = ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genPureField Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []

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

genFoldMapClause :: Con -> Q ([Type], Clause)
genFoldMapClause :: Con -> Q ([Type], Clause)
genFoldMapClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       body :: Q Exp
body | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
fieldNames = [| mempty |]
            | Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       append :: m Exp -> m Exp -> m Exp
append m Exp
a m Exp
b = [| $(a) <> $(b) |]
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let body :: Q Exp
body | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [VarBangType]
fields = [| mempty |]
            | Bool
otherwise = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
append forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], Exp)
newField [VarBangType]
fields
       append :: m Exp -> m Exp -> m Exp
append m Exp
a m Exp
b = [| $(a) <> $(b) |]
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) = Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genFoldMapField Name
f Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
genFoldMapClause (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFoldMapClause (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genFoldMapClause (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genFoldMapClause (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genFoldMapClause (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Con -> Q ([Type], Clause)
genFoldMapClause Con
con

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

genTraverseClause :: Con -> Q ([Type], Clause)
genTraverseClause :: Con -> Q ([Type], Clause)
genTraverseClause (NormalC Name
name []) =
   (,) [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => m Pat
wildP, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name []] (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [| pure $(conE name) |]) []
genTraverseClause (NormalC Name
name [BangType]
fieldTypes) = do
   Name
f          <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   [Name]
fieldNames <- forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (forall (t :: * -> *) a. Foldable t => t a -> Int
length [BangType]
fieldTypes) (forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x")
   let pats :: [Q Pat]
pats = [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
conP Name
name (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
fieldNames)]
       constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Name -> BangType -> Q ([Type], Exp)
newField [Name]
fieldNames [BangType]
fieldTypes
       newFields :: [Q Exp]
newFields = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) [Q ([Type], Exp)]
constraintsAndFields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) [Q Exp]
newFields
       apply :: (m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (m Exp
a, Bool
False) m Exp
b = ([| $(a) <$> $(b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newField :: Name -> BangType -> Q ([Type], Exp)
       newField :: Name -> BangType -> Q ([Type], Exp)
newField Name
x (Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [Q Pat]
pats Q Body
body []
genTraverseClause (RecC Name
name [VarBangType]
fields) = do
   Name
f <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   Name
x <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   let constraintsAndFields :: [Q ([Type], Exp)]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], Exp)
newField [VarBangType]
fields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {m :: * -> *}.
Quote m =>
(m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name, Bool
False) forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], Exp)]
constraintsAndFields
       apply :: (m Exp, Bool) -> m Exp -> (m Exp, Bool)
apply (m Exp
a, Bool
False) m Exp
b = ([| $(a) <$> $(b) |], Bool
True)
       apply (m Exp
a, Bool
True) m Exp
b = ([| $(a) <*> $(b) |], Bool
True)
       newField :: VarBangType -> Q ([Type], Exp)
       newField :: VarBangType -> Q ([Type], Exp)
newField (Name
fieldName, Bang
_, Type
fieldType) = Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)
genTraverseField (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
f) Type
fieldType (Name -> Name -> Q Exp
getFieldOf Name
x Name
fieldName) forall a. a -> a
id
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], Exp)]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
f, Name
x forall (m :: * -> *). Quote m => Name -> m Pat -> m Pat
`TH.asP` forall (m :: * -> *). Quote m => Name -> [m FieldPat] -> m Pat
TH.recP Name
name []] Q Body
body []
genTraverseClause (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genTraverseClause (Name -> [BangType] -> Con
NormalC Name
name [BangType]
fieldTypes)
genTraverseClause (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving Name
tyConName Name
_tyVar) <- forall a. Typeable a => Q (Maybe a)
getQ
      forall a. Typeable a => a -> Q ()
putQ (Name -> Name -> Deriving
Deriving Name
tyConName Name
tyVar)
      Con -> Q ([Type], Clause)
genTraverseClause (Name -> [VarBangType] -> Con
RecC Name
name [VarBangType]
fields)
genTraverseClause (ForallC [TyVarBndr Specificity]
_vars [Type]
_cxt Con
con) = Con -> Q ([Type], Clause)
genTraverseClause Con
con

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

genCotraverseClause :: Con -> Q ([Type], Clause)
genCotraverseClause :: Con -> Q ([Type], Clause)
genCotraverseClause (NormalC Name
name []) = Con -> Q ([Type], Clause)
genCotraverseClause (Name -> [VarBangType] -> Con
RecC Name
name [])
genCotraverseClause (RecC Name
name [VarBangType]
fields) = do
   Name
withName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.Distributive (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.cotraverse) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withName)
                                   Type
fieldType [| $(projectField fieldName) <$> $(varE argName) |] forall a. a -> a
id)
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
withName, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []

genCotraverseTraversableClause :: Con -> Q ([Type], Clause)
genCotraverseTraversableClause :: Con -> Q ([Type], Clause)
genCotraverseTraversableClause (NormalC Name
name []) = Con -> Q ([Type], Clause)
genCotraverseTraversableClause (Name -> [VarBangType] -> Con
RecC Name
name [])
genCotraverseTraversableClause (RecC Name
name [VarBangType]
fields) = do
   Name
withName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Q Exp
-> Q Exp
-> Type
-> Q Exp
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genCotraverseField ''Rank2.DistributiveTraversable
                                   (forall (m :: * -> *). Quote m => Name -> m Exp
varE 'Rank2.cotraverseTraversable) (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
withName) Type
fieldType
                                   [| $(projectField fieldName) <$> $(varE argName) |] forall a. a -> a
id)
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
withName, forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []

genDeliverClause :: Name -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause :: Name -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause Name
typeName Maybe Name
typeVar (NormalC Name
name []) = Name -> Maybe Name -> Con -> Q ([Type], Clause)
genDeliverClause Name
typeName Maybe Name
typeVar (Name -> [VarBangType] -> Con
RecC Name
name [])
genDeliverClause Name
recType Maybe Name
typeVar (RecC Name
name [VarBangType]
fields) = do
   Name
argName <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let constraintsAndFields :: [Q ([Type], (Name, Exp))]
constraintsAndFields = forall a b. (a -> b) -> [a] -> [b]
map VarBangType -> Q ([Type], (Name, Exp))
newNamedField [VarBangType]
fields
       body :: Q Body
body = forall (m :: * -> *). Quote m => m Exp -> m Body
normalB forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Quote m => Name -> [m (Name, Exp)] -> m Exp
recConE Name
name forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Q ([Type], (Name, Exp))]
constraintsAndFields
       recExp :: m Exp -> m Exp
recExp m Exp
g = forall b a. b -> (a -> b) -> Maybe a -> b
maybe m Exp
g (\Name
v-> [|($g :: $(conT recType) $(varT v))|]) Maybe Name
typeVar
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))
newNamedField (Name
fieldName, Bang
_, Type
fieldType) =
          ((,) Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name
-> Type
-> ((Q Exp -> Q Exp) -> Q Exp)
-> ((Q Exp -> Q Exp) -> Q Exp)
-> Q Exp
-> (Q Exp -> Q Exp)
-> (Q Exp -> Q Exp)
-> Q ([Type], Exp)
genDeliverField ''Rank2.Logistic Type
fieldType
               (\Q Exp -> Q Exp
wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| Rank2.apply set |]) (getFieldOfE [|g|] fieldName)]) |])
               (\Q Exp -> Q Exp
wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| set |]) (getFieldOfE [|g|] fieldName)]) |])
               (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
argName)
               forall a. a -> a
id
               forall a. a -> a
id)
   [Type]
constraints <- (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q ([Type], (Name, Exp))]
constraintsAndFields
   (,) [Type]
constraints forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
TH.clause [forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
argName] Q Body
body []

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

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

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

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

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

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

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