Redefine bifunctors in terms of product categories.
parent
05ddc84fff
commit
8a1fad57df
GPG Key ID:
4B7F3DA9351E577C
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 _ (Right x) = (\case{}) x
|
||||
prodER _ (Left x) = (\case{}) x
|
||||
prodER _ (Right x) = x
|
||||
prodAL _ _ _ (Left x) = Left (Left x)
|
||||
prodAL _ _ _ (Right (Left x)) = Left (Right x)
|
||||
prodAL _ _ _ (Right (Right x)) = Right x
|
||||
prodAR _ _ _ (Left (Left x)) = Left x
|
||||
prodAR _ _ _ (Left (Right x)) = Right (Left x)
|
||||
prodAR _ _ _ (Right x) = Right (Right x)
|
||||
prodEL _ = \case
|
||||
Left x -> x
|
||||
Right x -> absurd x
|
||||
prodER _ = \case
|
||||
Left x -> absurd x
|
||||
Right x -> x
|
||||
prodAL _ _ _ = \case
|
||||
Left x -> Left (Left x)
|
||||
Right (Left x) -> Left (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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue