diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/rank2classes.cabal b/rank2classes.cabal --- a/rank2classes.cabal +++ b/rank2classes.cabal @@ -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 diff --git a/src/Rank2.hs b/src/Rank2.hs --- a/src/Rank2.hs +++ b/src/Rank2.hs @@ -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) - diff --git a/src/Rank2/TH.hs b/src/Rank2/TH.hs --- a/src/Rank2/TH.hs +++ b/src/Rank2/TH.hs @@ -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 diff --git a/test/TH.hs b/test/TH.hs new file mode 100644 --- /dev/null +++ b/test/TH.hs @@ -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