Redefine bifunctors in terms of product categories.

.github/workflows/ci.yml

@@ -10,10 +10,11 @@ jobs:
     - name: Checkout sources
       uses: actions/checkout@v2
 
-    - name: Install latest Haskell Stack
+    - name: Install Haskell toolchain
       uses: haskell/actions/setup@v1
       with:
         ghc-version: '9.0.1'
+        cabal-version: '3.4.0.0'
 
     - name: Build
       run: cabal v2-build

monoids-in-the-category-of-endofunctors.cabal

@@ -28,6 +28,7 @@ library
       Category.Groupoid
       Category.Monoid
       Category.Monoidal
+      Category.Product
       Category.Semigroup
       Data.Dict
       Data.Fin
@@ -88,6 +89,7 @@ library
       TupleSections
       TypeApplications
       TypeFamilyDependencies
+      TypeInType
       TypeOperators
       TypeSynonymInstances
       ViewPatterns

src/Category/Constraint.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 module Category.Constraint
     ( (:-) (Sub), (\\)
@@ -7,6 +8,7 @@ module Category.Constraint
 import Category.Base
 import Category.Functor
 import Category.Monoidal
+import Category.Product
 import Data.Dict
 import Data.Kind (Constraint, Type)
 
@@ -23,7 +25,7 @@ instance NiceCat (:-) where
     id = Sub Dict
 
 instance Functor (Nat (->) (:-)) (Yoneda (:-)) (:-) where
-    map (Op (Sub f)) = Nat \_ (Sub g) -> Sub case f of Dict -> case g of Dict -> Dict
+    map (Op (Sub f)) = Nat_ \(Sub g) -> Sub case f of Dict -> case g of Dict -> Dict
 
 instance Functor (->) (:-) ((:-) a) where
     map = (.)
@@ -31,6 +33,15 @@ instance Functor (->) (:-) ((:-) a) where
 instance Functor (->) (:-) Dict where
     map f = \Dict -> case f of Sub Dict -> Dict
 
+type UncurryC :: (a -> b -> Constraint) -> (a, b) -> Constraint
+class f (Pi1 ab) (Pi2 ab) => UncurryC f ab
+instance f (Pi1 ab) (Pi2 ab) => UncurryC f ab
+type instance Uncurry = UncurryC
+
+instance Unc (:-) where
+    uncurry _ = Sub Dict
+    ununcurry _ = Sub Dict
+
 class (c, d) => ProdC c d
 instance (c, d) => ProdC c d
 -- Note that, to my understanding,

src/Category/Functor.hs

@@ -3,8 +3,6 @@ module Category.Functor
     ( Functor, map
     , Endo, Endofunctor, endomap
     , Contravariant, contramap
-    , Bifunctor, bimap, first, second
-    , Profunctor, dimap, lmap, rmap
     , Nat (Nat), runNat, pattern Nat_, natId
     , Const (Const), getConst
     ) where
@@ -35,28 +33,6 @@ instance {-# INCOHERENT #-} Functor dest (Yoneda src) f => Contravariant dest sr
 instance {-# INCOHERENT #-} Functor dest src f => Contravariant dest (Yoneda src) f where
     contramap (Op f) = map f
 
-type Bifunctor :: (j -> j -> Type) -> (i -> i -> Type) -> (i -> i -> j) -> Constraint
-class (Functor (Nat dest src) src f, forall x. Functor dest src (f x)) => Bifunctor dest src f
-instance (Functor (Nat dest src) src f, forall x. Functor dest src (f x)) => Bifunctor dest src f
-bimap :: Bifunctor dest src f => src a c -> src b d -> dest (f a b) (f c d)
-bimap f g = runNat (map f) (idR g) . map g
--- FIXME: A NiceCat dependency should not be necessary here,
---   this most likely means that my definition of Bifunctor is inadequate.
-first :: forall dest src f a b c. (Bifunctor dest src f, NiceCat src) => src a b -> dest (f a c) (f b c)
-first f = runNat (map f) (id :: Obj src c)
-second :: Bifunctor dest src f => src b c -> dest (f a b) (f a c)
-second g = map g
-
-type Profunctor :: (j -> j -> Type) -> (i -> i -> Type) -> (i -> i -> j) -> Constraint
-class (Functor (Nat dest src) (Yoneda src) f, forall x. Functor dest src (f x)) => Profunctor dest src f
-instance (Functor (Nat dest src) (Yoneda src) f, forall x. Functor dest src (f x)) => Profunctor dest src f
-dimap :: Profunctor dest src f => src a b -> src c d -> dest (f b c) (f a d)
-dimap f g = runNat (map (Op f)) (idR g) . map g
-lmap :: forall dest src f a b c. (Profunctor dest src f, NiceCat src) => src a b -> dest (f b c) (f a c)
-lmap f = runNat (map (Op f)) (id :: Obj src c)
-rmap :: Profunctor dest src f => src b c -> dest (f a b) (f a c)
-rmap f = map f
-
 type Nat :: (j -> j -> Type) -> (i -> i -> Type) -> (i -> j) -> (i -> j) -> Type
 data Nat dest src f g = (Functor dest src f, Functor dest src g) => Nat { runNat :: !(forall a. Obj src a -> dest (f a) (g a)) }
 
@@ -86,16 +62,16 @@ instance Functor (->) (FUN m) (FUN m a) where
     map f = \g -> f . g
 
 instance Functor (Nat (->) (FUN m)) (Yoneda (FUN m)) (FUN m) where
-    map (Op f) = Nat \_ g -> g . f
+    map (Op f) = Nat_ \g -> g . f
 
 instance Functor (Nat (FUN m) (FUN m)) (FUN m) (,) where
-    map f = Nat \_ (x, y) -> (f x, y)
+    map f = Nat_ \(x, y) -> (f x, y)
 
 instance Functor (FUN m) (FUN m) ((,) a) where
     map f = \(x, y) -> (x, f y)
 
 instance Functor (Nat (FUN m) (FUN m)) (FUN m) Either where
-    map f = Nat \_ -> \case
+    map f = Nat_ \case
         Left y -> Left (f y)
         Right x -> Right x
 
@@ -116,7 +92,7 @@ type Const :: Type -> i -> Type
 newtype Const a b = Const { getConst :: a }
 
 instance Functor (Nat (->) (->)) (->) Const where
-    map f = Nat \_ (Const x) -> Const (f x)
+    map f = Nat_ \(Const x) -> Const (f x)
 
 instance {-# INCOHERENT #-} Category src => Functor (->) src (Const a) where
     map _ = \(Const x) -> Const x

src/Category/Monoidal.hs

@@ -1,11 +1,13 @@
 module Category.Monoidal
     ( TensorProduct, Unit, unitObj, prodObj, prodIL, prodIR, prodEL, prodER, prodAL, prodAR
+    , prodIL_, prodIR_, prodEL_, prodER_, prodAL_, prodAR_
     , Compose (Compose), getCompose
     , Identity (Identity), getIdentity
     ) where
 
 import Category.Base
 import Category.Functor
+import Category.Product
 import Data.Either (Either (Left, Right))
 import Data.Kind (Constraint, FUN, Type)
 import Data.Void (Void)
@@ -15,7 +17,7 @@ import Data.Void (Void)
 -- including the category of types itself,
 -- so instead of using a @Monoidal@ typeclass, we use a @TensorProduct@ typeclass.
 type TensorProduct :: (i -> i -> Type) -> (i -> i -> i) -> Constraint
-class Endo Bifunctor morph prod => TensorProduct (morph :: i -> i -> Type) prod where
+class Bifunctor morph morph morph prod => TensorProduct (morph :: i -> i -> Type) prod where
     type Unit morph prod :: i
     -- | The unit is an object.
     unitObj :: proxy prod -> Obj morph (Unit morph prod)
@@ -40,6 +42,24 @@ class Endo Bifunctor morph prod => TensorProduct (morph :: i -> i -> Type) prod
     -- | Reassociate a product, nesting it to the right.
     prodAR :: Obj morph a -> Obj morph b -> Obj morph c -> morph (prod (prod a b) c) (prod a (prod b c))
 
+prodIL_ :: (NiceCat morph, TensorProduct morph prod) => morph a (prod a (Unit morph prod))
+prodIL_ = prodIL id
+
+prodIR_ :: (NiceCat morph, TensorProduct morph prod) => morph a (prod (Unit morph prod) a)
+prodIR_ = prodIR id
+
+prodEL_ :: (NiceCat morph, TensorProduct morph prod) => morph (prod a (Unit morph prod)) a
+prodEL_ = prodEL id
+
+prodER_ :: (NiceCat morph, TensorProduct morph prod) => morph (prod (Unit morph prod) a) a
+prodER_ = prodER id
+
+prodAL_ :: (NiceCat morph, TensorProduct morph prod) => morph (prod a (prod b c)) (prod (prod a b) c)
+prodAL_ = prodAL id id id
+
+prodAR_ :: (NiceCat morph, TensorProduct morph prod) => morph (prod (prod a b) c) (prod a (prod b c))
+prodAR_ = prodAR id id id
+
 instance TensorProduct (FUN m) (,) where
     type Unit (FUN m) (,) = ()
     prodIL _ = \x -> (x, ())
@@ -49,20 +69,27 @@ instance TensorProduct (FUN m) (,) where
     prodAL _ _ _ = \(x, (y, z)) -> ((x, y), z)
     prodAR _ _ _ = \((x, y), z) -> (x, (y, z))
 
+absurd :: Void %1-> a
+absurd = \case{}
+
 instance TensorProduct (FUN m) Either where
     type Unit (FUN m) Either = Void
     prodIL _ = Left
     prodIR _ = Right
-    prodEL _ (Left x) = x
+    prodEL _ = \case
-    prodEL _ (Right x) = (\case{}) x
+        Left x -> x
-    prodER _ (Left x) = (\case{}) x
+        Right x -> absurd x
-    prodER _ (Right x) = x
+    prodER _ = \case
-    prodAL _ _ _ (Left x) = Left (Left x)
+        Left x -> absurd x
-    prodAL _ _ _ (Right (Left x)) = Left (Right x)
+        Right x -> x
-    prodAL _ _ _ (Right (Right x)) = Right x
+    prodAL _ _ _ = \case
-    prodAR _ _ _ (Left (Left x)) = Left x
+        Left x -> Left (Left x)
-    prodAR _ _ _ (Left (Right x)) = Right (Left x)
+        Right (Left x) -> Left (Right x)
-    prodAR _ _ _ (Right x) = Right (Right x)
+        Right (Right x) -> Right x
+    prodAR _ _ _ = \case
+        Left (Left x) -> Left x
+        Left (Right x) -> Right (Left x)
+        Right x -> Right (Right x)
 
 data Compose f g x = (Functor (->) (->) f, Functor (->) (->) g) => Compose { getCompose :: !(f (g x)) }
 newtype Identity x = Identity { getIdentity :: x }
@@ -71,10 +98,10 @@ instance Functor (FUN m) (FUN m) Identity where
     map f = \(Identity x) -> Identity (f x)
 
 instance Functor (Nat (Nat (->) (->)) (Nat (->) (->))) (Nat (->) (->)) Compose where
-    map (Nat f) = Nat \(Nat _) -> Nat \_ (Compose x) -> Compose (f id x)
+    map (Nat f) = Nat \(Nat _) -> Nat_ \(Compose x) -> Compose (f id x)
 
 instance Functor (Nat (->) (->)) (Nat (->) (->)) (Compose f) where
-    map (Nat f) = Nat \_ (Compose x) -> Compose (map (f id) x)
+    map (Nat f) = Nat_ \(Compose x) -> Compose (map (f id) x)
 
 instance Functor (->) (->) (Compose (f :: Type -> Type) g) where
     map f = \(Compose x) -> Compose (map @_ @_ @_ @(->) (map f) x)

src/Category/Product.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE UndecidableInstances, UndecidableSuperClasses #-}
+module Category.Product
+    ( Pi1, Pi2, pairEta
+    , Product (Product)
+    , Uncurry, Uncurry' (Uncurry), getUncurry, UncurryN (UncurryN), getUncurryN
+    , Unc, uncurry, ununcurry
+    , Bifunctor, bimap_, bimap, first, second
+    , Profunctor, dimap
+    ) where
+
+import Category.Base
+import Category.Functor
+import Data.Dict
+import Data.Kind (Constraint, FUN, Type)
+import Data.Proxy
+import Unsafe.Coerce (unsafeCoerce)
+
+-- | The first projection of the type-level tuple.
+type Pi1 :: (i, j) -> i
+type family Pi1 xy where
+    Pi1 '(x, _) = x
+
+-- | The second projection of the type-level tuple.
+type Pi2 :: (i, j) -> j
+type family Pi2 xy where
+    Pi2 '(_, y) = y
+
+-- | Eta expansion for the pair type *on the type level*. **This does not hold on the value level.**
+--
+-- This is not provable by GHC's constraint solver, but it is safe to assume.
+-- Maybe. Hopefully.
+pairEta :: proxy x -> Dict (x ~ '(Pi1 x, Pi2 x))
+pairEta = unsafeCoerce (Dict :: Dict ())
+
+-- | The product category of two categories `c` and `d` is the category
+-- whose objects are pairs of objects from `c` and `d` and whose arrows
+-- are pairs of arrows from `c` and `d`.
+type Product :: (i -> i -> Type) -> (j -> j -> Type) -> (i, j) -> (i, j) -> Type
+data Product c d a b = Product !(c (Pi1 a) (Pi1 b)) !(d (Pi2 a) (Pi2 b))
+
+instance (Category c, Category d) => Category (Product c d) where
+    idL (Product f g) = Product (idL f) (idL g)
+    idR (Product f g) = Product (idR f) (idR g)
+    Product f1 g1 . Product f2 g2 = Product (f1 . f2) (g1 . g2)
+
+instance (NiceCat c, NiceCat d) => NiceCat (Product c d) where
+    id = Product id id
+
+type Uncurry :: (a -> b -> c) -> (a, b) -> c
+type family Uncurry
+
+type Uncurry' :: (a -> b -> Type) -> (a, b) -> Type
+newtype Uncurry' f ab = Uncurry { getUncurry :: f (Pi1 ab) (Pi2 ab) }
+type instance Uncurry = Uncurry'
+
+type UncurryN :: (a -> b -> c -> Type) -> (a, b) -> c -> Type
+newtype UncurryN f ab x = UncurryN { getUncurryN :: f (Pi1 ab) (Pi2 ab) x }
+type instance Uncurry = UncurryN
+
+instance (Category c, Functor (->) c (f a b)) => Functor (->) c (UncurryN f '(a, b)) where
+    map f (UncurryN x) = UncurryN (map f x)
+
+type Unc :: (c -> c -> Type) -> Constraint
+class Category cat => Unc cat where
+    uncurry :: Obj cat (f a b) -> cat (f a b) (Uncurry f '(a, b))
+    ununcurry :: Obj cat (f a b) -> cat (Uncurry f '(a, b)) (f a b)
+
+instance Unc (FUN m) where
+    uncurry _ = Uncurry
+    ununcurry _ (Uncurry x) = x
+
+instance Unc (Nat (->) (->)) where
+    uncurry (Nat _) = Nat_ UncurryN
+    ununcurry (Nat _) = Nat_ \(UncurryN x) -> x
+
+-- | A bifunctor is a functor whose domain is the product category.
+type Bifunctor :: (k -> k -> Type) -> (i -> i -> Type) -> (j -> j -> Type) -> (i -> j -> k) -> Constraint
+class (Unc cod, Category dom1, Category dom2, Functor cod (Product dom1 dom2) (Uncurry f)) => Bifunctor cod dom1 dom2 f where
+    bimap_ :: forall a b. Obj dom1 a -> Obj dom2 b -> Obj cod (f a b)
+
+bimap :: forall cod dom1 dom2 f a b c d. Bifunctor cod dom1 dom2 f => dom1 a c -> dom2 b d -> cod (f a b) (f c d)
+bimap f g = ununcurry (bimap_ (idR f) (idR g)) . map (Product f g) . uncurry (bimap_ (idL f) (idL g))
+
+first :: forall cod dom f a b c. (NiceCat dom, Bifunctor cod dom dom f) => dom a b -> cod (f a c) (f b c)
+first f = bimap f (id :: dom c c)
+
+second :: forall cod dom f a b c. (NiceCat dom, Bifunctor cod dom dom f) => dom b c -> cod (f a b) (f a c)
+second g = bimap (id :: dom a a) g
+
+instance (Unc cod, Functor (Nat cod dom2) dom1 f, forall x. Functor cod dom2 (f x), uncurry ~ Uncurry) => Functor cod (Product dom1 dom2) (uncurry f) where
+    {-# INLINABLE map #-}
+    map :: forall a b. Product dom1 dom2 a b -> cod (uncurry f a) (uncurry f b)
+    map (Product f g) = lemma (uncurry (map (idR g)) . runNat (map f) (idR g) . map g . ununcurry (map (idL g)))
+        where lemma :: ((a ~ '(Pi1 a, Pi2 a), b ~ '(Pi1 b, Pi2 b)) => c) -> c
+              lemma x = case pairEta (Proxy @a) of Dict -> case pairEta (Proxy @b) of Dict -> x
+instance (Unc cod, Category dom1, Functor (Nat cod dom2) dom1 f, forall x. Functor cod dom2 (f x)) => Bifunctor cod dom1 dom2 f where
+    bimap_ a b = runNat (map a) b . map b
+
+type Profunctor :: (k -> k -> Type) -> (i -> i -> Type) -> (j -> j -> Type) -> (i -> j -> k) -> Constraint
+class Bifunctor cod (Yoneda dom1) dom2 f => Profunctor cod dom1 dom2 f
+instance Bifunctor cod (Yoneda dom1) dom2 f => Profunctor cod dom1 dom2 f
+
+dimap :: Profunctor cod dom1 dom2 f => dom1 c a -> dom2 b d -> cod (f a b) (f c d)
+dimap f g = bimap (Op f) g

src/Category/Semigroup.hs

@@ -10,7 +10,7 @@ class TensorProduct morph prod => Semigroup morph prod s where
     append :: morph (prod s s) s
 
 instance Semigroup (Nat (->) (->)) Compose Maybe where
-    append = Nat \_ (Compose x') -> case x' of
+    append = Nat_ \(Compose x') -> case x' of
         Nothing -> Nothing
         Just Nothing -> Nothing
         Just (Just x) -> Just x