rank2classes 1.4.4 → 1.4.5

raw patch · 4 files changed

+182/−61 lines, 4 filesdep +data-functor-logisticdep ~template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-functor-logistic

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• rank2classes.cabal +4/−3
• src/Rank2.hs +74/−10
• src/Rank2/TH.hs +97/−48

@@ -1,3 +1,10 @@+Version 1.4.5+---------------+* Added the `Logistic` type class, `getters` and `setters`+* Added `Rank2.TH.deriveLogistic`, included it in `deriveAll`+* Compiling with GHC 9.4.2+* Forward compatibility with `TypeFamilies`+ Version 1.4.4 --------------- * Tested with GHC 9.2.1, incremented the upper `template-haskell` dependency bound

@@ -1,5 +1,5 @@ name:                rank2classes-version:             1.4.4+version:             1.4.5 synopsis:            standard type constructor class hierarchy, only with methods of rank 2 types description:   A mirror image of the standard type constructor class hierarchy rooted in 'Functor', except with methods of rank 2@@ -40,10 +40,11 @@   ghc-options:         -Wall   build-depends:       base >=4.10 && <5,                        transformers >= 0.5 && < 0.7,-                       distributive < 0.7+                       distributive < 0.7,+                       data-functor-logistic < 0.1    if flag(use-template-haskell)-    build-depends: template-haskell >= 2.11 && < 2.19+    build-depends: template-haskell >= 2.11 && < 2.20     exposed-modules: Rank2.TH  test-suite doctests

