From 6195f1ee4c26992933e2be5c4fdbabf47bece0fc Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Mon, 29 Jan 2024 21:58:35 -0800
Subject: [PATCH 1/4] IcelandJack & Ed Kmett's categorical Functor design.

---
 monoidal-functors.cabal         |   2 +
 src/Data/Functor/Categorical.hs | 316 ++++++++++++++++++++++++++++++++
 2 files changed, 318 insertions(+)
 create mode 100644 src/Data/Functor/Categorical.hs

diff --git a/monoidal-functors.cabal b/monoidal-functors.cabal
index 9e68bde..7eb7b44 100644
--- a/monoidal-functors.cabal
+++ b/monoidal-functors.cabal
@@ -63,6 +63,7 @@ library
     semigroupoids                 >= 6.0.0 && < 6.1,
     these                         >= 1.2 && < 1.3,
     mtl                           >= 2.2.2 && < 2.4,
+    witherable                    >= 0.4.2 && < 0.5,
 
   exposed-modules:
     Control.Category.Tensor
@@ -72,6 +73,7 @@ library
     Data.Bifunctor.Module
     Data.Bifunctor.Monoidal
     Data.Bifunctor.Monoidal.Specialized
+    Data.Functor.Categorical
     Data.Functor.Invariant
     Data.Functor.Module
     Data.Functor.Monoidal
