Refactor functors and related packages

CHANGELOG.md

@@ -8,12 +8,15 @@ Breaking changes:
 - Added support for PureScript 0.14 and dropped support for all previous versions (#24)
 
 New features:
+- Added `Clown`, `Costar`, `Flip`, `Joker`, and `Product2` types, adapted from the `purescript-bifunctors` and `purescript-profunctor` packages (#31)
+- This package no longer depends on the `purescript-foldable-traversable` package. Relevant instances have been moved to that package. (#31)
 
 Bugfixes:
 
 Other improvements:
 - Migrated CI to GitHub Actions and updated installation instructions to use Spago (#25)
 - Added a CHANGELOG.md file and pull request template (#28, #29)
+- This package now depends on the `purescript-contravariant`, `purescript-distributive`, `purescript-invariant`, and `purescript-profunctor` packages, and contains instances previously in some of those packages (#31)
 
 ## [v3.1.1](https://github.com/purescript/purescript-functors/releases/tag/v3.1.1) - 2018-11-30
 

bower.json

@@ -19,12 +19,15 @@
   "dependencies": {
     "purescript-bifunctors": "master",
     "purescript-const": "master",
+    "purescript-contravariant": "master",
     "purescript-control": "master",
+    "purescript-distributive": "master",
     "purescript-either": "master",
-    "purescript-foldable-traversable": "master",
+    "purescript-invariant": "master",
     "purescript-maybe": "master",
     "purescript-newtype": "master",
     "purescript-prelude": "master",
+    "purescript-profunctor": "master",
     "purescript-tuples": "master",
     "purescript-unsafe-coerce": "master"
   },

src/Data/Functor/App.purs

@@ -11,13 +11,8 @@ import Control.Lazy (class Lazy)
 import Control.MonadPlus (class MonadZero, class MonadPlus)
 import Control.Plus (class Plus)
 import Data.Eq (class Eq1)
-import Data.Foldable (class Foldable)
-import Data.FoldableWithIndex (class FoldableWithIndex)
-import Data.FunctorWithIndex (class FunctorWithIndex)
 import Data.Newtype (class Newtype)
 import Data.Ord (class Ord1)
-import Data.Traversable (class Traversable)
-import Data.TraversableWithIndex (class TraversableWithIndex)
 import Unsafe.Coerce (unsafeCoerce)
 
 newtype App :: forall k. (k -> Type) -> k -> Type
@@ -50,7 +45,6 @@ instance monoidApp :: (Applicative f, Monoid a) => Monoid (App f a) where
 instance monadZeroApp :: MonadZero f => MonadZero (App f)
 
 derive newtype instance functorApp :: Functor f => Functor (App f)
-derive newtype instance functorWithIndexApp :: FunctorWithIndex a f => FunctorWithIndex a (App f)
 derive newtype instance applyApp :: Apply f => Apply (App f)
 derive newtype instance applicativeApp :: Applicative f => Applicative (App f)
 derive newtype instance bindApp :: Bind f => Bind (App f)
@@ -60,9 +54,5 @@ derive newtype instance plusApp :: Plus f => Plus (App f)
 derive newtype instance alternativeApp :: Alternative f => Alternative (App f)
 derive newtype instance monadPlusApp :: MonadPlus f => MonadPlus (App f)
 derive newtype instance lazyApp :: Lazy (f a) => Lazy (App f a)
-derive newtype instance foldableApp :: Foldable f => Foldable (App f)
-derive newtype instance traversableApp :: Traversable f => Traversable (App f)
-derive newtype instance foldableWithIndexApp :: FoldableWithIndex a f => FoldableWithIndex a (App f)
-derive newtype instance traversableWithIndexApp :: TraversableWithIndex a f => TraversableWithIndex a (App f)
 derive newtype instance extendApp :: Extend f => Extend (App f)
 derive newtype instance comonadApp :: Comonad f => Comonad (App f)

src/Data/Functor/Clown.purs

@@ -0,0 +1,44 @@
+module Data.Functor.Clown where
+
+import Prelude
+
+import Control.Biapplicative (class Biapplicative)
+import Control.Biapply (class Biapply)
+import Data.Bifunctor (class Bifunctor)
+import Data.Functor.Contravariant (class Contravariant, cmap)
+import Data.Newtype (class Newtype)
+import Data.Profunctor (class Profunctor)
+
+-- | This advanced type's usage and its relation to `Joker` is best understood
+-- | by reading through "Clowns to the Left, Jokers to the Right (Functional
+-- | Pearl)"
+-- | https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.475.6134&rep=rep1&type=pdf
+newtype Clown :: (Type -> Type) -> Type -> Type -> Type
+newtype Clown f a b = Clown (f a)
+
+derive instance newtypeClown :: Newtype (Clown f a b) _
+
+derive newtype instance eqClown :: Eq (f a) => Eq (Clown f a b)
+
+derive newtype instance ordClown :: Ord (f a) => Ord (Clown f a b)
+
+instance showClown :: Show (f a) => Show (Clown f a b) where
+  show (Clown x) = "(Clown " <> show x <> ")"
+
+instance functorClown :: Functor (Clown f a) where
+  map _ (Clown a) = Clown a
+
+instance bifunctorClown :: Functor f => Bifunctor (Clown f) where
+  bimap f _ (Clown a) = Clown (map f a)
+
+instance biapplyClown :: Apply f => Biapply (Clown f) where
+  biapply (Clown fg) (Clown xy) = Clown (fg <*> xy)
+
+instance biapplicativeClown :: Applicative f => Biapplicative (Clown f) where
+  bipure a _ = Clown (pure a)
+
+instance profunctorClown :: Contravariant f => Profunctor (Clown f) where
+  dimap f g (Clown a) = Clown (cmap f a)
+
+hoistClown :: forall f g a b. (f ~> g) -> Clown f a b -> Clown g a b
+hoistClown f (Clown a) = Clown (f a)

src/Data/Functor/Compose.purs

@@ -6,15 +6,9 @@ import Control.Alt (class Alt, alt)
 import Control.Alternative (class Alternative)
 import Control.Plus (class Plus, empty)
 import Data.Eq (class Eq1, eq1)
-import Data.Foldable (class Foldable, foldl, foldMap, foldr)
-import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex)
 import Data.Functor.App (hoistLiftApp)
-import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
 import Data.Newtype (class Newtype)
 import Data.Ord (class Ord1, compare1)
-import Data.Traversable (class Traversable, traverse)
-import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
-import Data.Tuple (Tuple, curry)
 
 -- | `Compose f g` is the composition of the two functors `f` and `g`.
 newtype Compose :: forall k1 k2. (k2 -> Type) -> (k1 -> k2) -> k1 -> Type
@@ -49,32 +43,12 @@ instance showCompose :: Show (f (g a)) => Show (Compose f g a) where
 instance functorCompose :: (Functor f, Functor g) => Functor (Compose f g) where
   map f (Compose fga) = Compose $ map f <$> fga
 
-instance functorWithIndexCompose :: (FunctorWithIndex a f, FunctorWithIndex b g) => FunctorWithIndex (Tuple a b) (Compose f g) where
-  mapWithIndex f (Compose fga) = Compose $ mapWithIndex (mapWithIndex <<< curry f) fga
-
 instance applyCompose :: (Apply f, Apply g) => Apply (Compose f g) where
   apply (Compose f) (Compose x) = Compose $ apply <$> f <*> x
 
 instance applicativeCompose :: (Applicative f, Applicative g) => Applicative (Compose f g) where
   pure = Compose <<< pure <<< pure
 
-instance foldableCompose :: (Foldable f, Foldable g) => Foldable (Compose f g) where
-  foldr f i (Compose fga) = foldr (flip (foldr f)) i fga
-  foldl f i (Compose fga) = foldl (foldl f) i fga
-  foldMap f (Compose fga) = foldMap (foldMap f) fga
-
-instance foldableWithIndexCompose :: (FoldableWithIndex a f, FoldableWithIndex b g) => FoldableWithIndex (Tuple a b) (Compose f g) where
-  foldrWithIndex f i (Compose fga) = foldrWithIndex (\a -> flip (foldrWithIndex (curry f a))) i fga
-  foldlWithIndex f i (Compose fga) = foldlWithIndex (foldlWithIndex <<< curry f) i fga
-  foldMapWithIndex f (Compose fga) = foldMapWithIndex (foldMapWithIndex <<< curry f) fga
-
-instance traversableCompose :: (Traversable f, Traversable g) => Traversable (Compose f g) where
-  traverse f (Compose fga) = map Compose $ traverse (traverse f) fga
-  sequence = traverse identity
-
-instance traversableWithIndexCompose :: (TraversableWithIndex a f, TraversableWithIndex b g) => TraversableWithIndex (Tuple a b) (Compose f g) where
-  traverseWithIndex f (Compose fga) = map Compose $ traverseWithIndex (traverseWithIndex <<< curry f) fga
-
 instance altCompose :: (Alt f, Functor g) => Alt (Compose f g) where
   alt (Compose a) (Compose b) = Compose $ alt a b
 

src/Data/Functor/Coproduct.purs

@@ -7,13 +7,8 @@ import Control.Extend (class Extend, extend)
 import Data.Bifunctor (bimap)
 import Data.Either (Either(..))
 import Data.Eq (class Eq1, eq1)
-import Data.Foldable (class Foldable, foldMap, foldl, foldr)
-import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex)
-import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
 import Data.Newtype (class Newtype)
 import Data.Ord (class Ord1, compare1)
-import Data.Traversable (class Traversable, traverse, sequence)
-import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
 
 -- | `Coproduct f g` is the coproduct of two functors `f` and `g`
 newtype Coproduct :: forall k. (k -> Type) -> (k -> Type) -> k -> Type
@@ -72,36 +67,10 @@ instance showCoproduct :: (Show (f a), Show (g a)) => Show (Coproduct f g a) whe
 instance functorCoproduct :: (Functor f, Functor g) => Functor (Coproduct f g) where
   map f (Coproduct e) = Coproduct (bimap (map f) (map f) e)
 
-instance functorWithIndexCoproduct :: (FunctorWithIndex a f, FunctorWithIndex b g) => FunctorWithIndex (Either a b) (Coproduct f g) where
-  mapWithIndex f (Coproduct e) = Coproduct (bimap (mapWithIndex (f <<< Left)) (mapWithIndex (f <<< Right)) e)
-
 instance extendCoproduct :: (Extend f, Extend g) => Extend (Coproduct f g) where
   extend f = Coproduct <<< coproduct
     (Left <<< extend (f <<< Coproduct <<< Left))
     (Right <<< extend (f <<< Coproduct <<< Right))
 
 instance comonadCoproduct :: (Comonad f, Comonad g) => Comonad (Coproduct f g) where
   extract = coproduct extract extract
-
-instance foldableCoproduct :: (Foldable f, Foldable g) => Foldable (Coproduct f g) where
-  foldr f z = coproduct (foldr f z) (foldr f z)
-  foldl f z = coproduct (foldl f z) (foldl f z)
-  foldMap f = coproduct (foldMap f) (foldMap f)
-
-instance foldableWithIndexCoproduct :: (FoldableWithIndex a f, FoldableWithIndex b g) => FoldableWithIndex (Either a b) (Coproduct f g) where
-  foldrWithIndex f z = coproduct (foldrWithIndex (f <<< Left) z) (foldrWithIndex (f <<< Right) z)
-  foldlWithIndex f z = coproduct (foldlWithIndex (f <<< Left) z) (foldlWithIndex (f <<< Right) z)
-  foldMapWithIndex f = coproduct (foldMapWithIndex (f <<< Left)) (foldMapWithIndex (f <<< Right))
-
-instance traversableCoproduct :: (Traversable f, Traversable g) => Traversable (Coproduct f g) where
-  traverse f = coproduct
-    (map (Coproduct <<< Left) <<< traverse f)
-    (map (Coproduct <<< Right) <<< traverse f)
-  sequence = coproduct
-    (map (Coproduct <<< Left) <<< sequence)
-    (map (Coproduct <<< Right) <<< sequence)
-
-instance traversableWithIndexCoproduct :: (TraversableWithIndex a f, TraversableWithIndex b g) => TraversableWithIndex (Either a b) (Coproduct f g) where
-  traverseWithIndex f = coproduct
-    (map (Coproduct <<< Left) <<< traverseWithIndex (f <<< Left))
-    (map (Coproduct <<< Right) <<< traverseWithIndex (f <<< Right))

src/Data/Functor/Costar.purs

@@ -0,0 +1,66 @@
+module Data.Functor.Costar where
+
+import Prelude
+
+import Control.Comonad (class Comonad, extract)
+import Control.Extend (class Extend, (=<=))
+import Data.Bifunctor (class Bifunctor)
+import Data.Distributive (class Distributive, distribute)
+import Data.Functor.Contravariant (class Contravariant, cmap)
+import Data.Functor.Invariant (class Invariant, imapF)
+import Data.Newtype (class Newtype)
+import Data.Profunctor (class Profunctor, lcmap)
+import Data.Profunctor.Closed (class Closed)
+import Data.Profunctor.Strong (class Strong)
+import Data.Tuple (Tuple(..), fst, snd)
+
+-- | `Costar` turns a `Functor` into a `Profunctor` "backwards".
+-- |
+-- | `Costar f` is also the co-Kleisli category for `f`.
+newtype Costar :: (Type -> Type) -> Type -> Type -> Type
+newtype Costar f b a = Costar (f b -> a)
+
+derive instance newtypeCostar :: Newtype (Costar f a b) _
+
+instance semigroupoidCostar :: Extend f => Semigroupoid (Costar f) where
+  compose (Costar f) (Costar g) = Costar (f =<= g)
+
+instance categoryCostar :: Comonad f => Category (Costar f) where
+  identity = Costar extract
+
+instance functorCostar :: Functor (Costar f a) where
+  map f (Costar g) = Costar (f <<< g)
+
+instance invariantCostar :: Invariant (Costar f a) where
+  imap = imapF
+
+instance applyCostar :: Apply (Costar f a) where
+  apply (Costar f) (Costar g) = Costar \a -> f a (g a)
+
+instance applicativeCostar :: Applicative (Costar f a) where
+  pure a = Costar \_ -> a
+
+instance bindCostar :: Bind (Costar f a) where
+  bind (Costar m) f = Costar \x -> case f (m x) of Costar g -> g x
+
+instance monadCostar :: Monad (Costar f a)
+
+instance distributiveCostar :: Distributive (Costar f a) where
+  distribute f = Costar \a -> map (\(Costar g) -> g a) f
+  collect f = distribute <<< map f
+
+instance bifunctorCostar :: Contravariant f => Bifunctor (Costar f) where
+  bimap f g (Costar h) = Costar (cmap f >>> h >>> g)
+
+instance profunctorCostar :: Functor f => Profunctor (Costar f) where
+  dimap f g (Costar h) = Costar (map f >>> h >>> g)
+
+instance strongCostar :: Comonad f => Strong (Costar f) where
+  first (Costar f) = Costar \x -> Tuple (f (map fst x)) (snd (extract x))
+  second (Costar f) = Costar \x -> Tuple (fst (extract x)) (f (map snd x))
+
+instance closedCostar :: Functor f => Closed (Costar f) where
+  closed (Costar f) = Costar \g x -> f (map (_ $ x) g)
+
+hoistCostar :: forall f g a b. (g ~> f) -> Costar f a b -> Costar g a b
+hoistCostar f (Costar g) = Costar (lcmap f g)

src/Data/Functor/Flip.purs

@@ -0,0 +1,38 @@
+module Data.Functor.Flip where
+
+import Prelude
+
+import Control.Biapplicative (class Biapplicative, bipure)
+import Control.Biapply (class Biapply, (<<*>>))
+import Data.Bifunctor (class Bifunctor, bimap, lmap)
+import Data.Functor.Contravariant (class Contravariant)
+import Data.Newtype (class Newtype)
+import Data.Profunctor (class Profunctor, lcmap)
+
+-- | Flips the order of the type arguments of a `Bifunctor`.
+newtype Flip :: forall k1 k2. (k1 -> k2 -> Type) -> k2 -> k1 -> Type
+newtype Flip p a b = Flip (p b a)
+
+derive instance newtypeFlip :: Newtype (Flip p a b) _
+
+derive newtype instance eqFlip :: Eq (p b a) => Eq (Flip p a b)
+
+derive newtype instance ordFlip :: Ord (p b a) => Ord (Flip p a b)
+
+instance showFlip :: Show (p a b) => Show (Flip p b a) where
+  show (Flip x) = "(Flip " <> show x <> ")"
+
+instance functorFlip :: Bifunctor p => Functor (Flip p a) where
+  map f (Flip a) = Flip (lmap f a)
+
+instance bifunctorFlip :: Bifunctor p => Bifunctor (Flip p) where
+  bimap f g (Flip a) = Flip (bimap g f a)
+
+instance biapplyFlip :: Biapply p => Biapply (Flip p) where
+  biapply (Flip fg) (Flip xy) = Flip (fg <<*>> xy)
+
+instance biapplicativeFlip :: Biapplicative p => Biapplicative (Flip p) where
+  bipure a b = Flip (bipure b a)
+
+instance contravariantFlip :: Profunctor p => Contravariant (Flip p b) where
+  cmap f (Flip a) = Flip (lcmap f a)

src/Data/Functor/Joker.purs

@@ -0,0 +1,60 @@
+module Data.Functor.Joker where
+
+import Prelude
+
+import Control.Biapplicative (class Biapplicative)
+import Control.Biapply (class Biapply)
+import Data.Bifunctor (class Bifunctor)
+import Data.Either (Either(..))
+import Data.Newtype (class Newtype, un)
+import Data.Profunctor (class Profunctor)
+import Data.Profunctor.Choice (class Choice)
+
+-- | This advanced type's usage and its relation to `Clown` is best understood
+-- | by reading through "Clowns to the Left, Jokers to the Right (Functional
+-- | Pearl)"
+-- | https://citeseerx.ist.psu.edu/viewdoc/download?doi=10.1.1.475.6134&rep=rep1&type=pdf
+newtype Joker :: (Type -> Type) -> Type -> Type -> Type
+newtype Joker g a b = Joker (g b)
+
+derive instance newtypeJoker :: Newtype (Joker f a b) _
+
+derive newtype instance eqJoker :: Eq (f b) => Eq (Joker f a b)
+
+derive newtype instance ordJoker :: Ord (f b) => Ord (Joker f a b)
+
+instance showJoker :: Show (f b) => Show (Joker f a b) where
+  show (Joker x) = "(Joker " <> show x <> ")"
+
+instance functorJoker :: Functor f => Functor (Joker f a) where
+  map f (Joker a) = Joker (map f a)
+
+instance applyJoker :: Apply f => Apply (Joker f a) where
+  apply (Joker f) (Joker g) = Joker $ apply f g
+
+instance applicativeJoker :: Applicative f => Applicative (Joker f a) where
+  pure = Joker <<< pure
+
+instance bindJoker :: Bind f => Bind (Joker f a) where
+  bind (Joker ma) amb = Joker $ ma >>= (amb >>> un Joker)
+
+instance monadJoker :: Monad m => Monad (Joker m a)
+
+instance bifunctorJoker :: Functor g => Bifunctor (Joker g) where
+  bimap _ g (Joker a) = Joker (map g a)
+
+instance biapplyJoker :: Apply g => Biapply (Joker g) where
+  biapply (Joker fg) (Joker xy) = Joker (fg <*> xy)
+
+instance biapplicativeJoker :: Applicative g => Biapplicative (Joker g) where
+  bipure _ b = Joker (pure b)
+
+instance profunctorJoker :: Functor f => Profunctor (Joker f) where
+  dimap f g (Joker a) = Joker (map g a)
+
+instance choiceJoker :: Functor f => Choice (Joker f) where
+  left  (Joker f) = Joker $ map Left f
+  right (Joker f) = Joker $ map Right f
+
+hoistJoker :: forall f g a b. (f ~> g) -> Joker f a b -> Joker g a b
+hoistJoker f (Joker a) = Joker (f a)