diff --git a/src/Cat/Category/Monad.agda b/src/Cat/Category/Monad.agda index db4e356..2f42f32 100644 --- a/src/Cat/Category/Monad.agda +++ b/src/Cat/Category/Monad.agda @@ -14,6 +14,7 @@ These two formulations are proven to be equivalent: Monoidal.Monad ≃ Kleisli.Monad +The monoidal representation is exposed by default from this module. ---} {-# OPTIONS --cubical --allow-unsolved-metas #-} @@ -30,382 +31,10 @@ open import Cubical.GradLemma using (gradLemma) open import Cat.Category open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation +open import Cat.Category.Monad.Monoidal as Monoidal public +open import Cat.Category.Monad.Kleisli as Kleisli open import Cat.Categories.Fun --- "A monad in the monoidal form" [voe] -module Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where - private - ℓ = ℓa ⊔ ℓb - - open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_) - open NaturalTransformation ℂ ℂ - record RawMonad : Set ℓ where - field - R : EndoFunctor ℂ - pureNT : NaturalTransformation F.identity R - joinNT : NaturalTransformation F[ R ∘ R ] R - - -- Note that `pureT` and `joinT` differs from their definition in the - -- kleisli formulation only by having an explicit parameter. - pureT : Transformation F.identity R - pureT = proj₁ pureNT - pureN : Natural F.identity R pureT - pureN = proj₂ pureNT - - joinT : Transformation F[ R ∘ R ] R - joinT = proj₁ joinNT - joinN : Natural F[ R ∘ R ] R joinT - joinN = proj₂ joinNT - - Romap = Functor.omap R - Rfmap = Functor.fmap R - - bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] - bind {X} {Y} f = joinT Y ∘ Rfmap f - - IsAssociative : Set _ - IsAssociative = {X : Object} - → joinT X ∘ Rfmap (joinT X) ≡ joinT X ∘ joinT (Romap X) - IsInverse : Set _ - IsInverse = {X : Object} - → joinT X ∘ pureT (Romap X) ≡ 𝟙 - × joinT X ∘ Rfmap (pureT X) ≡ 𝟙 - IsNatural = ∀ {X Y} f → joinT Y ∘ Rfmap f ∘ pureT X ≡ f - IsDistributive = ∀ {X Y Z} (g : Arrow Y (Romap Z)) (f : Arrow X (Romap Y)) - → joinT Z ∘ Rfmap g ∘ (joinT Y ∘ Rfmap f) - ≡ joinT Z ∘ Rfmap (joinT Z ∘ Rfmap g ∘ f) - - record IsMonad (raw : RawMonad) : Set ℓ where - open RawMonad raw public - field - isAssociative : IsAssociative - isInverse : IsInverse - - private - module R = Functor R - module ℂ = Category ℂ - - isNatural : IsNatural - isNatural {X} {Y} f = begin - joinT Y ∘ R.fmap f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ - joinT Y ∘ (R.fmap f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ - joinT Y ∘ (pureT (R.omap Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ - joinT Y ∘ pureT (R.omap Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ - 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ - f ∎ - - isDistributive : IsDistributive - isDistributive {X} {Y} {Z} g f = sym aux - where - module R² = Functor F[ R ∘ R ] - distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} - → R.fmap (a ∘ b ∘ c) - ≡ R.fmap a ∘ R.fmap b ∘ R.fmap c - distrib3 {a = a} {b} {c} = begin - R.fmap (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ - R.fmap (a ∘ b) ∘ R.fmap c ≡⟨ cong (_∘ _) R.isDistributive ⟩ - R.fmap a ∘ R.fmap b ∘ R.fmap c ∎ - aux = begin - joinT Z ∘ R.fmap (joinT Z ∘ R.fmap g ∘ f) - ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib3 ⟩ - joinT Z ∘ (R.fmap (joinT Z) ∘ R.fmap (R.fmap g) ∘ R.fmap f) - ≡⟨⟩ - joinT Z ∘ (R.fmap (joinT Z) ∘ R².fmap g ∘ R.fmap f) - ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ - joinT Z ∘ (R.fmap (joinT Z) ∘ (R².fmap g ∘ R.fmap f)) - ≡⟨ ℂ.isAssociative ⟩ - (joinT Z ∘ R.fmap (joinT Z)) ∘ (R².fmap g ∘ R.fmap f) - ≡⟨ cong (λ φ → φ ∘ (R².fmap g ∘ R.fmap f)) isAssociative ⟩ - (joinT Z ∘ joinT (R.omap Z)) ∘ (R².fmap g ∘ R.fmap f) - ≡⟨ ℂ.isAssociative ⟩ - joinT Z ∘ joinT (R.omap Z) ∘ R².fmap g ∘ R.fmap f - ≡⟨⟩ - ((joinT Z ∘ joinT (R.omap Z)) ∘ R².fmap g) ∘ R.fmap f - ≡⟨ cong (_∘ R.fmap f) (sym ℂ.isAssociative) ⟩ - (joinT Z ∘ (joinT (R.omap Z) ∘ R².fmap g)) ∘ R.fmap f - ≡⟨ cong (λ φ → φ ∘ R.fmap f) (cong (_∘_ (joinT Z)) (joinN g)) ⟩ - (joinT Z ∘ (R.fmap g ∘ joinT Y)) ∘ R.fmap f - ≡⟨ cong (_∘ R.fmap f) ℂ.isAssociative ⟩ - joinT Z ∘ R.fmap g ∘ joinT Y ∘ R.fmap f - ≡⟨ sym (Category.isAssociative ℂ) ⟩ - joinT Z ∘ R.fmap g ∘ (joinT Y ∘ R.fmap f) - ∎ - - record Monad : Set ℓ where - field - raw : RawMonad - isMonad : IsMonad raw - open IsMonad isMonad public - - private - module _ {m : RawMonad} where - open RawMonad m - propIsAssociative : isProp IsAssociative - propIsAssociative x y i {X} - = Category.arrowsAreSets ℂ _ _ (x {X}) (y {X}) i - propIsInverse : isProp IsInverse - propIsInverse x y i {X} = e1 i , e2 i - where - xX = x {X} - yX = y {X} - e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX) - e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX) - - open IsMonad - propIsMonad : (raw : _) → isProp (IsMonad raw) - IsMonad.isAssociative (propIsMonad raw a b i) j - = propIsAssociative {raw} - (isAssociative a) (isAssociative b) i j - IsMonad.isInverse (propIsMonad raw a b i) - = propIsInverse {raw} - (isInverse a) (isInverse b) i - - module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - private - eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - eqIsMonad = lemPropF propIsMonad eq - - Monad≡ : m ≡ n - Monad.raw (Monad≡ i) = eq i - Monad.isMonad (Monad≡ i) = eqIsMonad i - --- "A monad in the Kleisli form" [voe] -module Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where - private - ℓ = ℓa ⊔ ℓb - module ℂ = Category ℂ - open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) - - -- | Data for a monad. - -- - -- Note that (>>=) is not expressible in a general category because objects - -- are not generally types. - record RawMonad : Set ℓ where - field - omap : Object → Object - pure : {X : Object} → ℂ [ X , omap X ] - bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] - - -- | functor map - -- - -- This should perhaps be defined in a "Klesli-version" of functors as well? - fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ] - fmap f = bind (pure ∘ f) - - -- | Composition of monads aka. the kleisli-arrow. - _>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ] - f >=> g = f >>> (bind g) - - -- | Flattening nested monads. - join : {A : Object} → ℂ [ omap (omap A) , omap A ] - join = bind 𝟙 - - ------------------ - -- * Monad laws -- - ------------------ - - -- There may be better names than what I've chosen here. - - IsIdentity = {X : Object} - → bind pure ≡ 𝟙 {omap X} - IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ]) - → pure >>> (bind f) ≡ f - IsDistributive = {X Y Z : Object} (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ]) - → (bind f) >>> (bind g) ≡ bind (f >=> g) - - -- | Functor map fusion. - -- - -- This is really a functor law. Should we have a kleisli-representation of - -- functors as well and make them a super-class? - Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]} - → fmap (g ∘ f) ≡ fmap g ∘ fmap f - - -- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be: - IsNaturalForeign : Set _ - IsNaturalForeign = {X : Object} → join {X} ∘ fmap join ≡ join ∘ join - - IsInverse : Set _ - IsInverse = {X : Object} → join {X} ∘ pure ≡ 𝟙 × join {X} ∘ fmap pure ≡ 𝟙 - - record IsMonad (raw : RawMonad) : Set ℓ where - open RawMonad raw public - field - isIdentity : IsIdentity - isNatural : IsNatural - isDistributive : IsDistributive - - -- | Map fusion is admissable. - fusion : Fusion - fusion {g = g} {f} = begin - fmap (g ∘ f) ≡⟨⟩ - bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (f >>> (g >>> pure)) ≡⟨ cong (λ φ → bind (f >>> φ)) (sym (isNatural _)) ⟩ - bind (f >>> (pure >>> (bind (g >>> pure)))) ≡⟨⟩ - bind (f >>> (pure >>> fmap g)) ≡⟨⟩ - bind ((fmap g ∘ pure) ∘ f) ≡⟨ cong bind (sym ℂ.isAssociative) ⟩ - bind (fmap g ∘ (pure ∘ f)) ≡⟨ sym distrib ⟩ - bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ - fmap g ∘ fmap f ∎ - where - distrib : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) - distrib = isDistributive (pure ∘ g) (pure ∘ f) - - -- | This formulation gives rise to the following endo-functor. - private - rawR : RawFunctor ℂ ℂ - RawFunctor.omap rawR = omap - RawFunctor.fmap rawR = fmap - - isFunctorR : IsFunctor ℂ ℂ rawR - IsFunctor.isIdentity isFunctorR = begin - bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ - bind pure ≡⟨ isIdentity ⟩ - 𝟙 ∎ - - IsFunctor.isDistributive isFunctorR {f = f} {g} = begin - bind (pure ∘ (g ∘ f)) ≡⟨⟩ - fmap (g ∘ f) ≡⟨ fusion ⟩ - fmap g ∘ fmap f ≡⟨⟩ - bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ - - -- FIXME Naming! - R : EndoFunctor ℂ - Functor.raw R = rawR - Functor.isFunctor R = isFunctorR - - private - open NaturalTransformation ℂ ℂ - - R⁰ : EndoFunctor ℂ - R⁰ = F.identity - R² : EndoFunctor ℂ - R² = F[ R ∘ R ] - module R = Functor R - module R⁰ = Functor R⁰ - module R² = Functor R² - pureT : Transformation R⁰ R - pureT A = pure - pureN : Natural R⁰ R pureT - pureN {A} {B} f = begin - pureT B ∘ R⁰.fmap f ≡⟨⟩ - pure ∘ f ≡⟨ sym (isNatural _) ⟩ - bind (pure ∘ f) ∘ pure ≡⟨⟩ - fmap f ∘ pure ≡⟨⟩ - R.fmap f ∘ pureT A ∎ - joinT : Transformation R² R - joinT C = join - joinN : Natural R² R joinT - joinN f = begin - join ∘ R².fmap f ≡⟨⟩ - bind 𝟙 ∘ R².fmap f ≡⟨⟩ - R².fmap f >>> bind 𝟙 ≡⟨⟩ - fmap (fmap f) >>> bind 𝟙 ≡⟨⟩ - fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩ - bind (bind (f >>> pure) >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((bind (f >>> pure) >>> pure) >=> 𝟙) - ≡⟨⟩ - bind ((bind (f >>> pure) >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (bind (f >>> pure) >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩ - bind (bind (f >>> pure) >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind (bind (f >>> pure)) - ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ - bind (𝟙 >>> bind (f >>> pure)) ≡⟨⟩ - bind (𝟙 >=> (f >>> pure)) - ≡⟨ sym (isDistributive _ _) ⟩ - bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩ - bind 𝟙 >>> fmap f ≡⟨⟩ - bind 𝟙 >>> R.fmap f ≡⟨⟩ - R.fmap f ∘ bind 𝟙 ≡⟨⟩ - R.fmap f ∘ join ∎ - - pureNT : NaturalTransformation R⁰ R - proj₁ pureNT = pureT - proj₂ pureNT = pureN - - joinNT : NaturalTransformation R² R - proj₁ joinNT = joinT - proj₂ joinNT = joinN - - isNaturalForeign : IsNaturalForeign - isNaturalForeign = begin - fmap join >>> join ≡⟨⟩ - bind (join >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((join >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (join >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩ - bind (join >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind join ≡⟨⟩ - bind (bind 𝟙) - ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ - bind (𝟙 >>> bind 𝟙) ≡⟨⟩ - bind (𝟙 >=> 𝟙) ≡⟨ sym (isDistributive _ _) ⟩ - bind 𝟙 >>> bind 𝟙 ≡⟨⟩ - join >>> join ∎ - - isInverse : IsInverse - isInverse = inv-l , inv-r - where - inv-l = begin - pure >>> join ≡⟨⟩ - pure >>> bind 𝟙 ≡⟨ isNatural _ ⟩ - 𝟙 ∎ - inv-r = begin - fmap pure >>> join ≡⟨⟩ - bind (pure >>> pure) >>> bind 𝟙 - ≡⟨ isDistributive _ _ ⟩ - bind ((pure >>> pure) >=> 𝟙) ≡⟨⟩ - bind ((pure >>> pure) >>> bind 𝟙) - ≡⟨ cong bind ℂ.isAssociative ⟩ - bind (pure >>> (pure >>> bind 𝟙)) - ≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩ - bind (pure >>> 𝟙) - ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ - bind pure ≡⟨ isIdentity ⟩ - 𝟙 ∎ - - record Monad : Set ℓ where - field - raw : RawMonad - isMonad : IsMonad raw - open IsMonad isMonad public - - private - module _ (raw : RawMonad) where - open RawMonad raw - propIsIdentity : isProp IsIdentity - propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i - propIsNatural : isProp IsNatural - propIsNatural x y i = λ f - → ℂ.arrowsAreSets _ _ (x f) (y f) i - propIsDistributive : isProp IsDistributive - propIsDistributive x y i = λ g f - → ℂ.arrowsAreSets _ _ (x g f) (y g f) i - - open IsMonad - propIsMonad : (raw : _) → isProp (IsMonad raw) - IsMonad.isIdentity (propIsMonad raw x y i) - = propIsIdentity raw (isIdentity x) (isIdentity y) i - IsMonad.isNatural (propIsMonad raw x y i) - = propIsNatural raw (isNatural x) (isNatural y) i - IsMonad.isDistributive (propIsMonad raw x y i) - = propIsDistributive raw (isDistributive x) (isDistributive y) i - - module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where - private - eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] - eqIsMonad = lemPropF propIsMonad eq - - Monad≡ : m ≡ n - Monad.raw (Monad≡ i) = eq i - Monad.isMonad (Monad≡ i) = eqIsMonad i - -- | The monoidal- and kleisli presentation of monads are equivalent. module _ {ℓa ℓb : Level} {ℂ : Category ℓa ℓb} where private diff --git a/src/Cat/Category/Monad/Kleisli.agda b/src/Cat/Category/Monad/Kleisli.agda new file mode 100644 index 0000000..8f96b82 --- /dev/null +++ b/src/Cat/Category/Monad/Kleisli.agda @@ -0,0 +1,253 @@ +{--- +The Kleisli formulation of monads + ---} +{-# OPTIONS --cubical --allow-unsolved-metas #-} +open import Agda.Primitive + +open import Data.Product + +open import Cubical +open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) +open import Cubical.GradLemma using (gradLemma) + +open import Cat.Category +open import Cat.Category.Functor as F +open import Cat.Category.NaturalTransformation +open import Cat.Categories.Fun + +-- "A monad in the Kleisli form" [voe] +module Cat.Category.Monad.Kleisli {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where +private + ℓ = ℓa ⊔ ℓb + module ℂ = Category ℂ + open ℂ using (Arrow ; 𝟙 ; Object ; _∘_ ; _>>>_) + +-- | Data for a monad. +-- +-- Note that (>>=) is not expressible in a general category because objects +-- are not generally types. +record RawMonad : Set ℓ where + field + omap : Object → Object + pure : {X : Object} → ℂ [ X , omap X ] + bind : {X Y : Object} → ℂ [ X , omap Y ] → ℂ [ omap X , omap Y ] + + -- | functor map + -- + -- This should perhaps be defined in a "Klesli-version" of functors as well? + fmap : ∀ {A B} → ℂ [ A , B ] → ℂ [ omap A , omap B ] + fmap f = bind (pure ∘ f) + + -- | Composition of monads aka. the kleisli-arrow. + _>=>_ : {A B C : Object} → ℂ [ A , omap B ] → ℂ [ B , omap C ] → ℂ [ A , omap C ] + f >=> g = f >>> (bind g) + + -- | Flattening nested monads. + join : {A : Object} → ℂ [ omap (omap A) , omap A ] + join = bind 𝟙 + + ------------------ + -- * Monad laws -- + ------------------ + + -- There may be better names than what I've chosen here. + + IsIdentity = {X : Object} + → bind pure ≡ 𝟙 {omap X} + IsNatural = {X Y : Object} (f : ℂ [ X , omap Y ]) + → pure >>> (bind f) ≡ f + IsDistributive = {X Y Z : Object} (g : ℂ [ Y , omap Z ]) (f : ℂ [ X , omap Y ]) + → (bind f) >>> (bind g) ≡ bind (f >=> g) + + -- | Functor map fusion. + -- + -- This is really a functor law. Should we have a kleisli-representation of + -- functors as well and make them a super-class? + Fusion = {X Y Z : Object} {g : ℂ [ Y , Z ]} {f : ℂ [ X , Y ]} + → fmap (g ∘ f) ≡ fmap g ∘ fmap f + + -- In the ("foreign") formulation of a monad `IsNatural`'s analogue here would be: + IsNaturalForeign : Set _ + IsNaturalForeign = {X : Object} → join {X} ∘ fmap join ≡ join ∘ join + + IsInverse : Set _ + IsInverse = {X : Object} → join {X} ∘ pure ≡ 𝟙 × join {X} ∘ fmap pure ≡ 𝟙 + +record IsMonad (raw : RawMonad) : Set ℓ where + open RawMonad raw public + field + isIdentity : IsIdentity + isNatural : IsNatural + isDistributive : IsDistributive + + -- | Map fusion is admissable. + fusion : Fusion + fusion {g = g} {f} = begin + fmap (g ∘ f) ≡⟨⟩ + bind ((f >>> g) >>> pure) ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (f >>> (g >>> pure)) ≡⟨ cong (λ φ → bind (f >>> φ)) (sym (isNatural _)) ⟩ + bind (f >>> (pure >>> (bind (g >>> pure)))) ≡⟨⟩ + bind (f >>> (pure >>> fmap g)) ≡⟨⟩ + bind ((fmap g ∘ pure) ∘ f) ≡⟨ cong bind (sym ℂ.isAssociative) ⟩ + bind (fmap g ∘ (pure ∘ f)) ≡⟨ sym distrib ⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ≡⟨⟩ + fmap g ∘ fmap f ∎ + where + distrib : fmap g ∘ fmap f ≡ bind (fmap g ∘ (pure ∘ f)) + distrib = isDistributive (pure ∘ g) (pure ∘ f) + + -- | This formulation gives rise to the following endo-functor. + private + rawR : RawFunctor ℂ ℂ + RawFunctor.omap rawR = omap + RawFunctor.fmap rawR = fmap + + isFunctorR : IsFunctor ℂ ℂ rawR + IsFunctor.isIdentity isFunctorR = begin + bind (pure ∘ 𝟙) ≡⟨ cong bind (proj₁ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ + 𝟙 ∎ + + IsFunctor.isDistributive isFunctorR {f = f} {g} = begin + bind (pure ∘ (g ∘ f)) ≡⟨⟩ + fmap (g ∘ f) ≡⟨ fusion ⟩ + fmap g ∘ fmap f ≡⟨⟩ + bind (pure ∘ g) ∘ bind (pure ∘ f) ∎ + + -- FIXME Naming! + R : EndoFunctor ℂ + Functor.raw R = rawR + Functor.isFunctor R = isFunctorR + + private + open NaturalTransformation ℂ ℂ + + R⁰ : EndoFunctor ℂ + R⁰ = F.identity + R² : EndoFunctor ℂ + R² = F[ R ∘ R ] + module R = Functor R + module R⁰ = Functor R⁰ + module R² = Functor R² + pureT : Transformation R⁰ R + pureT A = pure + pureN : Natural R⁰ R pureT + pureN {A} {B} f = begin + pureT B ∘ R⁰.fmap f ≡⟨⟩ + pure ∘ f ≡⟨ sym (isNatural _) ⟩ + bind (pure ∘ f) ∘ pure ≡⟨⟩ + fmap f ∘ pure ≡⟨⟩ + R.fmap f ∘ pureT A ∎ + joinT : Transformation R² R + joinT C = join + joinN : Natural R² R joinT + joinN f = begin + join ∘ R².fmap f ≡⟨⟩ + bind 𝟙 ∘ R².fmap f ≡⟨⟩ + R².fmap f >>> bind 𝟙 ≡⟨⟩ + fmap (fmap f) >>> bind 𝟙 ≡⟨⟩ + fmap (bind (f >>> pure)) >>> bind 𝟙 ≡⟨⟩ + bind (bind (f >>> pure) >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((bind (f >>> pure) >>> pure) >=> 𝟙) + ≡⟨⟩ + bind ((bind (f >>> pure) >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (bind (f >>> pure) >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (bind (f >>> pure) >>> φ)) (isNatural _) ⟩ + bind (bind (f >>> pure) >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind (bind (f >>> pure)) + ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ + bind (𝟙 >>> bind (f >>> pure)) ≡⟨⟩ + bind (𝟙 >=> (f >>> pure)) + ≡⟨ sym (isDistributive _ _) ⟩ + bind 𝟙 >>> bind (f >>> pure) ≡⟨⟩ + bind 𝟙 >>> fmap f ≡⟨⟩ + bind 𝟙 >>> R.fmap f ≡⟨⟩ + R.fmap f ∘ bind 𝟙 ≡⟨⟩ + R.fmap f ∘ join ∎ + + pureNT : NaturalTransformation R⁰ R + proj₁ pureNT = pureT + proj₂ pureNT = pureN + + joinNT : NaturalTransformation R² R + proj₁ joinNT = joinT + proj₂ joinNT = joinN + + isNaturalForeign : IsNaturalForeign + isNaturalForeign = begin + fmap join >>> join ≡⟨⟩ + bind (join >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((join >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (join >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (join >>> φ)) (isNatural _) ⟩ + bind (join >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind join ≡⟨⟩ + bind (bind 𝟙) + ≡⟨ cong bind (sym (proj₁ ℂ.isIdentity)) ⟩ + bind (𝟙 >>> bind 𝟙) ≡⟨⟩ + bind (𝟙 >=> 𝟙) ≡⟨ sym (isDistributive _ _) ⟩ + bind 𝟙 >>> bind 𝟙 ≡⟨⟩ + join >>> join ∎ + + isInverse : IsInverse + isInverse = inv-l , inv-r + where + inv-l = begin + pure >>> join ≡⟨⟩ + pure >>> bind 𝟙 ≡⟨ isNatural _ ⟩ + 𝟙 ∎ + inv-r = begin + fmap pure >>> join ≡⟨⟩ + bind (pure >>> pure) >>> bind 𝟙 + ≡⟨ isDistributive _ _ ⟩ + bind ((pure >>> pure) >=> 𝟙) ≡⟨⟩ + bind ((pure >>> pure) >>> bind 𝟙) + ≡⟨ cong bind ℂ.isAssociative ⟩ + bind (pure >>> (pure >>> bind 𝟙)) + ≡⟨ cong (λ φ → bind (pure >>> φ)) (isNatural _) ⟩ + bind (pure >>> 𝟙) + ≡⟨ cong bind (proj₂ ℂ.isIdentity) ⟩ + bind pure ≡⟨ isIdentity ⟩ + 𝟙 ∎ + +record Monad : Set ℓ where + field + raw : RawMonad + isMonad : IsMonad raw + open IsMonad isMonad public + +private + module _ (raw : RawMonad) where + open RawMonad raw + propIsIdentity : isProp IsIdentity + propIsIdentity x y i = ℂ.arrowsAreSets _ _ x y i + propIsNatural : isProp IsNatural + propIsNatural x y i = λ f + → ℂ.arrowsAreSets _ _ (x f) (y f) i + propIsDistributive : isProp IsDistributive + propIsDistributive x y i = λ g f + → ℂ.arrowsAreSets _ _ (x g f) (y g f) i + + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isIdentity (propIsMonad raw x y i) + = propIsIdentity raw (isIdentity x) (isIdentity y) i + IsMonad.isNatural (propIsMonad raw x y i) + = propIsNatural raw (isNatural x) (isNatural y) i + IsMonad.isDistributive (propIsMonad raw x y i) + = propIsDistributive raw (isDistributive x) (isDistributive y) i + +module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where + private + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq + + Monad≡ : m ≡ n + Monad.raw (Monad≡ i) = eq i + Monad.isMonad (Monad≡ i) = eqIsMonad i diff --git a/src/Cat/Category/Monad/Monoidal.agda b/src/Cat/Category/Monad/Monoidal.agda new file mode 100644 index 0000000..b969187 --- /dev/null +++ b/src/Cat/Category/Monad/Monoidal.agda @@ -0,0 +1,154 @@ +{--- +Monoidal formulation of monads + ---} +{-# OPTIONS --cubical --allow-unsolved-metas #-} +open import Agda.Primitive + +open import Data.Product + +open import Cubical +open import Cubical.NType.Properties using (lemPropF ; lemSig ; lemSigP) +open import Cubical.GradLemma using (gradLemma) + +open import Cat.Category +open import Cat.Category.Functor as F +open import Cat.Category.NaturalTransformation +open import Cat.Categories.Fun + +module Cat.Category.Monad.Monoidal {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where + +-- "A monad in the monoidal form" [voe] +private + ℓ = ℓa ⊔ ℓb + +open Category ℂ using (Object ; Arrow ; 𝟙 ; _∘_) +open NaturalTransformation ℂ ℂ +record RawMonad : Set ℓ where + field + R : EndoFunctor ℂ + pureNT : NaturalTransformation F.identity R + joinNT : NaturalTransformation F[ R ∘ R ] R + + -- Note that `pureT` and `joinT` differs from their definition in the + -- kleisli formulation only by having an explicit parameter. + pureT : Transformation F.identity R + pureT = proj₁ pureNT + pureN : Natural F.identity R pureT + pureN = proj₂ pureNT + + joinT : Transformation F[ R ∘ R ] R + joinT = proj₁ joinNT + joinN : Natural F[ R ∘ R ] R joinT + joinN = proj₂ joinNT + + Romap = Functor.omap R + Rfmap = Functor.fmap R + + bind : {X Y : Object} → ℂ [ X , Romap Y ] → ℂ [ Romap X , Romap Y ] + bind {X} {Y} f = joinT Y ∘ Rfmap f + + IsAssociative : Set _ + IsAssociative = {X : Object} + → joinT X ∘ Rfmap (joinT X) ≡ joinT X ∘ joinT (Romap X) + IsInverse : Set _ + IsInverse = {X : Object} + → joinT X ∘ pureT (Romap X) ≡ 𝟙 + × joinT X ∘ Rfmap (pureT X) ≡ 𝟙 + IsNatural = ∀ {X Y} f → joinT Y ∘ Rfmap f ∘ pureT X ≡ f + IsDistributive = ∀ {X Y Z} (g : Arrow Y (Romap Z)) (f : Arrow X (Romap Y)) + → joinT Z ∘ Rfmap g ∘ (joinT Y ∘ Rfmap f) + ≡ joinT Z ∘ Rfmap (joinT Z ∘ Rfmap g ∘ f) + +record IsMonad (raw : RawMonad) : Set ℓ where + open RawMonad raw public + field + isAssociative : IsAssociative + isInverse : IsInverse + + private + module R = Functor R + module ℂ = Category ℂ + + isNatural : IsNatural + isNatural {X} {Y} f = begin + joinT Y ∘ R.fmap f ∘ pureT X ≡⟨ sym ℂ.isAssociative ⟩ + joinT Y ∘ (R.fmap f ∘ pureT X) ≡⟨ cong (λ φ → joinT Y ∘ φ) (sym (pureN f)) ⟩ + joinT Y ∘ (pureT (R.omap Y) ∘ f) ≡⟨ ℂ.isAssociative ⟩ + joinT Y ∘ pureT (R.omap Y) ∘ f ≡⟨ cong (λ φ → φ ∘ f) (proj₁ isInverse) ⟩ + 𝟙 ∘ f ≡⟨ proj₂ ℂ.isIdentity ⟩ + f ∎ + + isDistributive : IsDistributive + isDistributive {X} {Y} {Z} g f = sym aux + where + module R² = Functor F[ R ∘ R ] + distrib3 : ∀ {A B C D} {a : Arrow C D} {b : Arrow B C} {c : Arrow A B} + → R.fmap (a ∘ b ∘ c) + ≡ R.fmap a ∘ R.fmap b ∘ R.fmap c + distrib3 {a = a} {b} {c} = begin + R.fmap (a ∘ b ∘ c) ≡⟨ R.isDistributive ⟩ + R.fmap (a ∘ b) ∘ R.fmap c ≡⟨ cong (_∘ _) R.isDistributive ⟩ + R.fmap a ∘ R.fmap b ∘ R.fmap c ∎ + aux = begin + joinT Z ∘ R.fmap (joinT Z ∘ R.fmap g ∘ f) + ≡⟨ cong (λ φ → joinT Z ∘ φ) distrib3 ⟩ + joinT Z ∘ (R.fmap (joinT Z) ∘ R.fmap (R.fmap g) ∘ R.fmap f) + ≡⟨⟩ + joinT Z ∘ (R.fmap (joinT Z) ∘ R².fmap g ∘ R.fmap f) + ≡⟨ cong (_∘_ (joinT Z)) (sym ℂ.isAssociative) ⟩ + joinT Z ∘ (R.fmap (joinT Z) ∘ (R².fmap g ∘ R.fmap f)) + ≡⟨ ℂ.isAssociative ⟩ + (joinT Z ∘ R.fmap (joinT Z)) ∘ (R².fmap g ∘ R.fmap f) + ≡⟨ cong (λ φ → φ ∘ (R².fmap g ∘ R.fmap f)) isAssociative ⟩ + (joinT Z ∘ joinT (R.omap Z)) ∘ (R².fmap g ∘ R.fmap f) + ≡⟨ ℂ.isAssociative ⟩ + joinT Z ∘ joinT (R.omap Z) ∘ R².fmap g ∘ R.fmap f + ≡⟨⟩ + ((joinT Z ∘ joinT (R.omap Z)) ∘ R².fmap g) ∘ R.fmap f + ≡⟨ cong (_∘ R.fmap f) (sym ℂ.isAssociative) ⟩ + (joinT Z ∘ (joinT (R.omap Z) ∘ R².fmap g)) ∘ R.fmap f + ≡⟨ cong (λ φ → φ ∘ R.fmap f) (cong (_∘_ (joinT Z)) (joinN g)) ⟩ + (joinT Z ∘ (R.fmap g ∘ joinT Y)) ∘ R.fmap f + ≡⟨ cong (_∘ R.fmap f) ℂ.isAssociative ⟩ + joinT Z ∘ R.fmap g ∘ joinT Y ∘ R.fmap f + ≡⟨ sym (Category.isAssociative ℂ) ⟩ + joinT Z ∘ R.fmap g ∘ (joinT Y ∘ R.fmap f) + ∎ + +record Monad : Set ℓ where + field + raw : RawMonad + isMonad : IsMonad raw + open IsMonad isMonad public + +private + module _ {m : RawMonad} where + open RawMonad m + propIsAssociative : isProp IsAssociative + propIsAssociative x y i {X} + = Category.arrowsAreSets ℂ _ _ (x {X}) (y {X}) i + propIsInverse : isProp IsInverse + propIsInverse x y i {X} = e1 i , e2 i + where + xX = x {X} + yX = y {X} + e1 = Category.arrowsAreSets ℂ _ _ (proj₁ xX) (proj₁ yX) + e2 = Category.arrowsAreSets ℂ _ _ (proj₂ xX) (proj₂ yX) + + open IsMonad + propIsMonad : (raw : _) → isProp (IsMonad raw) + IsMonad.isAssociative (propIsMonad raw a b i) j + = propIsAssociative {raw} + (isAssociative a) (isAssociative b) i j + IsMonad.isInverse (propIsMonad raw a b i) + = propIsInverse {raw} + (isInverse a) (isInverse b) i + +module _ {m n : Monad} (eq : Monad.raw m ≡ Monad.raw n) where + private + eqIsMonad : (λ i → IsMonad (eq i)) [ Monad.isMonad m ≡ Monad.isMonad n ] + eqIsMonad = lemPropF propIsMonad eq + + Monad≡ : m ≡ n + Monad.raw (Monad≡ i) = eq i + Monad.isMonad (Monad≡ i) = eqIsMonad i diff --git a/src/Cat/Category/Monad/Voevodsky.agda b/src/Cat/Category/Monad/Voevodsky.agda index 02898a1..7644f53 100644 --- a/src/Cat/Category/Monad/Voevodsky.agda +++ b/src/Cat/Category/Monad/Voevodsky.agda @@ -12,7 +12,9 @@ open import Cubical.GradLemma using (gradLemma) open import Cat.Category open import Cat.Category.Functor as F open import Cat.Category.NaturalTransformation -open import Cat.Category.Monad +open import Cat.Category.Monad using (Monoidal≃Kleisli) +import Cat.Category.Monad.Monoidal as Monoidal +import Cat.Category.Monad.Kleisli as Kleisli open import Cat.Categories.Fun module _ {ℓa ℓb : Level} (ℂ : Category ℓa ℓb) where