packages feed

rank2classes 0.1 → 0.2

raw patch · 4 files changed

+180/−42 lines, 4 files

Files

README.md view
@@ -53,8 +53,9 @@  If you wish to have the standard [Eq](http://hackage.haskell.org/package/base/docs/Data-Eq.html#t:Eq) and [Show](http://hackage.haskell.org/package/base/docs/Text-Show.html#t:Show) instances for a record type like `Person`,-it's best if they refer to the [Eq1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Eq1)-and [Show1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Show1) instances for its+it's best if they refer to the+[Eq1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Eq1) and+[Show1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Show1) instances for its parameter `f`:  ~~~ {.haskell}
rank2classes.cabal view
@@ -1,5 +1,5 @@ name:                rank2classes-version:             0.1+version:             0.2 synopsis:            a mirror image of some standard type classes, with methods of rank 2 types description:   A mirror image of the standard constructor type class hierarchy rooted in 'Functor', except with methods of rank 2
src/Rank2.hs view
@@ -5,15 +5,17 @@ -- This will bring into scope the standard classes 'Functor', 'Applicative', 'Foldable', and 'Traversable', but with a -- @Rank2.@ prefix and a twist that their methods operate on a heterogenous collection. The same property is shared by -- the two less standard classes 'Apply' and 'Distributive'.-{-# LANGUAGE InstanceSigs, KindSignatures, Rank2Types, ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs, KindSignatures, Rank2Types, ScopedTypeVariables, PolyKinds, DefaultSignatures #-} module Rank2 ( -- * Rank 2 classes    Functor(..), Apply(..), Applicative(..),-   Foldable(..), Traversable(..), Distributive(..),+   Foldable(..), Traversable(..), Distributive(..), DistributiveTraversable(..), distributeJoin, -- * Rank 2 data types    Compose(..), Empty(..), Only(..), Identity(..), Product(..), Arrow(..), -- * Method synonyms and helper functions-   ap, fmap, liftA3)+   ap, fmap, liftA3, liftA4, liftA5,+   fmapTraverse, liftA2Traverse1, liftA2Traverse2, liftA2TraverseBoth,+   cotraverse, cotraverseTraversable) where  import qualified Control.Applicative as Rank1@@ -31,7 +33,8 @@  -- | Alphabetical synonym for '<$>' fmap :: Functor g => (forall a. p a -> q a) -> g p -> g q-fmap = (<$>)+fmap f g = f <$> g+{-# INLINE fmap #-}  -- | Equivalent of 'Foldable' for rank 2 data types class Foldable g where@@ -57,46 +60,94 @@    (<*>) :: g (Arrow p q) -> g p -> g q    -- | Equivalent of 'Rank1.liftA2' for rank 2 data types    liftA2 :: (forall a. p a -> q a -> r a) -> g p -> g q -> g r+   -- | Equivalent of 'Rank1.liftA3' for rank 2 data types+   liftA3 :: (forall a. p a -> q a -> r a -> s a) -> g p -> g q -> g r -> g s     (<*>) = liftA2 apply    liftA2 f g h = (Arrow . f) <$> g <*> h+   liftA3 f g h i = liftA2 (\p q-> Arrow (f p q)) g h <*> i +liftA4 :: Apply g => (forall a. p a -> q a -> r a -> s a -> t a) -> g p -> g q -> g r -> g s -> g t+liftA4 f g h i j = liftA3 (\p q r-> Arrow (f p q r)) g h i <*> j++liftA5 :: Apply g => (forall a. p a -> q a -> r a -> s a -> t a -> u a) -> g p -> g q -> g r -> g s -> g t -> g u+liftA5 f g1 g2 g3 g4 g5 = liftA4 (\p q r s-> Arrow (f p q r s)) g1 g2 g3 g4 <*> g5+ -- | Alphabetical synonym for '<*>' ap :: Apply g => g (Arrow p q) -> g p -> g q ap = (<*>) --- | Equivalent of 'Rank1.liftA3' for rank 2 data types-liftA3 :: Apply g => (forall a. p a -> q a -> r a -> s a) -> g p -> g q -> g r -> g s-liftA3 f g h i = (\x-> Arrow (Arrow . f x)) <$> g <*> h <*> i- -- | Equivalent of 'Rank1.Applicative' for rank 2 data types class Apply g => Applicative g where    pure :: (forall a. f a) -> g f---- | Equivalent of 'Distributive' for rank 2 data types-class Functor g => Distributive g where+  +-- | Equivalent of 'Rank1.Distributive' for rank 2 data types+class DistributiveTraversable g => Distributive g where    {-# MINIMAL distributeWith #-}    collect :: Rank1.Functor f1 => (a -> g f2) -> f1 a -> g (Compose f1 f2)    distribute :: Rank1.Functor f1 => f1 (g f2) -> g (Compose f1 f2)    distributeWith :: Rank1.Functor f1 => (forall x. f1 (f2 x) -> f x) -> f1 (g f2) -> g f-   distributeM :: Rank1.Monad f => f (g f) -> g f     collect f = distribute . Rank1.fmap f    distribute = distributeWith Compose-   distributeM = distributeWith Rank1.join +-- | A weaker 'Distributive' that requires 'Rank1.Traversable' to use, not just a 'Rank1.Functor'.+class Functor g => DistributiveTraversable (g :: (k -> *) -> *) where+   collectTraversable :: Rank1.Traversable f1 => (a -> g f2) -> f1 a -> g (Compose f1 f2)   +   distributeTraversable :: Rank1.Traversable f1 => f1 (g f2) -> g (Compose f1 f2)+   distributeWithTraversable :: Rank1.Traversable f1 => (forall x. f1 (f2 x) -> f x) -> f1 (g f2) -> g f++   collectTraversable f = distributeTraversable . Rank1.fmap f+   distributeTraversable = distributeWithTraversable Compose+   +   default distributeWithTraversable :: (Rank1.Traversable f1, Distributive g) => +                                        (forall x. f1 (f2 x) -> f x) -> f1 (g f2) -> g f+   distributeWithTraversable = distributeWith++-- | A variant of 'distribute' convenient with 'Rank1.Monad' instances+distributeJoin :: (Distributive g, Rank1.Monad f) => f (g f) -> g f+distributeJoin = distributeWith Rank1.join++-- | Like 'fmap', but traverses over its argument+fmapTraverse :: (DistributiveTraversable f, Rank1.Traversable g) => (forall a. g (t a) -> u a) -> g (f t) -> f u+fmapTraverse f x = fmap (f . getCompose) (distributeTraversable x)++-- | Like 'liftA2', but traverses over its first argument+liftA2Traverse1 :: (Apply f, DistributiveTraversable f, Rank1.Traversable g) =>+                   (forall a. g (t a) -> u a -> v a) -> g (f t) -> f u -> f v+liftA2Traverse1 f x = liftA2 (f . getCompose) (distributeTraversable x)++-- | Like 'liftA2', but traverses over its second argument+liftA2Traverse2 :: (Apply f, DistributiveTraversable f, Rank1.Traversable g) => +                   (forall a. t a -> g (u a) -> v a) -> f t -> g (f u) -> f v+liftA2Traverse2 f x y = liftA2 (\x' y' -> f x' (getCompose y')) x (distributeTraversable y)++-- | Like 'liftA2', but traverses over both its arguments+liftA2TraverseBoth :: (Apply f, DistributiveTraversable f, Rank1.Traversable g1, Rank1.Traversable g2) =>+                      (forall a. g1 (t a) -> g2 (u a) -> v a) -> g1 (f t) -> g2 (f u) -> f v+liftA2TraverseBoth f x y = liftA2 applyCompose (distributeTraversable x) (distributeTraversable y)+   where applyCompose x' y' = f (getCompose x') (getCompose y')++-- | Equivalent of 'Rank1.cotraverse' for rank 2 data types +cotraverse :: (Distributive g, Rank1.Functor f) => (forall i. f (a i) -> b i) -> f (g a) -> g b+cotraverse f = (fmap (f . getCompose)) . distribute++-- | Equivalent of 'Rank1.cotraverse' for rank 2 data types using traversable+cotraverseTraversable :: (DistributiveTraversable g, Rank1.Traversable f) => +                         (forall i. f (a i) -> b i) -> f (g a) -> g b+cotraverseTraversable f = (fmap (f . getCompose)) . distributeTraversable+ -- | A rank-2 equivalent of '()', a zero-element tuple-data Empty (f :: * -> *) = Empty deriving (Eq, Ord, Show)+data Empty f = Empty deriving (Eq, Ord, Show)  -- | A rank-2 tuple of only one element-newtype Only a (f :: * -> *) = Only {fromOnly :: f a} deriving (Eq, Ord, Show)+newtype Only a f = Only {fromOnly :: f a} deriving (Eq, Ord, Show)  -- | Equivalent of 'Data.Functor.Identity' for rank 2 data types-newtype Identity g (f :: * -> *) = Identity {runIdentity :: g f} deriving (Eq, Ord, Show)+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}+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)@@ -184,18 +235,23 @@ instance (Applicative g, Applicative h) => Applicative (Product g h) where    pure f = Pair (pure f) (pure f) +instance DistributiveTraversable Empty+instance DistributiveTraversable (Only x)+instance DistributiveTraversable g => DistributiveTraversable (Identity g) where+   distributeWithTraversable w f = Identity (distributeWithTraversable w $ Rank1.fmap runIdentity f)+instance (DistributiveTraversable g, DistributiveTraversable h) => DistributiveTraversable (Product g h) where+   distributeWithTraversable w f = Pair (distributeWithTraversable w $ Rank1.fmap fst f) +                                        (distributeWithTraversable w $ Rank1.fmap snd f)+ instance Distributive Empty where    distributeWith _ _ = Empty-   distributeM _ = Empty  instance Distributive (Only x) where    distributeWith w f = Only (w $ Rank1.fmap fromOnly f)-   distributeM f = Only (f >>= fromOnly)  instance Distributive g => Distributive (Identity g) where    distributeWith w f = Identity (distributeWith w $ Rank1.fmap runIdentity f)-   distributeM f = Identity (distributeM $ Rank1.fmap runIdentity f)  instance (Distributive g, Distributive h) => Distributive (Product g h) where    distributeWith w f = Pair (distributeWith w $ Rank1.fmap fst f) (distributeWith w $ Rank1.fmap snd f)-   distributeM f = Pair (distributeM $ Rank1.fmap fst f) (distributeM $ Rank1.fmap snd f)+
src/Rank2/TH.hs view
@@ -11,7 +11,7 @@ -- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial  module Rank2.TH (deriveAll, deriveFunctor, deriveApply, deriveApplicative,-                 deriveFoldable, deriveTraversable, deriveDistributive)+                 deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable) where  import Control.Monad (replicateM)@@ -25,7 +25,7 @@  deriveAll :: Name -> Q [Dec] deriveAll ty = foldr f (pure []) [deriveFunctor, deriveApply, deriveApplicative,-                                  deriveFoldable, deriveTraversable, deriveDistributive]+                                  deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable]    where f derive rest = (<>) <$> derive ty <*> rest  deriveFunctor :: Name -> Q [Dec]@@ -36,7 +36,7 @@ deriveApply :: Name -> Q [Dec] deriveApply ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty-   sequence [instanceD (return []) instanceType [genAp cs]]+   sequence [instanceD (return []) instanceType [genAp cs, genLiftA2 cs, genLiftA3 cs]]  deriveApplicative :: Name -> Q [Dec] deriveApplicative ty = do@@ -56,8 +56,13 @@ deriveDistributive :: Name -> Q [Dec] deriveDistributive ty = do    (instanceType, cs) <- reifyConstructors ''Rank2.Distributive ty-   sequence [instanceD (return []) instanceType [genDistributeWith cs, genDistributeM cs]]+   sequence [instanceD (return []) instanceType [genDistributeWith cs]] +deriveDistributiveTraversable :: Name -> Q [Dec]+deriveDistributiveTraversable ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.DistributiveTraversable ty+   sequence [instanceD (return []) instanceType [genDistributeWithTraversable cs]]+ reifyConstructors :: Name -> Name -> Q (TypeQ, [Con]) reifyConstructors cls ty = do    (TyConI tyCon) <- reify ty@@ -80,6 +85,12 @@ genAp :: [Con] -> Q Dec genAp cs = funD '(Rank2.<*>) (map genApClause cs) +genLiftA2 :: [Con] -> Q Dec+genLiftA2 cs = funD 'Rank2.liftA2 (map genLiftA2Clause cs)++genLiftA3 :: [Con] -> Q Dec+genLiftA3 cs = funD 'Rank2.liftA3 (map genLiftA3Clause cs)+ genPure :: [Con] -> Q Dec genPure cs = funD 'Rank2.pure (map genPureClause cs) @@ -89,12 +100,12 @@ genTraverse :: [Con] -> Q Dec genTraverse cs = funD 'Rank2.traverse (map genTraverseClause cs) -genDistributeM :: [Con] -> Q Dec-genDistributeM cs = funD 'Rank2.distributeM (map genDistributeMClause cs)- genDistributeWith :: [Con] -> Q Dec genDistributeWith cs = funD 'Rank2.distributeWith (map genDistributeWithClause cs) +genDistributeWithTraversable :: [Con] -> Q Dec+genDistributeWithTraversable cs = funD 'Rank2.distributeWith (map genDistributeWithTraversableClause cs)+ genFmapClause :: Con -> Q Clause genFmapClause (NormalC name fieldTypes) = do    f          <- newName "f"@@ -123,7 +134,74 @@                 | ty == VarT typeVar -> fieldExp fieldName [| Rank2.fmap $(varE f) ($(varE fieldName) $(varE x)) |]              _ -> fieldExp fieldName [| $(varE x) |]    clause [varP f, varP x] body []- ++genLiftA2Clause :: Con -> Q Clause+genLiftA2Clause (NormalC name fieldTypes) = do+   f          <- newName "f"+   fieldNames1 <- replicateM (length fieldTypes) (newName "x")+   fieldNames2 <- replicateM (length fieldTypes) (newName "y")+   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) |]+   clause pats body []+genLiftA2Clause (RecC name fields) = do+   f <- newName "f"+   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 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)) |]+   clause [varP f, varP x, varP y] body []++genLiftA3Clause :: Con -> Q Clause+genLiftA3Clause (NormalC name fieldTypes) = do+   f          <- newName "f"+   fieldNames1 <- replicateM (length fieldTypes) (newName "x")+   fieldNames2 <- replicateM (length fieldTypes) (newName "y")+   fieldNames3 <- replicateM (length fieldTypes) (newName "z")+   let pats = [varP f, tildeP (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+       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) |]+   clause pats body []+genLiftA3Clause (RecC name fields) = do+   f <- newName "f"+   x <- newName "x"+   y <- newName "y"+   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)) |]+   clause [varP f, varP x, varP y, varP z] body []+ genApClause :: Con -> Q Clause genApClause (NormalC name fieldTypes) = do    fieldNames1 <- replicateM (length fieldTypes) (newName "x")@@ -233,21 +311,24 @@              _ -> [| $(varE x) |]    clause [varP f, varP x] body [] -genDistributeMClause :: Con -> Q Clause-genDistributeMClause (RecC name fields) = do+genDistributeWithClause :: Con -> Q Clause+genDistributeWithClause (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 argName) >>= $(varE fieldName) |]-             AppT _ ty | ty == VarT typeVar ->-                         fieldExp fieldName [| Rank2.distributeM ($(varE fieldName) <$> $(varE argName)) |]-   clause [varP argName] body []+             AppT ty _+                | ty == VarT typeVar -> fieldExp fieldName [| $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+             AppT _ ty+                | ty == VarT typeVar ->+                  fieldExp fieldName [| Rank2.distributeWith $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+   clause [varP withName, varP argName] body [] -genDistributeWithClause :: Con -> Q Clause-genDistributeWithClause (RecC name fields) = do+genDistributeWithTraversableClause :: Con -> Q Clause+genDistributeWithTraversableClause (RecC name fields) = do    withName <- newName "w"    argName <- newName "f"    let body = normalB $ recConE name $ map newNamedField fields@@ -259,5 +340,5 @@                 | ty == VarT typeVar -> fieldExp fieldName [| $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]              AppT _ ty                 | ty == VarT typeVar ->-                  fieldExp fieldName [| Rank2.distributeWith $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+                  fieldExp fieldName [| Rank2.distributeWithTraversable $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]    clause [varP withName, varP argName] body []