diff --git a/src/Data/Functor/Categorical.hs b/src/Data/Functor/Categorical.hs
new file mode 100644
index 0000000..0a97090
--- /dev/null
+++ b/src/Data/Functor/Categorical.hs
@@ -0,0 +1,316 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | A scratchpad for implementing Iceland Jack and Ed Kmett's
+-- categorical functor ideas.
+--
+-- If possible, this ought to give us a kind generic functor to
+-- replace 'GBifunctor'.
+--
+-- We also ought to be able to use the same tricks to get a kind
+-- generic Monoidal Functor class.
+module Data.Functor.Categorical where
+
+--------------------------------------------------------------------------------
+
+import Control.Applicative qualified as Hask
+import Control.Category
+import Control.Category.Tensor (Iso (..))
+import Control.Monad qualified as Hask
+import Control.Monad.Reader qualified as Hask
+import Control.Monad.State qualified as Hask
+import Data.Bifunctor qualified as Hask
+import Data.Bool (Bool)
+import Data.Either (Either)
+import Data.Function (($))
+import Data.Functor.Contravariant (Op (..), Predicate (..))
+import Data.Functor.Contravariant qualified as Hask
+import Data.Functor.Identity (Identity)
+import Data.Kind (Constraint, Type)
+import Data.Maybe (Maybe (..))
+import Data.Monoid (Endo (..))
+import Data.Profunctor qualified as Hask
+import Data.Semigroupoid
+import Witherable qualified as Hask
+
+--------------------------------------------------------------------------------
+
+type Functor :: (from -> to) -> Constraint
+class (Category (Dom f), Category (Cod f)) => Functor (f :: from -> to) where
+  type Dom f :: from -> from -> Type
+  type Cod f :: to -> to -> Type
+
+  map :: Dom f a b -> Cod f (f a) (f b)
+
+type Cat i = i -> i -> Type
+
+type Nat :: Cat s -> Cat t -> Cat (s -> t)
+data Nat source target f f' where
+  Nat :: (forall x. target (f x) (f' x)) -> Nat source target f f'
+
+instance (Semigroupoid c1, Semigroupoid c2) => Semigroupoid (Nat c1 c2) where
+  o :: Nat c1 c2 j k1 -> Nat c1 c2 i j -> Nat c1 c2 i k1
+  Nat c1 `o` Nat c2 = Nat (c1 `o` c2)
+
+instance (Semigroupoid c1, Semigroupoid c2, Category c1, Category c2) => Category (Nat c1 c2) where
+  id :: Nat c1 c2 a a
+  id = Nat id
+
+  (.) = o
+
+-- data Nat2 source target f f' f'' where
+--   Nat2 :: (forall x y. target (f x y) (f' x y)) -> Nat2 source target f f' f''
+
+-- instance (Category c1, Category c2, Category c3) => Category (Nat2 c1 c2 c3) where
+--   id = Nat2 _
+
+type FunctorOf :: Cat from -> Cat to -> (from -> to) -> Constraint
+class (Functor f, dom ~ Dom f, cod ~ Cod f) => FunctorOf dom cod f
+
+instance (Functor f, dom ~ Dom f, cod ~ Cod f) => FunctorOf dom cod f
+
+type EndofunctorOf :: Cat ob -> (ob -> ob) -> Constraint
+type EndofunctorOf cat = FunctorOf cat cat
+
+--------------------------------------------------------------------------------
+
+newtype FromFunctor f a = FromFunctor (f a)
+  deriving newtype (Hask.Functor)
+
+instance (Hask.Functor f) => Functor (FromFunctor f) where
+  type Dom (FromFunctor f) = (->)
+  type Cod (FromFunctor f) = (->)
+
+  map :: (a -> b) -> FromFunctor f a -> FromFunctor f b
+  map = Hask.fmap
+
+fmap :: (FunctorOf (->) (->) f) => (a -> b) -> f a -> f b
+fmap = map
+
+deriving via (FromFunctor Identity) instance Functor Identity
+
+deriving via (FromFunctor []) instance Functor []
+
+deriving via (FromFunctor ((,) a)) instance Functor ((,) a)
+
+deriving via (FromFunctor ((->) r)) instance Functor ((->) r)
+
+deriving via (FromFunctor Maybe) instance Functor Maybe
+
+deriving via (FromFunctor (Either e)) instance Functor (Either e)
+
+--------------------------------------------------------------------------------
+
+newtype FromContra f a = FromContra {getContra :: f a}
+  deriving newtype (Hask.Contravariant)
+
+instance (Hask.Contravariant f) => Functor (FromContra f) where
+  type Dom (FromContra f) = Op
+  type Cod (FromContra f) = (->)
+
+  map :: Dom (FromContra f) a b -> Cod (FromContra f) ((FromContra f) a) ((FromContra f) b)
+  map = Hask.contramap . getOp
+
+contramap :: (FunctorOf Op (->) f) => (a -> b) -> f b -> f a
+contramap = map . Op
+
+deriving via (FromContra Predicate) instance Functor Predicate
+
+--------------------------------------------------------------------------------
+
+type (<->) :: Cat Type
+type (<->) = Iso (->)
+
+instance Functor Endo where
+  type Dom Endo = (<->)
+  type Cod Endo = (->)
+
+  map :: (a <-> b) -> Endo a -> Endo b
+  map Iso {..} (Endo f) = Endo (fwd . f . bwd)
+
+invmap :: (FunctorOf (<->) (->) f) => (a -> b) -> (b -> a) -> f a -> f b
+invmap f g = map (Iso f g)
+
+--------------------------------------------------------------------------------
+
+newtype FromBifunctor f a b = FromBifunctor (f a b)
+  deriving newtype (Hask.Functor, Hask.Bifunctor)
+
+instance (Hask.Bifunctor p, FunctorOf (->) (->) (p x)) => Functor (FromBifunctor p x) where
+  type Dom (FromBifunctor p x) = (->)
+  type Cod (FromBifunctor p x) = (->)
+
+  map :: (a -> b) -> FromBifunctor p x a -> FromBifunctor p x b
+  map f (FromBifunctor pab) = FromBifunctor (map f pab)
+
+instance (Hask.Bifunctor p, forall x. FunctorOf (->) (->) (p x)) => Functor (FromBifunctor p) where
+  type Dom (FromBifunctor p) = (->)
+  type Cod (FromBifunctor p) = (Nat (->) (->))
+
+  map :: (a -> b) -> (Nat (->) (->)) (FromBifunctor p a) (FromBifunctor p b)
+  map f = Nat (\(FromBifunctor pax) -> FromBifunctor (Hask.first f pax))
+
+first :: forall p a b. (FunctorOf (->) (Nat (->) (->)) p) => (a -> b) -> forall x. p a x -> p b x
+first f = let (Nat f') = map f in f'
+
+second :: (FunctorOf (->) (->) (p x)) => (a -> b) -> p x a -> p x b
+second = fmap
+
+bimap :: (FunctorOf (->) (->) (p a), FunctorOf (->) (Nat (->) (->)) p) => (a -> b) -> (c -> d) -> p a c -> p b d
+bimap f g = first f . second g
+
+-- deriving via (FromBifunctor (,)) instance Functor (,)
+
+instance Functor (,) where
+  type Dom (,) = (->)
+  type Cod (,) = Nat (->) (->)
+
+  map :: (a -> b) -> Nat (->) (->) ((,) a) ((,) b)
+  map f = Nat (Hask.first f)
+
+instance Functor Either where
+  type Dom Either = (->)
+  type Cod Either = Nat (->) (->)
+
+  map :: (e -> e1) -> Nat (->) (->) (Either e) (Either e1)
+  map f = Nat (Hask.first f)
+
+--------------------------------------------------------------------------------
+
+newtype FromProfunctor f a b = FromProfunctor (f a b)
+  deriving newtype (Hask.Functor, Hask.Profunctor)
+
+instance (Hask.Profunctor p, FunctorOf (->) (->) (p x)) => Functor (FromProfunctor p x) where
+  type Dom (FromProfunctor p x) = (->)
+  type Cod (FromProfunctor p x) = (->)
+
+  map :: (a -> b) -> Cod (FromProfunctor p x) (FromProfunctor p x a) (FromProfunctor p x b)
+  map f (FromProfunctor pxa) = FromProfunctor (map f pxa)
+
+instance (Hask.Profunctor p) => Functor (FromProfunctor p) where
+  type Dom (FromProfunctor p) = Op
+  type Cod (FromProfunctor p) = (Nat (->) (->))
+
+  map :: Op a b -> Nat (->) (->) ((FromProfunctor p) a) ((FromProfunctor p) b)
+  map (Op f) = Nat (\(FromProfunctor pax) -> FromProfunctor (Hask.lmap f pax))
+
+lmap :: forall p a b. (FunctorOf Op (Nat (->) (->)) p) => (a -> b) -> forall x. p b x -> p a x
+lmap f = let (Nat f') = map @_ @_ @p (Op f) in f'
+
+rmap :: (FunctorOf (->) (->) (f x)) => (a -> b) -> f x a -> f x b
+rmap = fmap
+
+dimap :: (FunctorOf Op (Nat (->) (->)) p, forall x. FunctorOf (->) (->) (p x)) => (a -> b) -> (c -> d) -> p b c -> p a d
+dimap f g = lmap f . rmap g
+
+instance Functor (->) where
+  type Dom (->) = Op
+  type Cod (->) = Nat (->) (->)
+
+  map :: Op a b -> Nat (->) (->) ((->) a) ((->) b)
+  map (Op f) = Nat (. f)
+
+--------------------------------------------------------------------------------
+
+newtype FromFilterable f a = FromFilterable (f a)
+  deriving newtype (Hask.Functor, Hask.Filterable)
+
+instance (Hask.Filterable f) => Functor (FromFilterable f) where
+  type Dom (FromFilterable f) = (Hask.Star Maybe)
+  type Cod (FromFilterable f) = (->)
+
+  map :: Hask.Star Maybe a b -> FromFilterable f a -> FromFilterable f b
+  map (Hask.Star f) (FromFilterable fa) = FromFilterable (Hask.mapMaybe f fa)
+
+mapMaybe :: (FunctorOf (Hask.Star Maybe) (->) f) => (a -> Maybe b) -> f a -> f b
+mapMaybe f = map (Hask.Star f)
+
+catMaybes :: (FunctorOf (Hask.Star Maybe) (->) f) => f (Maybe a) -> f a
+catMaybes = map (Hask.Star id)
+
+filter :: (FunctorOf (Hask.Star Maybe) (->) f) => (a -> Bool) -> f a -> f a
+filter f = map (Hask.Star (\a -> if f a then Just a else Nothing))
+
+-- NOTE: These instances conflict with our Covariant Functor
+-- instances. Switching from associated types to Multi Parameter type
+-- classes would fix this:
+
+-- deriving via (FromFilterable []) instance Functor []
+
+-- deriving via (FromFilterable Maybe) instance Functor Maybe
+
+--------------------------------------------------------------------------------
+
+type Trifunctor :: (Type -> Type -> Type -> Type) -> Constraint
+type Trifunctor = FunctorOf (->) (Nat (->) (Nat (->) (->)))
+
+instance Functor (,,) where
+  type Dom (,,) = (->)
+  type Cod (,,) = (Nat (->) (Nat (->) (->)))
+
+  map :: (a -> b) -> (Nat (->) (Nat (->) (->))) ((,,) a) ((,,) b)
+  map f = Nat (Nat (\(x, y, z) -> (f x, y, z)))
+
+instance Functor ((,,) x) where
+  type Dom ((,,) x) = (->)
+  type Cod ((,,) x) = Nat (->) (->)
+
+  map :: (a -> b) -> Nat (->) (->) ((,,) x a) ((,,) x b)
+  map f = Nat (\(x, y, z) -> (x, f y, z))
+
+deriving via FromFunctor ((,,) x y) instance Functor ((,,) x y)
+
+tripleFirst :: (a -> b) -> (a, x, y) -> (b, x, y)
+tripleFirst f = let (Nat (Nat f')) = map f in f'
+
+tripleSecond :: (a -> b) -> (x, a, z) -> (x, b, z)
+tripleSecond f = let (Nat f') = map f in f'
+
+tripleThird :: (a -> b) -> (x, y, a) -> (x, y, b)
+tripleThird = map
+
+newtype MealyM m s i o = MealyM {runMealyM :: s -> i -> m (o, s)}
+  deriving
+    (Hask.Functor, Hask.Applicative, Hask.Monad)
+    via Hask.StateT s (Hask.ReaderT i m)
+
+deriving via (FromFunctor (MealyM m s i)) instance (Hask.Functor m) => Functor (MealyM m s i)
+
+instance (FunctorOf (->) (->) m) => Functor (MealyM m) where
+  type Dom (MealyM m) = (<->)
+  type Cod (MealyM m) = Nat Op (Nat (->) (->))
+
+  map :: (a <-> b) -> Nat Op (Nat (->) (->)) (MealyM m a) (MealyM m b)
+  map Iso {..} = Nat $ Nat $ \(MealyM mealy) -> MealyM $ \s i -> map (map fwd) $ mealy (bwd s) i
+
+instance Functor (MealyM m s) where
+  type Dom (MealyM m s) = Op
+  type Cod (MealyM m s) = Nat (->) (->)
+
+  map :: Op a b -> Nat (->) (->) (MealyM m s a) (MealyM m s b)
+  map (Op f) = Nat $ \(MealyM mealy) -> MealyM $ \s -> mealy s . f
+
+--------------------------------------------------------------------------------
+
+data MyHKD f = MyHKD {one :: f Bool, two :: f ()}
+
+instance Functor MyHKD where
+  type Dom MyHKD = (Nat (->) (->))
+  type Cod MyHKD = (->)
+
+  map :: (Nat (->) (->)) f g -> MyHKD f -> MyHKD g
+  map (Nat nat) MyHKD {..} = MyHKD (nat one) (nat two)
+
+newtype MyHKD2 p = MyHKD2 {field :: p () Bool}
+
+instance Functor MyHKD2 where
+  type Dom MyHKD2 = (Nat (->) (Nat (->) (->)))
+  type Cod MyHKD2 = (->)
+
+  map :: Dom MyHKD2 p q -> MyHKD2 p -> MyHKD2 q
+  map (Nat (Nat nat)) MyHKD2 {..} = MyHKD2 (nat field)

From 87cf7f91fa9682f29c34989018318871206acd77 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Tue, 30 Jan 2024 11:40:33 -0800
Subject: [PATCH 2/4] Multiparam Typeclass version of categorical functors.

This version is nice cause it collapes `Functor` and `FunctorOf` into
one class and it prevents overlapping instances when the same domain
and co-domain can yield multiple functors.

However, it also has more difficulty with instance resolution and
requires more type ascription/application.
---
 monoidal-functors.cabal           |   1 +
 src/Data/Functor/CategoricalV2.hs | 265 ++++++++++++++++++++++++++++++
 2 files changed, 266 insertions(+)
 create mode 100644 src/Data/Functor/CategoricalV2.hs

diff --git a/monoidal-functors.cabal b/monoidal-functors.cabal
index 7eb7b44..1cfba03 100644
--- a/monoidal-functors.cabal
+++ b/monoidal-functors.cabal
@@ -74,6 +74,7 @@ library
     Data.Bifunctor.Monoidal
     Data.Bifunctor.Monoidal.Specialized
     Data.Functor.Categorical
+    Data.Functor.CategoricalV2
     Data.Functor.Invariant
     Data.Functor.Module
     Data.Functor.Monoidal
diff --git a/src/Data/Functor/CategoricalV2.hs b/src/Data/Functor/CategoricalV2.hs
new file mode 100644
index 0000000..3df014c
--- /dev/null
+++ b/src/Data/Functor/CategoricalV2.hs
@@ -0,0 +1,265 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- | A scratchpad for implementing Iceland Jack and Ed Kmett's
+-- categorical functor ideas.
+--
+-- If possible, this ought to give us a kind generic functor to
+-- replace 'GBifunctor'.
+--
+-- We also ought to be able to use the same tricks to get a kind
+-- generic Monoidal Functor class.
+module Data.Functor.CategoricalV2 where
+
+--------------------------------------------------------------------------------
+
+import Control.Category
+import Control.Category.Tensor (Iso (..))
+import Control.Monad qualified as Hask
+import Data.Bifunctor qualified as Hask
+import Data.Bool (Bool)
+import Data.Either (Either)
+import Data.Functor.Contravariant (Op (..), Predicate (..))
+import Data.Functor.Contravariant qualified as Hask
+import Data.Functor.Identity (Identity)
+import Data.Kind (Constraint, Type)
+import Data.Maybe (Maybe (..))
+import Data.Monoid (Endo (..))
+import Data.Profunctor qualified as Hask
+import Data.Semigroupoid
+import Witherable qualified as Hask
+
+--------------------------------------------------------------------------------
+
+class (Category dom, Category cod) => Functor (dom :: from -> from -> Type) (cod :: to -> to -> Type) (f :: from -> to) where
+  map :: dom a b -> cod (f a) (f b)
+
+type Cat i = i -> i -> Type
+
+type Nat :: Cat s -> Cat t -> Cat (s -> t)
+data Nat source target f f' where
+  Nat :: (forall x. target (f x) (f' x)) -> Nat source target f f'
+
+instance (Semigroupoid c1, Semigroupoid c2) => Semigroupoid (Nat c1 c2) where
+  o :: Nat c1 c2 j k1 -> Nat c1 c2 i j -> Nat c1 c2 i k1
+  Nat c1 `o` Nat c2 = Nat (c1 `o` c2)
+
+instance (Semigroupoid c1, Semigroupoid c2, Category c1, Category c2) => Category (Nat c1 c2) where
+  id :: Nat c1 c2 a a
+  id = Nat id
+
+  (.) = o
+
+type Endofunctor :: Cat ob -> (ob -> ob) -> Constraint
+type Endofunctor cat = Functor cat cat
+
+--------------------------------------------------------------------------------
+
+newtype FromFunctor f a = FromFunctor (f a)
+  deriving newtype (Hask.Functor)
+
+instance (Hask.Functor f) => Functor (->) (->) (FromFunctor f) where
+  map :: (a -> b) -> FromFunctor f a -> FromFunctor f b
+  map = Hask.fmap
+
+fmap :: (Functor (->) (->) f) => (a -> b) -> f a -> f b
+fmap = map
+
+deriving via (FromFunctor Identity) instance Functor (->) (->) Identity
+
+deriving via (FromFunctor []) instance Functor (->) (->) []
+
+deriving via (FromFunctor ((,) a)) instance Functor (->) (->) ((,) a)
+
+deriving via (FromFunctor ((->) r)) instance Functor (->) (->) ((->) r)
+
+deriving via (FromFunctor Maybe) instance Functor (->) (->) Maybe
+
+deriving via (FromFunctor (Either e)) instance Functor (->) (->) (Either e)
+
+--------------------------------------------------------------------------------
+
+newtype FromContra f a = FromContra {getContra :: f a}
+  deriving newtype (Hask.Contravariant)
+
+instance (Hask.Contravariant f) => Functor Op (->) (FromContra f) where
+  map :: Op a b -> (FromContra f) a -> (FromContra f) b
+  map = Hask.contramap . getOp
+
+contramap :: (Functor Op (->) f) => (a -> b) -> f b -> f a
+contramap = map . Op
+
+deriving via (FromContra Predicate) instance Functor Op (->) Predicate
+
+--------------------------------------------------------------------------------
+
+type (<->) :: Cat Type
+type (<->) = Iso (->)
+
+instance Functor (<->) (->) Endo where
+  map :: (a <-> b) -> Endo a -> Endo b
+  map Iso {..} (Endo f) = Endo (fwd . f . bwd)
+
+invmap :: (Functor (<->) (->) f) => (a -> b) -> (b -> a) -> f a -> f b
+invmap f g = map (Iso f g)
+
+--------------------------------------------------------------------------------
+
+newtype FromBifunctor f a b = FromBifunctor (f a b)
+  deriving newtype (Hask.Functor, Hask.Bifunctor)
+
+instance (Hask.Bifunctor p, Functor (->) (->) (p x)) => Functor (->) (->) (FromBifunctor p x) where
+  map :: (a -> b) -> FromBifunctor p x a -> FromBifunctor p x b
+  map f (FromBifunctor pab) = FromBifunctor (map f pab)
+
+instance (Hask.Bifunctor p, forall x. Functor (->) (->) (p x)) => Functor (->) (Nat (->) (->)) (FromBifunctor p) where
+  map :: (a -> b) -> (Nat (->) (->)) (FromBifunctor p a) (FromBifunctor p b)
+  map f = Nat (\(FromBifunctor pax) -> FromBifunctor (Hask.first f pax))
+
+first :: forall p a b. (Functor (->) (Nat (->) (->)) p) => (a -> b) -> forall x. p a x -> p b x
+first f = let (Nat f') = (map :: (a -> b) -> Nat (->) (->) (p a) (p b)) f in f'
+
+second :: (Functor (->) (->) (p x)) => (a -> b) -> p x a -> p x b
+second = fmap
+
+bimap :: (Functor (->) (->) (p a), Functor (->) (Nat (->) (->)) p) => (a -> b) -> (c -> d) -> p a c -> p b d
+bimap f g = first f . second g
+
+-- deriving via (FromBifunctor (,)) instance Functor (->) (Nat (->) (->)) (,)
+
+instance Functor (->) (Nat (->) (->)) (,) where
+  map :: (a -> b) -> Nat (->) (->) ((,) a) ((,) b)
+  map f = Nat (Hask.first f)
+
+instance Functor (->) (Nat (->) (->)) Either where
+  map :: (e -> e1) -> Nat (->) (->) (Either e) (Either e1)
+  map f = Nat (Hask.first f)
+
+--------------------------------------------------------------------------------
+
+newtype FromProfunctor f a b = FromProfunctor (f a b)
+  deriving newtype (Hask.Functor, Hask.Profunctor)
+
+instance (Hask.Profunctor p, Functor (->) (->) (p x)) => Functor (->) (->) (FromProfunctor p x) where
+  map :: (a -> b) -> FromProfunctor p x a -> FromProfunctor p x b
+  map f (FromProfunctor pxa) = FromProfunctor (map f pxa)
+
+instance (Hask.Profunctor p) => Functor Op (Nat (->) (->)) (FromProfunctor p) where
+  map :: Op a b -> Nat (->) (->) ((FromProfunctor p) a) ((FromProfunctor p) b)
+  map (Op f) = Nat (\(FromProfunctor pax) -> FromProfunctor (Hask.lmap f pax))
+
+lmap :: forall p a b. (Functor Op (Nat (->) (->)) p) => (a -> b) -> forall x. p b x -> p a x
+lmap f = let (Nat f') = (map :: Op b a -> Nat (->) (->) (p b) (p a)) (Op f) in f'
+
+rmap :: (Functor (->) (->) (f x)) => (a -> b) -> f x a -> f x b
+rmap = fmap
+
+dimap :: (Functor Op (Nat (->) (->)) p, forall x. Functor (->) (->) (p x)) => (a -> b) -> (c -> d) -> p b c -> p a d
+dimap f g = lmap f . rmap g
+
+instance Functor Op (Nat (->) (->)) (->) where
+  map :: Op a b -> Nat (->) (->) ((->) a) ((->) b)
+  map (Op f) = Nat (. f)
+
+--------------------------------------------------------------------------------
+
+newtype FromFilterable f a = FromFilterable (f a)
+  deriving newtype (Hask.Functor, Hask.Filterable)
+
+instance (Hask.Filterable f) => Functor (Hask.Star Maybe) (->) (FromFilterable f) where
+  map :: Hask.Star Maybe a b -> FromFilterable f a -> FromFilterable f b
+  map (Hask.Star f) (FromFilterable fa) = FromFilterable (Hask.mapMaybe f fa)
+
+mapMaybe :: (Functor (Hask.Star Maybe) (->) f) => (a -> Maybe b) -> f a -> f b
+mapMaybe f = map (Hask.Star f)
+
+catMaybes :: (Functor (Hask.Star Maybe) (->) f) => f (Maybe a) -> f a
+catMaybes = map (Hask.Star id)
+
+filter :: (Functor (Hask.Star Maybe) (->) f) => (a -> Bool) -> f a -> f a
+filter f = map (Hask.Star (\a -> if f a then Just a else Nothing))
+
+deriving via (FromFilterable []) instance Functor (Hask.Star Maybe) (->) []
+
+deriving via (FromFilterable Maybe) instance Functor (Hask.Star Maybe) (->) Maybe
+
+--------------------------------------------------------------------------------
+-- TODO:
+
+type Trifunctor :: (Type -> Type -> Type -> Type) -> Constraint
+type Trifunctor = Functor (->) (Nat (->) (Nat (->) (->)))
+
+instance Functor (->) (Nat (->) (Nat (->) (->))) (,,) where
+  map :: (a -> b) -> (Nat (->) (Nat (->) (->))) ((,,) a) ((,,) b)
+  map f = Nat (Nat (\(x, y, z) -> (f x, y, z)))
+
+instance Functor (->) (Nat (->) (->)) ((,,) x) where
+  map :: (a -> b) -> Nat (->) (->) ((,,) x a) ((,,) x b)
+  map f = Nat (\(x, y, z) -> (x, f y, z))
+
+deriving via FromFunctor ((,,) x y) instance Functor (->) (->) ((,,) x y)
+
+tripleFirst :: (a -> b) -> (a, x, y) -> (b, x, y)
+tripleFirst f = let (Nat (Nat f')) = (map :: (a -> b) -> Nat (->) (Nat (->) (->)) ((,,) a) ((,,) b)) f in f'
+
+tripleSecond :: (a -> b) -> (x, a, z) -> (x, b, z)
+tripleSecond f = let (Nat f') = (map :: (a -> b) -> Nat (->) (->) ((,,) x a) ((,,) x b)) f in f'
+
+tripleThird :: (a -> b) -> (x, y, a) -> (x, y, b)
+tripleThird = map
+
+-- newtype Mealy m s i o = Mealy { runMealy :: s -> i -> m (o, s) }
+--   deriving
+--     (Hask.Functor, Hask.Applicative, Hask.Monad)
+--     via Hask.StateT s (Hask.ReaderT i m)
+
+-- deriving via (FromFunctor (Mealy m s i)) instance (Hask.Functor m) => Functor (Mealy m s i)
+
+-- instance Functor (Mealy m s) where
+--   type Dom (Mealy m s) = Op
+--   type Cod (Mealy m s) = Nat (->) (->)
+
+--   map :: Dom (Mealy m s) a b -> Cod (Mealy m s) (Mealy m s a) (Mealy m s b)
+--   map = _
+
+--------------------------------------------------------------------------------
+
+-- Some Ideal Interface
+-- THIS IS ALL WRONG
+
+class Map1 dom cod f | f -> cod, f -> dom where
+  map1 :: dom a b -> cod (f a) (f b)
+
+instance (Hask.Functor f) => Map1 (->) (->) (FromFunctor f) where
+  map1 f (FromFunctor fa) = FromFunctor (Hask.fmap f fa)
+
+instance (Hask.Contravariant f) => Map1 Op (->) (FromContra f) where
+  map1 f (FromContra fa) = FromContra (Hask.contramap (getOp f) fa)
+
+instance (Hask.Filterable f) => Map1 (Hask.Star Maybe) (->) (FromFilterable f) where
+  map1 :: Hask.Star Maybe a b -> FromFilterable f a -> FromFilterable f b
+  map1 (Hask.Star f) (FromFilterable fa) = FromFilterable (Hask.mapMaybe f fa)
+
+instance (Hask.Bifunctor p) => Map1 (->) (->) (FromBifunctor p x) where
+  map1 :: (a -> b) -> FromBifunctor p x a -> FromBifunctor p x b
+  map1 f (FromBifunctor pab) = FromBifunctor (Hask.second f pab)
+
+instance (Hask.Profunctor p) => Map1 (->) (->) (FromProfunctor p x) where
+  map1 f (FromProfunctor pab) = FromProfunctor (Hask.rmap f pab)
+
+class Map2 dom cod f where
+  map2 :: dom a b -> cod (f a x) (f b x)
+
+instance (Hask.Bifunctor p) => Map1 (->) (Nat (->) (->)) (FromBifunctor p) where
+  map1 f = Nat (\(FromBifunctor pab) -> FromBifunctor (Hask.first f pab))
+
+instance (Hask.Profunctor p) => Map1 Op (Nat (->) (->)) (FromProfunctor p) where
+  map1 f = Nat (\(FromProfunctor pab) -> FromProfunctor (Hask.lmap (getOp f) pab))
+
+class Map3 dom cod f where
+  map3 :: dom a b -> cod (f a x y) (f b x y)

From 3032b768ea888dbcac803d22f91d1946dbbb84b7 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Wed, 31 Jan 2024 07:25:45 -0800
Subject: [PATCH 3/4] Add type alias for Nat

---
 src/Data/Functor/Categorical.hs | 61 ++++++++++++++++-----------------
 1 file changed, 29 insertions(+), 32 deletions(-)

diff --git a/src/Data/Functor/Categorical.hs b/src/Data/Functor/Categorical.hs
index 0a97090..7ae89cb 100644
--- a/src/Data/Functor/Categorical.hs
+++ b/src/Data/Functor/Categorical.hs
@@ -53,22 +53,19 @@ type Nat :: Cat s -> Cat t -> Cat (s -> t)
 data Nat source target f f' where
   Nat :: (forall x. target (f x) (f' x)) -> Nat source target f f'
 
+infixr 0 ~>
+type (~>) c1 c2 = Nat c1 c2
+
 instance (Semigroupoid c1, Semigroupoid c2) => Semigroupoid (Nat c1 c2) where
   o :: Nat c1 c2 j k1 -> Nat c1 c2 i j -> Nat c1 c2 i k1
   Nat c1 `o` Nat c2 = Nat (c1 `o` c2)
 
-instance (Semigroupoid c1, Semigroupoid c2, Category c1, Category c2) => Category (Nat c1 c2) where
-  id :: Nat c1 c2 a a
+instance (Semigroupoid c1, Semigroupoid c2, Category c1, Category c2) => Category (c1 ~> c2) where
+  id :: (c1 ~> c2) a a
   id = Nat id
 
   (.) = o
 
--- data Nat2 source target f f' f'' where
---   Nat2 :: (forall x y. target (f x y) (f' x y)) -> Nat2 source target f f' f''
-
--- instance (Category c1, Category c2, Category c3) => Category (Nat2 c1 c2 c3) where
---   id = Nat2 _
-
 type FunctorOf :: Cat from -> Cat to -> (from -> to) -> Constraint
 class (Functor f, dom ~ Dom f, cod ~ Cod f) => FunctorOf dom cod f
 
@@ -150,34 +147,34 @@ instance (Hask.Bifunctor p, FunctorOf (->) (->) (p x)) => Functor (FromBifunctor
 
 instance (Hask.Bifunctor p, forall x. FunctorOf (->) (->) (p x)) => Functor (FromBifunctor p) where
   type Dom (FromBifunctor p) = (->)
-  type Cod (FromBifunctor p) = (Nat (->) (->))
+  type Cod (FromBifunctor p) = (->) ~> (->)
 
-  map :: (a -> b) -> (Nat (->) (->)) (FromBifunctor p a) (FromBifunctor p b)
+  map :: (a -> b) -> ((->) ~> (->)) (FromBifunctor p a) (FromBifunctor p b)
   map f = Nat (\(FromBifunctor pax) -> FromBifunctor (Hask.first f pax))
 
-first :: forall p a b. (FunctorOf (->) (Nat (->) (->)) p) => (a -> b) -> forall x. p a x -> p b x
+first :: forall p a b. (FunctorOf (->) ((->) ~> (->)) p) => (a -> b) -> forall x. p a x -> p b x
 first f = let (Nat f') = map f in f'
 
 second :: (FunctorOf (->) (->) (p x)) => (a -> b) -> p x a -> p x b
 second = fmap
 
-bimap :: (FunctorOf (->) (->) (p a), FunctorOf (->) (Nat (->) (->)) p) => (a -> b) -> (c -> d) -> p a c -> p b d
+bimap :: (FunctorOf (->) (->) (p a), FunctorOf (->) ((->) ~> (->)) p) => (a -> b) -> (c -> d) -> p a c -> p b d
 bimap f g = first f . second g
 
 -- deriving via (FromBifunctor (,)) instance Functor (,)
 
 instance Functor (,) where
   type Dom (,) = (->)
-  type Cod (,) = Nat (->) (->)
+  type Cod (,) = (->) ~> (->)
 
-  map :: (a -> b) -> Nat (->) (->) ((,) a) ((,) b)
+  map :: (a -> b) -> ((->) ~> (->)) ((,) a) ((,) b)
   map f = Nat (Hask.first f)
 
 instance Functor Either where
   type Dom Either = (->)
-  type Cod Either = Nat (->) (->)
+  type Cod Either = (->) ~> (->)
 
-  map :: (e -> e1) -> Nat (->) (->) (Either e) (Either e1)
+  map :: (e -> e1) -> ((->) ~> (->)) (Either e) (Either e1)
   map f = Nat (Hask.first f)
 
 --------------------------------------------------------------------------------
@@ -194,25 +191,25 @@ instance (Hask.Profunctor p, FunctorOf (->) (->) (p x)) => Functor (FromProfunct
 
 instance (Hask.Profunctor p) => Functor (FromProfunctor p) where
   type Dom (FromProfunctor p) = Op
-  type Cod (FromProfunctor p) = (Nat (->) (->))
+  type Cod (FromProfunctor p) = (->) ~> (->)
 
-  map :: Op a b -> Nat (->) (->) ((FromProfunctor p) a) ((FromProfunctor p) b)
+  map :: Op a b -> ((->) ~> (->)) ((FromProfunctor p) a) ((FromProfunctor p) b)
   map (Op f) = Nat (\(FromProfunctor pax) -> FromProfunctor (Hask.lmap f pax))
 
-lmap :: forall p a b. (FunctorOf Op (Nat (->) (->)) p) => (a -> b) -> forall x. p b x -> p a x
+lmap :: forall p a b. (FunctorOf Op ((->) ~> (->)) p) => (a -> b) -> forall x. p b x -> p a x
 lmap f = let (Nat f') = map @_ @_ @p (Op f) in f'
 
 rmap :: (FunctorOf (->) (->) (f x)) => (a -> b) -> f x a -> f x b
 rmap = fmap
 
-dimap :: (FunctorOf Op (Nat (->) (->)) p, forall x. FunctorOf (->) (->) (p x)) => (a -> b) -> (c -> d) -> p b c -> p a d
+dimap :: (FunctorOf Op ((->) ~> (->)) p, forall x. FunctorOf (->) (->) (p x)) => (a -> b) -> (c -> d) -> p b c -> p a d
 dimap f g = lmap f . rmap g
 
 instance Functor (->) where
   type Dom (->) = Op
-  type Cod (->) = Nat (->) (->)
+  type Cod (->) = (->) ~> (->)
 
-  map :: Op a b -> Nat (->) (->) ((->) a) ((->) b)
+  map :: Op a b -> ((->) ~> (->)) ((->) a) ((->) b)
   map (Op f) = Nat (. f)
 
 --------------------------------------------------------------------------------
@@ -247,20 +244,20 @@ filter f = map (Hask.Star (\a -> if f a then Just a else Nothing))
 --------------------------------------------------------------------------------
 
 type Trifunctor :: (Type -> Type -> Type -> Type) -> Constraint
-type Trifunctor = FunctorOf (->) (Nat (->) (Nat (->) (->)))
+type Trifunctor = FunctorOf (->) ((->) ~> (->) ~> (->))
 
 instance Functor (,,) where
   type Dom (,,) = (->)
-  type Cod (,,) = (Nat (->) (Nat (->) (->)))
+  type Cod (,,) = (->) ~> (->) ~> (->)
 
-  map :: (a -> b) -> (Nat (->) (Nat (->) (->))) ((,,) a) ((,,) b)
+  map :: (a -> b) -> ((->) ~> (->) ~> (->)) ((,,) a) ((,,) b)
   map f = Nat (Nat (\(x, y, z) -> (f x, y, z)))
 
 instance Functor ((,,) x) where
   type Dom ((,,) x) = (->)
-  type Cod ((,,) x) = Nat (->) (->)
+  type Cod ((,,) x) = (->) ~> (->)
 
-  map :: (a -> b) -> Nat (->) (->) ((,,) x a) ((,,) x b)
+  map :: (a -> b) -> ((->) ~> (->)) ((,,) x a) ((,,) x b)
   map f = Nat (\(x, y, z) -> (x, f y, z))
 
 deriving via FromFunctor ((,,) x y) instance Functor ((,,) x y)
@@ -283,14 +280,14 @@ deriving via (FromFunctor (MealyM m s i)) instance (Hask.Functor m) => Functor (
 
 instance (FunctorOf (->) (->) m) => Functor (MealyM m) where
   type Dom (MealyM m) = (<->)
-  type Cod (MealyM m) = Nat Op (Nat (->) (->))
+  type Cod (MealyM m) = Nat Op ((->) ~> (->))
 
-  map :: (a <-> b) -> Nat Op (Nat (->) (->)) (MealyM m a) (MealyM m b)
+  map :: (a <-> b) -> Nat Op ((->) ~> (->)) (MealyM m a) (MealyM m b)
   map Iso {..} = Nat $ Nat $ \(MealyM mealy) -> MealyM $ \s i -> map (map fwd) $ mealy (bwd s) i
 
 instance Functor (MealyM m s) where
   type Dom (MealyM m s) = Op
-  type Cod (MealyM m s) = Nat (->) (->)
+  type Cod (MealyM m s) = (->) ~> (->)
 
   map :: Op a b -> Nat (->) (->) (MealyM m s a) (MealyM m s b)
   map (Op f) = Nat $ \(MealyM mealy) -> MealyM $ \s -> mealy s . f
@@ -300,7 +297,7 @@ instance Functor (MealyM m s) where
 data MyHKD f = MyHKD {one :: f Bool, two :: f ()}
 
 instance Functor MyHKD where
-  type Dom MyHKD = (Nat (->) (->))
+  type Dom MyHKD = (->) ~> (->)
   type Cod MyHKD = (->)
 
   map :: (Nat (->) (->)) f g -> MyHKD f -> MyHKD g
@@ -309,7 +306,7 @@ instance Functor MyHKD where
 newtype MyHKD2 p = MyHKD2 {field :: p () Bool}
 
 instance Functor MyHKD2 where
-  type Dom MyHKD2 = (Nat (->) (Nat (->) (->)))
+  type Dom MyHKD2 = (->) ~> ((->) ~> (->))
   type Cod MyHKD2 = (->)
 
   map :: Dom MyHKD2 p q -> MyHKD2 p -> MyHKD2 q

From 23555b7dc89509c1f9abab41fe59f59f72202961 Mon Sep 17 00:00:00 2001
From: solomon <ssbothwell@gmail.com>
Date: Wed, 31 Jan 2024 11:42:15 -0800
Subject: [PATCH 4/4] Switch `Nat` to a newtype fixing deriving via

---
 src/Data/Functor/Categorical.hs | 42 +++++++++++----------------------
 1 file changed, 14 insertions(+), 28 deletions(-)

diff --git a/src/Data/Functor/Categorical.hs b/src/Data/Functor/Categorical.hs
index 7ae89cb..06cefe1 100644
--- a/src/Data/Functor/Categorical.hs
+++ b/src/Data/Functor/Categorical.hs
@@ -25,7 +25,7 @@ import Control.Monad qualified as Hask
 import Control.Monad.Reader qualified as Hask
 import Control.Monad.State qualified as Hask
 import Data.Bifunctor qualified as Hask
-import Data.Bool (Bool)
+import Data.Bool (Bool (..))
 import Data.Either (Either)
 import Data.Function (($))
 import Data.Functor.Contravariant (Op (..), Predicate (..))
@@ -50,9 +50,12 @@ class (Category (Dom f), Category (Cod f)) => Functor (f :: from -> to) where
 type Cat i = i -> i -> Type
 
 type Nat :: Cat s -> Cat t -> Cat (s -> t)
-data Nat source target f f' where
+newtype Nat source target f f' where
   Nat :: (forall x. target (f x) (f' x)) -> Nat source target f f'
 
+runNat :: Nat source target f f' -> (forall x. target (f x) (f' x))
+runNat (Nat f) = f
+
 infixr 0 ~>
 type (~>) c1 c2 = Nat c1 c2
 
@@ -65,7 +68,7 @@ instance (Semigroupoid c1, Semigroupoid c2, Category c1, Category c2) => Categor
   id = Nat id
 
   (.) = o
-
+    
 type FunctorOf :: Cat from -> Cat to -> (from -> to) -> Constraint
 class (Functor f, dom ~ Dom f, cod ~ Cod f) => FunctorOf dom cod f
 
@@ -152,8 +155,8 @@ instance (Hask.Bifunctor p, forall x. FunctorOf (->) (->) (p x)) => Functor (Fro
   map :: (a -> b) -> ((->) ~> (->)) (FromBifunctor p a) (FromBifunctor p b)
   map f = Nat (\(FromBifunctor pax) -> FromBifunctor (Hask.first f pax))
 
-first :: forall p a b. (FunctorOf (->) ((->) ~> (->)) p) => (a -> b) -> forall x. p a x -> p b x
-first f = let (Nat f') = map f in f'
+first :: (FunctorOf (->) ((->) ~> (->)) p) => (a -> b) -> p a x -> p b x
+first = runNat . map
 
 second :: (FunctorOf (->) (->) (p x)) => (a -> b) -> p x a -> p x b
 second = fmap
@@ -161,21 +164,9 @@ second = fmap
 bimap :: (FunctorOf (->) (->) (p a), FunctorOf (->) ((->) ~> (->)) p) => (a -> b) -> (c -> d) -> p a c -> p b d
 bimap f g = first f . second g
 
--- deriving via (FromBifunctor (,)) instance Functor (,)
-
-instance Functor (,) where
-  type Dom (,) = (->)
-  type Cod (,) = (->) ~> (->)
+deriving via (FromBifunctor (,)) instance Functor (,)
 
-  map :: (a -> b) -> ((->) ~> (->)) ((,) a) ((,) b)
-  map f = Nat (Hask.first f)
-
-instance Functor Either where
-  type Dom Either = (->)
-  type Cod Either = (->) ~> (->)
-
-  map :: (e -> e1) -> ((->) ~> (->)) (Either e) (Either e1)
-  map f = Nat (Hask.first f)
+deriving via (FromBifunctor Either) instance Functor Either
 
 --------------------------------------------------------------------------------
 
@@ -196,8 +187,8 @@ instance (Hask.Profunctor p) => Functor (FromProfunctor p) where
   map :: Op a b -> ((->) ~> (->)) ((FromProfunctor p) a) ((FromProfunctor p) b)
   map (Op f) = Nat (\(FromProfunctor pax) -> FromProfunctor (Hask.lmap f pax))
 
-lmap :: forall p a b. (FunctorOf Op ((->) ~> (->)) p) => (a -> b) -> forall x. p b x -> p a x
-lmap f = let (Nat f') = map @_ @_ @p (Op f) in f'
+lmap :: (FunctorOf Op ((->) ~> (->)) p) => (a -> b) -> p b x -> p a x
+lmap = runNat . map . Op
 
 rmap :: (FunctorOf (->) (->) (f x)) => (a -> b) -> f x a -> f x b
 rmap = fmap
@@ -205,12 +196,7 @@ rmap = fmap
 dimap :: (FunctorOf Op ((->) ~> (->)) p, forall x. FunctorOf (->) (->) (p x)) => (a -> b) -> (c -> d) -> p b c -> p a d
 dimap f g = lmap f . rmap g
 
-instance Functor (->) where
-  type Dom (->) = Op
-  type Cod (->) = (->) ~> (->)
-
-  map :: Op a b -> ((->) ~> (->)) ((->) a) ((->) b)
-  map (Op f) = Nat (. f)
+deriving via (FromProfunctor (->)) instance Functor (->)
 
 --------------------------------------------------------------------------------
 
@@ -266,7 +252,7 @@ tripleFirst :: (a -> b) -> (a, x, y) -> (b, x, y)
 tripleFirst f = let (Nat (Nat f')) = map f in f'
 
 tripleSecond :: (a -> b) -> (x, a, z) -> (x, b, z)
-tripleSecond f = let (Nat f') = map f in f'
+tripleSecond = runNat . map
 
 tripleThird :: (a -> b) -> (x, y, a) -> (x, y, b)
 tripleThird = map