From b1029c0fcf99655e2c9b222518cffb1b665b05cb Mon Sep 17 00:00:00 2001
From: Ryan Hendrickson <ryan.hendrickson@alum.mit.edu>
Date: Thu, 4 Feb 2021 15:40:14 -0500
Subject: [PATCH] Refactor functors and related packages

This is part of a set of commits that rearrange the dependencies between
multiple packages. The immediate motivation is to allow certain newtypes
to be reused between `profunctor` and `bifunctors`, but this particular
approach goes a little beyond that in two ways: first, it attempts to
move data types (`either`, `tuple`) toward the bottom of the dependency
stack; and second, it tries to ensure no package comes between
`functors` and the packages most closely related to it, in order to open
the possibility of merging those packages together (which may be
desirable if at some point in the future additional newtypes are added
which reveal new and exciting constraints on the module dependency
graph).
---
 CHANGELOG.md                    |  3 ++
 bower.json                      |  5 ++-
 src/Data/Functor/App.purs       | 10 -----
 src/Data/Functor/Clown.purs     | 44 ++++++++++++++++++++++
 src/Data/Functor/Compose.purs   | 26 -------------
 src/Data/Functor/Coproduct.purs | 31 ----------------
 src/Data/Functor/Costar.purs    | 66 +++++++++++++++++++++++++++++++++
 src/Data/Functor/Flip.purs      | 38 +++++++++++++++++++
 src/Data/Functor/Joker.purs     | 60 ++++++++++++++++++++++++++++++
 src/Data/Functor/Product.purs   | 27 --------------
 src/Data/Functor/Product2.purs  | 40 ++++++++++++++++++++
 11 files changed, 255 insertions(+), 95 deletions(-)
 create mode 100644 src/Data/Functor/Clown.purs
 create mode 100644 src/Data/Functor/Costar.purs
 create mode 100644 src/Data/Functor/Flip.purs
 create mode 100644 src/Data/Functor/Joker.purs
 create mode 100644 src/Data/Functor/Product2.purs

diff --git a/CHANGELOG.md b/CHANGELOG.md
index e0ad8fe..d538ccd 100644
--- a/CHANGELOG.md
+++ b/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
 
diff --git a/bower.json b/bower.json
index efe378e..faa3989 100644
--- a/bower.json
+++ b/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"
   },
diff --git a/src/Data/Functor/App.purs b/src/Data/Functor/App.purs
index 3dcb8ec..4be5d04 100644
--- a/src/Data/Functor/App.purs
+++ b/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)
diff --git a/src/Data/Functor/Clown.purs b/src/Data/Functor/Clown.purs
new file mode 100644
index 0000000..9eaa75f
--- /dev/null
+++ b/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)
diff --git a/src/Data/Functor/Compose.purs b/src/Data/Functor/Compose.purs
index 4cf0bce..7c8b68f 100644
--- a/src/Data/Functor/Compose.purs
+++ b/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
 
diff --git a/src/Data/Functor/Coproduct.purs b/src/Data/Functor/Coproduct.purs
index e2ebe0f..ceac080 100644
--- a/src/Data/Functor/Coproduct.purs
+++ 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,9 +67,6 @@ 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))
@@ -82,26 +74,3 @@ instance extendCoproduct :: (Extend f, Extend g) => Extend (Coproduct f g) where
 
 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))
diff --git a/src/Data/Functor/Costar.purs b/src/Data/Functor/Costar.purs
new file mode 100644
index 0000000..edffe4e
--- /dev/null
+++ b/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)
diff --git a/src/Data/Functor/Flip.purs b/src/Data/Functor/Flip.purs
new file mode 100644
index 0000000..266662f
--- /dev/null
+++ b/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)
diff --git a/src/Data/Functor/Joker.purs b/src/Data/Functor/Joker.purs
new file mode 100644
index 0000000..12906db
--- /dev/null
+++ b/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)
diff --git a/src/Data/Functor/Product.purs b/src/Data/Functor/Product.purs
index 3e0da24..53ac864 100644
--- a/src/Data/Functor/Product.purs
+++ b/src/Data/Functor/Product.purs
@@ -2,17 +2,10 @@ module Data.Functor.Product where
 
 import Prelude
 
-import Control.Apply (lift2)
 import Data.Bifunctor (bimap)
-import Data.Either (Either(..))
 import Data.Eq (class Eq1, eq1)
-import Data.Foldable (class Foldable, foldr, foldl, foldMap)
-import Data.FoldableWithIndex (class FoldableWithIndex, foldMapWithIndex, foldlWithIndex, foldrWithIndex)
-import Data.FunctorWithIndex (class FunctorWithIndex, mapWithIndex)
 import Data.Newtype (class Newtype, unwrap)
 import Data.Ord (class Ord1, compare1)
-import Data.Traversable (class Traversable, traverse, sequence)
-import Data.TraversableWithIndex (class TraversableWithIndex, traverseWithIndex)
 import Data.Tuple (Tuple(..), fst, snd)
 
 -- | `Product f g` is the product of the two functors `f` and `g`.
