packages feed

rank2classes 1.2.1 → 1.3

raw patch · 4 files changed

+221/−114 lines, 4 files

Files

CHANGELOG.md view
@@ -1,3 +1,9 @@+Version 1.3+---------------+* Added `newtype Flip` to exports - PR by Jeremy List+* Generating INLINE pragmas from Rank2.TH+* Generating the proper constraints on derived instances where needed+ Version 1.2.1 --------------- * Added unsafeDeriveApply
rank2classes.cabal view
@@ -1,5 +1,5 @@ name:                rank2classes-version:             1.2.1+version:             1.3 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
src/Rank2.hs view
@@ -12,7 +12,7 @@    Functor(..), Apply(..), Applicative(..),    Foldable(..), Traversable(..), Distributive(..), DistributiveTraversable(..), distributeJoin, -- * Rank 2 data types-   Compose(..), Empty(..), Only(..), Identity(..), Product(..), Sum(..), Arrow(..), type (~>),+   Compose(..), Empty(..), Only(..), Flip(..), Identity(..), Product(..), Sum(..), Arrow(..), type (~>), -- * Method synonyms and helper functions    fst, snd, ap, fmap, liftA4, liftA5,    fmapTraverse, liftA2Traverse1, liftA2Traverse2, liftA2TraverseBoth,@@ -26,10 +26,10 @@ import Data.Coerce (coerce) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..))-import Data.Functor.Compose (Compose(..))+import Data.Functor.Compose (Compose(Compose, getCompose)) import Data.Functor.Const (Const(..))-import Data.Functor.Product (Product(..))-import Data.Functor.Sum (Sum(..))+import Data.Functor.Product (Product(Pair))+import Data.Functor.Sum (Sum(InL, InR))  import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) @@ -170,7 +170,8 @@ -- | Equivalent of 'Data.Functor.Identity' for rank 2 data types newtype Identity g f = Identity {runIdentity :: g f} deriving (Eq, Ord, Show) -newtype Flip g a f = Flip (g (f a)) deriving (Eq, Ord, Show)+-- | A nested parametric type represented as a rank-2 type+newtype Flip g a f = Flip {unFlip :: g (f a)} deriving (Eq, Ord, Show)  instance Semigroup (g (f a)) => Semigroup (Flip g a f) where    Flip x <> Flip y = Flip (x <> y)
src/Rank2/TH.hs view
@@ -23,7 +23,7 @@  import qualified Rank2 -data Deriving = Deriving { _derivingConstructor :: Name, _derivingVariable :: Name }+data Deriving = Deriving { _derivingConstructor :: Name, _derivingVariable :: Name } deriving Show  deriveAll :: Name -> Q [Dec] deriveAll ty = foldr f (pure []) [deriveFunctor, deriveApply, deriveApplicative,@@ -33,42 +33,61 @@ deriveFunctor :: Name -> Q [Dec] deriveFunctor ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Functor ty-   sequence [instanceD (return []) instanceType [genFmap cs]]+   (constraints, dec) <- genFmap cs+   sequence [instanceD (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-   sequence [instanceD (return []) instanceType [genAp cs, genLiftA2 cs, genLiftA3 cs]]+   (constraints, dec) <- genAp cs+   sequence [instanceD (cxt $ map pure constraints) instanceType+             [pure dec, genLiftA2 cs, genLiftA3 cs,+              pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,+              pragInlD 'Rank2.liftA2 Inlinable FunLike AllPhases]]  unsafeDeriveApply :: Name -> Q [Dec] unsafeDeriveApply ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty-   sequence [instanceD (return []) instanceType [genApUnsafely cs, genLiftA2Unsafely cs, genLiftA3Unsafely cs]]+   (constraints, dec) <- genApUnsafely cs+   sequence [instanceD (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 ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Applicative ty-   sequence [instanceD (return []) instanceType [genPure cs]]+   (constraints, dec) <- genPure cs+   sequence [instanceD (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-   sequence [instanceD (return []) instanceType [genFoldMap cs]]+   (constraints, dec) <- genFoldMap cs+   sequence [instanceD (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-   sequence [instanceD (return []) instanceType [genTraverse cs]]+   (constraints, dec) <- genTraverse cs+   sequence [instanceD (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-   sequence [instanceD (return []) instanceType [genCotraverse cs]]+   (constraints, dec) <- genCotraverse cs+   sequence [instanceD (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-   sequence [instanceD (return []) instanceType [genCotraverseTraversable cs]]+   (constraints, dec) <- genCotraverseTraversable cs+   sequence [instanceD (cxt $ map pure constraints) instanceType [pure dec]]  reifyConstructors :: Name -> Name -> Q (TypeQ, [Con]) reifyConstructors cls ty = do@@ -86,11 +105,13 @@    putQ (Deriving tyConName tyVar)    return (instanceType, cs) -genFmap :: [Con] -> Q Dec-genFmap cs = funD '(Rank2.<$>) (map genFmapClause cs)+genFmap :: [Con] -> Q ([Type], Dec)+genFmap cs = do (constraints, clauses) <- unzip <$> mapM genFmapClause cs+                return (concat constraints, FunD '(Rank2.<$>) clauses) -genAp :: [Con] -> Q Dec-genAp [con] = funD '(Rank2.<*>) [genApClause False con]+genAp :: [Con] -> Q ([Type], Dec)+genAp [con] = do (constraints, clause) <- genApClause False con+                 return (constraints, FunD '(Rank2.<*>) [clause])  genLiftA2 :: [Con] -> Q Dec genLiftA2 [con] = funD 'Rank2.liftA2 [genLiftA2Clause False con]@@ -98,8 +119,9 @@ genLiftA3 :: [Con] -> Q Dec genLiftA3 [con] = funD 'Rank2.liftA3 [genLiftA3Clause False con] -genApUnsafely :: [Con] -> Q Dec-genApUnsafely cons = funD '(Rank2.<*>) (genApClause True <$> cons)+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)@@ -107,49 +129,69 @@ genLiftA3Unsafely :: [Con] -> Q Dec genLiftA3Unsafely cons = funD 'Rank2.liftA3 (genLiftA3Clause True <$> cons) -genPure :: [Con] -> Q Dec-genPure cs = funD 'Rank2.pure (map genPureClause cs)+genPure :: [Con] -> Q ([Type], Dec)+genPure cs = do (constraints, clauses) <- unzip <$> mapM genPureClause cs+                return (concat constraints, FunD 'Rank2.pure clauses) -genFoldMap :: [Con] -> Q Dec-genFoldMap cs = funD 'Rank2.foldMap (map genFoldMapClause cs)+genFoldMap :: [Con] -> Q ([Type], Dec)+genFoldMap cs = do (constraints, clauses) <- unzip <$> mapM genFoldMapClause cs+                   return (concat constraints, FunD 'Rank2.foldMap clauses) -genTraverse :: [Con] -> Q Dec-genTraverse cs = funD 'Rank2.traverse (map genTraverseClause cs)+genTraverse :: [Con] -> Q ([Type], Dec)+genTraverse cs = do (constraints, clauses) <- unzip <$> mapM genTraverseClause cs+                    return (concat constraints, FunD 'Rank2.traverse clauses) -genCotraverse :: [Con] -> Q Dec-genCotraverse [con] = funD 'Rank2.cotraverse [genCotraverseClause con]+genCotraverse :: [Con] -> Q ([Type], Dec)+genCotraverse [con] = do (constraints, clause) <- genCotraverseClause con+                         return (constraints, FunD 'Rank2.cotraverse [clause]) -genCotraverseTraversable :: [Con] -> Q Dec-genCotraverseTraversable [con] = funD 'Rank2.cotraverseTraversable [genCotraverseTraversableClause con]+genCotraverseTraversable :: [Con] -> Q ([Type], Dec)+genCotraverseTraversable [con] = do (constraints, clause) <- genCotraverseTraversableClause con+                                    return (constraints, FunD 'Rank2.cotraverseTraversable [clause]) -genFmapClause :: Con -> Q Clause+genFmapClause :: Con -> Q ([Type], Clause) genFmapClause (NormalC name fieldTypes) = do    f          <- newName "f"    fieldNames <- replicateM (length fieldTypes) (newName "x")-   let pats = [varP f, tildeP (conP name $ map varP fieldNames)]-       body = normalB $ appsE $ conE name : zipWith newField fieldNames fieldTypes-       newField :: Name -> BangType -> Q Exp+   let pats = [varP f, conP name (map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       newFields = map (snd <$>) constraintsAndFields+       body = normalB $ appsE $ conE name : newFields+       newField :: Name -> BangType -> Q ([Type], Exp)        newField x (_, fieldType) = genFmapField (varE f) fieldType (varE x) id-   clause pats body []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats body [] genFmapClause (RecC name fields) = do    f <- newName "f"    x <- newName "x"-   let body = normalB $ recConE name $ map newNamedField fields-       newNamedField :: VarBangType -> Q (Name, Exp)+   let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newNamedField fields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))        newNamedField (fieldName, _, fieldType) =-          fieldExp fieldName (genFmapField (varE f) fieldType (appE (varE fieldName) (varE x)) id)-   clause [varP f, varP x] body []+          ((,) fieldName <$>)+          <$> genFmapField (varE f) fieldType (appE (varE fieldName) (varE x)) id+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP f, varP x] body []+genFmapClause (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genFmapClause (NormalC name fieldTypes)+genFmapClause (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genFmapClause (RecC name fields)+genFmapClause (ForallC _vars _cxt con) = genFmapClause con -genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genFmapField fun fieldType fieldAccess wrap = do    Just (Deriving _ typeVar) <- getQ    case fieldType of-     AppT ty _  | ty == VarT typeVar -> appE (wrap fun) fieldAccess-     AppT _ ty  | ty == VarT typeVar -> appE (wrap [| ($fun Rank2.<$>) |]) fieldAccess+     AppT ty _  | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess+     AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Functor t1) <$> appE (wrap [| ($fun Rank2.<$>) |]) fieldAccess      AppT t1 t2 | t1 /= VarT typeVar -> genFmapField fun t2 fieldAccess (wrap . appE (varE '(<$>)))      SigT ty _kind -> genFmapField fun ty fieldAccess wrap      ParensT ty -> genFmapField fun ty fieldAccess wrap-     _ -> fieldAccess+     _ -> (,) [] <$> fieldAccess  genLiftA2Clause :: Bool -> Con -> Q Clause genLiftA2Clause unsafely (NormalC name fieldTypes) = do@@ -157,7 +199,7 @@    fieldNames1 <- replicateM (length fieldTypes) (newName "x")    fieldNames2 <- replicateM (length fieldTypes) (newName "y")    let pats = [varP f,-               (if unsafely then id else tildeP) (conP name $ map varP fieldNames1),+               conP name (map varP fieldNames1),                tildeP (conP name $ map varP fieldNames2)]        body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes        newField :: (Name, Name) -> BangType -> Q Exp@@ -194,7 +236,7 @@    fieldNames2 <- replicateM (length fieldTypes) (newName "y")    fieldNames3 <- replicateM (length fieldTypes) (newName "z")    let pats = [varP f,-               (if unsafely then id else tildeP) (conP name $ map varP fieldNames1),+               conP name (map varP fieldNames1),                tildeP (conP name $ map varP fieldNames2),                 tildeP (conP name $ map varP fieldNames3)]        body = normalB $ appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes@@ -229,159 +271,217 @@      _ | unsafely -> [| error "Cannot apply liftA3 to field" |]        | otherwise -> error ("Cannot apply liftA3 to field of type " <> show fieldType) -genApClause :: Bool -> Con -> Q Clause+genApClause :: Bool -> Con -> Q ([Type], Clause) genApClause unsafely (NormalC name fieldTypes) = do    fieldNames1 <- replicateM (length fieldTypes) (newName "x")    fieldNames2 <- replicateM (length fieldTypes) (newName "y")-   let pats = [(if unsafely then id else tildeP) (conP name $ map varP fieldNames1),+   let pats = [conP name (map varP fieldNames1),                tildeP (conP name $ map varP fieldNames2)]-       body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes-       newField :: (Name, Name) -> BangType -> Q Exp+       constraintsAndFields = zipWith newField (zip fieldNames1 fieldNames2) fieldTypes+       newFields = map (snd <$>) constraintsAndFields+       body = normalB $ appsE $ conE name : newFields+       newField :: (Name, Name) -> BangType -> Q ([Type], Exp)        newField (x, y) (_, fieldType) = genApField unsafely fieldType (varE x) (varE y) id-   clause pats body []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats body [] genApClause unsafely (RecC name fields) = do    x <- newName "x"    y <- newName "y"-   let body = normalB $ recConE name $ map newNamedField fields-       newNamedField :: VarBangType -> Q (Name, Exp)+   let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newNamedField fields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))        newNamedField (fieldName, _, fieldType) =-          fieldExp fieldName (genApField unsafely fieldType (getFieldOf x) (getFieldOf y) id)+          ((,) fieldName <$>) <$> genApField unsafely fieldType (getFieldOf x) (getFieldOf y) id           where getFieldOf = appE (varE fieldName) . varE-   clause [varP x, varP y] body []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP x, varP y] body []+genApClause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genApClause unsafely (NormalC name fieldTypes)+genApClause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genApClause unsafely (RecC name fields)+genApClause unsafely (ForallC _vars _cxt con) = genApClause unsafely con -genApField :: Bool -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genApField :: Bool -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genApField unsafely fieldType field1Access field2Access wrap = do    Just (Deriving _ typeVar) <- getQ    case fieldType of-     AppT ty _ | ty == VarT typeVar -> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |]-     AppT _ ty | ty == VarT typeVar -> [| $(wrap (varE 'Rank2.ap)) $(field1Access) $(field2Access) |]+     AppT ty _ | ty == VarT typeVar -> (,) [] <$> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |]+     AppT t1 t2 | t2 == VarT typeVar ->+                  (,) (constrain ''Rank2.Apply t1) <$> [| $(wrap (varE 'Rank2.ap)) $(field1Access) $(field2Access) |]      AppT t1 t2 | t1 /= VarT typeVar -> genApField unsafely t2 field1Access field2Access (appE (varE 'liftA2) . wrap)      SigT ty _kind -> genApField unsafely ty field1Access field2Access wrap      ParensT ty -> genApField unsafely ty field1Access field2Access wrap-     _ | unsafely -> [| error ("Cannot apply ap to field" <> $(pure $ LitE $ StringL $ show fieldType)) |]+     _ | unsafely -> (,) [] <$> [| error ("Cannot apply ap to field" <> $(pure $ LitE $ StringL $ show fieldType)) |]        | otherwise -> error ("Cannot apply ap to field of type " <> show fieldType) -genPureClause :: Con -> Q Clause+genPureClause :: Con -> Q ([Type], Clause) genPureClause (NormalC name fieldTypes) = do    argName <- newName "f"-   let body = normalB $ appsE $ conE name : map newField fieldTypes-       newField :: BangType -> Q Exp+   let body = normalB $ appsE $ conE name : ((snd <$>) <$> constraintsAndFields)+       constraintsAndFields = map newField fieldTypes+       newField :: BangType -> Q ([Type], Exp)        newField (_, fieldType) = genPureField fieldType (varE argName) id-   clause [varP argName] body []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP argName] body [] genPureClause (RecC name fields) = do    argName <- newName "f"-   let body = normalB $ recConE name $ map newNamedField fields-       newNamedField :: VarBangType -> Q (Name, Exp)-       newNamedField (fieldName, _, fieldType) = fieldExp fieldName (genPureField fieldType (varE argName) id)-   clause [varP argName] body []+   let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newNamedField fields+       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 [] -genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genPureField fieldType pureValue wrap = do    Just (Deriving _ typeVar) <- getQ    case fieldType of-     AppT ty _ | ty == VarT typeVar -> wrap pureValue-     AppT _ ty | ty == VarT typeVar -> wrap (appE (varE 'Rank2.pure) pureValue)+     AppT ty _ | ty == VarT typeVar -> (,) [] <$> wrap pureValue+     AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Applicative t1) <$> wrap (appE (varE 'Rank2.pure) pureValue)      AppT t1 t2 | t1 /= VarT typeVar -> genPureField t2 pureValue (wrap . appE (varE 'pure))      SigT ty _kind -> genPureField ty pureValue wrap      ParensT ty -> genPureField ty pureValue wrap      _ -> error ("Cannot create a pure field of type " <> show fieldType) -genFoldMapClause :: Con -> Q Clause+genFoldMapClause :: Con -> Q ([Type], Clause) genFoldMapClause (NormalC name fieldTypes) = do    f          <- newName "f"    fieldNames <- replicateM (length fieldTypes) (newName "x")-   let pats = [varP f, tildeP (conP name $ map varP fieldNames)]+   let pats = [varP f, conP name (map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes        body | null fieldNames = [| mempty |]-            | otherwise = foldr1 append $ zipWith newField fieldNames fieldTypes+            | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields        append a b = [| $(a) <> $(b) |]-       newField :: Name -> BangType -> Q Exp+       newField :: Name -> BangType -> Q ([Type], Exp)        newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id-   clause pats (normalB body) []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats (normalB body) [] genFoldMapClause (RecC _name fields) = do    f <- newName "f"    x <- newName "x"    let body | null fields = [| mempty |]-            | otherwise = foldr1 append $ map newField fields+            | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields+       constraintsAndFields = map newField fields        append a b = [| $(a) <> $(b) |]-       newField :: VarBangType -> Q Exp+       newField :: VarBangType -> Q ([Type], Exp)        newField (fieldName, _, fieldType) = genFoldMapField f fieldType (appE (varE fieldName) (varE x)) id-   clause [varP f, varP x] (normalB body) []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP f, varP x] (normalB body) []+genFoldMapClause (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genFoldMapClause (NormalC name fieldTypes)+genFoldMapClause (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genFoldMapClause (RecC name fields)+genFoldMapClause (ForallC _vars _cxt con) = genFoldMapClause con -genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genFoldMapField funcName fieldType fieldAccess wrap = do    Just (Deriving _ typeVar) <- getQ    case fieldType of-     AppT ty _ | ty == VarT typeVar -> appE (wrap $ varE funcName) fieldAccess-     AppT _ ty | ty == VarT typeVar -> appE (wrap $ appE (varE 'Rank2.foldMap) (varE funcName)) fieldAccess+     AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap $ varE funcName) fieldAccess+     AppT t1 t2 | t2 == VarT typeVar ->+                  (,) (constrain ''Rank2.Foldable t1) <$> appE (wrap $ appE (varE 'Rank2.foldMap) (varE funcName)) fieldAccess      AppT t1 t2 | t1 /= VarT typeVar -> genFoldMapField funcName t2 fieldAccess (wrap . appE (varE 'foldMap))      SigT ty _kind -> genFoldMapField funcName ty fieldAccess wrap      ParensT ty -> genFoldMapField funcName ty fieldAccess wrap-     _ -> [| mempty |]+     _ -> (,) [] <$> [| mempty |] -genTraverseClause :: Con -> Q Clause+genTraverseClause :: Con -> Q ([Type], Clause) genTraverseClause (NormalC name []) =-   clause [wildP, wildP] (normalB [| pure $(conE name) |]) []+   (,) [] <$> clause [wildP, wildP] (normalB [| pure $(conE name) |]) [] genTraverseClause (NormalC name fieldTypes) = do    f          <- newName "f"    fieldNames <- replicateM (length fieldTypes) (newName "x")-   let pats = [varP f, tildeP (conP name $ map varP fieldNames)]-       body = normalB $ fst $ foldl apply (conE name, False) $ zipWith newField fieldNames fieldTypes+   let pats = [varP f, conP name (map varP fieldNames)]+       constraintsAndFields = zipWith newField fieldNames fieldTypes+       newFields = map (snd <$>) constraintsAndFields+       body = normalB $ fst $ foldl apply (conE name, False) newFields        apply (a, False) b = ([| $(a) <$> $(b) |], True)        apply (a, True) b = ([| $(a) <*> $(b) |], True)-       newField :: Name -> BangType -> Q Exp+       newField :: Name -> BangType -> Q ([Type], Exp)        newField x (_, fieldType) = genTraverseField (varE f) fieldType (varE x) id-   clause pats body []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause pats body [] genTraverseClause (RecC name fields) = do    f <- newName "f"    x <- newName "x"-   let body = normalB $ fst $ foldl apply (conE name, False) $ map newField fields+   let constraintsAndFields = map newField fields+       body = normalB $ fst $ foldl apply (conE name, False) $ (snd <$>) <$> constraintsAndFields        apply (a, False) b = ([| $(a) <$> $(b) |], True)        apply (a, True) b = ([| $(a) <*> $(b) |], True)-       newField :: VarBangType -> Q Exp+       newField :: VarBangType -> Q ([Type], Exp)        newField (fieldName, _, fieldType) = genTraverseField (varE f) fieldType (appE (varE fieldName) (varE x)) id-   clause [varP f, varP x] body []+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP f, varP x] body []+genTraverseClause (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genTraverseClause (NormalC name fieldTypes)+genTraverseClause (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) =+   do Just (Deriving tyConName _tyVar) <- getQ+      putQ (Deriving tyConName tyVar)+      genTraverseClause (RecC name fields)+genTraverseClause (ForallC _vars _cxt con) = genTraverseClause con -genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genTraverseField fun fieldType fieldAccess wrap = do    Just (Deriving _ typeVar) <- getQ    case fieldType of-     AppT ty _ | ty == VarT typeVar -> appE (wrap fun) fieldAccess-     AppT _ ty | ty == VarT typeVar -> appE (wrap [| Rank2.traverse $fun |]) fieldAccess+     AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess+     AppT t1 t2 | t2 == VarT typeVar ->+                  (,) (constrain ''Rank2.Traversable t1) <$> appE (wrap [| Rank2.traverse $fun |]) fieldAccess      AppT t1 t2 | t1 /= VarT typeVar -> genTraverseField fun t2 fieldAccess (wrap . appE (varE 'traverse))      SigT ty _kind -> genTraverseField fun ty fieldAccess wrap      ParensT ty -> genTraverseField fun ty fieldAccess wrap-     _ -> [| pure $fieldAccess |]+     _ -> (,) [] <$> [| pure $fieldAccess |] -genCotraverseClause :: Con -> Q Clause+genCotraverseClause :: Con -> Q ([Type], Clause) genCotraverseClause (NormalC name []) = genCotraverseClause (RecC name []) genCotraverseClause (RecC name fields) = do    withName <- newName "w"    argName <- newName "f"-   let body = normalB $ recConE name $ map newNamedField fields-       newNamedField :: VarBangType -> Q (Name, Exp)+   let constraintsAndFields = map newNamedField fields+       body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))        newNamedField (fieldName, _, fieldType) =-          fieldExp fieldName (genCotraverseField (varE 'Rank2.cotraverse) (varE withName) fieldType-                              [| $(varE fieldName) <$> $(varE argName) |] id)-   clause [varP withName, varP argName] body []+          ((,) 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 [] -genCotraverseTraversableClause :: Con -> Q Clause+genCotraverseTraversableClause :: Con -> Q ([Type], Clause) genCotraverseTraversableClause (NormalC name []) = genCotraverseTraversableClause (RecC name []) genCotraverseTraversableClause (RecC name fields) = do    withName <- newName "w"    argName <- newName "f"-   let body = normalB $ recConE name $ map newNamedField fields-       newNamedField :: VarBangType -> Q (Name, Exp)+   let constraintsAndFields = map newNamedField fields+       body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields+       newNamedField :: VarBangType -> Q ([Type], (Name, Exp))        newNamedField (fieldName, _, fieldType) =-          fieldExp fieldName (genCotraverseField (varE 'Rank2.cotraverseTraversable) (varE withName) fieldType-                              [| $(varE fieldName) <$> $(varE argName) |] id)-   clause [varP withName, varP argName] body []+          ((,) fieldName <$>) <$> (genCotraverseField ''Rank2.DistributiveTraversable+                                   (varE 'Rank2.cotraverseTraversable) (varE withName) fieldType+                                   [| $(varE fieldName) <$> $(varE argName) |] id)+   constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields+   (,) constraints <$> clause [varP withName, varP argName] body [] -genCotraverseField :: Q Exp -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp-genCotraverseField method fun fieldType fieldAccess wrap = do+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    case fieldType of-     AppT ty _ | ty == VarT typeVar -> appE (wrap fun) fieldAccess-     AppT _ ty | ty == VarT typeVar -> appE (wrap $ appE method fun) fieldAccess-     AppT t1 t2 | t1 /= VarT typeVar -> genCotraverseField method fun t2 fieldAccess (wrap . appE (varE 'cotraverse))-     SigT ty _kind -> genCotraverseField method fun ty fieldAccess wrap-     ParensT ty -> genCotraverseField method fun ty fieldAccess wrap+     AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess+     AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain className t1) <$> appE (wrap $ appE method fun) fieldAccess+     AppT t1 t2 | t1 /= VarT typeVar ->+                  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++constrain :: Name -> Type -> [Type]+constrain _ ConT{} = []+constrain cls t = [ConT cls `AppT` t]