rank2classes 1.0.2 → 1.1
raw patch · 5 files changed
+284/−132 lines, 5 filesdep +distributivedep +tastydep +tasty-hunitdep ~base
Dependencies added: distributive, tasty, tasty-hunit
Dependency ranges changed: base
Files
- CHANGELOG.md +11/−3
- rank2classes.cabal +24/−6
- src/Rank2.hs +27/−10
- src/Rank2/TH.hs +131/−113
- test/TH.hs +91/−0
CHANGELOG.md view
@@ -1,8 +1,16 @@+Version 1.1+---------------+* Replaced own `Product` data type by the one from `Data.Functor.Product`+* Added instances of `Data.Functor.Sum`+* Removed the TH generation of partial Apply and Distributive instances+* Covered more constructor cases in TH code+* Added use-template-haskell flag, true by default - PR by Dridus+ Version 1.0.2 ----------------* Fixed the bounds and Semigroup to compile with GHC 8.4.1+* Fixed the bounds and `Semigroup` to compile with GHC 8.4.1 * Added the ~> type synonym-* Fixed deriveFunctor for record fields with concrete types - PR by Tom Smalley+* Fixed `deriveFunctor` for record fields with concrete types - PR by Tom Smalley Version 1.0.1 ---------------@@ -10,7 +18,7 @@ Version 1.0 ----------------* Swapped distributeWith with cotraverse+* Swapped `distributeWith` with `cotraverse` * Documentation improvements Version 0.2.1.1
rank2classes.cabal view
@@ -1,5 +1,5 @@ name: rank2classes-version: 1.0.2+version: 1.1 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@@ -22,18 +22,25 @@ type: git location: https://github.com/blamario/grampa +flag use-template-haskell+ description: Enable the compilation of the Rank2.TH module+ default: True+ manual: True+ library hs-source-dirs: src- exposed-modules: Rank2, Rank2.TH+ exposed-modules: Rank2 default-language: Haskell2010 -- other-modules: ghc-options: -Wall build-depends: base >=4.9 && <5,- template-haskell >= 2.11 && < 2.14,- transformers >= 0.5 && < 0.6- -- hs-source-dirs: - default-language: Haskell2010+ transformers >= 0.5 && < 0.6,+ distributive == 0.5.* + if flag(use-template-haskell)+ build-depends: template-haskell >= 2.11 && < 2.14+ exposed-modules: Rank2.TH+ test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: test@@ -41,3 +48,14 @@ main-is: Doctest.hs ghc-options: -threaded -pgmL markdown-unlit build-depends: base, rank2classes, doctest >= 0.8++test-suite TH+ if !flag(use-template-haskell)+ buildable: False+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ main-is: TH.hs+ ghc-options: -threaded -pgmL markdown-unlit+ build-depends: base, rank2classes, distributive == 0.5.*,+ tasty < 2, tasty-hunit < 1
src/Rank2.hs view
@@ -12,9 +12,9 @@ Functor(..), Apply(..), Applicative(..), Foldable(..), Traversable(..), Distributive(..), DistributiveTraversable(..), distributeJoin, -- * Rank 2 data types- Compose(..), Empty(..), Only(..), Identity(..), Product(..), Arrow(..), type (~>),+ Compose(..), Empty(..), Only(..), Identity(..), Product(..), Sum(..), Arrow(..), type (~>), -- * Method synonyms and helper functions- ap, fmap, liftA4, liftA5,+ fst, snd, ap, fmap, liftA4, liftA5, fmapTraverse, liftA2Traverse1, liftA2Traverse2, liftA2TraverseBoth, distributeWith, distributeWithTraversable) where@@ -26,9 +26,19 @@ import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Functor.Compose (Compose(..))+import Data.Functor.Product (Product(..))+import Data.Functor.Sum (Sum(..)) import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) +-- | Helper function for accessing the first field of a 'Pair'+fst :: Product g h p -> g p+fst (Pair x _) = x++-- | Helper function for accessing the second field of a 'Pair'+snd :: Product g h p -> h p+snd (Pair _ y) = y+ -- | Equivalent of 'Functor' for rank 2 data types, satisfying the usual functor laws -- -- > id <$> g == g@@ -158,10 +168,6 @@ -- | Equivalent of 'Data.Functor.Identity' for rank 2 data types newtype Identity g f = Identity {runIdentity :: g f} deriving (Eq, Ord, Show) --- | Equivalent of 'Data.Functor.Product' for rank 2 data types-data Product g h f = Pair {fst :: g f, snd :: h f}- deriving (Eq, Ord, Show)- newtype Flip g a f = Flip (g (f a)) deriving (Eq, Ord, Show) instance Semigroup (g (f a)) => Semigroup (Flip g a f) where@@ -196,8 +202,12 @@ f <$> Identity g = Identity (f <$> g) instance (Functor g, Functor h) => Functor (Product g h) where- f <$> g = Pair (f <$> fst g) (f <$> snd g)+ f <$> ~(Pair a b) = Pair (f <$> a) (f <$> b) +instance (Functor g, Functor h) => Functor (Sum g h) where+ f <$> InL g = InL (f <$> g)+ f <$> InR h = InR (f <$> h)+ instance Foldable Empty where foldMap _ _ = mempty @@ -210,6 +220,10 @@ instance (Foldable g, Foldable h) => Foldable (Product g h) where foldMap f ~(Pair g h) = foldMap f g `mappend` foldMap f h +instance (Foldable g, Foldable h) => Foldable (Sum g h) where+ foldMap f (InL g) = foldMap f g+ foldMap f (InR h) = foldMap f h+ instance Traversable Empty where traverse _ _ = Rank1.pure Empty @@ -222,6 +236,10 @@ instance (Traversable g, Traversable h) => Traversable (Product g h) where traverse f ~(Pair g h) = Rank1.liftA2 Pair (traverse f g) (traverse f h) +instance (Traversable g, Traversable h) => Traversable (Sum g h) where+ traverse f (InL g) = InL Rank1.<$> traverse f g+ traverse f (InR h) = InR Rank1.<$> traverse f h+ instance Apply Empty where _ <*> _ = Empty liftA2 _ _ _ = Empty@@ -235,8 +253,8 @@ liftA2 f (Identity g) (Identity h) = Identity (liftA2 f g h) instance (Apply g, Apply h) => Apply (Product g h) where- gf <*> gx = Pair (fst gf <*> fst gx) (snd gf <*> snd gx)- liftA2 f ~(Pair g1 g2) ~(Pair h1 h2) = Pair (liftA2 f g1 h1) (liftA2 f g2 h2)+ ~(Pair gf hf) <*> ~(Pair gx hx) = Pair (gf <*> gx) (hf <*> hx)+ liftA2 f ~(Pair g1 h1) ~(Pair g2 h2) = Pair (liftA2 f g1 g2) (liftA2 f h1 h2) instance Applicative Empty where pure = const Empty@@ -269,4 +287,3 @@ instance (Distributive g, Distributive h) => Distributive (Product g h) where cotraverse w f = Pair (cotraverse w $ Rank1.fmap fst f) (cotraverse w $ Rank1.fmap snd f)-
src/Rank2/TH.hs view
@@ -14,7 +14,9 @@ deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable) where +import Control.Applicative (liftA2, liftA3) import Control.Monad (replicateM)+import Data.Distributive (cotraverse) import Data.Monoid ((<>)) import Language.Haskell.TH import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)@@ -83,13 +85,13 @@ genFmap cs = funD '(Rank2.<$>) (map genFmapClause cs) genAp :: [Con] -> Q Dec-genAp cs = funD '(Rank2.<*>) (map genApClause cs)+genAp [con] = funD '(Rank2.<*>) [genApClause con] genLiftA2 :: [Con] -> Q Dec-genLiftA2 cs = funD 'Rank2.liftA2 (map genLiftA2Clause cs)+genLiftA2 [con] = funD 'Rank2.liftA2 [genLiftA2Clause con] genLiftA3 :: [Con] -> Q Dec-genLiftA3 cs = funD 'Rank2.liftA3 (map genLiftA3Clause cs)+genLiftA3 [con] = funD 'Rank2.liftA3 [genLiftA3Clause con] genPure :: [Con] -> Q Dec genPure cs = funD 'Rank2.pure (map genPureClause cs)@@ -101,10 +103,10 @@ genTraverse cs = funD 'Rank2.traverse (map genTraverseClause cs) genCotraverse :: [Con] -> Q Dec-genCotraverse cs = funD 'Rank2.cotraverse (map genCotraverseClause cs)+genCotraverse [con] = funD 'Rank2.cotraverse [genCotraverseClause con] genCotraverseTraversable :: [Con] -> Q Dec-genCotraverseTraversable cs = funD 'Rank2.cotraverse (map genCotraverseTraversableClause cs)+genCotraverseTraversable [con] = funD 'Rank2.cotraverseTraversable [genCotraverseTraversableClause con] genFmapClause :: Con -> Q Clause genFmapClause (NormalC name fieldTypes) = do@@ -113,28 +115,28 @@ let pats = [varP f, tildeP (conP name $ map varP fieldNames)] body = normalB $ appsE $ conE name : zipWith newField fieldNames fieldTypes newField :: Name -> BangType -> Q Exp- newField x (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.fmap $(varE f) $(varE x) |]- _ -> [| $(varE x) |]+ newField x (_, fieldType) = genFmapField (varE f) fieldType (varE x) id 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)- newNamedField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _- | ty == VarT typeVar -> fieldExp fieldName [| $(varE f) ($(varE fieldName) $(varE x)) |]- AppT _ ty- | ty == VarT typeVar -> fieldExp fieldName [| Rank2.fmap $(varE f) ($(varE fieldName) $(varE x)) |]- _ -> fieldExp fieldName [| $(varE fieldName) $(varE x) |]+ newNamedField (fieldName, _, fieldType) =+ fieldExp fieldName (genFmapField (varE f) fieldType (appE (varE fieldName) (varE x)) id) clause [varP f, varP x] body [] +genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q 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 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+ genLiftA2Clause :: Con -> Q Clause genLiftA2Clause (NormalC name fieldTypes) = do f <- newName "f"@@ -143,11 +145,7 @@ let pats = [varP f, tildeP (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- newField (x, y) (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) $(varE y) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.liftA2 $(varE f) $(varE x) $(varE y) |]+ newField (x, y) (_, fieldType) = genLiftA2Field (varE f) fieldType (varE x) (varE y) id clause pats body [] genLiftA2Clause (RecC name fields) = do f <- newName "f"@@ -155,17 +153,22 @@ y <- newName "y" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp)- newNamedField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _- | ty == VarT typeVar -> fieldExp fieldName [| $(varE f) ($(varE fieldName) $(varE x)) - ($(varE fieldName) $(varE y)) |]- AppT _ ty- | ty == VarT typeVar -> fieldExp fieldName [| Rank2.liftA2 $(varE f) ($(varE fieldName) $(varE x)) - ($(varE fieldName) $(varE y)) |]+ newNamedField (fieldName, _, fieldType) =+ fieldExp fieldName (genLiftA2Field (varE f) fieldType (getFieldOf x) (getFieldOf y) id)+ where getFieldOf = appE (varE fieldName) . varE clause [varP f, varP x, varP y] body [] +genLiftA2Field :: Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genLiftA2Field fun fieldType field1Access field2Access wrap = do+ Just (Deriving _ typeVar) <- getQ+ case fieldType of+ AppT ty _ | ty == VarT typeVar -> [| $(wrap fun) $field1Access $field2Access |]+ AppT _ ty | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA2) fun) $field1Access $field2Access |]+ AppT t1 t2 | t1 /= VarT typeVar -> genLiftA2Field fun t2 field1Access field2Access (appE (varE 'liftA2) . wrap)+ SigT ty _kind -> genLiftA2Field fun ty field1Access field2Access wrap+ ParensT ty -> genLiftA2Field fun ty field1Access field2Access wrap+ _ -> error ("Cannot apply liftA2 to field of type " <> show fieldType)+ genLiftA3Clause :: Con -> Q Clause genLiftA3Clause (NormalC name fieldTypes) = do f <- newName "f"@@ -176,11 +179,7 @@ tildeP (conP name $ map varP fieldNames3)] body = normalB $ appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes newField :: (Name, Name, Name) -> BangType -> Q Exp- newField (x, y, z) (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) $(varE y) $(varE z) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.liftA3 $(varE f) $(varE x) $(varE y) $(varE z) |]+ newField (x, y, z) (_, fieldType) = genLiftA3Field (varE f) fieldType (varE x) (varE y) (varE z) id clause pats body [] genLiftA3Clause (RecC name fields) = do f <- newName "f"@@ -189,19 +188,26 @@ z <- newName "z" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp)- newNamedField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _- | ty == VarT typeVar -> fieldExp fieldName [| $(varE f) ($(varE fieldName) $(varE x))- ($(varE fieldName) $(varE y))- ($(varE fieldName) $(varE z)) |]- AppT _ ty- | ty == VarT typeVar -> fieldExp fieldName [| Rank2.liftA3 $(varE f) ($(varE fieldName) $(varE x))- ($(varE fieldName) $(varE y))- ($(varE fieldName) $(varE z)) |]+ newNamedField (fieldName, _, fieldType) =+ fieldExp fieldName (genLiftA3Field (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id)+ where getFieldOf = appE (varE fieldName) . varE clause [varP f, varP x, varP y, varP z] body [] +genLiftA3Field :: Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genLiftA3Field fun fieldType field1Access field2Access field3Access wrap = do+ Just (Deriving _ typeVar) <- getQ+ case fieldType of+ AppT ty _+ | ty == VarT typeVar -> [| $(wrap fun) $(field1Access) $(field2Access) $(field3Access) |]+ AppT _ ty+ | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA3) fun) $(field1Access) $(field2Access) $(field3Access) |]+ AppT t1 t2+ | t1 /= VarT typeVar+ -> genLiftA3Field fun t2 field1Access field2Access field3Access (appE (varE 'liftA3) . wrap)+ SigT ty _kind -> genLiftA3Field fun ty field1Access field2Access field3Access wrap+ ParensT ty -> genLiftA3Field fun ty field1Access field2Access field3Access wrap+ _ -> error ("Cannot apply liftA3 to field of type " <> show fieldType)+ genApClause :: Con -> Q Clause genApClause (NormalC name fieldTypes) = do fieldNames1 <- replicateM (length fieldTypes) (newName "x")@@ -209,78 +215,87 @@ let pats = [tildeP (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- newField (x, y) (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| Rank2.apply $(varE x) $(varE y) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.ap $(varE x) $(varE y) |]+ newField (x, y) (_, fieldType) = genApField fieldType (varE x) (varE y) id clause pats body [] genApClause (RecC name fields) = do x <- newName "x" y <- newName "y" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp)- newNamedField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> fieldExp fieldName [| $(varE fieldName) $(varE x) `Rank2.apply`- $(varE fieldName) $(varE y) |]- AppT _ ty | ty == VarT typeVar -> fieldExp fieldName [| $(varE fieldName) $(varE x) `Rank2.ap`- $(varE fieldName) $(varE y) |]+ newNamedField (fieldName, _, fieldType) =+ fieldExp fieldName (genApField fieldType (getFieldOf x) (getFieldOf y) id)+ where getFieldOf = appE (varE fieldName) . varE clause [varP x, varP y] body [] +genApField :: Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp+genApField 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 t1 t2 | t1 /= VarT typeVar -> genApField t2 field1Access field2Access (appE (varE 'liftA2) . wrap)+ SigT ty _kind -> genApField ty field1Access field2Access wrap+ ParensT ty -> genApField ty field1Access field2Access wrap+ _ -> error ("Cannot apply ap to field of type " <> show fieldType)+ genPureClause :: Con -> Q Clause genPureClause (NormalC name fieldTypes) = do argName <- newName "f" let body = normalB $ appsE $ conE name : map newField fieldTypes newField :: BangType -> Q Exp- newField (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> varE argName- AppT _ ty | ty == VarT typeVar -> appE (varE 'Rank2.pure) (varE argName)+ newField (_, fieldType) = genPureField fieldType (varE argName) id 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) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> fieldExp fieldName (varE argName)- AppT _ ty | ty == VarT typeVar -> fieldExp fieldName (appE (varE 'Rank2.pure) $ varE argName)+ newNamedField (fieldName, _, fieldType) = fieldExp fieldName (genPureField fieldType (varE argName) id) clause [varP argName] body [] +genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q 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 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 (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 $ foldr1 append $ zipWith newField fieldNames fieldTypes+ body = normalB $ foldr append [| mempty |] $ zipWith newField fieldNames fieldTypes append a b = [| $(a) <> $(b) |] newField :: Name -> BangType -> Q Exp- newField x (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.foldMap $(varE f) $(varE x) |]- _ -> [| $(varE x) |]+ newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id clause pats body [] genFoldMapClause (RecC _name fields) = do f <- newName "f" x <- newName "x"- let body = normalB $ foldr1 append $ map newField fields+ let body = normalB $ foldr append [| mempty |] $ map newField fields append a b = [| $(a) <> $(b) |] newField :: VarBangType -> Q Exp- newField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) ($(varE fieldName) $(varE x)) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.foldMap $(varE f) ($(varE fieldName) $(varE x)) |]- _ -> [| $(varE x) |]+ newField (fieldName, _, fieldType) = genFoldMapField f fieldType (appE (varE fieldName) (varE x)) id clause [varP f, varP x] body [] +genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q 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 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+ _ -> fieldAccess+ genTraverseClause :: Con -> Q Clause+genTraverseClause (NormalC name []) =+ clause [wildP, wildP] (normalB [| pure $(conE name) |]) [] genTraverseClause (NormalC name fieldTypes) = do f <- newName "f" fieldNames <- replicateM (length fieldTypes) (newName "x")@@ -289,12 +304,7 @@ apply (a, False) b = ([| $(a) <$> $(b) |], True) apply (a, True) b = ([| $(a) <*> $(b) |], True) newField :: Name -> BangType -> Q Exp- newField x (_, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.traverse $(varE f) $(varE x) |]- _ -> [| $(varE x) |]+ newField x (_, fieldType) = genTraverseField (varE f) fieldType (varE x) id clause pats body [] genTraverseClause (RecC name fields) = do f <- newName "f"@@ -303,42 +313,50 @@ apply (a, False) b = ([| $(a) <$> $(b) |], True) apply (a, True) b = ([| $(a) <*> $(b) |], True) newField :: VarBangType -> Q Exp- newField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _ | ty == VarT typeVar -> [| $(varE f) ($(varE fieldName) $(varE x)) |]- AppT _ ty | ty == VarT typeVar -> [| Rank2.traverse $(varE f) ($(varE fieldName) $(varE x)) |]- _ -> [| $(varE x) |]+ newField (fieldName, _, fieldType) = genTraverseField (varE f) fieldType (appE (varE fieldName) (varE x)) id clause [varP f, varP x] body [] +genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q 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 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+ _ -> fieldAccess+ genCotraverseClause :: Con -> Q 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)- newNamedField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _- | ty == VarT typeVar -> fieldExp fieldName [| $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]- AppT _ ty- | ty == VarT typeVar ->- fieldExp fieldName [| Rank2.cotraverse $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+ newNamedField (fieldName, _, fieldType) =+ fieldExp fieldName (genCotraverseField (varE 'Rank2.cotraverse) (varE withName) fieldType+ [| $(varE fieldName) <$> $(varE argName) |] id) clause [varP withName, varP argName] body [] genCotraverseTraversableClause :: Con -> Q 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)- newNamedField (fieldName, _, fieldType) = do- Just (Deriving _ typeVar) <- getQ- case fieldType of- AppT ty _- | ty == VarT typeVar -> fieldExp fieldName [| $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]- AppT _ ty- | ty == VarT typeVar ->- fieldExp fieldName [| Rank2.cotraverseTraversable $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+ newNamedField (fieldName, _, fieldType) =+ fieldExp fieldName (genCotraverseField (varE 'Rank2.cotraverseTraversable) (varE withName) fieldType+ [| $(varE fieldName) <$> $(varE argName) |] id) 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+ 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
+ test/TH.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE KindSignatures, RankNTypes, TemplateHaskell #-}++import Control.Applicative (liftA2)+import Data.Foldable (fold, foldMap)+import Data.Traversable (traverse)+import Data.Distributive (cotraverse)+import Data.Monoid (Dual, Sum(Sum), getDual)+import Data.Functor.Classes (Eq1, Show1, eq1, showsPrec1)+import Data.Functor.Compose (Compose(Compose))+import Data.Functor.Identity (Identity(Identity, runIdentity))+import qualified Rank2+import qualified Rank2.TH+import Test.Tasty+import Test.Tasty.HUnit++data Test0 (p :: * -> *) = Test0{} deriving (Eq, Show)++data Test1 p = Test1{single :: p Int,+ whole :: Test0 p,+ wrapSingle :: Dual (Identity (p String)),+ wrapWhole :: Sum (Identity (Test0 p))}++instance Eq1 p => Eq (Test1 p) where+ a == b = single a `eq1` single b+ && whole a == whole b+ && all (all id) (liftA2 (liftA2 eq1) (wrapSingle a) (wrapSingle b))+ && wrapWhole a == wrapWhole b++instance Show1 p => Show (Test1 p) where+ showsPrec p t s = "Test1{single= " ++ showsPrec1 p (single t)+ (", whole= " ++ showsPrec p (whole t)+ (", wrapSingle= Dual (Identity (" ++ showsPrec1 p (runIdentity $ getDual $ wrapSingle t)+ (")), wrapWhole= " ++ showsPrec p (wrapWhole t) s)))++$(Rank2.TH.deriveAll ''Test0)+$(Rank2.TH.deriveAll ''Test1)++main = defaultMain $ testCase "Template test" $+ do let test = Test1{single= [3, 4, 5],+ whole= Test0,+ wrapSingle= pure (pure ["a", "b", "ab"]),+ wrapWhole= pure (pure Test0)}+ id Rank2.<$> test @?= test+ Rank2.pure (Rank2.Arrow id) Rank2.<*> test @?= test+ Rank2.liftA2 (++) test test @?= Test1{single= [3, 4, 5, 3, 4, 5],+ whole= Test0,+ wrapSingle= pure (pure ["a", "b", "ab", "a", "b", "ab"]),+ wrapWhole= pure (pure Test0)}+ Rank2.foldMap (Sum . length) test @?= Sum 6+ Rank2.traverse (map Identity) test @?= [Test1{single= Identity 3,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "a"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 3,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "b"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 3,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "ab"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 4,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "a"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 4,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "b"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 4,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "ab"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 5,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "a"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 5,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "b"),+ wrapWhole= pure (pure Test0)},+ Test1{single= Identity 5,+ whole= Test0,+ wrapSingle= pure (pure $ Identity "ab"),+ wrapWhole= pure (pure Test0)}+ ]+ Rank2.distribute (Identity test) @?= Test1{single= Compose (Identity [3, 4, 5]),+ whole= Test0,+ wrapSingle= pure (pure $ Compose $ Identity ["a", "b", "ab"]),+ wrapWhole= pure (pure Test0)}+ Rank2.cotraverse (take 1 . map runIdentity) (Rank2.traverse (map Identity) test) @?= take 1 Rank2.<$> test