@@ -54,26 +47,6 @@ instance showProduct :: (Show (f a), Show (g a)) => Show (Product f g a) where
 instance functorProduct :: (Functor f, Functor g) => Functor (Product f g) where
   map f (Product fga) = Product (bimap (map f) (map f) fga)
 
-instance foldableProduct :: (Foldable f, Foldable g) => Foldable (Product f g) where
-  foldr f z (Product (Tuple fa ga)) = foldr f (foldr f z ga) fa
-  foldl f z (Product (Tuple fa ga)) = foldl f (foldl f z fa) ga
-  foldMap f (Product (Tuple fa ga)) = foldMap f fa <> foldMap f ga
-
-instance traversableProduct :: (Traversable f, Traversable g) => Traversable (Product f g) where
-  traverse f (Product (Tuple fa ga)) = lift2 product (traverse f fa) (traverse f ga)
-  sequence (Product (Tuple fa ga)) = lift2 product (sequence fa) (sequence ga)
-
-instance functorWithIndexProduct :: (FunctorWithIndex a f, FunctorWithIndex b g) => FunctorWithIndex (Either a b) (Product f g) where
-  mapWithIndex f (Product fga) = Product (bimap (mapWithIndex (f <<< Left)) (mapWithIndex (f <<< Right)) fga)
-
-instance foldableWithIndexProduct :: (FoldableWithIndex a f, FoldableWithIndex b g) => FoldableWithIndex (Either a b) (Product f g) where
-  foldrWithIndex f z (Product (Tuple fa ga)) = foldrWithIndex (f <<< Left) (foldrWithIndex (f <<< Right) z ga) fa
-  foldlWithIndex f z (Product (Tuple fa ga)) = foldlWithIndex (f <<< Right) (foldlWithIndex (f <<< Left) z fa) ga
-  foldMapWithIndex f (Product (Tuple fa ga)) = foldMapWithIndex (f <<< Left) fa <> foldMapWithIndex (f <<< Right) ga
-
-instance traversableWithIndexProduct :: (TraversableWithIndex a f, TraversableWithIndex b g) => TraversableWithIndex (Either a b) (Product f g) where
-  traverseWithIndex f (Product (Tuple fa ga)) = lift2 product (traverseWithIndex (f <<< Left) fa) (traverseWithIndex (f <<< Right) ga)
-
 instance applyProduct :: (Apply f, Apply g) => Apply (Product f g) where
   apply (Product (Tuple f g)) (Product (Tuple a b)) = product (apply f a) (apply g b)
 
diff --git a/src/Data/Functor/Product2.purs b/src/Data/Functor/Product2.purs
new file mode 100644
index 0000000..5dc1fe9
--- /dev/null
+++ b/src/Data/Functor/Product2.purs
@@ -0,0 +1,40 @@
+module Data.Functor.Product2 where
+
+import Prelude
+
+import Control.Biapplicative (class Biapplicative, bipure)
+import Control.Biapply (class Biapply, biapply)
+import Data.Bifunctor (class Bifunctor, bimap)
+import Data.Profunctor (class Profunctor, dimap)
+
+-- | The product of two types that both take two type parameters (e.g. `Either`,
+-- | `Tuple, etc.) where both type parameters are the same.
+-- |
+-- | ```purescript
+-- | Product2 (Tuple 4 true) (Right false) :: Product2 Tuple Either Int Boolean
+-- | Product2 (Tuple 4 true) (Left      8) :: Product2 Tuple Either Int Boolean
+-- | ```
+data Product2 :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type
+data Product2 f g a b = Product2 (f a b) (g a b)
+
+derive instance eqProduct2 :: (Eq (f a b), Eq (g a b)) => Eq (Product2 f g a b)
+
+derive instance ordProduct2 :: (Ord (f a b), Ord (g a b)) => Ord (Product2 f g a b)
+
+instance showProduct2 :: (Show (f a b), Show (g a b)) => Show (Product2 f g a b) where
+  show (Product2 x y) = "(Product2 " <> show x <> " " <> show y <> ")"
+
+instance functorProduct2 :: (Functor (f a), Functor (g a)) => Functor (Product2 f g a) where
+  map f (Product2 x y) = Product2 (map f x) (map f y)
+
+instance bifunctorProduct2 :: (Bifunctor f, Bifunctor g) => Bifunctor (Product2 f g) where
+  bimap f g (Product2 x y) = Product2 (bimap f g x) (bimap f g y)
+
+instance biapplyProduct2 :: (Biapply f, Biapply g) => Biapply (Product2 f g) where
+  biapply (Product2 w x) (Product2 y z) = Product2 (biapply w y) (biapply x z)
+
+instance biapplicativeProduct2 :: (Biapplicative f, Biapplicative g) => Biapplicative (Product2 f g) where
+  bipure a b = Product2 (bipure a b) (bipure a b)
+
+instance profunctorProduct2 :: (Profunctor f, Profunctor g) => Profunctor (Product2 f g) where
+  dimap f g (Product2 x y) = Product2 (dimap f g x) (dimap f g y)