-- | 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
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Functor Name
ty
   (constraints, dec) <- genFmap instanceType cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, pragInlD '(Rank2.<$>) Inline FunLike AllPhases]]

deriveApply :: Name -> Q [Dec]
deriveApply :: Name -> Q [Dec]
deriveApply Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Apply Name
ty
   (constraints, dec) <- genAp instanceType cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, genLiftA2 cs, genLiftA3 cs,
              pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,
              pragInlD 'Rank2.liftA2 Inlinable FunLike 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
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Apply Name
ty
   (constraints, dec) <- genApUnsafely instanceType cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, genLiftA2Unsafely cs, genLiftA3Unsafely cs,
              pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,
              pragInlD 'Rank2.liftA2 Inlinable FunLike AllPhases]]

deriveApplicative :: Name -> Q [Dec]
deriveApplicative :: Name -> Q [Dec]
deriveApplicative Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Applicative Name
ty
   (constraints, dec) <- genPure cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, pragInlD 'Rank2.pure Inline FunLike AllPhases]]

deriveFoldable :: Name -> Q [Dec]
deriveFoldable :: Name -> Q [Dec]
deriveFoldable Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Foldable Name
ty
   (constraints, dec) <- genFoldMap instanceType cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, pragInlD 'Rank2.foldMap Inlinable FunLike AllPhases]]

deriveTraversable :: Name -> Q [Dec]
deriveTraversable :: Name -> Q [Dec]
deriveTraversable Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Traversable Name
ty
   (constraints, dec) <- genTraverse instanceType cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, pragInlD 'Rank2.traverse Inlinable FunLike AllPhases]]

deriveDistributive :: Name -> Q [Dec]
deriveDistributive :: Name -> Q [Dec]
deriveDistributive Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Distributive Name
ty
   (constraints, dec) <- genCotraverse cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
             [pure dec, pragInlD 'Rank2.cotraverse Inline FunLike AllPhases]]

deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable :: Name -> Q [Dec]
deriveDistributiveTraversable Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.DistributiveTraversable Name
ty
   (constraints, dec) <- genCotraverseTraversable cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec]]

deriveLogistic :: Name -> Q [Dec]
deriveLogistic :: Name -> Q [Dec]
deriveLogistic Name
ty = do
   (instanceType, cs) <- Name -> Name -> Q (TypeQ, [Con])
reifyConstructors ''Rank2.Logistic Name
ty
   (constraints, decs) <- genDeliver instanceType cs
   sequence [instanceD (TH.cxt $ map pure constraints) instanceType
              (map pure decs <> [pragInlD 'Rank2.deliver Inline FunLike AllPhases])]

reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])
reifyConstructors Name
cls Name
ty = do
   (TyConI tyCon) <- Name -> Q Info
TH.reify Name
ty
   (tyConName, tyVars, _kind, cs) <- case tyCon of
      DataD [Type]
_ Name
nm [TyVarBndr BndrVis]
tyVars Maybe Type
kind [Con]
cs [DerivClause]
_   -> (Name, [TyVarBndr BndrVis], Maybe Type, [Con])
-> Q (Name, [TyVarBndr BndrVis], Maybe Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr BndrVis]
tyVars, Maybe Type
kind, [Con]
cs)
      NewtypeD [Type]
_ Name
nm [TyVarBndr BndrVis]
tyVars Maybe Type
kind Con
c [DerivClause]
_ -> (Name, [TyVarBndr BndrVis], Maybe Type, [Con])
-> Q (Name, [TyVarBndr BndrVis], Maybe Type, [Con])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
nm, [TyVarBndr BndrVis]
tyVars, Maybe Type
kind, [Con
c])
      Dec
_ -> [Char] -> Q (Name, [TyVarBndr BndrVis], 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 (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
_ (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 (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
   lastVar <- reifyTVKindSynonyms (last tyVars)

#if MIN_VERSION_template_haskell(2,17,0)
   let (KindedTV tyVar _ (AppT (AppT ArrowT _) resultKind)) = lastVar
       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 BndrVis -> TypeQ)
-> TypeQ -> [TyVarBndr BndrVis] -> 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 BndrVis -> 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 BndrVis] -> [TyVarBndr BndrVis]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr BndrVis]
tyVars)
       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 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)
   putQ (Deriving tyConName tyVar)
   return (instanceType, cs)

genFmap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFmap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFmap TypeQ
instanceType [Con]
cs = do
   it <- TypeQ