@@ -8,16 +8,18 @@ {-# LANGUAGE DefaultSignatures, InstanceSigs, KindSignatures, PolyKinds, Rank2Types #-} {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} {-# LANGUAGE EmptyCase #-}+{-# LANGUAGE TypeApplications #-} module Rank2 ( -- * Rank 2 classes    Functor(..), Apply(..), Applicative(..),-   Foldable(..), Traversable(..), Distributive(..), DistributiveTraversable(..), distributeJoin,+   Foldable(..), Traversable(..), Distributive(..), DistributiveTraversable(..), Logistic(..), distributeJoin, -- * Rank 2 data types    Compose(..), Empty(..), Only(..), Flip(..), Identity(..), Product(..), Sum(..), Arrow(..), type (~>), -- * Method synonyms and helper functions    ($), fst, snd, ap, fmap, liftA4, liftA5,    fmapTraverse, liftA2Traverse1, liftA2Traverse2, liftA2TraverseBoth,-   distributeWith, distributeWithTraversable)+   distributeWith, distributeWithTraversable,+   getters, setters) where  import qualified Control.Applicative as Rank1@@ -25,6 +27,8 @@ import qualified Data.Foldable as Rank1 import qualified Data.Traversable as Rank1 import qualified Data.Functor.Compose as Rank1+import qualified Data.Functor.Contravariant as Rank1+import qualified Data.Functor.Logistic as Rank1 import qualified Data.Distributive as Rank1 import Data.Coerce (coerce) import Data.Semigroup (Semigroup(..))@@ -32,6 +36,7 @@ import Data.Functor.Const (Const(..)) import Data.Functor.Product (Product(Pair)) import Data.Functor.Sum (Sum(InL, InR))+import Data.Kind (Type) import Data.Proxy (Proxy(..)) import qualified GHC.Generics as Generics @@ -69,7 +74,6 @@    sequence :: Rank1.Applicative m => g (Rank1.Compose m p) -> m (g p)    traverse f = sequence . fmap (Rank1.Compose . f)    sequence = traverse Rank1.getCompose- -- | Wrapper for functions that map the argument constructor type newtype Arrow p q a = Arrow{apply :: p a -> q a} @@ -113,17 +117,17 @@ -- | Equivalent of 'Rank1.Distributive' for rank 2 data types class DistributiveTraversable g => Distributive g where    {-# MINIMAL cotraverse|distribute #-}-   collect :: Rank1.Functor f1 => (a -> g f2) -> f1 a -> g (Rank1.Compose f1 f2)-   distribute :: Rank1.Functor f1 => f1 (g f2) -> g (Rank1.Compose f1 f2)+   collect :: Rank1.Functor p => (a -> g q) -> p a -> g (Rank1.Compose p q)+   distribute :: Rank1.Functor p => p (g q) -> g (Rank1.Compose p q)    -- | Dual of 'traverse', equivalent of 'Rank1.cotraverse' for rank 2 data types     cotraverse :: Rank1.Functor m => (forall a. m (p a) -> q a) -> m (g p) -> g q     collect f = distribute . Rank1.fmap f    distribute = cotraverse Rank1.Compose-   cotraverse f = (fmap (f . Rank1.getCompose)) . distribute+   cotraverse f = fmap (f . Rank1.getCompose) . distribute  -- | A weaker 'Distributive' that requires 'Rank1.Traversable' to use, not just a 'Rank1.Functor'.-class Functor g => DistributiveTraversable (g :: (k -> *) -> *) where+class Functor g => DistributiveTraversable (g :: (k -> Type) -> Type) where    collectTraversable :: Rank1.Traversable f1 => (a -> g f2) -> f1 a -> g (Rank1.Compose f1 f2)       distributeTraversable :: Rank1.Traversable f1 => f1 (g f2) -> g (Rank1.Compose f1 f2)    cotraverseTraversable :: Rank1.Traversable f1 => (forall x. f1 (f2 x) -> f x) -> f1 (g f2) -> g f@@ -135,6 +139,10 @@                                     (forall a. m (p a) -> q a) -> m (g p) -> g q    cotraverseTraversable = cotraverse +-- | Equivalent of 'Rank1.Logistic' for rank 2 data types+class Functor g => Logistic g where+   deliver :: Rank1.Contravariant p => p (g q -> g q) -> g (Rank1.Compose p (q ~> q))+ -- | A variant of 'distribute' convenient with 'Rank1.Monad' instances distributeJoin :: (Distributive g, Rank1.Monad f) => f (g f) -> g f distributeJoin = cotraverse Rank1.join@@ -154,11 +162,21 @@ liftA2Traverse2 f x y = liftA2 (\x' y' -> f x' (Rank1.getCompose y')) x (distributeTraversable y)  -- | Like 'liftA2', but traverses over both its arguments-liftA2TraverseBoth :: (Apply g, DistributiveTraversable g, Rank1.Traversable f1, Rank1.Traversable f2) =>+liftA2TraverseBoth :: forall f1 f2 g t u v.+                      (Apply g, DistributiveTraversable g, Rank1.Traversable f1, Rank1.Traversable f2) =>                       (forall a. f1 (t a) -> f2 (u a) -> v a) -> f1 (g t) -> f2 (g u) -> g v liftA2TraverseBoth f x y = liftA2 applyCompose (distributeTraversable x) (distributeTraversable y)-   where applyCompose x' y' = f (Rank1.getCompose x') (Rank1.getCompose y')+   where applyCompose :: forall a. Rank1.Compose f1 t a -> Rank1.Compose f2 u a -> v a+         applyCompose x' y' = f (Rank1.getCompose x') (Rank1.getCompose y') +-- | Enumerate getters for each element+getters :: Distributive g => g (Rank1.Compose ((->) (g f)) f)+getters = distribute id++-- | Enumerate setters for each element+setters :: Logistic g => g ((f ~> f) ~> Const (g f -> g f))+setters = Arrow . (Const .) . Rank1.getOp . Rank1.getCompose <$> deliver (Rank1.Op id)+ {-# DEPRECATED distributeWith "Use cotraverse instead." #-} -- | Synonym for 'cotraverse' distributeWith :: (Distributive g, Rank1.Functor f) => (forall i. f (a i) -> b i) -> f (g a) -> g b@@ -194,7 +212,7 @@  instance Monoid (g (f a)) => Monoid (Flip g a f) where    mempty = Flip mempty-   Flip x `mappend` Flip y = Flip (x `mappend` y)+   mappend = (<>)  instance Rank1.Functor g => Rank2.Functor (Flip g a) where    f <$> Flip g = Flip (f Rank1.<$> g)@@ -498,3 +516,49 @@    cotraverse w f = Generics.Rec1 (cotraverse w (Rank1.fmap Generics.unRec1 f)) instance (Distributive f, Distributive g) => Distributive ((Generics.:*:) f g) where    cotraverse w f = cotraverse w (Rank1.fmap (\(a Generics.:*: _) -> a) f) Generics.:*: cotraverse w (Rank1.fmap (\(_ Generics.:*: b) -> b) f)++instance Logistic Empty where+   deliver _ = Empty++instance Logistic Proxy where+   deliver _ = Proxy++instance Logistic (Only x) where+   deliver f = Only (Rank1.Compose (Rank1.contramap coerce f))++instance Logistic g => Logistic (Identity g) where+   deliver f = Identity (deliver (Rank1.contramap coerce f))++instance (Logistic g, Rank1.Logistic p) => Logistic (Compose g p) where+   deliver = Compose+             . fmap (inRank1Compose (Rank1.fmap (Rank1.Compose . Rank1.contramap apply)+                                     . Rank1.deliver+                                     . Rank1.contramap (Arrow . inRank1Compose)))+             . deliver+             . Rank1.contramap inCompose++inCompose :: (g (Rank1.Compose p q) -> g' (Rank1.Compose p' q')) -> Compose g p q -> Compose g' p' q'+inCompose f = Compose . f . getCompose++inRank1Compose :: (p (q a) -> p' (q' a')) -> Rank1.Compose p q a -> Rank1.Compose p' q' a'+inRank1Compose f = Rank1.Compose . f . Rank1.getCompose++instance (Logistic g, Logistic h) => Logistic (Product g h) where+   deliver f = Pair (deliver (Rank1.contramap first f)) (deliver (Rank1.contramap second f))++first :: (g p -> g' p) -> Product g h p -> Product g' h p+first f (Pair g h) = Pair (f g) h++second :: (h p -> h' p) -> Product g h p -> Product g h' p+second f (Pair g h) = Pair g (f h)++instance Logistic f => Logistic (Generics.M1 i c f) where+   deliver f = Generics.M1 (deliver (Rank1.contramap (\f'-> Generics.M1 . f' . Generics.unM1) f))++instance Logistic f => Logistic (Generics.Rec1 f) where+   deliver f = Generics.Rec1 (deliver (Rank1.contramap (\f'-> Generics.Rec1 . f' . Generics.unRec1) f))++instance (Logistic f, Logistic g) => Logistic ((Generics.:*:) f g) where+   deliver f = deliver (Rank1.contramap (\f' (a Generics.:*: b) -> f' a Generics.:*: b) f)+               Generics.:*:+               deliver (Rank1.contramap (\f' (a Generics.:*: b) -> a Generics.:*: f' b) f)

@@ -12,15 +12,22 @@ -- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial  module Rank2.TH (deriveAll, deriveFunctor, deriveApply, unsafeDeriveApply, deriveApplicative,-                 deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable)+                 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 (contramap)+import Data.Functor.Logistic (deliver) import Data.Monoid ((<>))-import Language.Haskell.TH-import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)+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, instanceD, varE, varP, normalB, pragInlD, recConE, recUpdE, wildP)+import Language.Haskell.TH.Syntax (BangType, VarBangType, Info(TyConI), getQ, putQ, newName)  import qualified Rank2 @@ -28,21 +35,22 @@  deriveAll :: Name -> Q [Dec] deriveAll ty = foldr f (pure []) [deriveFunctor, deriveApply, deriveApplicative,-                                  deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable]+                                  deriveFoldable, deriveTraversable,+                                  deriveDistributive, deriveDistributiveTraversable, deriveLogistic]    where f derive rest = (<>) <$> derive ty <*> rest  deriveFunctor :: Name -> Q [Dec] deriveFunctor ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Functor ty    (constraints, dec) <- genFmap cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType              [pure dec, pragInlD '(Rank2.<$>) Inline FunLike AllPhases]]  deriveApply :: Name -> Q [Dec] deriveApply ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty    (constraints, dec) <- genAp cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   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]]@@ -52,7 +60,7 @@ unsafeDeriveApply ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty    (constraints, dec) <- genApUnsafely cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   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]]@@ -61,39 +69,46 @@ deriveApplicative ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Applicative ty    (constraints, dec) <- genPure cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType              [pure dec, pragInlD 'Rank2.pure Inline FunLike AllPhases]]  deriveFoldable :: Name -> Q [Dec] deriveFoldable ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Foldable ty    (constraints, dec) <- genFoldMap cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType              [pure dec, pragInlD 'Rank2.foldMap Inlinable FunLike AllPhases]]  deriveTraversable :: Name -> Q [Dec] deriveTraversable ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Traversable ty    (constraints, dec) <- genTraverse cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType              [pure dec, pragInlD 'Rank2.traverse Inlinable FunLike AllPhases]]  deriveDistributive :: Name -> Q [Dec] deriveDistributive ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Distributive ty    (constraints, dec) <- genCotraverse cs-   sequence [instanceD (cxt $ map pure constraints) instanceType+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType              [pure dec, pragInlD 'Rank2.cotraverse Inline FunLike AllPhases]]  deriveDistributiveTraversable :: Name -> Q [Dec] deriveDistributiveTraversable ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.DistributiveTraversable ty    (constraints, dec) <- genCotraverseTraversable cs-   sequence [instanceD (cxt $ map pure constraints) instanceType [pure dec]]+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec]] +deriveLogistic :: Name -> Q [Dec]+deriveLogistic ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Logistic ty+   (constraints, dec) <- genDeliver cs+   sequence [instanceD (TH.cxt $ map pure constraints) instanceType+             [pure dec, pragInlD 'Rank2.deliver Inline FunLike AllPhases]]+ reifyConstructors :: Name -> Name -> Q (TypeQ, [Con]) reifyConstructors cls ty = do-   (TyConI tyCon) <- reify ty+   (TyConI tyCon) <- TH.reify ty    (tyConName, tyVars, _kind, cs) <- case tyCon of       DataD _ nm tyVars kind cs _   -> return (nm, tyVars, kind, cs)       NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c])@@ -101,14 +116,14 @@   #if MIN_VERSION_template_haskell(2,17,0)    let (KindedTV tyVar () (AppT (AppT ArrowT _) StarT)) = last tyVars-       instanceType           = conT cls `appT` foldl apply (conT tyConName) (init tyVars)-       apply t (PlainTV name _)    = appT t (varT name)-       apply t (KindedTV name _ _) = appT t (varT name)+       instanceType           = TH.conT cls `TH.appT` foldl apply (TH.conT tyConName) (init tyVars)+       apply t (PlainTV name _)    = TH.appT t (TH.varT name)+       apply t (KindedTV name _ _) = TH.appT t (TH.varT name) #else    let (KindedTV tyVar (AppT (AppT ArrowT _) StarT)) = last tyVars-       instanceType           = conT cls `appT` foldl apply (conT tyConName) (init tyVars)-       apply t (PlainTV name)    = appT t (varT name)-       apply t (KindedTV name _) = appT t (varT name)+       instanceType           = TH.conT cls `TH.appT` foldl apply (TH.conT tyConName) (init tyVars)+       apply t (PlainTV name)    = TH.appT t (TH.varT name)+       apply t (KindedTV name _) = TH.appT t (TH.varT name) #endif      putQ (Deriving tyConName tyVar)@@ -123,20 +138,20 @@                  return (constraints, FunD '(Rank2.<*>) [clause])  genLiftA2 :: [Con] -> Q Dec-genLiftA2 [con] = funD 'Rank2.liftA2 [genLiftA2Clause False con]+genLiftA2 [con] = TH.funD 'Rank2.liftA2 [genLiftA2Clause False con]  genLiftA3 :: [Con] -> Q Dec-genLiftA3 [con] = funD 'Rank2.liftA3 [genLiftA3Clause False con]+genLiftA3 [con] = TH.funD 'Rank2.liftA3 [genLiftA3Clause False con]  genApUnsafely :: [Con] -> Q ([Type], Dec) genApUnsafely cons = do (constraints, clauses) <- unzip <$> mapM (genApClause True) cons                         return (concat constraints, FunD '(Rank2.<*>) clauses)  genLiftA2Unsafely :: [Con] -> Q Dec-genLiftA2Unsafely cons = funD 'Rank2.liftA2 (genLiftA2Clause True <$> cons)+genLiftA2Unsafely cons = TH.funD 'Rank2.liftA2 (genLiftA2Clause True <$> cons)  genLiftA3Unsafely :: [Con] -> Q Dec-genLiftA3Unsafely cons = funD 'Rank2.liftA3 (genLiftA3Clause True <$> cons)+genLiftA3Unsafely cons = TH.funD 'Rank2.liftA3 (genLiftA3Clause True <$> cons)  genPure :: [Con] -> Q ([Type], Dec) genPure cs = do (constraints, clauses) <- unzip <$> mapM genPureClause cs@@ -158,6 +173,10 @@ genCotraverseTraversable [con] = do (constraints, clause) <- genCotraverseTraversableClause con                                     return (constraints, FunD 'Rank2.cotraverseTraversable [clause]) +genDeliver :: [Con] -> Q ([Type], Dec)+genDeliver [con] = do (constraints, clause) <- genDeliverClause con+                      return (constraints, FunD 'Rank2.deliver [clause])+ genFmapClause :: Con -> Q ([Type], Clause) genFmapClause (NormalC name fieldTypes) = do    f          <- newName "f"@@ -165,11 +184,11 @@    let pats = [varP f, conP name (map varP fieldNames)]        constraintsAndFields = zipWith newField fieldNames fieldTypes        newFields = map (snd <$>) constraintsAndFields-       body = normalB $ appsE $ conE name : newFields+       body = normalB $ TH.appsE $ conE name : newFields        newField :: Name -> BangType -> Q ([Type], Exp)        newField x (_, fieldType) = genFmapField (varE f) fieldType (varE x) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause pats body []+   (,) constraints <$> TH.clause pats body [] genFmapClause (RecC name fields) = do    f <- newName "f"    x <- newName "x"@@ -180,7 +199,7 @@           ((,) fieldName <$>)           <$> genFmapField (varE f) fieldType (appE (varE fieldName) (varE x)) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP f, x `asP` recP name []] body []+   (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body [] genFmapClause (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =    do Just (Deriving tyConName _tyVar) <- getQ       putQ (Deriving tyConName tyVar)@@ -209,10 +228,10 @@    y <- newName "y"    fieldNames2 <- replicateM (length fieldTypes) (newName "y")    let pats = [varP f, conP name (map varP fieldNames1), varP y]-       body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes+       body = normalB $ TH.appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes        newField :: (Name, Name) -> BangType -> Q Exp        newField (x, y) (_, fieldType) = genLiftA2Field unsafely (varE f) fieldType (varE x) (varE y) id-   clause pats body [valD (conP name $ map varP fieldNames2) (normalB $ varE y) []]+   TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) []] genLiftA2Clause unsafely (RecC name fields) = do    f <- newName "f"    x <- newName "x"@@ -220,9 +239,9 @@    let body = normalB $ recConE name $ map newNamedField fields        newNamedField :: VarBangType -> Q (Name, Exp)        newNamedField (fieldName, _, fieldType) =-          fieldExp fieldName (genLiftA2Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) id)+          TH.fieldExp fieldName (genLiftA2Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) id)           where getFieldOf = appE (varE fieldName) . varE-   clause [varP f, x `asP` recP name [], varP y] body []+   TH.clause [varP f, x `TH.asP` TH.recP name [], varP y] body [] genLiftA2Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =    do Just (Deriving tyConName _tyVar) <- getQ       putQ (Deriving tyConName tyVar)@@ -255,11 +274,11 @@    fieldNames2 <- replicateM (length fieldTypes) (newName "y")    fieldNames3 <- replicateM (length fieldTypes) (newName "z")    let pats = [varP f, conP name (map varP fieldNames1), varP y, varP z]-       body = normalB $ appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes+       body = normalB $ TH.appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes        newField :: (Name, Name, Name) -> BangType -> Q Exp        newField (x, y, z) (_, fieldType) = genLiftA3Field unsafely (varE f) fieldType (varE x) (varE y) (varE z) id-   clause pats body [valD (conP name $ map varP fieldNames2) (normalB $ varE y) [],-                     valD (conP name $ map varP fieldNames3) (normalB $ varE z) []]+   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 unsafely (RecC name fields) = do    f <- newName "f"    x <- newName "x"@@ -268,9 +287,10 @@    let body = normalB $ recConE name $ map newNamedField fields        newNamedField :: VarBangType -> Q (Name, Exp)        newNamedField (fieldName, _, fieldType) =-          fieldExp fieldName (genLiftA3Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id)+          TH.fieldExp fieldName+             (genLiftA3Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id)           where getFieldOf = appE (varE fieldName) . varE-   clause [varP f, x `asP` recP name [], varP y, varP z] body []+   TH.clause [varP f, x `TH.asP` TH.recP name [], varP y, varP z] body [] genLiftA3Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =    do Just (Deriving tyConName _tyVar) <- getQ       putQ (Deriving tyConName tyVar)@@ -305,11 +325,11 @@    let pats = [conP name (map varP fieldNames1), varP rhsName]        constraintsAndFields = zipWith newField (zip fieldNames1 fieldNames2) fieldTypes        newFields = map (snd <$>) constraintsAndFields-       body = normalB $ appsE $ conE name : newFields+       body = normalB $ TH.appsE $ conE name : newFields        newField :: (Name, Name) -> BangType -> Q ([Type], Exp)        newField (x, y) (_, fieldType) = genApField unsafely fieldType (varE x) (varE y) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause pats body [valD (conP name $ map varP fieldNames2) (normalB $ varE rhsName) []]+   (,) constraints <$> TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE rhsName) []] genApClause unsafely (RecC name fields) = do    x <- newName "x"    y <- newName "y"@@ -320,7 +340,7 @@           ((,) fieldName <$>) <$> genApField unsafely fieldType (getFieldOf x) (getFieldOf y) id           where getFieldOf = appE (varE fieldName) . varE    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [x `asP` recP name [], varP y] body []+   (,) constraints <$> TH.clause [x `TH.asP` TH.recP name [], varP y] body [] genApClause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =    do Just (Deriving tyConName _tyVar) <- getQ       putQ (Deriving tyConName tyVar)@@ -347,12 +367,12 @@ genPureClause :: Con -> Q ([Type], Clause) genPureClause (NormalC name fieldTypes) = do    argName <- newName "f"-   let body = normalB $ appsE $ conE name : ((snd <$>) <$> constraintsAndFields)+   let body = normalB $ TH.appsE $ conE name : ((snd <$>) <$> constraintsAndFields)        constraintsAndFields = map newField fieldTypes        newField :: BangType -> Q ([Type], Exp)        newField (_, fieldType) = genPureField fieldType (varE argName) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP argName] body []+   (,) constraints <$> TH.clause [varP argName] body [] genPureClause (RecC name fields) = do    argName <- newName "f"    let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields@@ -360,7 +380,7 @@        newNamedField :: VarBangType -> Q ([Type], (Name, Exp))        newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> genPureField fieldType (varE argName) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP argName] body []+   (,) constraints <$> TH.clause [varP argName] body []  genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genPureField fieldType pureValue wrap = do@@ -385,7 +405,7 @@        newField :: Name -> BangType -> Q ([Type], Exp)        newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause pats (normalB body) []+   (,) constraints <$> TH.clause pats (normalB body) [] genFoldMapClause (RecC name fields) = do    f <- newName "f"    x <- newName "x"@@ -396,7 +416,7 @@        newField :: VarBangType -> Q ([Type], Exp)        newField (fieldName, _, fieldType) = genFoldMapField f fieldType (appE (varE fieldName) (varE x)) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP f, x `asP` recP name []] (normalB body) []+   (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] (normalB body) [] genFoldMapClause (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =    do Just (Deriving tyConName _tyVar) <- getQ       putQ (Deriving tyConName tyVar)@@ -421,7 +441,7 @@  genTraverseClause :: Con -> Q ([Type], Clause) genTraverseClause (NormalC name []) =-   (,) [] <$> clause [wildP, conP name []] (normalB [| pure $(conE name) |]) []+   (,) [] <$> TH.clause [wildP, conP name []] (normalB [| pure $(conE name) |]) [] genTraverseClause (NormalC name fieldTypes) = do    f          <- newName "f"    fieldNames <- replicateM (length fieldTypes) (newName "x")@@ -434,7 +454,7 @@        newField :: Name -> BangType -> Q ([Type], Exp)        newField x (_, fieldType) = genTraverseField (varE f) fieldType (varE x) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause pats body []+   (,) constraints <$> TH.clause pats body [] genTraverseClause (RecC name fields) = do    f <- newName "f"    x <- newName "x"@@ -445,7 +465,7 @@        newField :: VarBangType -> Q ([Type], Exp)        newField (fieldName, _, fieldType) = genTraverseField (varE f) fieldType (appE (varE fieldName) (varE x)) id    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP f, x `asP` recP name []] body []+   (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body [] genTraverseClause (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =    do Just (Deriving tyConName _tyVar) <- getQ       putQ (Deriving tyConName tyVar)@@ -480,7 +500,7 @@           ((,) fieldName <$>) <$> (genCotraverseField ''Rank2.Distributive (varE 'Rank2.cotraverse) (varE withName)                                    fieldType [| $(varE fieldName) <$> $(varE argName) |] id)    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP withName, varP argName] body []+   (,) constraints <$> TH.clause [varP withName, varP argName] body []  genCotraverseTraversableClause :: Con -> Q ([Type], Clause) genCotraverseTraversableClause (NormalC name []) = genCotraverseTraversableClause (RecC name [])@@ -495,8 +515,25 @@                                    (varE 'Rank2.cotraverseTraversable) (varE withName) fieldType                                    [| $(varE fieldName) <$> $(varE argName) |] id)    constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields-   (,) constraints <$> clause [varP withName, varP argName] body []+   (,) constraints <$> TH.clause [varP withName, varP argName] body [] +genDeliverClause :: Con -> Q ([Type], Clause)+genDeliverClause (NormalC name []) = genDeliverClause (RecC name [])+genDeliverClause (RecC name fields) = do+   argName <- newName "f"+   let constraintsAndFields = map newNamedField fields+       body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))+       newNamedField (fieldName, _, fieldType) =+          ((,) fieldName <$>)+          <$> (genDeliverField ''Rank2.Logistic [| contramap |] fieldType+               [| \set g-> $(TH.recUpdE [|g|] [(,) fieldName <$> [| Rank2.apply set $ $(varE fieldName) g |]]) |]+               [| \set g-> $(TH.recUpdE [|g|] [(,) fieldName <$> [| set $ $(varE fieldName) g |]]) |]+               (varE argName)+               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 className method fun fieldType fieldAccess wrap = do    Just (Deriving _ typeVar) <- getQ@@ -507,6 +544,18 @@                   genCotraverseField className method fun t2 fieldAccess (wrap . appE (varE 'cotraverse))      SigT ty _kind -> genCotraverseField className method fun ty fieldAccess wrap      ParensT ty -> genCotraverseField className method fun ty fieldAccess wrap++genDeliverField :: Name -> Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp)+genDeliverField className fun fieldType fieldUpdate subRecordUpdate arg wrap = do+   Just (Deriving _ typeVar) <- getQ+   case fieldType of+     AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE [|Compose|] (wrap fun `appE` fieldUpdate `appE` arg)+     AppT t1 t2 | t2 == VarT typeVar ->+                  (,) (constrain className t1) <$> appE [| Rank2.deliver |] (wrap fun `appE` subRecordUpdate `appE` arg)+     AppT t1 t2 | t1 /= VarT typeVar ->+                  genDeliverField className fun t2 fieldUpdate subRecordUpdate arg (wrap . appE (varE 'deliver))+     SigT ty _kind -> genDeliverField className fun ty fieldUpdate subRecordUpdate arg wrap+     ParensT ty -> genDeliverField className fun ty fieldUpdate subRecordUpdate arg wrap  constrain :: Name -> Type -> [Type] constrain _ ConT{} = []