instanceType
   (constraints, clauses) <- unzip <$> mapM (genFmapClause it) cs
   return (concat constraints, FunD '(Rank2.<$>) clauses)

genAp :: TypeQ -> [Con] -> Q ([Type], Dec)
genAp :: TypeQ -> [Con] -> Q ([Type], Dec)
genAp TypeQ
instanceType [Con
con] = do
   it <- TypeQ
instanceType
   (constraints, clause) <- genApClause False it con
   return (constraints, FunD '(Rank2.<*>) [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
   it <- TypeQ
instanceType
   (constraints, clauses) <- unzip <$> mapM (genApClause True it) cons
   return (concat constraints, FunD '(Rank2.<*>) 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 (constraints, 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
                return (concat constraints, FunD 'Rank2.pure clauses)

genFoldMap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap :: TypeQ -> [Con] -> Q ([Type], Dec)
genFoldMap TypeQ
instanceType [Con]
cs = do
   it <- TypeQ
instanceType
   (constraints, clauses) <- unzip <$> mapM (genFoldMapClause it) cs
   return (concat constraints, FunD 'Rank2.foldMap clauses)

genTraverse :: TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse :: TypeQ -> [Con] -> Q ([Type], Dec)
genTraverse TypeQ
instanceType [Con]
cs = do
   it <- TypeQ
instanceType
   (constraints, clauses) <- unzip <$> mapM (genTraverseClause it) cs
   return (concat constraints, FunD 'Rank2.traverse clauses)

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

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

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


genFmapClause :: Type -> Con -> Q ([Type], Clause)
genFmapClause :: Type -> Con -> Q ([Type], Clause)
genFmapClause Type
_ (NormalC Name
name [BangType]
fieldTypes) = do
   f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   fieldNames <- replicateM (length fieldTypes) (newName "x")
   let 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 = (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 ([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 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
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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause pats body []
genFmapClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   x <- newName "x"
   let 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 = (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 (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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body []
genFmapClause Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genFmapClause instanceType (NormalC name fieldTypes)
genFmapClause Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genFmapClause instanceType (RecC name 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   fieldNames1 <- replicateM (length fieldTypes) (newName "x")
   y <- newName "y"
   fieldNames2 <- replicateM (length fieldTypes) (newName "y")
   let 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 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
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
   TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) []]
genLiftA2Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   x <- newName "x"
   y <- newName "y"
   let 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 (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
   TH.clause [varP f, x `TH.asP` TH.recP name [], varP y] body []
genLiftA2Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      genLiftA2Clause unsafely (NormalC name fieldTypes)
genLiftA2Clause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      genLiftA2Clause unsafely (RecC name 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   fieldNames1 <- replicateM (length fieldTypes) (newName "x")
   y <- newName "y"
   z <- newName "z"
   fieldNames2 <- replicateM (length fieldTypes) (newName "y")
   fieldNames3 <- replicateM (length fieldTypes) (newName "z")
   let 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 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
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
   TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) [],
                        TH.valD (conP name $ map varP fieldNames3) (normalB $ varE z) []]
genLiftA3Clause Bool
unsafely (RecC Name
name [VarBangType]
fields) = do
   f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   x <- newName "x"
   y <- newName "y"
   z <- newName "z"
   let 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 (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)
   TH.clause [varP f, x `TH.asP` TH.recP name [], varP y, varP z] body []
genLiftA3Clause Bool
unsafely (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      genLiftA3Clause unsafely (NormalC name fieldTypes)
genLiftA3Clause Bool
unsafely (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
_ (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      genLiftA3Clause unsafely (RecC name 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   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")
   fieldNames2 <- replicateM (length fieldTypes) (newName "y")
   rhsName <- newName "rhs"
   let 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 = ((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 ([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 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
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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE rhsName) []]
genApClause Bool
unsafely Type
_ (RecC Name
name [VarBangType]
fields) = do
   x <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"x"
   y <- newName "y"
   let 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 = (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 (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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [x `TH.asP` TH.recP name [], varP y] body []
genApClause Bool
unsafely Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genApClause unsafely instanceType (NormalC name fieldTypes)
genApClause Bool
unsafely Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genApClause unsafely instanceType (RecC name 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let 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 = (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 (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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP argName] body []
genPureClause (RecC Name
name [VarBangType]
fields) = do
   argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let 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 = (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 (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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP argName] 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   fieldNames <- replicateM (length fieldTypes) (newName "x")
   let 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 = (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 | [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
a m Exp
b = [| $(m Exp
a) <> $(m Exp
b) |]
       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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause pats (normalB body) []
genFoldMapClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   x <- newName "x"
   let 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 = (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
a m Exp
b = [| $(m Exp
a) <> $(m Exp
b) |]
       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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] (normalB body) []
genFoldMapClause Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genFoldMapClause instanceType (NormalC name fieldTypes)
genFoldMapClause Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genFoldMapClause instanceType (RecC name 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   f          <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   fieldNames <- replicateM (length fieldTypes) (newName "x")
   let 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 = (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 ([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 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
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
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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause pats body []
genTraverseClause Type
_ (RecC Name
name [VarBangType]
fields) = do
   f <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   x <- newName "x"
   let 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 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
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 (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
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body []
genTraverseClause Type
instanceType (GadtC [Name
name] [BangType]
fieldTypes _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genTraverseClause instanceType (NormalC name fieldTypes)
genTraverseClause Type
instanceType (RecGadtC [Name
name] [VarBangType]
fields _resultType :: Type
_resultType@(AppT Type
initType (VarT Name
tyVar))) =
   do Just (Deriving tyConName _tyVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
      putQ (Deriving tyConName tyVar)
      let AppT _classType t = instanceType
      first (renameConstraintVars t initType <$>) <$> genTraverseClause instanceType (RecC name 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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
   withName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   argName <- newName "f"
   let 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 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 (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)
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP withName, varP argName] 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
   withName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"w"
   argName <- newName "f"
   let 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 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 (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)
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP withName, varP argName] 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
   argName <- [Char] -> Q Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
   let 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 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
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 (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)
   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields
   (,) constraints <$> TH.clause [varP argName] 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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 _ typeVar) <- Q (Maybe Deriving)
forall a. Typeable a => Q (Maybe a)
getQ
   case 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)
  dotty <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.OverloadedRecordDot
  if dotty
     then TH.projectionE (pure $ TH.nameBase field)
     else varE 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)
  dotty <- Extension -> Q Bool
TH.isExtEnabled Extension
TH.OverloadedRecordDot
  if dotty
     then TH.getFieldE record (TH.nameBase field)
     else appE (varE field) 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