├── .gitignore ├── Setup.lhs ├── Data ├── Category │ ├── Unit.hs │ ├── Product.hs │ ├── Void.hs │ ├── NNO.hs │ ├── Enriched │ │ ├── Yoneda.hs │ │ ├── Poset3.hs │ │ ├── Limit.hs │ │ └── Functor.hs │ ├── Constraint.hs │ ├── Yoneda.hs │ ├── Kleisli.hs │ ├── Cube.hs │ ├── Preorder.hs │ ├── RepresentableFunctor.hs │ ├── Fix.hs │ ├── Dialg.hs │ ├── Comma.hs │ ├── Enriched.hs │ ├── Fin.hs │ ├── Adjunction.hs │ ├── Simplex.hs │ ├── CartesianClosed.hs │ ├── WeightedLimit.hs │ ├── Coproduct.hs │ ├── KanExtension.hs │ ├── Functor.hs │ ├── Boolean.hs │ ├── NaturalTransformation.hs │ ├── Monoidal.hs │ └── Limit.hs └── Category.hs ├── README ├── LICENSE └── data-category.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | .DS_Store 2 | dist-newstyle -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain -------------------------------------------------------------------------------- /Data/Category/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Unit 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Unit where 12 | 13 | import Data.Category 14 | 15 | 16 | data Unit a b where 17 | Unit :: Unit () () 18 | 19 | -- | `Unit` is the category with one object. 20 | instance Category Unit where 21 | 22 | src Unit = Unit 23 | tgt Unit = Unit 24 | 25 | Unit . Unit = Unit 26 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Data-category is a collection of categories, and some categorical constructions on them. 2 | 3 | You can restrict the types of the objects of your category by using a GADT for the arrow type. 4 | To be able to proof to the compiler that a type is an object in some category, objects also need to be represented at the value level. 5 | The corresponding identity arrow of the object is used for that. 6 | 7 | See the 'Monoid', 'Boolean' and 'Product' categories for some examples. 8 | 9 | Note: Strictly speaking this package defines Hask-enriched categories, not ordinary categories (which are Set-enriched.) 10 | In practice this means we are allowed to ignore 'undefined' (f.e. when talking about uniqueness of morphisms), 11 | and we can treat the categories as normal categories. -------------------------------------------------------------------------------- /Data/Category/Product.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, GADTs, FlexibleContexts, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Product 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Product where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category 16 | 17 | 18 | data (:**:) :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where 19 | (:**:) :: c1 a1 b1 -> c2 a2 b2 -> (:**:) c1 c2 (a1, a2) (b1, b2) 20 | 21 | -- | The product category of categories @c1@ and @c2@. 22 | instance (Category c1, Category c2) => Category (c1 :**: c2) where 23 | 24 | src (a1 :**: a2) = src a1 :**: src a2 25 | tgt (a1 :**: a2) = tgt a1 :**: tgt a2 26 | 27 | (a1 :**: a2) . (b1 :**: b2) = (a1 . b1) :**: (a2 . b2) -------------------------------------------------------------------------------- /Data/Category/Void.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase, LambdaCase, TypeOperators, GADTs, TypeFamilies, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Void 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Void where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category 16 | import Data.Category.Functor 17 | import Data.Category.NaturalTransformation 18 | 19 | 20 | data Void a b 21 | 22 | magic :: Void a b -> x 23 | magic = \case { } 24 | 25 | -- | `Void` is the category with no objects. 26 | instance Category Void where 27 | 28 | src = magic 29 | tgt = magic 30 | 31 | (.) = magic 32 | 33 | 34 | voidNat :: (Functor f, Functor g, Dom f ~ Void, Dom g ~ Void, Cod f ~ d, Cod g ~ d) 35 | => f -> g -> Nat Void d f g 36 | voidNat f g = Nat f g magic 37 | 38 | 39 | data Magic (k :: Type -> Type -> Type) = Magic 40 | -- | Since there is nothing to map in `Void`, there's a functor from it to any other category. 41 | instance Category k => Functor (Magic k) where 42 | type Dom (Magic k) = Void 43 | type Cod (Magic k) = k 44 | 45 | Magic % f = magic f 46 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Sjoerd Visscher 2011 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Sjoerd Visscher nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | -------------------------------------------------------------------------------- /Data/Category.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, RankNTypes, PolyKinds, LinearTypes, FlexibleInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category ( 12 | 13 | -- * Category 14 | Category(..) 15 | , Obj 16 | , Kind 17 | 18 | -- * Opposite category 19 | , Op(..) 20 | 21 | -- * `(->)`/Hask 22 | , obj 23 | 24 | ) where 25 | 26 | import GHC.Exts 27 | import Data.Kind (Type) 28 | 29 | infixr 8 . 30 | 31 | -- | Whenever objects are required at value level, they are represented by their identity arrows. 32 | type Obj k a = k a a 33 | 34 | -- | An instance of @Category k@ declares the arrow @k@ as a category. 35 | class Category k where 36 | 37 | src :: k a b -> Obj k a 38 | tgt :: k a b -> Obj k b 39 | 40 | (.) :: k b c -> k a b -> k a c 41 | 42 | 43 | obj :: Obj (FUN m) a 44 | obj x = x 45 | 46 | -- | For @m ~ Many@: The category with Haskell types as objects and Haskell functions as arrows, i.e. @(->)@. 47 | -- For @m ~ One@: The category with Haskell types as objects and Haskell linear functions as arrows, i.e. @(%1->)@. 48 | instance Category (FUN m) where 49 | 50 | src _ = obj 51 | tgt _ = obj 52 | 53 | f . g = \x -> f (g x) 54 | 55 | 56 | newtype Op k a b = Op { unOp :: k b a } 57 | 58 | -- | @Op k@ is opposite category of the category @k@. 59 | instance Category k => Category (Op k) where 60 | 61 | src (Op a) = Op (tgt a) 62 | tgt (Op a) = Op (src a) 63 | 64 | (Op a) . (Op b) = Op (b . a) 65 | 66 | 67 | -- | @Kind k@ is the kind of the objects of the category @k@. 68 | type family Kind (k :: o -> o -> Type) :: Type where 69 | Kind (k :: o -> o -> Type) = o 70 | -------------------------------------------------------------------------------- /Data/Category/NNO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Peano 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.NNO where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category.Functor 16 | import Data.Category.Limit 17 | import Data.Category.Unit 18 | import Data.Category.Coproduct 19 | import Data.Category.Fix (Fix(..)) 20 | 21 | 22 | class HasTerminalObject k => HasNaturalNumberObject k where 23 | 24 | type NaturalNumberObject k :: Type 25 | 26 | zero :: k (TerminalObject k) (NaturalNumberObject k) 27 | succ :: k (NaturalNumberObject k) (NaturalNumberObject k) 28 | 29 | primRec :: k (TerminalObject k) a -> k a a -> k (NaturalNumberObject k) a 30 | 31 | 32 | data NatNum = Z | S NatNum 33 | 34 | instance HasNaturalNumberObject (->) where 35 | 36 | type NaturalNumberObject (->) = NatNum 37 | 38 | zero = \() -> Z 39 | succ = S 40 | 41 | primRec z _ Z = z () 42 | primRec z s (S n) = s (primRec z s n) 43 | 44 | 45 | -- type Nat = Fix ((:++:) Unit) 46 | 47 | -- instance HasNaturalNumberObject Cat where 48 | 49 | -- type NaturalNumberObject Cat = CatW Nat 50 | 51 | -- zero = CatA (Const (Fix (I1 Unit))) 52 | -- succ = CatA (Wrap :.: Inj2) 53 | 54 | -- primRec (CatA z) (CatA s) = CatA (PrimRec z s) 55 | 56 | -- data PrimRec z s = PrimRec z s 57 | -- instance (Functor z, Functor s, Dom z ~ Unit, Cod z ~ Dom s, Dom s ~ Cod s) => Functor (PrimRec z s) where 58 | -- type Dom (PrimRec z s) = Nat 59 | -- type Cod (PrimRec z s) = Cod z 60 | -- type PrimRec z s :% I1 () = z :% () 61 | -- type PrimRec z s :% I2 n = s :% PrimRec z s :% n 62 | -- PrimRec z _ % Fix (I1 Unit) = z % Unit 63 | -- PrimRec z s % Fix (I2 n) = s % PrimRec z s % n 64 | -------------------------------------------------------------------------------- /Data/Category/Enriched/Yoneda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators 3 | , TypeFamilies 4 | , GADTs 5 | , RankNTypes 6 | , PatternSynonyms 7 | , FlexibleContexts 8 | , FlexibleInstances 9 | , NoImplicitPrelude 10 | , UndecidableInstances 11 | , ScopedTypeVariables 12 | , ConstraintKinds 13 | , MultiParamTypeClasses 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Enriched.Yoneda 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Enriched.Yoneda where 25 | 26 | import Data.Kind (Type) 27 | 28 | import Data.Category (Category(..), Obj) 29 | import Data.Category.CartesianClosed (CartesianClosed(..), curry) 30 | import Data.Category.Limit (HasBinaryProducts(..), HasTerminalObject(..)) 31 | import Data.Category.Enriched 32 | import Data.Category.Enriched.Functor 33 | import Data.Category.Enriched.Limit 34 | 35 | 36 | yoneda :: forall f k x. (HasEnds (V k), EFunctorOf k (Self (V k)) f) => f -> Obj k x -> V k (End (V k) (EHomX_ k x :->>: f)) (f :%% x) 37 | yoneda f x = apply (hom x x) (getSelf (f %% x)) . (endCounit (EHomX_ x ->> f) x &&& id x . terminate (end (EHomX_ x ->> f))) 38 | 39 | yonedaInv :: forall f k x. (HasEnds (V k), EFunctor f, EDom f ~ k, ECod f ~ Self (V k)) => f -> Obj k x -> V k (f :%% x) (End (V k) (EHomX_ k x :->>: f)) 40 | yonedaInv f x = endFactorizer (EHomX_ x ->> f) h 41 | where 42 | h :: Obj k a -> V k (f :%% x) (Exponential (V k) (k $ (x, a)) (f :%% a)) 43 | h a = curry fx xa fa (apply fx fa . (map f x a . proj2 fx xa &&& proj1 fx xa)) 44 | where 45 | xa = hom x a 46 | Self fx = f %% x 47 | Self fa = f %% a 48 | 49 | data Y (k :: Type -> Type -> Type) = Y 50 | -- | Yoneda embedding 51 | instance (ECategory k, HasEnds (V k)) => EFunctor (Y k) where 52 | type EDom (Y k) = EOp k 53 | type ECod (Y k) = FunCat k (Self (V k)) 54 | type Y k :%% x = EHomX_ k x 55 | Y %% EOp x = FArr (EHomX_ x) (EHomX_ x) 56 | map Y (EOp a) (EOp b) = yonedaInv (EHomX_ b) a 57 | -------------------------------------------------------------------------------- /Data/Category/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GADTs 3 | , DataKinds 4 | , RankNTypes 5 | , TypeFamilies 6 | , TypeOperators 7 | , KindSignatures 8 | , ConstraintKinds 9 | , FlexibleInstances 10 | , ScopedTypeVariables 11 | , UndecidableInstances 12 | , QuantifiedConstraints 13 | , MultiParamTypeClasses 14 | , UndecidableSuperClasses 15 | , NoImplicitPrelude 16 | #-} 17 | ----------------------------------------------------------------------------- 18 | -- | 19 | -- Module : Data.Category.Constraint 20 | -- License : BSD-style (see the file LICENSE) 21 | -- 22 | -- Maintainer : sjoerd@w3future.com 23 | -- Stability : experimental 24 | -- Portability : non-portable 25 | ----------------------------------------------------------------------------- 26 | module Data.Category.Constraint where 27 | 28 | import Data.Kind (Constraint, Type) 29 | import GHC.Exts (Any) 30 | 31 | import Data.Category 32 | import Data.Category.Limit 33 | import Data.Category.CartesianClosed 34 | 35 | data Dict :: Constraint -> Type where 36 | Dict :: a => Dict a 37 | 38 | -- | Code mostly stolen from the constraints package 39 | newtype a :- b = Sub (a => Dict b) 40 | 41 | id :: a :- a 42 | id = Sub Dict 43 | 44 | instance Category (:-) where 45 | src _ = id 46 | tgt _ = id 47 | Sub c . Sub b = Sub (case b of Dict -> c) 48 | 49 | class Any => Bottom where 50 | no :: a 51 | instance HasInitialObject (:-) where 52 | type InitialObject (:-) = Bottom 53 | initialObject = id 54 | initialize _ = Sub no 55 | 56 | instance HasTerminalObject (:-) where 57 | type TerminalObject (:-) = () :: Constraint 58 | terminalObject = id 59 | terminate _ = Sub Dict 60 | 61 | instance HasBinaryProducts (:-) where 62 | type BinaryProduct (:-) a b = (a, b) :: Constraint 63 | proj1 _ _ = Sub Dict 64 | proj2 _ _ = Sub Dict 65 | Sub a &&& Sub b = Sub (case (a, b) of (Dict, Dict) -> Dict) 66 | 67 | class (a => b) => a :=>: b where ins :: a :- b 68 | instance (a => b) => a :=>: b where ins = Sub Dict 69 | 70 | instance CartesianClosed (:-) where 71 | type Exponential (:-) a b = a :=>: b 72 | apply _ _ = Sub Dict 73 | tuple _ _ = Sub Dict 74 | a ^^^ b = a ^^^ b -- TODO: Sub (toDict (a . ins . b)) where toDict :: (a :- b) -> Dict (a :=>: b) 75 | -------------------------------------------------------------------------------- /Data/Category/Yoneda.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, RankNTypes, TypeFamilies, PatternSynonyms, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Yoneda 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Yoneda where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category 16 | import Data.Category.Functor 17 | import Data.Category.NaturalTransformation 18 | import Data.Category.Adjunction 19 | 20 | type YonedaEmbedding k = Curry2 (Op k) k (Hom k) 21 | -- | The Yoneda embedding functor, @C -> Set^(C^op)@. 22 | pattern YonedaEmbedding :: Category k => YonedaEmbedding k 23 | pattern YonedaEmbedding = Curry2 Hom 24 | 25 | 26 | data Yoneda (k :: Type -> Type -> Type) f = Yoneda 27 | -- | 'Yoneda' converts a functor @f@ into a natural transformation from the hom functor to f. 28 | instance (Category k, Functor f, Dom f ~ Op k, Cod f ~ (->)) => Functor (Yoneda k f) where 29 | type Dom (Yoneda k f) = Op k 30 | type Cod (Yoneda k f) = (->) 31 | type Yoneda k f :% a = Nat (Op k) (->) (k :-*: a) f 32 | Yoneda % Op ab = \n -> n . YonedaEmbedding % ab 33 | 34 | 35 | -- | 'fromYoneda' and 'toYoneda' are together the isomophism from the Yoneda lemma. 36 | fromYoneda :: (Category k, Functor f, Dom f ~ Op k, Cod f ~ (->)) => f -> Nat (Op k) (->) (Yoneda k f) f 37 | fromYoneda f = Nat Yoneda f (\(Op a) n -> (n ! Op a) a) 38 | 39 | toYoneda :: (Category k, Functor f, Dom f ~ Op k, Cod f ~ (->)) => f -> Nat (Op k) (->) f (Yoneda k f) 40 | toYoneda f = Nat f Yoneda (\(Op a) fa -> Nat (Hom_X a) f (\_ h -> (f % Op h) fa)) 41 | 42 | 43 | haskUnit :: Obj (->) () 44 | haskUnit = obj 45 | 46 | data M1 = M1 47 | instance Functor M1 where 48 | type Dom M1 = Nat (Op (->)) (->) 49 | type Cod M1 = (->) 50 | type M1 :% f = f :% () 51 | M1 % n = n ! Op haskUnit 52 | 53 | haskIsTotal :: Adjunction (->) (Nat (Op (->)) (->)) M1 (YonedaEmbedding (->)) 54 | haskIsTotal = mkAdjunctionInit M1 YonedaEmbedding 55 | (\(Nat f _ _) -> Nat f (Hom_X (f % Op haskUnit)) (\_ fz z -> (f % Op (\() -> z)) fz)) 56 | (\_ n fu -> (n ! Op haskUnit) fu ()) 57 | -------------------------------------------------------------------------------- /Data/Category/Kleisli.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, TypeOperators, GADTs, FlexibleInstances, FlexibleContexts, RankNTypes, ScopedTypeVariables, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Kleisli 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- This is an attempt at the Kleisli category, and the construction 12 | -- of an adjunction for each monad. 13 | ----------------------------------------------------------------------------- 14 | module Data.Category.Kleisli where 15 | 16 | import Data.Category 17 | import Data.Category.Functor 18 | import Data.Category.NaturalTransformation 19 | import Data.Category.Monoidal 20 | import qualified Data.Category.Adjunction as A 21 | 22 | 23 | data Kleisli m a b where 24 | Kleisli :: (Functor m, Dom m ~ k, Cod m ~ k) => Monad m -> Obj k b -> k a (m :% b) -> Kleisli m a b 25 | 26 | kleisliId :: (Functor m, Dom m ~ k, Cod m ~ k) => Monad m -> Obj k a -> Kleisli m a a 27 | kleisliId m a = Kleisli m a (unit m ! a) 28 | 29 | -- | The category of Kleisli arrows. 30 | instance Category (Kleisli m) where 31 | 32 | src (Kleisli m _ f) = kleisliId m (src f) 33 | tgt (Kleisli m b _) = kleisliId m b 34 | 35 | (Kleisli m c f) . (Kleisli _ _ g) = Kleisli m c ((multiply m ! c) . (monadFunctor m % f) . g) 36 | 37 | 38 | 39 | newtype KleisliFree m = KleisliFree (Monad m) 40 | instance (Functor m, Dom m ~ k, Cod m ~ k) => Functor (KleisliFree m) where 41 | type Dom (KleisliFree m) = Dom m 42 | type Cod (KleisliFree m) = Kleisli m 43 | type KleisliFree m :% a = a 44 | KleisliFree m % f = Kleisli m (tgt f) ((unit m ! tgt f) . f) 45 | 46 | data KleisliForget m = KleisliForget 47 | instance (Functor m, Dom m ~ k, Cod m ~ k) => Functor (KleisliForget m) where 48 | type Dom (KleisliForget m) = Kleisli m 49 | type Cod (KleisliForget m) = Dom m 50 | type KleisliForget m :% a = m :% a 51 | KleisliForget % Kleisli m b f = (multiply m ! b) . (monadFunctor m % f) 52 | 53 | kleisliAdj :: (Functor m, Dom m ~ k, Cod m ~ k) 54 | => Monad m -> A.Adjunction (Kleisli m) k (KleisliFree m) (KleisliForget m) 55 | kleisliAdj m = A.mkAdjunctionInit (KleisliFree m) KleisliForget (unit m !) (\(Kleisli _ x _) f -> Kleisli m x f) 56 | -------------------------------------------------------------------------------- /Data/Category/Enriched/Poset3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators 3 | , TypeFamilies 4 | , GADTs 5 | , RankNTypes 6 | , PatternSynonyms 7 | , FlexibleContexts 8 | , FlexibleInstances 9 | , NoImplicitPrelude 10 | , UndecidableInstances 11 | , ScopedTypeVariables 12 | , ConstraintKinds 13 | , MultiParamTypeClasses 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Enriched.Poset3 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Enriched.Poset3 where 25 | 26 | import Data.Category.Boolean 27 | import Data.Category.Enriched 28 | 29 | data One 30 | data Two 31 | data Three 32 | data PosetTest a b where 33 | One :: PosetTest One One 34 | Two :: PosetTest Two Two 35 | Three :: PosetTest Three Three 36 | 37 | type family Poset3 a b where 38 | Poset3 Two One = Fls 39 | Poset3 Three One = Fls 40 | Poset3 Three Two = Fls 41 | Poset3 a b = Tru 42 | instance ECategory PosetTest where 43 | type V PosetTest = Boolean 44 | type PosetTest $ (a, b) = Poset3 a b 45 | hom One One = Tru 46 | hom One Two = Tru 47 | hom One Three = Tru 48 | hom Two One = Fls 49 | hom Two Two = Tru 50 | hom Two Three = Tru 51 | hom Three One = Fls 52 | hom Three Two = Fls 53 | hom Three Three = Tru 54 | 55 | id One = Tru 56 | id Two = Tru 57 | id Three = Tru 58 | comp One One One = Tru 59 | comp One One Two = Tru 60 | comp One One Three = Tru 61 | comp One Two One = F2T 62 | comp One Two Two = Tru 63 | comp One Two Three = Tru 64 | comp One Three One = F2T 65 | comp One Three Two = F2T 66 | comp One Three Three = Tru 67 | comp Two One One = Fls 68 | comp Two One Two = F2T 69 | comp Two One Three = F2T 70 | comp Two Two One = Fls 71 | comp Two Two Two = Tru 72 | comp Two Two Three = Tru 73 | comp Two Three One = Fls 74 | comp Two Three Two = F2T 75 | comp Two Three Three = Tru 76 | comp Three One One = Fls 77 | comp Three One Two = Fls 78 | comp Three One Three = F2T 79 | comp Three Two One = Fls 80 | comp Three Two Two = Fls 81 | comp Three Two Three = F2T 82 | comp Three Three One = Fls 83 | comp Three Three Two = Fls 84 | comp Three Three Three = Tru 85 | -------------------------------------------------------------------------------- /data-category.cabal: -------------------------------------------------------------------------------- 1 | name: data-category 2 | version: 0.11 3 | synopsis: Category theory 4 | 5 | description: Data-category is a collection of categories, and some categorical constructions on them. 6 | . 7 | You can restrict the types of the objects of your category by using a GADT for the arrow type. 8 | To be able to proof to the compiler that a type is an object in some category, objects also need to be represented at the value level. 9 | The corresponding identity arrow of the object is used for that. 10 | . 11 | See the 'Boolean' and 'Product' categories for some examples. 12 | . 13 | Note: Strictly speaking this package defines Hask-enriched categories, not ordinary categories (which are Set-enriched.) 14 | In practice this means we are allowed to ignore 'undefined' (f.e. when talking about uniqueness of morphisms), 15 | and we can treat the categories as normal categories. 16 | 17 | category: Math 18 | license: BSD3 19 | license-file: LICENSE 20 | author: Sjoerd Visscher 21 | maintainer: sjoerd@w3future.com 22 | stability: experimental 23 | homepage: http://github.com/sjoerdvisscher/data-category 24 | bug-reports: http://github.com/sjoerdvisscher/data-category/issues 25 | 26 | build-type: Simple 27 | cabal-version: >= 1.10 28 | 29 | Library 30 | exposed-modules: 31 | Data.Category, 32 | Data.Category.Functor, 33 | Data.Category.NaturalTransformation, 34 | Data.Category.Unit, 35 | Data.Category.Void, 36 | Data.Category.Product, 37 | Data.Category.Coproduct, 38 | Data.Category.RepresentableFunctor, 39 | Data.Category.Adjunction, 40 | Data.Category.Limit, 41 | Data.Category.WeightedLimit, 42 | Data.Category.KanExtension, 43 | Data.Category.Monoidal, 44 | Data.Category.CartesianClosed, 45 | Data.Category.Yoneda, 46 | Data.Category.Boolean, 47 | Data.Category.Fin, 48 | Data.Category.Fix, 49 | Data.Category.Kleisli, 50 | Data.Category.Dialg, 51 | Data.Category.NNO, 52 | Data.Category.Simplex, 53 | Data.Category.Cube, 54 | Data.Category.Comma, 55 | Data.Category.Preorder, 56 | Data.Category.Enriched, 57 | Data.Category.Enriched.Functor, 58 | Data.Category.Enriched.Limit, 59 | Data.Category.Enriched.Yoneda, 60 | Data.Category.Enriched.Poset3 61 | build-depends: 62 | base >=4.15 && <5, 63 | ghc-prim 64 | 65 | default-language: Haskell2010 66 | 67 | source-repository head 68 | type: git 69 | location: git://github.com/sjoerdvisscher/data-category.git 70 | -------------------------------------------------------------------------------- /Data/Category/Cube.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, RankNTypes, TypeOperators, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Cube 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- The cube category. 12 | ----------------------------------------------------------------------------- 13 | module Data.Category.Cube where 14 | 15 | import Data.Kind (Type) 16 | 17 | import Data.Category 18 | import Data.Category.Product 19 | import Data.Category.Functor 20 | import Data.Category.Monoidal 21 | import Data.Category.Limit 22 | 23 | 24 | data Z 25 | data S n 26 | 27 | 28 | data Sign = M | P 29 | 30 | data Cube :: Type -> Type -> Type where 31 | Z :: Cube Z Z 32 | S :: Cube x y -> Cube (S x) (S y) 33 | Y :: Sign -> Cube x y -> Cube x (S y) -- face maps 34 | X :: Cube x y -> Cube (S x) y -- degeneracy map 35 | 36 | 37 | instance Category Cube where 38 | src Z = Z 39 | src (S c) = S (src c) 40 | src (Y _ c) = src c 41 | src (X c) = S (src c) 42 | 43 | tgt Z = Z 44 | tgt (S c) = S (tgt c) 45 | tgt (Y _ c) = S (tgt c) 46 | tgt (X c) = tgt c 47 | 48 | Z . c = c 49 | c . Z = c 50 | S c . S d = S (c . d) 51 | S c . Y s d = Y s (c . d) 52 | Y s c . d = Y s (c . d) 53 | X c . S d = X (c . d) 54 | X c . Y _ d = c . d 55 | c . X d = X (c . d) 56 | 57 | 58 | instance HasTerminalObject Cube where 59 | type TerminalObject Cube = Z 60 | 61 | terminalObject = Z 62 | 63 | terminate Z = Z 64 | terminate (S f) = X (terminate f) 65 | 66 | 67 | data Sign0 = SM | S0 | SP 68 | 69 | data ACube :: Type -> Type where 70 | Nil :: ACube Z 71 | Cons :: Sign0 -> ACube n -> ACube (S n) 72 | 73 | data Forget = Forget 74 | -- | Turn @Cube x y@ arrows into @ACube x -> ACube y@ functions. 75 | instance Functor Forget where 76 | type Dom Forget = Cube 77 | type Cod Forget = (->) 78 | type Forget :% n = ACube n 79 | Forget % Z = \x -> x 80 | Forget % S f = \(Cons s x) -> Cons s ((Forget % f) x) 81 | Forget % Y M f = \x -> Cons SM ((Forget % f) x) 82 | Forget % Y P f = \x -> Cons SP ((Forget % f) x) 83 | Forget % X f = \(Cons _ x) -> (Forget % f) x 84 | 85 | 86 | data Add = Add 87 | -- | Ordinal addition is a bifuntor, it concattenates the maps as it were. 88 | instance Functor Add where 89 | type Dom Add = Cube :**: Cube 90 | type Cod Add = Cube 91 | type Add :% (Z , n) = n 92 | type Add :% (S m, n) = S (Add :% (m, n)) 93 | Add % (Z :**: g) = g 94 | Add % (S f :**: g) = S (Add % (f :**: g)) 95 | Add % (Y s f :**: g) = Y s (Add % (f :**: g)) 96 | Add % (X f :**: g) = X (Add % (f :**: g)) 97 | 98 | 99 | instance TensorProduct Add where 100 | type Unit Add = Z 101 | unitObject Add = Z 102 | 103 | leftUnitor Add a = a 104 | leftUnitorInv Add a = a 105 | rightUnitor Add Z = Z 106 | rightUnitor Add (S n) = S (rightUnitor Add n) 107 | rightUnitorInv Add Z = Z 108 | rightUnitorInv Add (S n) = S (rightUnitorInv Add n) 109 | associator Add Z Z n = n 110 | associator Add Z (S m) n = S (associator Add Z m n) 111 | associator Add (S l) m n = S (associator Add l m n) 112 | associatorInv Add Z Z n = n 113 | associatorInv Add Z (S m) n = S (associatorInv Add Z m n) 114 | associatorInv Add (S l) m n = S (associatorInv Add l m n) 115 | -------------------------------------------------------------------------------- /Data/Category/Preorder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs, TypeFamilies, PatternSynonyms, ScopedTypeVariables, RankNTypes, TypeOperators #-} 2 | module Data.Category.Preorder where 3 | 4 | import Prelude hiding ((.), id, Functor) 5 | 6 | import Data.Category 7 | import Data.Category.Limit 8 | import Data.Category.CartesianClosed 9 | import Data.Category.Functor 10 | import Data.Category.Adjunction 11 | import Data.Category.Enriched 12 | import Data.Category.Enriched.Functor 13 | import Data.Category.Enriched.Limit hiding (HasEnds(..)) 14 | 15 | data Preorder a x y where 16 | (:<=:) :: a -> a -> Preorder a x y 17 | 18 | pattern Obj :: a -> Preorder a x y 19 | pattern Obj a <- a :<=: _ where 20 | Obj a = a :<=: a 21 | {-# COMPLETE Obj #-} -- Note: only complete for identity arrows `Obj Preorder a` 22 | 23 | unObj :: Obj (Preorder a) x -> a 24 | unObj (Obj a) = a 25 | 26 | instance Eq a => Category (Preorder a) where 27 | src (s :<=: _) = Obj s 28 | tgt (_ :<=: t) = Obj t 29 | (b :<=: c) . (a :<=: b') = if b == b' then a :<=: c else error "Invalid composition" 30 | 31 | instance (Eq a, Bounded a) => HasInitialObject (Preorder a) where 32 | type InitialObject (Preorder a) = () 33 | initialObject = Obj minBound 34 | initialize (Obj a) = minBound :<=: a 35 | 36 | instance (Eq a, Bounded a) => HasTerminalObject (Preorder a) where 37 | type TerminalObject (Preorder a) = () 38 | terminalObject = Obj maxBound 39 | terminate (Obj a) = a :<=: maxBound 40 | 41 | instance Ord a => HasBinaryProducts (Preorder a) where 42 | type BinaryProduct (Preorder a) x y = () 43 | proj1 (Obj a) (Obj b) = min a b :<=: a 44 | proj2 (Obj a) (Obj b) = min a b :<=: b 45 | (a :<=: x) &&& (_a :<=: y) = a :<=: min x y 46 | 47 | instance Ord a => HasBinaryCoproducts (Preorder a) where 48 | type BinaryCoproduct (Preorder a) x y = () 49 | inj1 (Obj a) (Obj b) = a :<=: max a b 50 | inj2 (Obj a) (Obj b) = b :<=: max a b 51 | (x :<=: a) ||| (y :<=: _a) = max x y :<=: a 52 | 53 | -- | `ordExp a b` is the largest x such that min x a <= b 54 | ordExp :: (Ord a, Bounded a) => a -> a -> a 55 | ordExp a b = if a <= b then maxBound else b 56 | 57 | instance (Ord a, Bounded a) => CartesianClosed (Preorder a) where 58 | type Exponential (Preorder a) x y = () 59 | apply (Obj a) (Obj b) = min (ordExp a b) a :<=: b 60 | tuple (Obj a) (Obj b) = b :<=: ordExp a (min a b) 61 | (z1 :<=: z2) ^^^ (y2 :<=: y1) = ordExp y1 z1 :<=: ordExp y2 z2 62 | 63 | 64 | class Category k => EnumObjs k where 65 | enumObjs :: (forall a. Obj k a -> r) -> [r] 66 | 67 | glb :: (Ord a, Bounded a) => [a] -> a 68 | glb [] = maxBound 69 | glb xs = minimum xs 70 | 71 | 72 | type End' t = () 73 | end 74 | :: (VProfunctor k k t, V k ~ Preorder a, EnumObjs k, Ord a, Bounded a) 75 | => t -> Obj (Preorder a) (End' t) 76 | end t = Obj $ glb (enumObjs (\a -> unObj (getSelf (t %% (EOp a :<>: a))))) 77 | 78 | endCounit 79 | :: (VProfunctor k k t, V k ~ Preorder a, EnumObjs k, Ord a, Bounded a) 80 | => t -> Obj k b -> Preorder a (End' t) (t :%% (b, b)) 81 | endCounit t a = unObj (end t) :<=: unObj (getSelf (t %% (EOp a :<>: a))) 82 | 83 | endFactorizer 84 | :: (VProfunctor k k t, V k ~ Preorder a, EnumObjs k, Ord a, Bounded a) 85 | => t -> Obj (Preorder a) x -> (forall b. Obj k b -> Preorder a x (t :%% (b, b))) -> Preorder a x (End' t) 86 | endFactorizer _ (Obj x) f = x :<=: glb (enumObjs (\b -> case f b of _ :<=: tbb -> tbb)) 87 | 88 | 89 | data Floor = Floor 90 | instance Functor Floor where 91 | type Dom Floor = Preorder Double 92 | type Cod Floor = Preorder Integer 93 | type Floor :% a = () 94 | Floor % (a :<=: b) = floor a :<=: floor b 95 | 96 | data FromInteger = FromInteger 97 | instance Functor FromInteger where 98 | type Dom FromInteger = Preorder Integer 99 | type Cod FromInteger = Preorder Double 100 | type FromInteger :% a = () 101 | FromInteger % (a :<=: b) = fromInteger a :<=: fromInteger b 102 | 103 | floorGaloisConnection :: Adjunction (Preorder Double) (Preorder Integer) FromInteger Floor 104 | floorGaloisConnection = mkAdjunction FromInteger Floor 105 | (\(Obj a) (_fromIntegerA :<=: b) -> a :<=: floor b) 106 | (\(Obj b) (a :<=: _floorB) -> fromInteger a :<=: b) -------------------------------------------------------------------------------- /Data/Category/RepresentableFunctor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, RankNTypes, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.RepresentableFunctor 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.RepresentableFunctor where 12 | 13 | import Data.Category 14 | import Data.Category.Functor 15 | import Data.Category.NaturalTransformation 16 | import Data.Category.Adjunction 17 | 18 | 19 | data Representable f repObj = Representable 20 | { representedFunctor :: f 21 | , representingObject :: Obj (Dom f) repObj 22 | , represent :: forall k z. (Dom f ~ k, Cod f ~ (->)) => Obj k z -> f :% z -> k repObj z 23 | , universalElement :: forall k. (Dom f ~ k, Cod f ~ (->)) => f :% repObj 24 | } 25 | 26 | unrepresent :: (Functor f, Dom f ~ k, Cod f ~ (->)) => Representable f repObj -> k repObj z -> f :% z 27 | unrepresent rep h = (representedFunctor rep % h) (universalElement rep) 28 | 29 | covariantHomRepr :: Category k => Obj k x -> Representable (x :*-: k) x 30 | covariantHomRepr x = Representable 31 | { representedFunctor = HomX_ x 32 | , representingObject = x 33 | , represent = \_ h -> h 34 | , universalElement = x 35 | } 36 | 37 | contravariantHomRepr :: Category k => Obj k x -> Representable (k :-*: x) x 38 | contravariantHomRepr x = Representable 39 | { representedFunctor = Hom_X x 40 | , representingObject = Op x 41 | , represent = \_ h -> Op h 42 | , universalElement = x 43 | } 44 | 45 | type InitialUniversal x u a = Representable (x :*%: u) a 46 | -- | An initial universal property, a universal morphism from x to u. 47 | initialUniversal :: Functor u 48 | => u 49 | -> Obj (Dom u) a 50 | -> Cod u x (u :% a) 51 | -> (forall y. Obj (Dom u) y -> Cod u x (u :% y) -> Dom u a y) 52 | -> InitialUniversal x u a 53 | initialUniversal u ob mor factorizer = Representable 54 | { representedFunctor = HomXF (src mor) u 55 | , representingObject = ob 56 | , represent = factorizer 57 | , universalElement = mor 58 | } 59 | 60 | type TerminalUniversal x u a = Representable (u :%*: x) a 61 | -- | A terminal universal property, a universal morphism from u to x. 62 | terminalUniversal :: Functor u 63 | => u 64 | -> Obj (Dom u) a 65 | -> Cod u (u :% a) x 66 | -> (forall y. Obj (Dom u) y -> Cod u (u :% y) x -> Dom u y a) 67 | -> TerminalUniversal x u a 68 | terminalUniversal u ob mor factorizer = Representable 69 | { representedFunctor = HomFX u (tgt mor) 70 | , representingObject = Op ob 71 | , represent = \(Op y) f -> Op (factorizer y f) 72 | , universalElement = mor 73 | } 74 | 75 | 76 | -- | For an adjunction F -| G, each pair (FY, unit_Y) is an initial morphism from Y to G. 77 | adjunctionInitialProp :: Adjunction c d f g -> Obj d y -> InitialUniversal y g (f :% y) 78 | adjunctionInitialProp adj@(Adjunction f g _ _) y = initialUniversal g (f % y) (adjunctionUnit adj ! y) (rightAdjunct adj) 79 | 80 | -- | For an adjunction F -| G, each pair (GX, counit_X) is a terminal morphism from F to X. 81 | adjunctionTerminalProp :: Adjunction c d f g -> Obj c x -> TerminalUniversal x f (g :% x) 82 | adjunctionTerminalProp adj@(Adjunction f g _ _) x = terminalUniversal f (g % x) (adjunctionCounit adj ! x) (leftAdjunct adj) 83 | 84 | 85 | initialPropAdjunction :: forall f g c d. (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 86 | => f -> g -> (forall y. InitialUniversal y g (f :% y)) -> Adjunction c d f g 87 | initialPropAdjunction f g univ = mkAdjunctionInit f g (\_ -> universalElement univ) (represent univ) 88 | 89 | terminalPropAdjunction :: forall f g c d. (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 90 | => f -> g -> (forall x. TerminalUniversal x f (g :% x)) -> Adjunction c d f g 91 | terminalPropAdjunction f g univ = mkAdjunctionTerm f g ((unOp .) . represent univ . Op) (\_ -> universalElement univ) 92 | -------------------------------------------------------------------------------- /Data/Category/Fix.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, PatternSynonyms, TypeOperators, TypeFamilies, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Fix 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Fix where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category 16 | import Data.Category.Functor 17 | import Data.Category.Limit 18 | import Data.Category.CartesianClosed 19 | import Data.Category.Monoidal 20 | 21 | import qualified Data.Category.Unit as U 22 | import Data.Category.Coproduct 23 | 24 | 25 | newtype Fix f a b = Fix (f (Fix f) a b) 26 | 27 | -- | @`Fix` f@ is the fixed point category for a category combinator `f`. 28 | deriving instance Category (f (Fix f)) => Category (Fix f) 29 | 30 | -- | @Fix f@ inherits its (co)limits from @f (Fix f)@. 31 | instance HasInitialObject (f (Fix f)) => HasInitialObject (Fix f) where 32 | type InitialObject (Fix f) = InitialObject (f (Fix f)) 33 | initialObject = Fix initialObject 34 | initialize (Fix a) = Fix (initialize a) 35 | 36 | -- | @Fix f@ inherits its (co)limits from @f (Fix f)@. 37 | instance HasTerminalObject (f (Fix f)) => HasTerminalObject (Fix f) where 38 | type TerminalObject (Fix f) = TerminalObject (f (Fix f)) 39 | terminalObject = Fix terminalObject 40 | terminate (Fix a) = Fix (terminate a) 41 | 42 | -- | @Fix f@ inherits its (co)limits from @f (Fix f)@. 43 | instance HasBinaryProducts (f (Fix f)) => HasBinaryProducts (Fix f) where 44 | type BinaryProduct (Fix f) x y = BinaryProduct (f (Fix f)) x y 45 | proj1 (Fix a) (Fix b) = Fix (proj1 a b) 46 | proj2 (Fix a) (Fix b) = Fix (proj2 a b) 47 | Fix a &&& Fix b = Fix (a &&& b) 48 | 49 | -- | @Fix f@ inherits its (co)limits from @f (Fix f)@. 50 | instance HasBinaryCoproducts (f (Fix f)) => HasBinaryCoproducts (Fix f) where 51 | type BinaryCoproduct (Fix f) x y = BinaryCoproduct (f (Fix f)) x y 52 | inj1 (Fix a) (Fix b) = Fix (inj1 a b) 53 | inj2 (Fix a) (Fix b) = Fix (inj2 a b) 54 | Fix a ||| Fix b = Fix (a ||| b) 55 | 56 | -- | @Fix f@ inherits its exponentials from @f (Fix f)@. 57 | instance CartesianClosed (f (Fix f)) => CartesianClosed (Fix f) where 58 | type Exponential (Fix f) x y = Exponential (f (Fix f)) x y 59 | apply (Fix a) (Fix b) = Fix (apply a b) 60 | tuple (Fix a) (Fix b) = Fix (tuple a b) 61 | Fix a ^^^ Fix b = Fix (a ^^^ b) 62 | 63 | data Wrap (f :: Type -> Type -> Type) = Wrap 64 | -- | The `Wrap` functor wraps `Fix` around @f (Fix f)@. 65 | instance Category (f (Fix f)) => Functor (Wrap (Fix f)) where 66 | type Dom (Wrap (Fix f)) = f (Fix f) 67 | type Cod (Wrap (Fix f)) = Fix f 68 | type Wrap (Fix f) :% a = a 69 | Wrap % f = Fix f 70 | 71 | data Unwrap (f :: Type -> Type -> Type) = Unwrap 72 | -- | The `Unwrap` functor unwraps @Fix f@ to @f (Fix f)@. 73 | instance Category (f (Fix f)) => Functor (Unwrap (Fix f)) where 74 | type Dom (Unwrap (Fix f)) = Fix f 75 | type Cod (Unwrap (Fix f)) = f (Fix f) 76 | type Unwrap (Fix f) :% a = a 77 | Unwrap % Fix f = f 78 | 79 | type WrapTensor f t = Wrap f :.: t :.: (Unwrap f :***: Unwrap f) 80 | -- | @Fix f@ inherits tensor products from @f (Fix f)@. 81 | instance (TensorProduct t, Cod t ~ f (Fix f)) => TensorProduct (WrapTensor (Fix f) t) where 82 | type Unit (WrapTensor (Fix f) t) = Unit t 83 | unitObject (_ :.: t :.: _) = Fix (unitObject t) 84 | 85 | leftUnitor (_ :.: t :.: _) (Fix a) = Fix (leftUnitor t a) 86 | leftUnitorInv (_ :.: t :.: _) (Fix a) = Fix (leftUnitorInv t a) 87 | rightUnitor (_ :.: t :.: _) (Fix a) = Fix (rightUnitor t a) 88 | rightUnitorInv (_ :.: t :.: _) (Fix a) = Fix (rightUnitorInv t a) 89 | associator (_ :.: t :.: _) (Fix a) (Fix b) (Fix c) = Fix (associator t a b c) 90 | associatorInv (_ :.: t :.: _) (Fix a) (Fix b) (Fix c) = Fix (associatorInv t a b c) 91 | 92 | -- | Take the `Omega` category, add a new disctinct object, and an arrow from that object to every object in `Omega`, 93 | -- and you get `Omega` again. 94 | type Omega = Fix ((:>>:) U.Unit) 95 | 96 | type Z = I1 () 97 | type S n = I2 n 98 | pattern Z :: Obj Omega Z 99 | pattern Z = Fix (DC (I1A U.Unit)) 100 | pattern S :: Omega a b -> Omega (S a) (S b) 101 | pattern S n = Fix (DC (I2A n)) 102 | z2s :: Obj Omega n -> Omega Z (S n) 103 | z2s n = Fix (DC (I12 U.Unit n (Const (\() -> ())) ())) 104 | -------------------------------------------------------------------------------- /Data/Category/Dialg.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, GADTs, FlexibleInstances, FlexibleContexts, ViewPatterns, ScopedTypeVariables, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Dialg 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Dialg(F,G), the category of (F,G)-dialgebras and (F,G)-homomorphisms. 12 | ----------------------------------------------------------------------------- 13 | module Data.Category.Dialg where 14 | 15 | import Data.Category 16 | import Data.Category.Functor 17 | import Data.Category.NaturalTransformation 18 | import Data.Category.Limit 19 | import Data.Category.Product 20 | import Data.Category.Monoidal 21 | import qualified Data.Category.Adjunction as A 22 | 23 | 24 | -- | Objects of Dialg(F,G) are (F,G)-dialgebras. 25 | data Dialgebra f g a where 26 | Dialgebra :: (Category c, Category d, Dom f ~ c, Dom g ~ c, Cod f ~ d, Cod g ~ d, Functor f, Functor g) 27 | => Obj c a -> d (f :% a) (g :% a) -> Dialgebra f g a 28 | 29 | -- | Arrows of Dialg(F,G) are (F,G)-homomorphisms. 30 | data Dialg f g a b where 31 | DialgA :: (Category c, Category d, Dom f ~ c, Dom g ~ c, Cod f ~ d, Cod g ~ d, Functor f, Functor g) 32 | => Dialgebra f g a -> Dialgebra f g b -> c a b -> Dialg f g a b 33 | 34 | dialgId :: Dialgebra f g a -> Obj (Dialg f g) a 35 | dialgId d@(Dialgebra a _) = DialgA d d a 36 | 37 | dialgebra :: Obj (Dialg f g) a -> Dialgebra f g a 38 | dialgebra (DialgA d _ _) = d 39 | 40 | -- | The category of (F,G)-dialgebras. 41 | instance Category (Dialg f g) where 42 | 43 | src (DialgA s _ _) = dialgId s 44 | tgt (DialgA _ t _) = dialgId t 45 | 46 | DialgA _ t f . DialgA s _ g = DialgA s t (f . g) 47 | 48 | 49 | 50 | type Alg f = Dialg f (Id (Dom f)) 51 | type Algebra f a = Dialgebra f (Id (Dom f)) a 52 | type Coalg f = Dialg (Id (Dom f)) f 53 | type Coalgebra f a = Dialgebra (Id (Dom f)) f a 54 | 55 | -- | The initial F-algebra is the initial object in the category of F-algebras. 56 | type InitialFAlgebra f = InitialObject (Alg f) 57 | 58 | -- | The terminal F-coalgebra is the terminal object in the category of F-coalgebras. 59 | type TerminalFAlgebra f = TerminalObject (Coalg f) 60 | 61 | -- | A catamorphism of an F-algebra is the arrow to it from the initial F-algebra. 62 | type Cata f a = Algebra f a -> Alg f (InitialFAlgebra f) a 63 | 64 | -- | A anamorphism of an F-coalgebra is the arrow from it to the terminal F-coalgebra. 65 | type Ana f a = Coalgebra f a -> Coalg f a (TerminalFAlgebra f) 66 | 67 | 68 | 69 | 70 | 71 | data NatNum = Z () | S NatNum 72 | primRec :: (() -> t) -> (t -> t) -> NatNum -> t 73 | primRec z _ (Z ()) = z () 74 | primRec z s (S n) = s (primRec z s n) 75 | 76 | -- | The category for defining the natural numbers and primitive recursion can be described as 77 | -- @Dialg(F,G)@, with @F(A)=\<1,A>@ and @G(A)=\@. 78 | instance HasInitialObject (Dialg (Tuple1 (->) (->) ()) (DiagProd (->))) where 79 | 80 | type InitialObject (Dialg (Tuple1 (->) (->) ()) (DiagProd (->))) = NatNum 81 | 82 | initialObject = dialgId (Dialgebra obj (Z :**: S)) 83 | 84 | initialize (dialgebra -> d@(Dialgebra _ (z :**: s))) = DialgA (dialgebra initialObject) d (primRec z s) 85 | 86 | 87 | 88 | newtype FreeAlg m = FreeAlg (Monad m) 89 | -- | @FreeAlg@ M takes @x@ to the free algebra @(M x, mu_x)@ of the monad @M@. 90 | instance (Functor m, Dom m ~ k, Cod m ~ k) => Functor (FreeAlg m) where 91 | type Dom (FreeAlg m) = Dom m 92 | type Cod (FreeAlg m) = Alg m 93 | type FreeAlg m :% a = m :% a 94 | FreeAlg m % f = DialgA (freeAlg m (src f)) (freeAlg m (tgt f)) (monadFunctor m % f) 95 | 96 | freeAlg :: (Functor m, Dom m ~ k, Cod m ~ k) => Monad m -> Obj (Cod m) x -> Algebra m (m :% x) 97 | freeAlg m x = Dialgebra (monadFunctor m % x) (multiply m ! x) 98 | 99 | data ForgetAlg m = ForgetAlg 100 | -- | @ForgetAlg m@ is the forgetful functor for @Alg m@. 101 | instance (Functor m, Dom m ~ k, Cod m ~ k) => Functor (ForgetAlg m) where 102 | type Dom (ForgetAlg m) = Alg m 103 | type Cod (ForgetAlg m) = Dom m 104 | type ForgetAlg m :% a = a 105 | ForgetAlg % DialgA _ _ f = f 106 | 107 | eilenbergMooreAdj :: (Functor m, Dom m ~ k, Cod m ~ k) 108 | => Monad m -> A.Adjunction (Alg m) k (FreeAlg m) (ForgetAlg m) 109 | eilenbergMooreAdj m = A.mkAdjunctionUnits (FreeAlg m) ForgetAlg 110 | (unit m !) 111 | (\(DialgA b@(Dialgebra _ h) _ _) -> DialgA (Dialgebra (src h) (monadFunctor m % h)) b h) 112 | -------------------------------------------------------------------------------- /Data/Category/Comma.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, MultiParamTypeClasses, GADTs, FlexibleContexts, FlexibleInstances, ScopedTypeVariables, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Comma 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- Comma categories. 12 | ----------------------------------------------------------------------------- 13 | module Data.Category.Comma where 14 | 15 | import Data.Kind (Type) 16 | 17 | import Data.Category 18 | import Data.Category.Adjunction 19 | import Data.Category.Functor 20 | import Data.Category.Limit 21 | import Data.Category.RepresentableFunctor 22 | 23 | 24 | data CommaO :: Type -> Type -> Type -> Type where 25 | CommaO :: (Cod t ~ k, Cod s ~ k) 26 | => Obj (Dom t) a -> k (t :% a) (s :% b) -> Obj (Dom s) b -> CommaO t s (a, b) 27 | 28 | data (:/\:) :: Type -> Type -> Type -> Type -> Type where 29 | CommaA :: 30 | CommaO t s (a, b) -> 31 | Dom t a a' -> 32 | Dom s b b' -> 33 | CommaO t s (a', b') -> 34 | (t :/\: s) (a, b) (a', b') 35 | 36 | commaId :: CommaO t s (a, b) -> Obj (t :/\: s) (a, b) 37 | commaId o@(CommaO a _ b) = CommaA o a b o 38 | 39 | -- | The comma category T \\downarrow S 40 | instance (Category (Dom t), Category (Dom s)) => Category (t :/\: s) where 41 | 42 | src (CommaA so _ _ _) = commaId so 43 | tgt (CommaA _ _ _ to) = commaId to 44 | 45 | (CommaA _ g h to) . (CommaA so g' h' _) = CommaA so (g . g') (h . h') to 46 | 47 | 48 | type (f `ObjectsFUnder` a) = ConstF f a :/\: f 49 | type (f `ObjectsFOver` a) = f :/\: ConstF f a 50 | 51 | type (c `ObjectsUnder` a) = Id c `ObjectsFUnder` a 52 | type (c `ObjectsOver` a) = Id c `ObjectsFOver` a 53 | 54 | 55 | initialUniversalComma :: forall u x c a a_ 56 | . (Functor u, c ~ (u `ObjectsFUnder` x), HasInitialObject c, (a_, a) ~ InitialObject c) 57 | => u -> InitialUniversal x u a 58 | initialUniversalComma u = case initialObject :: Obj c (a_, a) of 59 | CommaA (CommaO _ mor a) _ _ _ -> 60 | initialUniversal u a mor factorizer 61 | where 62 | factorizer :: forall y. Obj (Dom u) y -> Cod u x (u :% y) -> Dom u a y 63 | factorizer y arr = case init (commaId (CommaO y arr y)) of CommaA _ _ f _ -> f 64 | where 65 | init :: Obj c (y, y) -> c (a_, a) (y, y) 66 | init = initialize 67 | 68 | terminalUniversalComma :: forall u x c a a_ 69 | . (Functor u, c ~ (u `ObjectsFOver` x), HasTerminalObject c, (a, a_) ~ TerminalObject c) 70 | => u -> TerminalUniversal x u a 71 | terminalUniversalComma u = case terminalObject :: Obj c (a, a_) of 72 | CommaA (CommaO a mor _) _ _ _ -> 73 | terminalUniversal u a mor factorizer 74 | where 75 | factorizer :: forall y. Obj (Dom u) y -> Cod u (u :% y) x -> Dom u y a 76 | factorizer y arr = case term (commaId (CommaO y arr y)) of CommaA _ f _ _ -> f 77 | where 78 | term :: Obj c (y, y) -> c (y, y) (a, a_) 79 | term = terminate 80 | 81 | 82 | type Arrows k = Id k :/\: Id k 83 | 84 | data IdArrow (k :: Type -> Type -> Type) = IdArrow 85 | instance Category k => Functor (IdArrow k) where 86 | type Dom (IdArrow k) = k 87 | type Cod (IdArrow k) = Arrows k 88 | type IdArrow k :% a = (a, a) 89 | IdArrow % f = CommaA 90 | (CommaO (src f) (src f) (src f)) 91 | f 92 | f 93 | (CommaO (tgt f) (tgt f) (tgt f)) 94 | 95 | data Src (k :: Type -> Type -> Type) = Src 96 | instance Category k => Functor (Src k) where 97 | type Dom (Src k) = Arrows k 98 | type Cod (Src k) = k 99 | type Src k :% (a, b) = a 100 | Src % (CommaA _ aa' _ _) = aa' 101 | 102 | data Tgt (k :: Type -> Type -> Type) = Tgt 103 | instance Category k => Functor (Tgt k) where 104 | type Dom (Tgt k) = Arrows k 105 | type Cod (Tgt k) = k 106 | type Tgt k :% (a, b) = b 107 | Tgt % (CommaA _ _ bb' _) = bb' 108 | 109 | -- | Taking the target of an arrow is left adjoint to taking the identity of an object 110 | tgtIdAdj :: Category k => Adjunction k (Arrows k) (Tgt k) (IdArrow k) 111 | tgtIdAdj = mkAdjunctionUnits Tgt IdArrow (\(CommaA o@(CommaO _ ab b) _ _ _) -> CommaA o ab b (CommaO b b b)) (\o -> o) 112 | 113 | -- | Taking the source of an arrow is right adjoint to taking the identity of an object 114 | idSrcAdj :: Category k => Adjunction (Arrows k) k (IdArrow k) (Src k) 115 | idSrcAdj = mkAdjunctionUnits IdArrow Src (\o -> o) (\(CommaA o@(CommaO a ab _) _ _ _) -> CommaA (CommaO a a a) a ab o) -------------------------------------------------------------------------------- /Data/Category/Enriched.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators 3 | , TypeFamilies 4 | , GADTs 5 | , RankNTypes 6 | , PatternSynonyms 7 | , FlexibleContexts 8 | , FlexibleInstances 9 | , NoImplicitPrelude 10 | , UndecidableInstances 11 | , ScopedTypeVariables 12 | , ConstraintKinds 13 | , MultiParamTypeClasses 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Enriched 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Enriched where 25 | 26 | import Data.Kind (Type) 27 | 28 | import Data.Category (Category(..), Obj, Op(..)) 29 | import Data.Category.Product 30 | import Data.Category.Functor (Functor(..), Hom(..)) 31 | import Data.Category.Limit (HasBinaryProducts(..), HasTerminalObject(..)) 32 | import Data.Category.CartesianClosed (CartesianClosed(..), ExpFunctor(..), curry, uncurry) 33 | 34 | -- | An enriched category 35 | class CartesianClosed (V k) => ECategory (k :: Type -> Type -> Type) where 36 | -- | The category V which k is enriched in 37 | type V k :: Type -> Type -> Type 38 | 39 | -- | The hom object in V from a to b 40 | type k $ ab :: Type 41 | hom :: Obj k a -> Obj k b -> Obj (V k) (k $ (a, b)) 42 | 43 | id :: Obj k a -> Arr k a a 44 | comp :: Obj k a -> Obj k b -> Obj k c -> V k (BinaryProduct (V k) (k $ (b, c)) (k $ (a, b))) (k $ (a, c)) 45 | 46 | 47 | -- | Arrows as elements of @k@ 48 | type Arr k a b = V k (TerminalObject (V k)) (k $ (a, b)) 49 | 50 | compArr :: ECategory k => Obj k a -> Obj k b -> Obj k c -> Arr k b c -> Arr k a b -> Arr k a c 51 | compArr a b c f g = comp a b c . (f &&& g) 52 | 53 | 54 | data Underlying k a b = Underlying (Obj k a) (Arr k a b) (Obj k b) 55 | -- | The underlying category of an enriched category 56 | instance ECategory k => Category (Underlying k) where 57 | src (Underlying a _ _) = Underlying a (id a) a 58 | tgt (Underlying _ _ b) = Underlying b (id b) b 59 | Underlying b f c . Underlying a g _ = Underlying a (compArr a b c f g) c 60 | 61 | 62 | newtype EOp k a b = EOp (k b a) 63 | -- | The opposite of an enriched category 64 | instance ECategory k => ECategory (EOp k) where 65 | type V (EOp k) = V k 66 | type EOp k $ (a, b) = k $ (b, a) 67 | hom (EOp a) (EOp b) = hom b a 68 | id (EOp a) = id a 69 | comp (EOp a) (EOp b) (EOp c) = comp c b a . (proj2 (hom c b) (hom b a) &&& proj1 (hom c b) (hom b a)) 70 | 71 | 72 | data (:<>:) :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where 73 | (:<>:) :: (V k1 ~ V k2) => Obj k1 a1 -> Obj k2 a2 -> (:<>:) k1 k2 (a1, a2) (a1, a2) 74 | 75 | -- | The enriched product category of enriched categories @c1@ and @c2@. 76 | instance (ECategory k1, ECategory k2, V k1 ~ V k2) => ECategory (k1 :<>: k2) where 77 | type V (k1 :<>: k2) = V k1 78 | type (k1 :<>: k2) $ ((a1, a2), (b1, b2)) = BinaryProduct (V k1) (k1 $ (a1, b1)) (k2 $ (a2, b2)) 79 | hom (a1 :<>: a2) (b1 :<>: b2) = hom a1 b1 *** hom a2 b2 80 | id (a1 :<>: a2) = id a1 &&& id a2 81 | comp (a1 :<>: a2) (b1 :<>: b2) (c1 :<>: c2) = 82 | comp a1 b1 c1 . (proj1 bc1 bc2 . proj1 l r &&& proj1 ab1 ab2 . proj2 l r) &&& 83 | comp a2 b2 c2 . (proj2 bc1 bc2 . proj1 l r &&& proj2 ab1 ab2 . proj2 l r) 84 | where 85 | ab1 = hom a1 b1 86 | ab2 = hom a2 b2 87 | bc1 = hom b1 c1 88 | bc2 = hom b2 c2 89 | l = bc1 *** bc2 90 | r = ab1 *** ab2 91 | 92 | 93 | newtype Self v a b = Self { getSelf :: v a b } 94 | -- | Self enrichment 95 | instance CartesianClosed v => ECategory (Self v) where 96 | type V (Self v) = v 97 | type Self v $ (a, b) = Exponential v a b 98 | hom (Self a) (Self b) = ExpFunctor % (Op a :**: b) 99 | id (Self a) = toSelf a 100 | comp (Self a) (Self b) (Self c) = curry (bc *** ab) a c (apply b c . (proj1 bc ab *** apply a b) . shuffle) 101 | where 102 | bc = c ^^^ b 103 | ab = b ^^^ a 104 | shuffle = proj1 (bc *** ab) a &&& (proj2 bc ab *** a) 105 | 106 | toSelf :: CartesianClosed v => v a b -> Arr (Self v) a b 107 | toSelf v = curry terminalObject (src v) (tgt v) (v . proj2 terminalObject (src v)) 108 | 109 | fromSelf :: forall v a b. CartesianClosed v => Obj v a -> Obj v b -> Arr (Self v) a b -> v a b 110 | fromSelf a b arr = uncurry terminalObject a b arr . (terminate a &&& a) 111 | 112 | 113 | newtype InHask k a b = InHask (k a b) 114 | -- | Any regular category is enriched in (->), aka Hask 115 | instance Category k => ECategory (InHask k) where 116 | type V (InHask k) = (->) 117 | type InHask k $ (a, b) = k a b 118 | hom (InHask a) (InHask b) = Hom % (Op a :**: b) 119 | id (InHask f) () = f 120 | comp _ _ _ (f, g) = f . g 121 | -------------------------------------------------------------------------------- /Data/Category/Fin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, PolyKinds, DataKinds, FlexibleInstances, FlexibleContexts, UndecidableInstances, NoImplicitPrelude #-} 2 | {-# LANGUAGE EmptyCase, TypeApplications, ScopedTypeVariables, TypeOperators #-} 3 | module Data.Category.Fin where 4 | 5 | import Data.Category 6 | import Data.Category.Limit 7 | import Data.Category.CartesianClosed 8 | 9 | data Nat = Z | S Nat 10 | 11 | data Fin n where 12 | FZ :: Fin ('S n) 13 | FS :: Fin n -> Fin ('S n) 14 | 15 | data LTE (n :: Nat) (a :: Fin n) (b :: Fin n) where 16 | ZEQ :: LTE ('S m) 'FZ 'FZ 17 | ZLT :: LTE ('S m) 'FZ b -> LTE ('S ('S m)) 'FZ ('FS b) 18 | SLT :: LTE ('S m) a b -> LTE ('S ('S m)) ('FS a) ('FS b) 19 | 20 | instance Category (LTE n) where 21 | src ZEQ = ZEQ 22 | src (ZLT _) = ZEQ 23 | src (SLT a) = SLT (src a) 24 | tgt ZEQ = ZEQ 25 | tgt (ZLT a) = SLT (tgt a) 26 | tgt (SLT a) = SLT (tgt a) 27 | ZEQ . a = a 28 | a . ZEQ = a 29 | SLT a . ZLT b = ZLT (a . b) 30 | SLT a . SLT b = SLT (a . b) 31 | 32 | instance HasInitialObject (LTE ('S n)) where 33 | type InitialObject (LTE ('S n)) = 'FZ 34 | initialObject = ZEQ 35 | initialize ZEQ = ZEQ 36 | initialize (SLT a) = ZLT (initialize a) 37 | 38 | instance HasTerminalObject (LTE ('S 'Z)) where 39 | type TerminalObject (LTE ('S 'Z)) = 'FZ 40 | terminalObject = ZEQ 41 | terminate ZEQ = ZEQ 42 | 43 | instance HasTerminalObject (LTE ('S n)) => HasTerminalObject (LTE ('S ('S n))) where 44 | type TerminalObject (LTE ('S ('S n))) = 'FS (TerminalObject (LTE ('S n))) 45 | terminalObject = SLT terminalObject 46 | terminate ZEQ = ZLT (terminate ZEQ) 47 | terminate (SLT a) = SLT (terminate a) 48 | 49 | instance HasBinaryCoproducts (LTE ('S 'Z)) where 50 | type BinaryCoproduct (LTE ('S 'Z)) 'FZ 'FZ = 'FZ 51 | inj1 ZEQ ZEQ = ZEQ 52 | inj2 ZEQ ZEQ = ZEQ 53 | ZEQ ||| ZEQ = ZEQ 54 | 55 | instance HasBinaryCoproducts (LTE ('S n)) => HasBinaryCoproducts (LTE ('S ('S n))) where 56 | type BinaryCoproduct (LTE ('S ('S n))) 'FZ 'FZ = 'FZ 57 | type BinaryCoproduct (LTE ('S ('S n))) 'FZ ('FS b) = 'FS (BinaryCoproduct (LTE ('S n)) 'FZ b) 58 | type BinaryCoproduct (LTE ('S ('S n))) ('FS a) 'FZ = 'FS (BinaryCoproduct (LTE ('S n)) a 'FZ) 59 | type BinaryCoproduct (LTE ('S ('S n))) ('FS a) ('FS b) = 'FS (BinaryCoproduct (LTE ('S n)) a b) 60 | inj1 ZEQ ZEQ = ZEQ 61 | inj1 ZEQ (SLT a) = ZLT (inj1 ZEQ a) 62 | inj1 (SLT a) ZEQ = SLT (inj1 a ZEQ) 63 | inj1 (SLT a) (SLT b) = SLT (inj1 a b) 64 | inj2 ZEQ ZEQ = ZEQ 65 | inj2 ZEQ (SLT a) = SLT (inj2 ZEQ a) 66 | inj2 (SLT a) ZEQ = ZLT (inj2 a ZEQ) 67 | inj2 (SLT a) (SLT b) = SLT (inj2 a b) 68 | ZEQ ||| ZEQ = ZEQ 69 | ZLT a ||| ZLT b = ZLT (case a ||| b of { ZEQ -> ZEQ; ZLT n -> ZLT n }) 70 | ZLT a ||| SLT b = SLT (a ||| b) 71 | SLT a ||| ZLT b = SLT (a ||| b) 72 | SLT a ||| SLT b = SLT (a ||| b) 73 | 74 | instance HasBinaryProducts (LTE ('S 'Z)) where 75 | type BinaryProduct (LTE ('S 'Z)) 'FZ 'FZ = 'FZ 76 | proj1 ZEQ ZEQ = ZEQ 77 | proj2 ZEQ ZEQ = ZEQ 78 | ZEQ &&& ZEQ = ZEQ 79 | 80 | instance HasBinaryProducts (LTE ('S n)) => HasBinaryProducts (LTE ('S ('S n))) where 81 | type BinaryProduct (LTE ('S ('S n))) 'FZ 'FZ = 'FZ 82 | type BinaryProduct (LTE ('S ('S n))) 'FZ ('FS b) = 'FZ 83 | type BinaryProduct (LTE ('S ('S n))) ('FS a) 'FZ = 'FZ 84 | type BinaryProduct (LTE ('S ('S n))) ('FS a) ('FS b) = 'FS (BinaryProduct (LTE ('S n)) a b) 85 | proj1 ZEQ ZEQ = ZEQ 86 | proj1 ZEQ (SLT _) = ZEQ 87 | proj1 (SLT a) ZEQ = ZLT (case proj1 a ZEQ of { ZEQ -> ZEQ; ZLT n -> ZLT n }) 88 | proj1 (SLT a) (SLT b) = SLT (proj1 a b) 89 | proj2 ZEQ ZEQ = ZEQ 90 | proj2 ZEQ (SLT a) = ZLT (case proj2 ZEQ a of { ZEQ -> ZEQ; ZLT n -> ZLT n }) 91 | proj2 (SLT _) ZEQ = ZEQ 92 | proj2 (SLT a) (SLT b) = SLT (proj2 a b) 93 | ZEQ &&& ZEQ = ZEQ 94 | ZEQ &&& ZLT _ = ZEQ 95 | ZLT _ &&& ZEQ = ZEQ 96 | ZLT a &&& ZLT b = ZLT (a &&& b) 97 | SLT a &&& SLT b = SLT (a &&& b) 98 | 99 | data Proof a n where 100 | Proof :: (BinaryProduct (LTE ('S n)) 'FZ a ~ 'FZ, BinaryProduct (LTE ('S n)) a 'FZ ~ 'FZ) => Proof a n 101 | proof :: Obj (LTE ('S n)) a -> Proof a n 102 | proof = proof -- trust me 103 | 104 | instance CartesianClosed (LTE ('S 'Z)) where 105 | type Exponential (LTE ('S 'Z)) 'FZ 'FZ = 'FZ 106 | apply ZEQ ZEQ = ZEQ 107 | tuple ZEQ ZEQ = ZEQ 108 | ZEQ ^^^ ZEQ = ZEQ 109 | 110 | -- b -> c = max(a: min(a, b) <= c) 111 | -- → 0 1 2 3 112 | -- +------- 113 | -- 0|3 3 3 3 114 | -- 1|0 3 3 3 115 | -- 2|0 1 3 3 116 | -- 3|0 1 2 3 117 | instance CartesianClosed (LTE ('S n)) => CartesianClosed (LTE ('S ('S n))) where 118 | type Exponential (LTE ('S ('S n))) 'FZ 'FZ = 'FS (Exponential (LTE ('S n)) 'FZ 'FZ) 119 | type Exponential (LTE ('S ('S n))) 'FZ ('FS b) = 'FS (Exponential (LTE ('S n)) 'FZ b) 120 | type Exponential (LTE ('S ('S n))) ('FS a) 'FZ = 'FZ 121 | type Exponential (LTE ('S ('S n))) ('FS a) ('FS b) = 'FS (Exponential (LTE ('S n)) a b) 122 | apply ZEQ ZEQ = ZEQ 123 | apply ZEQ (SLT a) = ZLT (case apply ZEQ a of { ZEQ -> ZEQ; ZLT n -> ZLT n }) 124 | apply (SLT _) ZEQ = ZEQ 125 | apply (SLT a) (SLT b) = SLT (apply a b) 126 | tuple ZEQ ZEQ = case proof (ZEQ @n) of Proof -> ZLT (tuple ZEQ ZEQ) 127 | tuple ZEQ (SLT a) = case proof (src a) of Proof -> SLT (tuple ZEQ a) 128 | tuple (SLT _) ZEQ = ZEQ 129 | tuple (SLT a) (SLT b) = SLT (tuple a b) 130 | ZEQ ^^^ ZEQ = SLT (ZEQ ^^^ ZEQ) 131 | ZEQ ^^^ ZLT a = ZLT (initialize (tgt (ZEQ ^^^ a))) 132 | ZEQ ^^^ SLT _ = ZEQ 133 | ZLT a ^^^ ZEQ = SLT (a ^^^ ZEQ) 134 | ZLT a ^^^ ZLT b = ZLT (initialize (tgt (a ^^^ b))) 135 | ZLT a ^^^ SLT b = ZLT (initialize (tgt (a ^^^ b))) 136 | SLT a ^^^ ZEQ = SLT (a ^^^ ZEQ) 137 | SLT a ^^^ ZLT b = SLT (a ^^^ b) 138 | SLT a ^^^ SLT b = SLT (a ^^^ b) 139 | 140 | -------------------------------------------------------------------------------- /Data/Category/Enriched/Limit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators 3 | , TypeFamilies 4 | , GADTs 5 | , RankNTypes 6 | , PatternSynonyms 7 | , FlexibleContexts 8 | , FlexibleInstances 9 | , NoImplicitPrelude 10 | , UndecidableInstances 11 | , ScopedTypeVariables 12 | , ConstraintKinds 13 | , MultiParamTypeClasses 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Enriched.Limit 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Enriched.Limit where 25 | 26 | import Data.Kind (Type) 27 | 28 | import Data.Category (Category(..), Obj) 29 | import Data.Category.Functor (Functor(..)) 30 | import Data.Category.Limit (HasBinaryProducts(..)) 31 | import Data.Category.CartesianClosed (CartesianClosed(..), curry, flip) 32 | import qualified Data.Category.WeightedLimit as Hask 33 | import Data.Category.Enriched 34 | import Data.Category.Enriched.Functor 35 | 36 | type VProfunctor k l t = EFunctorOf (EOp k :<>: l) (Self (V k)) t 37 | 38 | class CartesianClosed v => HasEnds v where 39 | type End (v :: Type -> Type -> Type) t :: Type 40 | end :: (VProfunctor k k t, V k ~ v) => t -> Obj v (End v t) 41 | endCounit :: (VProfunctor k k t, V k ~ v) => t -> Obj k a -> v (End v t) (t :%% (a, a)) 42 | endFactorizer :: (VProfunctor k k t, V k ~ v) => t -> (forall a. Obj k a -> v x (t :%% (a, a))) -> v x (End v t) 43 | 44 | 45 | newtype HaskEnd t = HaskEnd { getHaskEnd :: forall k a. VProfunctor k k t => t -> Obj k a -> t :%% (a, a) } 46 | instance HasEnds (->) where 47 | type End (->) t = HaskEnd t 48 | end _ e = e 49 | endCounit t a (HaskEnd e) = e t a 50 | endFactorizer _ e x = HaskEnd (\_ a -> e a x) 51 | 52 | 53 | data FunCat a b t s where 54 | FArr :: (EFunctorOf a b t, EFunctorOf a b s) => t -> s -> FunCat a b t s 55 | 56 | type t :->>: s = EHom (ECod t) :.: (Opposite t :<*>: s) 57 | (->>) :: (EFunctor t, EFunctor s, ECod t ~ ECod s, V (ECod t) ~ V (ECod s)) => t -> s -> t :->>: s 58 | t ->> s = EHom :.: (Opposite t :<*>: s) 59 | -- | The enriched functor category @[a, b]@ 60 | instance (HasEnds (V a), CartesianClosed (V a), V a ~ V b) => ECategory (FunCat a b) where 61 | type V (FunCat a b) = V a 62 | type FunCat a b $ (t, s) = End (V a) (t :->>: s) 63 | hom (FArr t _) (FArr s _) = end (t ->> s) 64 | id (FArr t _) = endFactorizer (t ->> t) (\a -> id (t %% a)) 65 | comp (FArr t _) (FArr s _) (FArr r _) = endFactorizer (t ->> r) 66 | (\a -> comp (t %% a) (s %% a) (r %% a) . (endCounit (s ->> r) a *** endCounit (t ->> s) a)) 67 | 68 | 69 | data EndFunctor (k :: Type -> Type -> Type) = EndFunctor 70 | instance (HasEnds (V k), ECategory k) => EFunctor (EndFunctor k) where 71 | type EDom (EndFunctor k) = FunCat (EOp k :<>: k) (Self (V k)) 72 | type ECod (EndFunctor k) = Self (V k) 73 | type EndFunctor k :%% t = End (V k) t 74 | EndFunctor %% (FArr t _) = Self (end t) 75 | map EndFunctor (FArr f _) (FArr g _) = curry (end (f ->> g)) (end f) (end g) (endFactorizer g (\a -> 76 | let aa = EOp a :<>: a in apply (getSelf (f %% aa)) (getSelf (g %% aa)) . (endCounit (f ->> g) aa *** endCounit f a))) 77 | 78 | 79 | -- d :: j -> k, w :: j -> Self (V k) 80 | type family WeigtedLimit (k :: Type -> Type -> Type) w d :: Type 81 | type Lim w d = WeigtedLimit (ECod d) w d 82 | 83 | class (HasEnds (V k), EFunctor w, ECod w ~ Self (V k)) => HasLimits k w where 84 | limitObj :: EFunctorOf (EDom w) k d => w -> d -> Obj k (Lim w d) 85 | limit :: EFunctorOf (EDom w) k d => w -> d -> Obj k e -> V k (k $ (e, Lim w d)) (End (V k) (w :->>: (EHomX_ k e :.: d))) 86 | limitInv :: EFunctorOf (EDom w) k d => w -> d -> Obj k e -> V k (End (V k) (w :->>: (EHomX_ k e :.: d))) (k $ (e, Lim w d)) 87 | 88 | -- d :: j -> k, w :: EOp j -> Self (V k) 89 | type family WeigtedColimit (k :: Type -> Type -> Type) w d :: Type 90 | type Colim w d = WeigtedColimit (ECod d) w d 91 | 92 | class (HasEnds (V k), EFunctor w, ECod w ~ Self (V k)) => HasColimits k w where 93 | colimitObj :: (EFunctorOf j k d, EOp j ~ EDom w) => w -> d -> Obj k (Colim w d) 94 | colimit :: (EFunctorOf j k d, EOp j ~ EDom w) => w -> d -> Obj k e -> V k (k $ (Colim w d, e)) (End (V k) (w :->>: (EHom_X k e :.: Opposite d))) 95 | colimitInv :: (EFunctorOf j k d, EOp j ~ EDom w) => w -> d -> Obj k e -> V k (End (V k) (w :->>: (EHom_X k e :.: Opposite d))) (k $ (Colim w d, e)) 96 | 97 | 98 | type instance WeigtedLimit (Self v) w d = End v (w :->>: d) 99 | instance (HasEnds v, EFunctor w, ECod w ~ Self v) => HasLimits (Self v) w where 100 | limitObj w d = Self (end (w ->> d)) 101 | limit w d (Self e) = let wed = w ->> (EHomX_ (Self e) :.: d) in endFactorizer wed 102 | (\a -> let { Self wa = w %% a; Self da = d %% a } in flip e wa da . (endCounit (w ->> d) a ^^^ e)) 103 | limitInv w d (Self e) = let wed = w ->> (EHomX_ (Self e) :.: d) in curry (end wed) e (end (w ->> d)) 104 | (endFactorizer (w ->> d) (\a -> let { Self wa = w %% a; Self da = d %% a } in apply e (da ^^^ wa) . (flip wa e da . endCounit wed a *** e))) 105 | 106 | type instance WeigtedLimit (InHask k) (InHaskToHask w) d = Hask.WeightedLimit k w (UnderlyingHask (Dom w) k d) 107 | instance Hask.HasWLimits k w => HasLimits (InHask k) (InHaskToHask w) where 108 | limitObj (InHaskToHask w) d = InHask (Hask.limitObj w (UnderlyingHask d)) 109 | limit (InHaskToHask w) d _ el = HaskEnd (\_ (InHask a) wa -> Hask.limit w (UnderlyingHask d) a wa . el) 110 | limitInv (InHaskToHask w) d (InHask e) (HaskEnd n) = 111 | Hask.limitFactorizer w (UnderlyingHask d) e (n (InHaskToHask w ->> (EHomX_ (InHask e) :.: d)) . InHask) 112 | -------------------------------------------------------------------------------- /Data/Category/Adjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, GADTs, FlexibleContexts, ScopedTypeVariables, RankNTypes, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Adjunction 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Adjunction ( 12 | 13 | -- * Adjunctions 14 | Adjunction(..) 15 | , mkAdjunction 16 | , mkAdjunctionUnits 17 | , mkAdjunctionInit 18 | , mkAdjunctionTerm 19 | 20 | , leftAdjunct 21 | , rightAdjunct 22 | , adjunctionUnit 23 | , adjunctionCounit 24 | 25 | -- * Adjunctions as a category 26 | , idAdj 27 | , composeAdj 28 | , AdjArrow(..) 29 | 30 | -- * Examples 31 | , precomposeAdj 32 | , postcomposeAdj 33 | , contAdj 34 | 35 | ) where 36 | 37 | import Data.Category 38 | import Data.Category.Functor 39 | import Data.Category.Product 40 | import Data.Category.NaturalTransformation 41 | 42 | data Adjunction c d f g = (Functor f, Functor g, Category c, Category d, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 43 | => Adjunction 44 | { leftAdjoint :: f 45 | , rightAdjoint :: g 46 | , leftAdjunctN :: Profunctors c d (Costar f) (Star g) 47 | , rightAdjunctN :: Profunctors c d (Star g) (Costar f) 48 | } 49 | 50 | -- | Make an adjunction from the hom-set isomorphism. 51 | mkAdjunction :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 52 | => f -> g 53 | -> (forall a b. Obj d a -> c (f :% a) b -> d a (g :% b)) 54 | -> (forall a b. Obj c b -> d a (g :% b) -> c (f :% a) b) 55 | -> Adjunction c d f g 56 | mkAdjunction f g l r = Adjunction f g (Nat (Costar f) (Star g) (\(Op a :**: _) -> l a)) (Nat (Star g) (Costar f) (\(_ :**: b) -> r b)) 57 | 58 | -- | Make an adjunction from the unit and counit. 59 | mkAdjunctionUnits :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 60 | => f -> g 61 | -> (forall a. Obj d a -> Component (Id d) (g :.: f) a) 62 | -> (forall a. Obj c a -> Component (f :.: g) (Id c) a) 63 | -> Adjunction c d f g 64 | mkAdjunctionUnits f g un coun = mkAdjunction f g (\a h -> (g % h) . un a) (\b h -> coun b . (f % h)) 65 | 66 | -- | Make an adjunction from an initial universal property. 67 | mkAdjunctionInit :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 68 | => f -> g 69 | -> (forall a. Obj d a -> d a (g :% (f :% a))) 70 | -> (forall a b. Obj c b -> d a (g :% b) -> c (f :% a) b) 71 | -> Adjunction c d f g 72 | mkAdjunctionInit f g un adj = mkAdjunction f g (\a h -> (g % h) . un a) adj 73 | 74 | -- | Make an adjunction from a terminal universal property. 75 | mkAdjunctionTerm :: (Functor f, Functor g, Dom f ~ d, Cod f ~ c, Dom g ~ c, Cod g ~ d) 76 | => f -> g 77 | -> (forall a b. Obj d a -> c (f :% a) b -> d a (g :% b)) 78 | -> (forall b. Obj c b -> c (f :% (g :% b)) b) 79 | -> Adjunction c d f g 80 | mkAdjunctionTerm f g adj coun = mkAdjunction f g adj (\b h -> coun b . (f % h)) 81 | 82 | leftAdjunct :: Adjunction c d f g -> Obj d a -> c (f :% a) b -> d a (g :% b) 83 | leftAdjunct (Adjunction _ _ l _) a h = (l ! (Op a :**: tgt h)) h 84 | rightAdjunct :: Adjunction c d f g -> Obj c b -> d a (g :% b) -> c (f :% a) b 85 | rightAdjunct (Adjunction _ _ _ r) b h = (r ! (Op (src h) :**: b)) h 86 | 87 | adjunctionUnit :: Adjunction c d f g -> Nat d d (Id d) (g :.: f) 88 | adjunctionUnit adj@(Adjunction f g _ _) = Nat Id (g :.: f) (\a -> leftAdjunct adj a (f % a)) 89 | adjunctionCounit :: Adjunction c d f g -> Nat c c (f :.: g) (Id c) 90 | adjunctionCounit adj@(Adjunction f g _ _) = Nat (f :.: g) Id (\b -> rightAdjunct adj b (g % b)) 91 | 92 | 93 | idAdj :: Category k => Adjunction k k (Id k) (Id k) 94 | idAdj = mkAdjunction Id Id (\_ f -> f) (\_ f -> f) 95 | 96 | composeAdj :: Adjunction d e f g -> Adjunction c d f' g' -> Adjunction c e (f' :.: f) (g :.: g') 97 | composeAdj l@(Adjunction f g _ _) r@(Adjunction f' g' _ _) = mkAdjunction (f' :.: f) (g :.: g') 98 | (\a -> leftAdjunct l a . leftAdjunct r (f % a)) (\b -> rightAdjunct r b . rightAdjunct l (g' % b)) 99 | 100 | 101 | data AdjArrow c d where 102 | AdjArrow :: (Category c, Category d) => Adjunction c d f g -> AdjArrow c d 103 | 104 | -- | The category with categories as objects and adjunctions as arrows. 105 | instance Category AdjArrow where 106 | 107 | src (AdjArrow Adjunction{}) = AdjArrow idAdj 108 | tgt (AdjArrow Adjunction{}) = AdjArrow idAdj 109 | 110 | AdjArrow x . AdjArrow y = AdjArrow (composeAdj x y) 111 | 112 | 113 | 114 | precomposeAdj :: Category e => Adjunction c d f g -> Adjunction (Nat c e) (Nat d e) (Precompose g e) (Precompose f e) 115 | precomposeAdj adj@(Adjunction f g _ _) = mkAdjunctionUnits 116 | (Precompose g) 117 | (Precompose f) 118 | (\nh@(Nat h _ _) -> compAssocInv h g f . (nh `o` adjunctionUnit adj) . idPrecompInv h) 119 | (\nh@(Nat h _ _) -> idPrecomp h . (nh `o` adjunctionCounit adj) . compAssoc h f g) 120 | 121 | postcomposeAdj :: Category e => Adjunction c d f g -> Adjunction (Nat e c) (Nat e d) (Postcompose f e) (Postcompose g e) 122 | postcomposeAdj adj@(Adjunction f g _ _) = mkAdjunctionUnits 123 | (Postcompose f) 124 | (Postcompose g) 125 | (\nh@(Nat h _ _) -> compAssoc g f h . (adjunctionUnit adj `o` nh) . idPostcompInv h) 126 | (\nh@(Nat h _ _) -> idPostcomp h . (adjunctionCounit adj `o` nh) . compAssocInv f g h) 127 | 128 | contAdj :: Adjunction (Op (->)) (->) (Opposite ((->) :-*: r) :.: OpOpInv (->)) ((->) :-*: r) 129 | contAdj = mkAdjunction 130 | (Opposite (Hom_X obj) :.: OpOpInv) 131 | (Hom_X obj) 132 | (\_ -> \(Op f) -> \b a -> f a b) 133 | (\_ -> \f -> Op (\b a -> f a b)) 134 | -------------------------------------------------------------------------------- /Data/Category/Simplex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, RankNTypes, TypeOperators, UndecidableInstances, LambdaCase, FlexibleContexts, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Simplex 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- The (augmented) simplex category. 12 | ----------------------------------------------------------------------------- 13 | module Data.Category.Simplex ( 14 | 15 | -- * Simplex Category 16 | Simplex(..) 17 | , Z, S 18 | , suc 19 | 20 | -- * Functor 21 | , Forget(..) 22 | , Fin(..) 23 | , Add(..) 24 | 25 | -- * The universal monoid 26 | , universalMonoid 27 | , Replicate(..) 28 | 29 | ) where 30 | 31 | import Data.Kind (Type) 32 | 33 | import Data.Category 34 | import Data.Category.Product 35 | import Data.Category.Functor 36 | import Data.Category.NaturalTransformation 37 | import Data.Category.Monoidal 38 | import Data.Category.Limit 39 | 40 | 41 | data Z 42 | data S n 43 | 44 | 45 | -- A Simplex x y structure plots a non-decreasing line, ending with Z 46 | -- 47 | -- ^ +-----Z 48 | -- | | XXY 49 | -- y | Y | 50 | -- |XXXY | 51 | -- XY----+ 52 | -- x -> 53 | 54 | data Simplex :: Type -> Type -> Type where 55 | Z :: Simplex Z Z 56 | Y :: Simplex x y -> Simplex x (S y) 57 | X :: Simplex x (S y) -> Simplex (S x) (S y) 58 | 59 | suc :: Obj Simplex n -> Obj Simplex (S n) 60 | suc = X . Y 61 | -- Note: Objects are represented by their identity arrows, 62 | -- which are in the shape of the elements of `iterate suc Z`. 63 | 64 | -- | The (augmented) simplex category is the category of finite ordinals and order preserving maps. 65 | instance Category Simplex where 66 | src Z = Z 67 | src (Y f) = src f 68 | src (X f) = suc (src f) 69 | 70 | tgt Z = Z 71 | tgt (Y f) = suc (tgt f) 72 | tgt (X f) = tgt f 73 | 74 | Z . f = f 75 | f . Z = f 76 | Y f . g = Y (f . g) 77 | X f . Y g = f . g 78 | X f . X g = X (X f . g) 79 | 80 | 81 | -- | The ordinal @0@ is the initial object of the simplex category. 82 | instance HasInitialObject Simplex where 83 | type InitialObject Simplex = Z 84 | 85 | initialObject = Z 86 | 87 | initialize Z = Z 88 | initialize (X (Y f)) = Y (initialize f) 89 | 90 | -- | The ordinal @1@ is the terminal object of the simplex category. 91 | instance HasTerminalObject Simplex where 92 | type TerminalObject Simplex = S Z 93 | 94 | terminalObject = suc Z 95 | 96 | terminate Z = Y Z 97 | terminate (X (Y f)) = X (terminate f) 98 | 99 | 100 | data Fin :: Type -> Type where 101 | Fz :: Fin (S n) 102 | Fs :: Fin n -> Fin (S n) 103 | 104 | data Forget = Forget 105 | -- | Turn @Simplex x y@ arrows into @Fin x -> Fin y@ functions. 106 | instance Functor Forget where 107 | type Dom Forget = Simplex 108 | type Cod Forget = (->) 109 | type Forget :% n = Fin n 110 | Forget % Z = obj 111 | Forget % Y f = Fs . (Forget % f) 112 | Forget % X f = \case 113 | Fz -> Fz 114 | Fs n -> (Forget % f) n 115 | 116 | 117 | data Add = Add 118 | -- | Ordinal addition is a bifuntor, it concattenates the maps as it were. 119 | instance Functor Add where 120 | type Dom Add = Simplex :**: Simplex 121 | type Cod Add = Simplex 122 | type Add :% (Z , n) = n 123 | type Add :% (S m, n) = S (Add :% (m, n)) 124 | Add % (Z :**: g) = g 125 | Add % (Y f :**: g) = Y (Add % (f :**: g)) 126 | Add % (X f :**: g) = X (Add % (f :**: g)) 127 | 128 | -- | Ordinal addition makes the simplex category a monoidal category, with @0@ as unit. 129 | instance TensorProduct Add where 130 | type Unit Add = Z 131 | unitObject Add = Z 132 | 133 | leftUnitor Add a = a 134 | leftUnitorInv Add a = a 135 | rightUnitor Add Z = Z 136 | rightUnitor Add (X (Y n)) = X (Y (rightUnitor Add n)) 137 | rightUnitorInv Add Z = Z 138 | rightUnitorInv Add (X (Y n)) = X (Y (rightUnitorInv Add n)) 139 | associator Add Z Z n = n 140 | associator Add Z (X (Y m)) n = X (Y (associator Add Z m n)) 141 | associator Add (X (Y l)) m n = X (Y (associator Add l m n)) 142 | associatorInv Add Z Z n = n 143 | associatorInv Add Z (X (Y m)) n = X (Y (associatorInv Add Z m n)) 144 | associatorInv Add (X (Y l)) m n = X (Y (associatorInv Add l m n)) 145 | 146 | 147 | -- | The maps @0 -> 1@ and @2 -> 1@ form a monoid, which is universal, c.f. `Replicate`. 148 | universalMonoid :: MonoidObject Add (S Z) 149 | universalMonoid = MonoidObject { unit = Y Z, multiply = X (X (Y Z)) } 150 | 151 | data Replicate f a = Replicate f (MonoidObject f a) 152 | -- | Replicate a monoid a number of times. 153 | instance TensorProduct f => Functor (Replicate f a) where 154 | type Dom (Replicate f a) = Simplex 155 | type Cod (Replicate f a) = Cod f 156 | type Replicate f a :% Z = Unit f 157 | type Replicate f a :% S n = f :% (a, Replicate f a :% n) 158 | Replicate f _ % Z = unitObject f 159 | Replicate f m % Y n = f % (unit m :**: tgt n') . leftUnitorInv f (tgt n') . n' where n' = Replicate f m % n 160 | Replicate f m % X (Y n) = f % (tgt (unit m) :**: (Replicate f m % n)) 161 | Replicate f m % X (X n) = n' . (f % (multiply m :**: b)) . associatorInv f a a b 162 | where 163 | n' = Replicate f m % X n 164 | a = tgt (unit m) 165 | b = src (Replicate f m % n) 166 | 167 | data Cobar f d = Cobar (Monad f) (Obj (Dom f) d) 168 | -- | The cobar construction 169 | instance Category (Dom f) => Functor (Cobar f d) where 170 | type Dom (Cobar f d) = Simplex 171 | type Cod (Cobar f d) = Dom f 172 | type Cobar f d :% s = (Replicate (EndoFunctorCompose (Dom f)) f :% s) :% d 173 | Cobar f d % s = (Replicate FunctorCompose f % s) ! d -------------------------------------------------------------------------------- /Data/Category/CartesianClosed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators, 3 | TypeFamilies, 4 | GADTs, 5 | PolyKinds, 6 | DataKinds, 7 | Rank2Types, 8 | PatternSynonyms, 9 | ScopedTypeVariables, 10 | UndecidableInstances, 11 | TypeSynonymInstances, 12 | FlexibleInstances, 13 | TupleSections, 14 | NoImplicitPrelude #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.CartesianClosed 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.CartesianClosed where 25 | 26 | import Data.Kind (Type) 27 | 28 | import Data.Category 29 | import Data.Category.Functor 30 | import Data.Category.NaturalTransformation 31 | import Data.Category.Product 32 | import Data.Category.Limit 33 | import Data.Category.Adjunction 34 | import Data.Category.Monoidal as M 35 | import Data.Category.Yoneda 36 | import qualified Data.Category.Unit as U 37 | 38 | 39 | -- | A category is cartesian closed if it has all products and exponentials for all objects. 40 | class (HasTerminalObject k, HasBinaryProducts k) => CartesianClosed k where 41 | type Exponential k (y :: Kind k) (z :: Kind k) :: Kind k 42 | 43 | apply :: Obj k y -> Obj k z -> k (BinaryProduct k (Exponential k y z) y) z 44 | tuple :: Obj k y -> Obj k z -> k z (Exponential k y (BinaryProduct k z y)) 45 | (^^^) :: k z1 z2 -> k y2 y1 -> k (Exponential k y1 z1) (Exponential k y2 z2) 46 | 47 | 48 | data ExpFunctor (k :: Type -> Type -> Type) = ExpFunctor 49 | -- | The exponential as a bifunctor. 50 | instance CartesianClosed k => Functor (ExpFunctor k) where 51 | type Dom (ExpFunctor k) = Op k :**: k 52 | type Cod (ExpFunctor k) = k 53 | type ExpFunctor k :% (y, z) = Exponential k y z 54 | 55 | ExpFunctor % (Op y :**: z) = z ^^^ y 56 | 57 | 58 | flip :: CartesianClosed k => Obj k a -> Obj k b -> Obj k c -> k (Exponential k a (Exponential k b c)) (Exponential k b (Exponential k a c)) 59 | flip a b c = flip a b c -- TODO 60 | 61 | 62 | -- | Exponentials in @Hask@ are functions. 63 | instance CartesianClosed (->) where 64 | type Exponential (->) y z = y -> z 65 | 66 | apply _ _ (f, y) = f y 67 | tuple _ _ z = (z,) 68 | f ^^^ h = \g -> f . g . h 69 | 70 | 71 | instance CartesianClosed U.Unit where 72 | type Exponential U.Unit () () = () 73 | apply U.Unit U.Unit = U.Unit 74 | tuple U.Unit U.Unit = U.Unit 75 | U.Unit ^^^ U.Unit = U.Unit 76 | 77 | 78 | -- | Exponentials in @Cat@ are the functor categories. 79 | instance CartesianClosed Cat where 80 | type Exponential Cat c d = Nat c d 81 | 82 | apply CatA{} CatA{} = CatA Apply 83 | tuple CatA{} CatA{} = CatA Tuple 84 | CatA f ^^^ CatA h = CatA (Wrap f h) 85 | 86 | 87 | type PShExponential k y z = (Presheaves k :-*: z) :.: Opposite 88 | ( ProductFunctor (Presheaves k) 89 | :.: Tuple2 (Presheaves k) (Presheaves k) y 90 | :.: YonedaEmbedding k 91 | ) 92 | pattern PshExponential :: Category k => Obj (Presheaves k) y -> Obj (Presheaves k) z -> PShExponential k y z 93 | pattern PshExponential y z = Hom_X z :.: Opposite (ProductFunctor :.: Tuple2 y :.: YonedaEmbedding) 94 | 95 | -- | The category of presheaves on a category @C@ is cartesian closed for any @C@. 96 | instance Category k => CartesianClosed (Presheaves k) where 97 | type Exponential (Presheaves k) y z = PShExponential k y z 98 | 99 | apply yn@(Nat y _ _) zn@(Nat z _ _) = Nat (PshExponential yn zn :*: y) z (\(Op i) (n, yi) -> (n ! Op i) (i, yi)) 100 | tuple yn zn@(Nat z _ _) = Nat z (PshExponential yn (zn *** yn)) (\(Op i) zi -> Nat (Hom_X i) z (\_ j2i -> (z % Op j2i) zi) *** yn) 101 | zn ^^^ yn = Nat (PshExponential (tgt yn) (src zn)) (PshExponential (src yn) (tgt zn)) (\(Op i) n -> zn . n . (natId (Hom_X i) *** yn)) 102 | 103 | 104 | 105 | -- | The product functor is left adjoint the the exponential functor. 106 | curryAdj :: CartesianClosed k 107 | => Obj k y 108 | -> Adjunction k k 109 | (ProductFunctor k :.: Tuple2 k k y) 110 | (ExpFunctor k :.: Tuple1 (Op k) k y) 111 | curryAdj y = mkAdjunctionUnits (ProductFunctor :.: Tuple2 y) (ExpFunctor :.: Tuple1 (Op y)) (tuple y) (apply y) 112 | 113 | -- | From the adjunction between the product functor and the exponential functor we get the curry and uncurry functions, 114 | -- generalized to any cartesian closed category. 115 | curry :: (CartesianClosed k, Kind k ~ Type) => Obj k x -> Obj k y -> Obj k z -> k (BinaryProduct k x y) z -> k x (Exponential k y z) 116 | curry x y _ = leftAdjunct (curryAdj y) x 117 | 118 | uncurry :: (CartesianClosed k, Kind k ~ Type) => Obj k x -> Obj k y -> Obj k z -> k x (Exponential k y z) -> k (BinaryProduct k x y) z 119 | uncurry _ y z = rightAdjunct (curryAdj y) z 120 | 121 | -- | From every adjunction we get a monad, in this case the State monad. 122 | type State k s a = Exponential k s (BinaryProduct k a s) 123 | 124 | stateMonadReturn :: (CartesianClosed k, Kind k ~ Type) => Obj k s -> Obj k a -> k a (State k s a) 125 | stateMonadReturn s a = M.unit (adjunctionMonad (curryAdj s)) ! a 126 | 127 | stateMonadJoin :: (CartesianClosed k, Kind k ~ Type) => Obj k s -> Obj k a -> k (State k s (State k s a)) (State k s a) 128 | stateMonadJoin s a = M.multiply (adjunctionMonad (curryAdj s)) ! a 129 | 130 | -- ! From every adjunction we also get a comonad, the Context comonad in this case. 131 | type Context k s a = BinaryProduct k (Exponential k s a) s 132 | 133 | contextComonadExtract :: (CartesianClosed k, Kind k ~ Type) => Obj k s -> Obj k a -> k (Context k s a) a 134 | contextComonadExtract s a = M.counit (adjunctionComonad (curryAdj s)) ! a 135 | 136 | contextComonadDuplicate :: (CartesianClosed k, Kind k ~ Type) => Obj k s -> Obj k a -> k (Context k s a) (Context k s (Context k s a)) 137 | contextComonadDuplicate s a = M.comultiply (adjunctionComonad (curryAdj s)) ! a 138 | -------------------------------------------------------------------------------- /Data/Category/WeightedLimit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, RankNTypes, GADTs, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, NoImplicitPrelude, FlexibleContexts #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.WeightedLimit 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.WeightedLimit where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category 16 | import Data.Category.Functor 17 | import Data.Category.Product 18 | import Data.Category.NaturalTransformation 19 | import qualified Data.Category.Limit as L 20 | 21 | 22 | type WeightedCone w d e = forall a. Obj (Dom w) a -> w :% a -> Cod d e (d :% a) 23 | 24 | -- | @w@-weighted limits in the category @k@. 25 | class (Functor w, Cod w ~ (->), Category k) => HasWLimits k w where 26 | type WeightedLimit k w d :: Type 27 | limitObj :: FunctorOf (Dom w) k d => w -> d -> Obj k (WLimit w d) 28 | limit :: FunctorOf (Dom w) k d => w -> d -> WeightedCone w d (WLimit w d) 29 | limitFactorizer :: FunctorOf (Dom w) k d => w -> d -> Obj k e -> WeightedCone w d e -> k e (WLimit w d) 30 | 31 | type WLimit w d = WeightedLimit (Cod d) w d 32 | 33 | data LimitFunctor (k :: Type -> Type -> Type) w = LimitFunctor w 34 | instance HasWLimits k w => Functor (LimitFunctor k w) where 35 | type Dom (LimitFunctor k w) = Nat (Dom w) k 36 | type Cod (LimitFunctor k w) = k 37 | type LimitFunctor k w :% d = WeightedLimit k w d 38 | 39 | LimitFunctor w % Nat d d' n = limitFactorizer w d' (limitObj w d) (\a wa -> n a . limit w d a wa) 40 | 41 | 42 | -- | Regular limits as weigthed limits, weighted by the constant functor to '()'. 43 | instance L.HasLimits j k => HasWLimits k (Const j (->) ()) where 44 | type WeightedLimit k (Const j (->) ()) d = L.Limit d 45 | limitObj Const{} d = L.coneVertex (L.limit (natId d)) 46 | limit Const{} d a () = L.limit (natId d) ! a 47 | limitFactorizer Const{} d e f = L.limitFactorizer (Nat (Const e) d (`f` ())) 48 | 49 | 50 | class Category v => HasEnds v where 51 | type End (v :: Type -> Type -> Type) t :: Type 52 | end :: FunctorOf (Op k :**: k) v t => t -> Obj v (End v t) 53 | endCounit :: FunctorOf (Op k :**: k) v t => t -> Obj k a -> v (End v t) (t :% (a, a)) 54 | endFactorizer :: FunctorOf (Op k :**: k) v t => t -> (forall a. Obj k a -> v x (t :% (a, a))) -> v x (End v t) 55 | 56 | -- | Ends as Hom-weighted limits 57 | instance HasEnds k => HasWLimits k (Hom k) where 58 | type WeightedLimit k (Hom k) d = End k d 59 | limitObj Hom d = end d 60 | limit Hom d (Op a :**: _) ab = d % (Op a :**: ab) . endCounit d a 61 | limitFactorizer Hom d _ f = endFactorizer d (\a -> f (Op a :**: a) a) 62 | 63 | data EndFunctor (k :: Type -> Type -> Type) (v :: Type -> Type -> Type) = EndFunctor 64 | instance (HasEnds v, Category k) => Functor (EndFunctor k v) where 65 | type Dom (EndFunctor k v) = Nat (Op k :**: k) v 66 | type Cod (EndFunctor k v) = v 67 | type EndFunctor k v :% t = End v t 68 | 69 | EndFunctor % Nat f g n = endFactorizer g (\a -> n (Op a :**: a) . endCounit f a) 70 | 71 | newtype HaskEnd t = HaskEnd { getHaskEnd :: forall k a. FunctorOf (Op k :**: k) (->) t => t -> Obj k a -> t :% (a, a) } 72 | instance HasEnds (->) where 73 | type End (->) t = HaskEnd t 74 | end _ e = e 75 | endCounit t a (HaskEnd f) = f t a 76 | endFactorizer _ e x = HaskEnd (\_ a -> e a x) 77 | 78 | 79 | type WeightedCocone w d e = forall a. Obj (Dom w) a -> w :% a -> Cod d (d :% a) e 80 | 81 | -- | @w@-weighted colimits in the category @k@. 82 | class (Functor w, Cod w ~ (->), Category k) => HasWColimits k w where 83 | type WeightedColimit k w d :: Type 84 | colimitObj :: (FunctorOf j k d, Op j ~ Dom w) => w -> d -> Obj k (WColimit w d) 85 | colimit :: (FunctorOf j k d, Op j ~ Dom w) => w -> d -> WeightedCocone w d (WColimit w d) 86 | colimitFactorizer :: (FunctorOf j k d, Op j ~ Dom w) => w -> d -> Obj k e -> WeightedCocone w d e -> k (WColimit w d) e 87 | 88 | type WColimit w d = WeightedColimit (Cod d) w d 89 | 90 | data ColimitFunctor (k :: Type -> Type -> Type) w = ColimitFunctor w 91 | instance (Functor w, Category k, HasWColimits k (w :.: OpOp (Dom w))) => Functor (ColimitFunctor k w) where 92 | type Dom (ColimitFunctor k w) = Nat (Op (Dom w)) k 93 | type Cod (ColimitFunctor k w) = k 94 | type ColimitFunctor k w :% d = WeightedColimit k (w :.: OpOp (Dom w)) d 95 | 96 | ColimitFunctor w % Nat d d' n = colimitFactorizer (w :.: OpOp) d (colimitObj (w :.: OpOp) d') (\(Op a) wa -> colimit (w :.: OpOp) d' (Op a) wa . n a) 97 | 98 | 99 | -- | Regular colimits as weigthed colimits, weighted by the constant functor to '()'. 100 | instance L.HasColimits j k => HasWColimits k (Const (Op j) (->) ()) where 101 | type WeightedColimit k (Const (Op j) (->) ()) d = L.Colimit d 102 | colimitObj (Const _) d = L.coconeVertex (L.colimit (natId d)) 103 | colimit (Const _) d (Op a) () = L.colimit (natId d) ! a 104 | colimitFactorizer (Const _) d e f = L.colimitFactorizer (Nat d (Const e) (\z -> f (Op z) ())) 105 | 106 | 107 | class Category v => HasCoends v where 108 | type Coend (v :: Type -> Type -> Type) t :: Type 109 | coend :: FunctorOf (Op k :**: k) v t => t -> Obj v (Coend v t) 110 | coendCounit :: FunctorOf (Op k :**: k) v t => t -> Obj k a -> v (t :% (a, a)) (Coend v t) 111 | coendFactorizer :: FunctorOf (Op k :**: k) v t => t -> (forall a. Obj k a -> v (t :% (a, a)) x) -> v (Coend v t) x 112 | 113 | data OpHom (k :: Type -> Type -> Type) = OpHom 114 | -- | The Hom-functor but with opposite domain. 115 | instance Category k => Functor (OpHom k) where 116 | type Dom (OpHom k) = Op (Op k :**: k) 117 | type Cod (OpHom k) = (->) 118 | type OpHom k :% (a1, a2) = k a2 a1 119 | OpHom % Op (Op f1 :**: f2) = \g -> f1 . g . f2 120 | 121 | -- | Coends as OpHom-weighted colimits 122 | instance HasCoends k => HasWColimits k (OpHom k) where 123 | type WeightedColimit k (OpHom k) d = Coend k d 124 | colimitObj OpHom d = coend d 125 | colimit OpHom d (Op (Op a :**: _)) ab = coendCounit d a . d % (Op a :**: ab) 126 | colimitFactorizer OpHom d _ f = coendFactorizer d (\a -> f (Op (Op a :**: a)) a) 127 | 128 | data CoendFunctor (k :: Type -> Type -> Type) (v :: Type -> Type -> Type) = CoendFunctor 129 | instance (HasCoends v, Category k) => Functor (CoendFunctor k v) where 130 | type Dom (CoendFunctor k v) = Nat (Op k :**: k) v 131 | type Cod (CoendFunctor k v) = v 132 | type CoendFunctor k v :% t = Coend v t 133 | 134 | CoendFunctor % Nat f g n = coendFactorizer f (\a -> coendCounit g a . n (Op a :**: a)) 135 | 136 | data HaskCoend t where 137 | HaskCoend :: FunctorOf (Op k :**: k) (->) t => t -> Obj k a -> t :% (a, a) -> HaskCoend t 138 | instance HasCoends (->) where 139 | type Coend (->) t = HaskCoend t 140 | coend _ e = e 141 | coendCounit t a taa = HaskCoend t a taa 142 | coendFactorizer _ f (HaskCoend _ a taa) = f a taa 143 | -------------------------------------------------------------------------------- /Data/Category/Coproduct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances, GADTs, FlexibleContexts, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Coproduct 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.Coproduct where 12 | 13 | import Data.Kind (Type) 14 | 15 | import Data.Category 16 | import Data.Category.Functor 17 | 18 | import Data.Category.NaturalTransformation 19 | import Data.Category.Product 20 | import Data.Category.Unit 21 | 22 | 23 | data I1 a 24 | data I2 a 25 | 26 | data (:++:) :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where 27 | I1 :: c1 a1 b1 -> (:++:) c1 c2 (I1 a1) (I1 b1) 28 | I2 :: c2 a2 b2 -> (:++:) c1 c2 (I2 a2) (I2 b2) 29 | 30 | -- | The coproduct category of categories @c1@ and @c2@. 31 | instance (Category c1, Category c2) => Category (c1 :++: c2) where 32 | 33 | src (I1 a) = I1 (src a) 34 | src (I2 a) = I2 (src a) 35 | tgt (I1 a) = I1 (tgt a) 36 | tgt (I2 a) = I2 (tgt a) 37 | 38 | (I1 a) . (I1 b) = I1 (a . b) 39 | (I2 a) . (I2 b) = I2 (a . b) 40 | 41 | 42 | 43 | 44 | data Inj1 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Inj1 45 | -- | 'Inj1' is a functor which injects into the left category. 46 | instance (Category c1, Category c2) => Functor (Inj1 c1 c2) where 47 | type Dom (Inj1 c1 c2) = c1 48 | type Cod (Inj1 c1 c2) = c1 :++: c2 49 | type Inj1 c1 c2 :% a = I1 a 50 | Inj1 % f = I1 f 51 | 52 | data Inj2 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Inj2 53 | -- | 'Inj2' is a functor which injects into the right category. 54 | instance (Category c1, Category c2) => Functor (Inj2 c1 c2) where 55 | type Dom (Inj2 c1 c2) = c2 56 | type Cod (Inj2 c1 c2) = c1 :++: c2 57 | type Inj2 c1 c2 :% a = I2 a 58 | Inj2 % f = I2 f 59 | 60 | data f1 :+++: f2 = f1 :+++: f2 61 | -- | @f1 :+++: f2@ is the coproduct of the functors @f1@ and @f2@. 62 | instance (Functor f1, Functor f2) => Functor (f1 :+++: f2) where 63 | type Dom (f1 :+++: f2) = Dom f1 :++: Dom f2 64 | type Cod (f1 :+++: f2) = Cod f1 :++: Cod f2 65 | type (f1 :+++: f2) :% (I1 a) = I1 (f1 :% a) 66 | type (f1 :+++: f2) :% (I2 a) = I2 (f2 :% a) 67 | (g :+++: _) % I1 f = I1 (g % f) 68 | (_ :+++: g) % I2 f = I2 (g % f) 69 | 70 | data CodiagCoprod (k :: Type -> Type -> Type) = CodiagCoprod 71 | -- | 'CodiagCoprod' is the codiagonal functor for coproducts. 72 | instance Category k => Functor (CodiagCoprod k) where 73 | type Dom (CodiagCoprod k) = k :++: k 74 | type Cod (CodiagCoprod k) = k 75 | type CodiagCoprod k :% I1 a = a 76 | type CodiagCoprod k :% I2 a = a 77 | CodiagCoprod % I1 f = f 78 | CodiagCoprod % I2 f = f 79 | 80 | newtype Cotuple1 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) a = Cotuple1 (Obj c1 a) 81 | -- | 'Cotuple1' projects out to the left category, replacing a value from the right category with a fixed object. 82 | instance (Category c1, Category c2) => Functor (Cotuple1 c1 c2 a1) where 83 | type Dom (Cotuple1 c1 c2 a1) = c1 :++: c2 84 | type Cod (Cotuple1 c1 c2 a1) = c1 85 | type Cotuple1 c1 c2 a1 :% I1 a = a 86 | type Cotuple1 c1 c2 a1 :% I2 a = a1 87 | Cotuple1 _ % I1 f = f 88 | Cotuple1 a % I2 _ = a 89 | 90 | newtype Cotuple2 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) a = Cotuple2 (Obj c2 a) 91 | -- | 'Cotuple2' projects out to the right category, replacing a value from the left category with a fixed object. 92 | instance (Category c1, Category c2) => Functor (Cotuple2 c1 c2 a2) where 93 | type Dom (Cotuple2 c1 c2 a2) = c1 :++: c2 94 | type Cod (Cotuple2 c1 c2 a2) = c2 95 | type Cotuple2 c1 c2 a2 :% I1 a = a2 96 | type Cotuple2 c1 c2 a2 :% I2 a = a 97 | Cotuple2 a % I1 _ = a 98 | Cotuple2 _ % I2 f = f 99 | 100 | 101 | data Cograph c d p :: Type -> Type -> Type where 102 | I1A :: c a1 b1 -> Cograph c d p (I1 a1) (I1 b1) 103 | I2A :: d a2 b2 -> Cograph c d p (I2 a2) (I2 b2) 104 | I12 :: Obj c a -> Obj d b -> p -> p :% (a, b) -> Cograph c d p (I1 a) (I2 b) 105 | 106 | -- | The cograph of the profunctor @p@. 107 | instance ProfunctorOf c d p => Category (Cograph c d p) where 108 | 109 | src (I1A a) = I1A (src a) 110 | src (I2A a) = I2A (src a) 111 | src (I12 a _ _ _) = I1A a 112 | tgt (I1A a) = I1A (tgt a) 113 | tgt (I2A a) = I2A (tgt a) 114 | tgt (I12 _ b _ _) = I2A b 115 | 116 | (I1A a) . (I1A b) = I1A (a . b) 117 | (I12 _ b p ab) . (I1A a) = I12 (src a) b p ((p % (Op a :**: b)) ab) 118 | (I2A b) . (I12 a _ p ab) = I12 a (tgt b) p ((p % (Op a :**: b)) ab) 119 | (I2A a) . (I2A b) = I2A (a . b) 120 | 121 | -- | The cograph is a cotabulator with this 2-cell. 122 | -- 123 | -- > C-Inj1-CG 124 | -- > | v | 125 | -- > p---@ | 126 | -- > | v | 127 | -- > D-Inj2-CG 128 | isCotabulator :: Obj c a -> Obj d b -> p -> p :% (a, b) -> Cograph c d p (Inj1 c d :% a) (Inj2 c d :% b) 129 | isCotabulator = I12 130 | 131 | -- | Any 2-cell of shape p(a, b) -> e(f a, g b) factors through the cotabulator 2-cell. 132 | -- 133 | -- > C--f--E C-Inj1-CG--X--E 134 | -- > | v | | v | v | 135 | -- > p--@ | == p---@ | | | 136 | -- > | v | | v | v | 137 | -- > D--g--E D-Inj2-CG--X--E 138 | data CotabulatorFactorizer (c :: Type -> Type -> Type) (d :: Type -> Type -> Type) (e :: Type -> Type -> Type) p f g 139 | = CotabulatorFactorizer f g (forall a b. Obj c a -> Obj d b -> p :% (a, b) -> e (f :% a) (g :% b)) 140 | instance (ProfunctorOf c d p, FunctorOf c e f, FunctorOf d e g) => Functor (CotabulatorFactorizer c d e p f g) where 141 | type Dom (CotabulatorFactorizer c d e p f g) = Cograph c d p 142 | type Cod (CotabulatorFactorizer c d e p f g) = e 143 | type CotabulatorFactorizer c d e p f g :% I1 a = f :% a 144 | type CotabulatorFactorizer c d e p f g :% I2 a = g :% a 145 | CotabulatorFactorizer f _ _ % I1A a = f % a 146 | CotabulatorFactorizer _ g _ % I2A a = g % a 147 | CotabulatorFactorizer _ _ p2fg % I12 a b _ pab = p2fg a b pab 148 | 149 | -- | The directed coproduct category of categories @c1@ and @c2@. 150 | newtype (c1 :>>: c2) a b = DC (Cograph c1 c2 (Const (Op c1 :**: c2) (->) ()) a b) deriving Category 151 | 152 | 153 | newtype NatAsFunctor f g = NatAsFunctor (Nat (Dom f) (Cod f) f g) 154 | 155 | -- | A natural transformation @Nat c d@ is isomorphic to a functor from @c :**: 2@ to @d@. 156 | instance (Functor f, Functor g, Dom f ~ Dom g, Cod f ~ Cod g) => Functor (NatAsFunctor f g) where 157 | 158 | type Dom (NatAsFunctor f g) = Dom f :**: Cograph Unit Unit (Hom Unit) 159 | type Cod (NatAsFunctor f g) = Cod f 160 | type NatAsFunctor f g :% (a, I1 ()) = f :% a 161 | type NatAsFunctor f g :% (a, I2 ()) = g :% a 162 | 163 | NatAsFunctor (Nat f _ _) % (a :**: I1A Unit) = f % a 164 | NatAsFunctor (Nat _ g _) % (a :**: I2A Unit) = g % a 165 | NatAsFunctor n % (a :**: I12 Unit Unit Hom Unit) = n ! a 166 | -------------------------------------------------------------------------------- /Data/Category/KanExtension.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleInstances 3 | , GADTs 4 | , MultiParamTypeClasses 5 | , RankNTypes 6 | , TypeOperators 7 | , TypeFamilies 8 | , UndecidableInstances 9 | , NoImplicitPrelude 10 | #-} 11 | ----------------------------------------------------------------------------- 12 | -- | 13 | -- Module : Data.Category.KanExtension 14 | -- License : BSD-style (see the file LICENSE) 15 | -- 16 | -- Maintainer : sjoerd@w3future.com 17 | -- Stability : experimental 18 | -- Portability : non-portable 19 | ----------------------------------------------------------------------------- 20 | module Data.Category.KanExtension where 21 | 22 | import Data.Kind (Type) 23 | 24 | import Data.Category 25 | import Data.Category.Functor 26 | import Data.Category.NaturalTransformation 27 | import Data.Category.Adjunction 28 | import Data.Category.Limit 29 | import Data.Category.Unit 30 | 31 | 32 | -- | An instance of @HasRightKan p k@ says there are right Kan extensions for all functors with codomain @k@. 33 | class (Functor p, Category k) => HasRightKan p k where 34 | -- | The right Kan extension of a functor @p@ for functors @f@ with codomain @k@. 35 | type RanFam p k (f :: Type) :: Type 36 | -- | 'ran' gives the defining natural transformation of the right Kan extension of @f@ along @p@. 37 | ran :: p -> Obj (Nat (Dom p) k) f -> Nat (Dom p) k (RanFam p k f :.: p) f 38 | -- | 'ranFactorizer' shows that this extension is universal. 39 | ranFactorizer :: Nat (Dom p) k (h :.: p) f -> Nat (Cod p) k h (RanFam p k f) 40 | 41 | type Ran p f = RanFam p (Cod f) f 42 | 43 | ranF :: HasRightKan p k => p -> Obj (Nat (Dom p) k) f -> Obj (Nat (Cod p) k) (RanFam p k f) 44 | ranF p f = ranF' (ran p f) 45 | 46 | ranF' :: Nat (Dom p) k (RanFam p k f :.: p) f -> Obj (Nat (Cod p) k) (RanFam p k f) 47 | ranF' (Nat (r :.: _) _ _) = natId r 48 | 49 | newtype RanFunctor (p :: Type) (k :: Type -> Type -> Type) = RanFunctor p 50 | instance HasRightKan p k => Functor (RanFunctor p k) where 51 | type Dom (RanFunctor p k) = Nat (Dom p) k 52 | type Cod (RanFunctor p k) = Nat (Cod p) k 53 | type RanFunctor p k :% f = RanFam p k f 54 | 55 | RanFunctor p % n = ranFactorizer (n . ran p (src n)) 56 | 57 | -- | The right Kan extension along @p@ is right adjoint to precomposition with @p@. 58 | ranAdj :: forall p k. HasRightKan p k => p -> Adjunction (Nat (Dom p) k) (Nat (Cod p) k) (Precompose p k) (RanFunctor p k) 59 | ranAdj p = mkAdjunctionTerm (Precompose p) (RanFunctor p) (\_ -> ranFactorizer) (ran p) 60 | 61 | 62 | -- | An instance of @HasLeftKan p k@ says there are left Kan extensions for all functors with codomain @k@. 63 | class (Functor p, Category k) => HasLeftKan p k where 64 | -- | The left Kan extension of a functor @p@ for functors @f@ with codomain @k@. 65 | type LanFam (p :: Type) (k :: Type -> Type -> Type) (f :: Type) :: Type 66 | -- | 'lan' gives the defining natural transformation of the left Kan extension of @f@ along @p@. 67 | lan :: p -> Obj (Nat (Dom p) k) f -> Nat (Dom p) k f (LanFam p k f :.: p) 68 | -- | 'lanFactorizer' shows that this extension is universal. 69 | lanFactorizer :: Nat (Dom p) k f (h :.: p) -> Nat (Cod p) k (LanFam p k f) h 70 | 71 | type Lan p f = LanFam p (Cod f) f 72 | 73 | lanF :: HasLeftKan p k => p -> Obj (Nat (Dom p) k) f -> Obj (Nat (Cod p) k) (LanFam p k f) 74 | lanF p f = lanF' (lan p f) 75 | 76 | lanF' :: Nat (Dom p) k f (LanFam p k f :.: p) -> Obj (Nat (Cod p) k) (LanFam p k f) 77 | lanF' (Nat _ (r :.: _) _) = natId r 78 | 79 | newtype LanFunctor (p :: Type) (k :: Type -> Type -> Type) = LanFunctor p 80 | instance HasLeftKan p k => Functor (LanFunctor p k) where 81 | type Dom (LanFunctor p k) = Nat (Dom p) k 82 | type Cod (LanFunctor p k) = Nat (Cod p) k 83 | type LanFunctor p k :% f = LanFam p k f 84 | 85 | LanFunctor p % n = lanFactorizer (lan p (tgt n) . n) 86 | 87 | -- | The left Kan extension along @p@ is left adjoint to precomposition with @p@. 88 | lanAdj :: forall p k. HasLeftKan p k => p -> Adjunction (Nat (Cod p) k) (Nat (Dom p) k) (LanFunctor p k) (Precompose p k) 89 | lanAdj p = mkAdjunctionInit (LanFunctor p) (Precompose p) (lan p) (\_ -> lanFactorizer) 90 | 91 | 92 | -- | The right Kan extension of @f@ along a functor to the unit category is the limit of @f@. 93 | instance HasLimits j k => HasRightKan (Const j Unit ()) k where 94 | type RanFam (Const j Unit ()) k f = Const Unit k (LimitFam j k f) 95 | ran p f@Nat{} = let cone = limit f in Nat (Const (coneVertex cone) :.: p) (srcF f) (cone !) 96 | ranFactorizer n@(Nat (h :.: _) _ _) = let fact = limitFactorizer (constPrecompIn n) in Nat h (Const (tgt fact)) (\Unit -> fact) 97 | 98 | -- | The left Kan extension of @f@ along a functor to the unit category is the colimit of @f@. 99 | instance HasColimits j k => HasLeftKan (Const j Unit ()) k where 100 | type LanFam (Const j Unit ()) k f = Const Unit k (ColimitFam j k f) 101 | lan p f@Nat{} = let cocone = colimit f in Nat (srcF f) (Const (coconeVertex cocone) :.: p) (cocone !) 102 | lanFactorizer n@(Nat _ (h :.: _) _) = let fact = colimitFactorizer (constPrecompOut n) in Nat (Const (src fact)) h (\Unit -> fact) 103 | 104 | 105 | -- | Ran id = id 106 | instance (Category j, Category k) => HasRightKan (Id j) k where 107 | type RanFam (Id j) k f = f 108 | ran Id (Nat f _ _) = idPrecomp f 109 | ranFactorizer n@(Nat (h :.: Id) _ _) = n . idPrecompInv h 110 | 111 | -- | Lan id = id 112 | instance (Category j, Category k) => HasLeftKan (Id j) k where 113 | type LanFam (Id j) k f = f 114 | lan Id (Nat f _ _) = idPrecompInv f 115 | lanFactorizer n@(Nat _ (h :.: Id) _) = idPrecomp h . n 116 | 117 | 118 | -- | Ran (q . p) = Ran q . Ran p 119 | instance (HasRightKan q k, HasRightKan p k) => HasRightKan (q :.: p) k where 120 | type RanFam (q :.: p) k f = RanFam q k (RanFam p k f) 121 | ran (q :.: p) f = let ranp = ran p f in case ran q (ranF' ranp) of 122 | ranq@(Nat (r :.: _) _ _) -> ranp . (ranq `o` natId p) . compAssocInv r q p 123 | ranFactorizer n@(Nat (h :.: (q :.: p)) _ _) = ranFactorizer (ranFactorizer (n . compAssoc h q p)) 124 | 125 | -- | Lan (q . p) = Lan q . Lan p 126 | instance (HasLeftKan q k, HasLeftKan p k) => HasLeftKan (q :.: p) k where 127 | type LanFam (q :.: p) k f = LanFam q k (LanFam p k f) 128 | lan (q :.: p) f = let lanp = lan p f in case lan q (lanF' lanp) of 129 | lanq@(Nat _ (l :.: _) _) -> compAssoc l q p . (lanq `o` natId p) . lanp 130 | lanFactorizer n@(Nat _ (h :.: (q :.: p)) _) = lanFactorizer (lanFactorizer (compAssocInv h q p . n)) 131 | 132 | 133 | newtype RanHask p f a = RanHask (forall c. Obj (Dom p) c -> Cod p a (p :% c) -> f :% c) 134 | data RanHaskF p f = RanHaskF 135 | instance Functor p => Functor (RanHaskF p f) where 136 | type Dom (RanHaskF p f) = Cod p 137 | type Cod (RanHaskF p f) = (->) 138 | type RanHaskF p f :% a = RanHask p f a 139 | RanHaskF % ab = \(RanHask r) -> RanHask (\c bpc -> r c (bpc . ab)) 140 | 141 | instance Functor p => HasRightKan (Any p) (->) where 142 | type RanFam (Any p) (->) f = RanHaskF p f 143 | ran (Any p) (Nat f _ _) = Nat (RanHaskF :.: Any p) f (\z (RanHask r) -> r z (p % z)) 144 | ranFactorizer (Nat (h :.: _) _ n) = Nat h RanHaskF (\_ hz -> RanHask (\c zpc -> n c ((h % zpc) hz))) 145 | 146 | data LanHask p f a where 147 | LanHask :: Obj (Dom p) c -> Cod p (p :% c) a -> f :% c -> LanHask p f a 148 | data LanHaskF p f = LanHaskF 149 | instance Functor p => Functor (LanHaskF p f) where 150 | type Dom (LanHaskF p f) = Cod p 151 | type Cod (LanHaskF p f) = (->) 152 | type LanHaskF p f :% a = LanHask p f a 153 | LanHaskF % ab = \(LanHask c pca fc) -> LanHask c (ab . pca) fc 154 | 155 | instance Functor p => HasLeftKan (Any p) (->) where 156 | type LanFam (Any p) (->) f = LanHaskF p f 157 | lan (Any p) (Nat f _ _) = Nat f (LanHaskF :.: Any p) (\z fz -> LanHask z (p % z) fz) 158 | lanFactorizer (Nat _ (h :.: _) n) = Nat LanHaskF h (\_ (LanHask c pcz fc) -> (h % pcz) (n c fc)) 159 | -------------------------------------------------------------------------------- /Data/Category/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | GADTs 3 | , PolyKinds 4 | , RankNTypes 5 | , ConstraintKinds 6 | , NoImplicitPrelude 7 | , TypeOperators 8 | , TypeFamilies 9 | , PatternSynonyms 10 | , FlexibleContexts 11 | , FlexibleInstances 12 | , UndecidableInstances 13 | , GeneralizedNewtypeDeriving 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Functor 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Functor ( 25 | 26 | -- * Cat 27 | Cat(..) 28 | 29 | -- * Functors 30 | , Functor(..) 31 | , FunctorOf 32 | 33 | -- ** Functor instances 34 | , Id(..) 35 | , (:.:)(..) 36 | , Const(..), ConstF 37 | , OpOp(..) 38 | , OpOpInv(..) 39 | , Any(..) 40 | 41 | -- *** Related to the product category 42 | , Proj1(..) 43 | , Proj2(..) 44 | , (:***:)(..) 45 | , DiagProd(..) 46 | , Tuple1, pattern Tuple1 47 | , Tuple2, pattern Tuple2 48 | , Swap, pattern Swap 49 | 50 | -- *** Hom functors 51 | , Hom(..) 52 | , (:*-:), pattern HomX_ 53 | , (:-*:), pattern Hom_X 54 | 55 | -- *** Profunctors 56 | , ProfunctorOf 57 | 58 | ) where 59 | 60 | import Data.Kind (Type) 61 | 62 | import Data.Category 63 | import Data.Category.Product 64 | 65 | infixr 9 % 66 | infixr 9 :% 67 | 68 | 69 | 70 | -- | Functors map objects and arrows. 71 | class (Category (Dom ftag), Category (Cod ftag)) => Functor ftag where 72 | 73 | -- | The domain, or source category, of the functor. 74 | type Dom ftag :: Type -> Type -> Type 75 | -- | The codomain, or target category, of the functor. 76 | type Cod ftag :: Type -> Type -> Type 77 | 78 | -- | @:%@ maps objects. 79 | type ftag :% a :: Type 80 | 81 | -- | @%@ maps arrows. 82 | (%) :: ftag -> Dom ftag a b -> Cod ftag (ftag :% a) (ftag :% b) 83 | 84 | type FunctorOf a b t = (Functor t, Dom t ~ a, Cod t ~ b) 85 | 86 | 87 | -- | Functors are arrows in the category Cat. 88 | data Cat :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type where 89 | CatA :: (Functor ftag, Category (Dom ftag), Category (Cod ftag)) => ftag -> Cat (Dom ftag) (Cod ftag) 90 | 91 | 92 | -- | @Cat@ is the category with categories as objects and funtors as arrows. 93 | instance Category Cat where 94 | 95 | src (CatA _) = CatA Id 96 | tgt (CatA _) = CatA Id 97 | 98 | CatA f1 . CatA f2 = CatA (f1 :.: f2) 99 | 100 | 101 | 102 | data Id (k :: Type -> Type -> Type) = Id 103 | 104 | -- | The identity functor on k 105 | instance Category k => Functor (Id k) where 106 | type Dom (Id k) = k 107 | type Cod (Id k) = k 108 | type Id k :% a = a 109 | 110 | _ % f = f 111 | 112 | 113 | data (g :.: h) where 114 | (:.:) :: (Functor g, Functor h, Cod h ~ Dom g) => g -> h -> g :.: h 115 | 116 | -- | The composition of two functors. 117 | instance (Category (Cod g), Category (Dom h)) => Functor (g :.: h) where 118 | type Dom (g :.: h) = Dom h 119 | type Cod (g :.: h) = Cod g 120 | type (g :.: h) :% a = g :% (h :% a) 121 | 122 | (g :.: h) % f = g % (h % f) 123 | 124 | 125 | 126 | data Const (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) x where 127 | Const :: Obj c2 x -> Const c1 c2 x 128 | 129 | -- | The constant functor. 130 | instance (Category c1, Category c2) => Functor (Const c1 c2 x) where 131 | type Dom (Const c1 c2 x) = c1 132 | type Cod (Const c1 c2 x) = c2 133 | type Const c1 c2 x :% a = x 134 | 135 | Const x % _ = x 136 | 137 | -- | The constant functor with the same domain and codomain as f. 138 | type ConstF f = Const (Dom f) (Cod f) 139 | 140 | 141 | 142 | data OpOp (k :: Type -> Type -> Type) = OpOp 143 | 144 | -- | The @Op (Op x) = x@ functor. 145 | instance Category k => Functor (OpOp k) where 146 | type Dom (OpOp k) = Op (Op k) 147 | type Cod (OpOp k) = k 148 | type OpOp k :% a = a 149 | 150 | OpOp % Op (Op f) = f 151 | 152 | 153 | data OpOpInv (k :: Type -> Type -> Type) = OpOpInv 154 | 155 | -- | The @x = Op (Op x)@ functor. 156 | instance Category k => Functor (OpOpInv k) where 157 | type Dom (OpOpInv k) = k 158 | type Cod (OpOpInv k) = Op (Op k) 159 | type OpOpInv k :% a = a 160 | 161 | OpOpInv % f = Op (Op f) 162 | 163 | 164 | -- | A functor wrapper in case of conflicting family instance declarations 165 | newtype Any f = Any f deriving Functor 166 | 167 | 168 | data Proj1 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Proj1 169 | 170 | -- | 'Proj1' is a bifunctor that projects out the first component of a product. 171 | instance (Category c1, Category c2) => Functor (Proj1 c1 c2) where 172 | type Dom (Proj1 c1 c2) = c1 :**: c2 173 | type Cod (Proj1 c1 c2) = c1 174 | type Proj1 c1 c2 :% (a1, a2) = a1 175 | 176 | Proj1 % (f1 :**: _) = f1 177 | 178 | 179 | data Proj2 (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Proj2 180 | 181 | -- | 'Proj2' is a bifunctor that projects out the second component of a product. 182 | instance (Category c1, Category c2) => Functor (Proj2 c1 c2) where 183 | type Dom (Proj2 c1 c2) = c1 :**: c2 184 | type Cod (Proj2 c1 c2) = c2 185 | type Proj2 c1 c2 :% (a1, a2) = a2 186 | 187 | Proj2 % (_ :**: f2) = f2 188 | 189 | 190 | data f1 :***: f2 where (:***:) :: (Functor f1, Functor f2) => f1 -> f2 -> f1 :***: f2 191 | 192 | -- | @f1 :***: f2@ is the product of the functors @f1@ and @f2@. 193 | instance (Functor f1, Functor f2) => Functor (f1 :***: f2) where 194 | type Dom (f1 :***: f2) = Dom f1 :**: Dom f2 195 | type Cod (f1 :***: f2) = Cod f1 :**: Cod f2 196 | type (f1 :***: f2) :% (a1, a2) = (f1 :% a1, f2 :% a2) 197 | 198 | (g1 :***: g2) % (f1 :**: f2) = (g1 % f1) :**: (g2 % f2) 199 | 200 | 201 | data DiagProd (k :: Type -> Type -> Type) = DiagProd 202 | 203 | -- | 'DiagProd' is the diagonal functor for products. 204 | instance Category k => Functor (DiagProd k) where 205 | type Dom (DiagProd k) = k 206 | type Cod (DiagProd k) = k :**: k 207 | type DiagProd k :% a = (a, a) 208 | 209 | DiagProd % f = f :**: f 210 | 211 | 212 | type Tuple1 c1 c2 a = (Const c2 c1 a :***: Id c2) :.: DiagProd c2 213 | -- | 'Tuple1' tuples with a fixed object on the left. 214 | pattern Tuple1 :: (Category c1, Category c2) => Obj c1 a -> Tuple1 c1 c2 a 215 | pattern Tuple1 a = (Const a :***: Id) :.: DiagProd 216 | 217 | type Swap (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = (Proj2 c1 c2 :***: Proj1 c1 c2) :.: DiagProd (c1 :**: c2) 218 | -- | 'swap' swaps the 2 categories of the product of categories. 219 | pattern Swap :: (Category c1, Category c2) => Swap c1 c2 220 | pattern Swap = (Proj2 :***: Proj1) :.: DiagProd 221 | 222 | type Tuple2 c1 c2 a = Swap c2 c1 :.: Tuple1 c2 c1 a 223 | -- | 'Tuple2' tuples with a fixed object on the right. 224 | pattern Tuple2 :: (Category c1, Category c2) => Obj c2 a -> Tuple2 c1 c2 a 225 | pattern Tuple2 a = Swap :.: Tuple1 a 226 | 227 | 228 | 229 | data Hom (k :: Type -> Type -> Type) = Hom 230 | 231 | -- | The Hom functor, Hom(--,--), a bifunctor contravariant in its first argument and covariant in its second argument. 232 | instance Category k => Functor (Hom k) where 233 | type Dom (Hom k) = Op k :**: k 234 | type Cod (Hom k) = (->) 235 | type (Hom k) :% (a1, a2) = k a1 a2 236 | 237 | Hom % (Op f1 :**: f2) = \g -> f2 . g . f1 238 | 239 | 240 | type x :*-: k = Hom k :.: Tuple1 (Op k) k x 241 | -- | The covariant functor Hom(X,--) 242 | pattern HomX_ :: Category k => Obj k x -> x :*-: k 243 | pattern HomX_ x = Hom :.: Tuple1 (Op x) 244 | 245 | type k :-*: x = Hom k :.: Tuple2 (Op k) k x 246 | -- | The contravariant functor Hom(--,X) 247 | pattern Hom_X :: Category k => Obj k x -> k :-*: x 248 | pattern Hom_X x = Hom :.: Tuple2 x 249 | 250 | 251 | type ProfunctorOf c d t = (FunctorOf (Op c :**: d) (->) t, Category c, Category d) -------------------------------------------------------------------------------- /Data/Category/Enriched/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators 3 | , TypeFamilies 4 | , GADTs 5 | , RankNTypes 6 | , PatternSynonyms 7 | , FlexibleContexts 8 | , FlexibleInstances 9 | , NoImplicitPrelude 10 | , UndecidableInstances 11 | , ScopedTypeVariables 12 | , ConstraintKinds 13 | , MultiParamTypeClasses 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Enriched.Functor 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Enriched.Functor where 25 | 26 | import Data.Kind (Type) 27 | 28 | import Data.Category (Category(..), Obj) 29 | import Data.Category.Functor (Functor(..)) 30 | import Data.Category.Limit (HasBinaryProducts(..), HasTerminalObject(..)) 31 | import Data.Category.CartesianClosed 32 | import Data.Category.Enriched 33 | 34 | -- | Enriched functors. 35 | class (ECategory (EDom ftag), ECategory (ECod ftag), V (EDom ftag) ~ V (ECod ftag)) => EFunctor ftag where 36 | 37 | -- | The domain, or source category, of the functor. 38 | type EDom ftag :: Type -> Type -> Type 39 | -- | The codomain, or target category, of the functor. 40 | type ECod ftag :: Type -> Type -> Type 41 | 42 | -- | @:%%@ maps objects at the type level 43 | type ftag :%% a :: Type 44 | 45 | -- | @%%@ maps object at the value level 46 | (%%) :: ftag -> Obj (EDom ftag) a -> Obj (ECod ftag) (ftag :%% a) 47 | 48 | -- | `map` maps arrows. 49 | map :: (EDom ftag ~ k) => ftag -> Obj k a -> Obj k b -> V k (k $ (a, b)) (ECod ftag $ (ftag :%% a, ftag :%% b)) 50 | 51 | type EFunctorOf a b t = (EFunctor t, EDom t ~ a, ECod t ~ b) 52 | 53 | 54 | data Id (k :: Type -> Type -> Type) = Id 55 | -- | The identity functor on k 56 | instance ECategory k => EFunctor (Id k) where 57 | type EDom (Id k) = k 58 | type ECod (Id k) = k 59 | type Id k :%% a = a 60 | Id %% a = a 61 | map Id = hom 62 | 63 | data (g :.: h) where 64 | (:.:) :: (EFunctor g, EFunctor h, ECod h ~ EDom g) => g -> h -> g :.: h 65 | -- | The composition of two functors. 66 | instance (ECategory (ECod g), ECategory (EDom h), V (EDom h) ~ V (ECod g), ECod h ~ EDom g) => EFunctor (g :.: h) where 67 | type EDom (g :.: h) = EDom h 68 | type ECod (g :.: h) = ECod g 69 | type (g :.: h) :%% a = g :%% (h :%% a) 70 | (g :.: h) %% a = g %% (h %% a) 71 | map (g :.: h) a b = map g (h %% a) (h %% b) . map h a b 72 | 73 | data Const (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) x where 74 | Const :: Obj c2 x -> Const c1 c2 x 75 | -- | The constant functor. 76 | instance (ECategory c1, ECategory c2, V c1 ~ V c2) => EFunctor (Const c1 c2 x) where 77 | type EDom (Const c1 c2 x) = c1 78 | type ECod (Const c1 c2 x) = c2 79 | type Const c1 c2 x :%% a = x 80 | Const x %% _ = x 81 | map (Const x) a b = id x . terminate (hom a b) 82 | 83 | data Opposite f where 84 | Opposite :: EFunctor f => f -> Opposite f 85 | -- | The dual of a functor 86 | instance (EFunctor f) => EFunctor (Opposite f) where 87 | type EDom (Opposite f) = EOp (EDom f) 88 | type ECod (Opposite f) = EOp (ECod f) 89 | type Opposite f :%% a = f :%% a 90 | Opposite f %% EOp a = EOp (f %% a) 91 | map (Opposite f) (EOp a) (EOp b) = map f b a 92 | 93 | data f1 :<*>: f2 = f1 :<*>: f2 94 | -- | @f1 :<*>: f2@ is the product of the functors @f1@ and @f2@. 95 | instance (EFunctor f1, EFunctor f2, V (ECod f1) ~ V (ECod f2)) => EFunctor (f1 :<*>: f2) where 96 | type EDom (f1 :<*>: f2) = EDom f1 :<>: EDom f2 97 | type ECod (f1 :<*>: f2) = ECod f1 :<>: ECod f2 98 | type (f1 :<*>: f2) :%% (a1, a2) = (f1 :%% a1, f2 :%% a2) 99 | (f1 :<*>: f2) %% (a1 :<>: a2) = (f1 %% a1) :<>: (f2 %% a2) 100 | map (f1 :<*>: f2) (a1 :<>: a2) (b1 :<>: b2) = map f1 a1 b1 *** map f2 a2 b2 101 | 102 | data DiagProd (k :: Type -> Type -> Type) = DiagProd 103 | -- | 'DiagProd' is the diagonal functor for products. 104 | instance ECategory k => EFunctor (DiagProd k) where 105 | type EDom (DiagProd k) = k 106 | type ECod (DiagProd k) = k :<>: k 107 | type DiagProd k :%% a = (a, a) 108 | DiagProd %% a = a :<>: a 109 | map DiagProd a b = hom a b &&& hom a b 110 | 111 | newtype UnderlyingF f = UnderlyingF f 112 | -- | The underlying functor of an enriched functor @f@ 113 | instance EFunctor f => Functor (UnderlyingF f) where 114 | type Dom (UnderlyingF f) = Underlying (EDom f) 115 | type Cod (UnderlyingF f) = Underlying (ECod f) 116 | type UnderlyingF f :% a = f :%% a 117 | UnderlyingF f % Underlying a ab b = Underlying (f %% a) (map f a b . ab) (f %% b) 118 | 119 | newtype InHaskF f = InHaskF f 120 | -- | A regular functor is a functor enriched in Hask. 121 | instance Functor f => EFunctor (InHaskF f) where 122 | type EDom (InHaskF f) = InHask (Dom f) 123 | type ECod (InHaskF f) = InHask (Cod f) 124 | type InHaskF f :%% a = f :% a 125 | InHaskF f %% InHask a = InHask (f % a) 126 | map (InHaskF f) _ _ = \g -> f % g 127 | 128 | newtype InHaskToHask f = InHaskToHask f 129 | instance (Functor f, Cod f ~ (->)) => EFunctor (InHaskToHask f) where 130 | type EDom (InHaskToHask f) = InHask (Dom f) 131 | type ECod (InHaskToHask f) = Self (->) 132 | type InHaskToHask f :%% a = f :% a 133 | InHaskToHask f %% InHask a = Self (f % a) 134 | map (InHaskToHask f) _ _ = \g -> f % g 135 | 136 | newtype UnderlyingHask (c :: Type -> Type -> Type) (d :: Type -> Type -> Type) f = UnderlyingHask f 137 | -- | The underlying functor of an enriched functor @f@ enriched in Hask. 138 | instance (EFunctor f, EDom f ~ InHask c, ECod f ~ InHask d, Category c, Category d) => Functor (UnderlyingHask c d f) where 139 | type Dom (UnderlyingHask c d f) = c 140 | type Cod (UnderlyingHask c d f) = d 141 | type UnderlyingHask c d f :% a = f :%% a 142 | UnderlyingHask f % g = map f (InHask (src g)) (InHask (tgt g)) g 143 | 144 | data EHom (k :: Type -> Type -> Type) = EHom 145 | instance ECategory k => EFunctor (EHom k) where 146 | type EDom (EHom k) = EOp k :<>: k 147 | type ECod (EHom k) = Self (V k) 148 | type EHom k :%% (a, b) = k $ (a, b) 149 | EHom %% (EOp a :<>: b) = Self (hom a b) 150 | map EHom (EOp a1 :<>: a2) (EOp b1 :<>: b2) = curry (ba *** ab) a b (comp b1 a1 b2 . (comp a1 a2 b2 . (proj2 ba ab *** a) &&& proj1 ba ab . proj1 (ba *** ab) a)) 151 | where 152 | a = hom a1 a2 153 | b = hom b1 b2 154 | ba = hom b1 a1 155 | ab = hom a2 b2 156 | 157 | -- | The enriched functor @k(x, -)@ 158 | data EHomX_ k x = EHomX_ (Obj k x) 159 | instance ECategory k => EFunctor (EHomX_ k x) where 160 | type EDom (EHomX_ k x) = k 161 | type ECod (EHomX_ k x) = Self (V k) 162 | type EHomX_ k x :%% y = k $ (x, y) 163 | EHomX_ x %% y = Self (hom x y) 164 | map (EHomX_ x) a b = curry (hom a b) (hom x a) (hom x b) (comp x a b) 165 | 166 | -- | The enriched functor @k(-, x)@ 167 | data EHom_X k x = EHom_X (Obj (EOp k) x) 168 | instance ECategory k => EFunctor (EHom_X k x) where 169 | type EDom (EHom_X k x) = EOp k 170 | type ECod (EHom_X k x) = Self (V k) 171 | type EHom_X k x :%% y = k $ (y, x) 172 | EHom_X x %% y = Self (hom x y) 173 | map (EHom_X x) a b = curry (hom a b) (hom x a) (hom x b) (comp x a b) 174 | 175 | 176 | -- | A V-enrichment on a functor @F: V -> V@ is the same thing as tensorial strength @(a, f b) -> f (a, b)@. 177 | strength :: EFunctorOf (Self v) (Self v) f => f -> Obj v a -> Obj v b -> v (BinaryProduct v a (f :%% b)) (f :%% (BinaryProduct v a b)) 178 | strength f a b = uncurry a fb fab (map f (Self b) (Self (a *** b)) . tuple b a) 179 | where 180 | Self fb = f %% Self b 181 | Self fab = f %% Self (a *** b) 182 | 183 | 184 | -- | Enriched natural transformations. 185 | data ENat :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where 186 | ENat :: (EFunctorOf c d f, EFunctorOf c d g) 187 | => f -> g -> (forall z. Obj c z -> Arr d (f :%% z) (g :%% z)) -> ENat c d f g 188 | -------------------------------------------------------------------------------- /Data/Category/Boolean.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies, GADTs, TypeOperators, LambdaCase, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, UndecidableInstances, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.Boolean 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | -- 11 | -- /2/ a.k.a. the Boolean category a.k.a. the walking arrow. 12 | -- It contains 2 objects, one for false and one for true. 13 | -- It contains 3 arrows, 2 identity arrows and one from false to true. 14 | ----------------------------------------------------------------------------- 15 | module Data.Category.Boolean where 16 | 17 | import Data.Kind (Type) 18 | 19 | import Data.Category 20 | import Data.Category.Limit 21 | import Data.Category.Monoidal 22 | import Data.Category.CartesianClosed 23 | 24 | import Data.Category.Functor 25 | import Data.Category.NaturalTransformation 26 | import Data.Category.Adjunction 27 | 28 | 29 | data Fls 30 | data Tru 31 | 32 | data Boolean a b where 33 | Fls :: Boolean Fls Fls 34 | F2T :: Boolean Fls Tru 35 | Tru :: Boolean Tru Tru 36 | 37 | -- | @Boolean@ is the category with true and false as objects, and an arrow from false to true. 38 | instance Category Boolean where 39 | 40 | src Fls = Fls 41 | src F2T = Fls 42 | src Tru = Tru 43 | 44 | tgt Fls = Fls 45 | tgt F2T = Tru 46 | tgt Tru = Tru 47 | 48 | Fls . Fls = Fls 49 | F2T . Fls = F2T 50 | Tru . F2T = F2T 51 | Tru . Tru = Tru 52 | 53 | 54 | -- | False is the initial object in the Boolean category. 55 | instance HasInitialObject Boolean where 56 | type InitialObject Boolean = Fls 57 | initialObject = Fls 58 | initialize Fls = Fls 59 | initialize Tru = F2T 60 | 61 | -- | True is the terminal object in the Boolean category. 62 | instance HasTerminalObject Boolean where 63 | type TerminalObject Boolean = Tru 64 | terminalObject = Tru 65 | terminate Fls = F2T 66 | terminate Tru = Tru 67 | 68 | 69 | -- | Conjunction is the binary product in the Boolean category. 70 | instance HasBinaryProducts Boolean where 71 | 72 | type BinaryProduct Boolean Fls Fls = Fls 73 | type BinaryProduct Boolean Fls Tru = Fls 74 | type BinaryProduct Boolean Tru Fls = Fls 75 | type BinaryProduct Boolean Tru Tru = Tru 76 | 77 | proj1 Fls Fls = Fls 78 | proj1 Fls Tru = Fls 79 | proj1 Tru Fls = F2T 80 | proj1 Tru Tru = Tru 81 | proj2 Fls Fls = Fls 82 | proj2 Fls Tru = F2T 83 | proj2 Tru Fls = Fls 84 | proj2 Tru Tru = Tru 85 | 86 | Fls &&& Fls = Fls 87 | Fls &&& F2T = Fls 88 | F2T &&& Fls = Fls 89 | F2T &&& F2T = F2T 90 | Tru &&& Tru = Tru 91 | 92 | 93 | -- | Disjunction is the binary coproduct in the Boolean category. 94 | instance HasBinaryCoproducts Boolean where 95 | 96 | type BinaryCoproduct Boolean Fls Fls = Fls 97 | type BinaryCoproduct Boolean Fls Tru = Tru 98 | type BinaryCoproduct Boolean Tru Fls = Tru 99 | type BinaryCoproduct Boolean Tru Tru = Tru 100 | 101 | inj1 Fls Fls = Fls 102 | inj1 Fls Tru = F2T 103 | inj1 Tru Fls = Tru 104 | inj1 Tru Tru = Tru 105 | inj2 Fls Fls = Fls 106 | inj2 Fls Tru = Tru 107 | inj2 Tru Fls = F2T 108 | inj2 Tru Tru = Tru 109 | 110 | Fls ||| Fls = Fls 111 | F2T ||| F2T = F2T 112 | F2T ||| Tru = Tru 113 | Tru ||| F2T = Tru 114 | Tru ||| Tru = Tru 115 | 116 | 117 | -- | Implication makes the Boolean category cartesian closed. 118 | instance CartesianClosed Boolean where 119 | 120 | type Exponential Boolean Fls Fls = Tru 121 | type Exponential Boolean Fls Tru = Tru 122 | type Exponential Boolean Tru Fls = Fls 123 | type Exponential Boolean Tru Tru = Tru 124 | 125 | apply Fls Fls = Fls 126 | apply Fls Tru = F2T 127 | apply Tru Fls = Fls 128 | apply Tru Tru = Tru 129 | 130 | tuple Fls Fls = F2T 131 | tuple Fls Tru = Tru 132 | tuple Tru Fls = Fls 133 | tuple Tru Tru = Tru 134 | 135 | Fls ^^^ Fls = Tru 136 | Fls ^^^ F2T = F2T 137 | Fls ^^^ Tru = Fls 138 | F2T ^^^ Fls = Tru 139 | F2T ^^^ F2T = F2T 140 | F2T ^^^ Tru = F2T 141 | Tru ^^^ Fls = Tru 142 | Tru ^^^ F2T = Tru 143 | Tru ^^^ Tru = Tru 144 | 145 | 146 | trueProductMonoid :: MonoidObject (ProductFunctor Boolean) Tru 147 | trueProductMonoid = MonoidObject Tru Tru 148 | 149 | falseCoproductComonoid :: ComonoidObject (CoproductFunctor Boolean) Fls 150 | falseCoproductComonoid = ComonoidObject Fls Fls 151 | 152 | trueProductComonoid :: ComonoidObject (ProductFunctor Boolean) Tru 153 | trueProductComonoid = ComonoidObject Tru Tru 154 | 155 | falseCoproductMonoid :: MonoidObject (CoproductFunctor Boolean) Fls 156 | falseCoproductMonoid = MonoidObject Fls Fls 157 | 158 | trueCoproductMonoid :: MonoidObject (CoproductFunctor Boolean) Tru 159 | trueCoproductMonoid = MonoidObject F2T Tru 160 | 161 | falseProductComonoid :: ComonoidObject (ProductFunctor Boolean) Fls 162 | falseProductComonoid = ComonoidObject F2T Fls 163 | 164 | 165 | newtype Arrow k a b = Arrow (k a b) 166 | -- | Any functor from the Boolean category points to an arrow in its target category. 167 | instance Category k => Functor (Arrow k a b) where 168 | type Dom (Arrow k a b) = Boolean 169 | type Cod (Arrow k a b) = k 170 | type Arrow k a b :% Fls = a 171 | type Arrow k a b :% Tru = b 172 | Arrow f % Fls = src f 173 | Arrow f % F2T = f 174 | Arrow f % Tru = tgt f 175 | 176 | 177 | -- | The limit of a functor from the Boolean category is the source of the arrow it points to. 178 | instance Category k => HasLimits Boolean k where 179 | type LimitFam Boolean k f = f :% Fls 180 | limit (Nat f _ _) = Nat (Const (f % Fls)) f (\case Fls -> f % Fls; Tru -> f % F2T) 181 | limitFactorizer n = n ! Fls 182 | 183 | -- | The source functor sends arrows (as functors from the Boolean category) to their source. 184 | type SrcFunctor = LimitFunctor Boolean 185 | 186 | -- | The colimit of a functor from the Boolean category is the target of the arrow it points to. 187 | instance Category k => HasColimits Boolean k where 188 | type ColimitFam Boolean k f = f :% Tru 189 | colimit (Nat f _ _) = Nat f (Const (f % Tru)) (\case Fls -> f % F2T; Tru -> f % Tru) 190 | colimitFactorizer n = n ! Tru 191 | 192 | -- | The target functor sends arrows (as functors from the Boolean category) to their target. 193 | type TgtFunctor = ColimitFunctor Boolean 194 | 195 | 196 | data Terminator (k :: Type -> Type -> Type) = Terminator 197 | -- | @Terminator k@ is the functor that sends an object to its terminating arrow. 198 | instance HasTerminalObject k => Functor (Terminator k) where 199 | type Dom (Terminator k) = k 200 | type Cod (Terminator k) = Nat Boolean k 201 | type Terminator k :% a = Arrow k a (TerminalObject k) 202 | Terminator % f = Nat (Arrow (terminate (src f))) (Arrow (terminate (tgt f))) (\case Fls -> f; Tru -> terminalObject) 203 | 204 | -- | @Terminator@ is right adjoint to the source functor. 205 | terminatorLimitAdj :: HasTerminalObject k => Adjunction k (Nat Boolean k) (SrcFunctor k) (Terminator k) 206 | terminatorLimitAdj = mkAdjunctionInit LimitFunctor Terminator 207 | (\(Nat b _ _) -> Nat b (Arrow (terminate (b % Fls))) (\case Fls -> b % Fls; Tru -> terminate (b % Tru))) 208 | (\_ n -> n ! Fls) 209 | 210 | 211 | data Initializer (k :: Type -> Type -> Type) = Initializer 212 | -- | @Initializer k@ is the functor that sends an object to its initializing arrow. 213 | instance HasInitialObject k => Functor (Initializer k) where 214 | type Dom (Initializer k) = k 215 | type Cod (Initializer k) = Nat Boolean k 216 | type Initializer k :% a = Arrow k (InitialObject k) a 217 | Initializer % f = Nat (Arrow (initialize (src f))) (Arrow (initialize (tgt f))) (\case Fls -> initialObject; Tru -> f) 218 | 219 | -- | @Initializer@ is left adjoint to the target functor. 220 | initializerColimitAdj :: HasInitialObject k => Adjunction (Nat Boolean k) k (Initializer k) (TgtFunctor k) 221 | initializerColimitAdj = mkAdjunctionTerm Initializer ColimitFunctor 222 | (\_ n -> n ! Tru) 223 | (\(Nat b _ _) -> Nat (Arrow (initialize (b % Tru))) b (\case Fls -> initialize (b % Fls); Tru -> b % Tru)) 224 | -------------------------------------------------------------------------------- /Data/Category/NaturalTransformation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeOperators, TypeFamilies, PatternSynonyms, FlexibleInstances, FlexibleContexts, UndecidableInstances, RankNTypes, GADTs, LiberalTypeSynonyms, NoImplicitPrelude #-} 2 | ----------------------------------------------------------------------------- 3 | -- | 4 | -- Module : Data.Category.NaturalTransformation 5 | -- License : BSD-style (see the file LICENSE) 6 | -- 7 | -- Maintainer : sjoerd@w3future.com 8 | -- Stability : experimental 9 | -- Portability : non-portable 10 | ----------------------------------------------------------------------------- 11 | module Data.Category.NaturalTransformation ( 12 | 13 | -- * Natural transformations 14 | (:~>) 15 | , Component 16 | , (!) 17 | , o 18 | , natId 19 | , pattern NatId 20 | , srcF 21 | , tgtF 22 | 23 | -- * Functor category 24 | , Nat(..) 25 | , Endo 26 | , Presheaves 27 | , Profunctors 28 | 29 | -- * Functor isomorphisms 30 | , compAssoc 31 | , compAssocInv 32 | , idPrecomp 33 | , idPrecompInv 34 | , idPostcomp 35 | , idPostcompInv 36 | , constPrecompIn 37 | , constPrecompOut 38 | , constPostcompIn 39 | , constPostcompOut 40 | 41 | -- * Related functors 42 | , FunctorCompose(..) 43 | , EndoFunctorCompose 44 | , Precompose, pattern Precompose 45 | , Postcompose, pattern Postcompose 46 | , Curry1, pattern Curry1 47 | , Curry2, pattern Curry2 48 | , Wrap(..) 49 | , Apply(..) 50 | , Tuple(..) 51 | , Opp(..), Opposite, pattern Opposite 52 | , HomF, pattern HomF 53 | , Star, pattern Star 54 | , Costar, pattern Costar 55 | , (:*%:), pattern HomXF 56 | , (:%*:), pattern HomFX 57 | 58 | ) where 59 | 60 | import Data.Kind (Type) 61 | 62 | import Data.Category 63 | import Data.Category.Functor 64 | import Data.Category.Product 65 | 66 | infixl 9 ! 67 | 68 | -- | @f :~> g@ is a natural transformation from functor f to functor g. 69 | type f :~> g = forall c d. (c ~ Dom f, c ~ Dom g, d ~ Cod f, d ~ Cod g) => Nat c d f g 70 | 71 | -- | Natural transformations are built up of components, 72 | -- one for each object @z@ in the domain category of @f@ and @g@. 73 | data Nat :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type -> Type -> Type where 74 | Nat :: (Functor f, Functor g, c ~ Dom f, c ~ Dom g, d ~ Cod f, d ~ Cod g) 75 | => f -> g -> (forall z. Obj c z -> Component f g z) -> Nat c d f g 76 | 77 | 78 | -- | A component for an object @z@ is an arrow from @F z@ to @G z@. 79 | type Component f g z = Cod f (f :% z) (g :% z) 80 | 81 | -- | 'n ! a' returns the component for the object @a@ of a natural transformation @n@. 82 | -- This can be generalized to any arrow (instead of just identity arrows). 83 | (!) :: (Category c, Category d) => Nat c d f g -> c a b -> d (f :% a) (g :% b) 84 | Nat f _ n ! h = n (tgt h) . f % h -- or g % h . n (src h), or n h when h is an identity arrow 85 | 86 | 87 | -- | Horizontal composition of natural transformations. 88 | o :: (Category c, Category d, Category e) => Nat d e j k -> Nat c d f g -> Nat c e (j :.: f) (k :.: g) 89 | njk@(Nat j k _) `o` nfg@(Nat f g _) = Nat (j :.: f) (k :.: g) ((njk !) . (nfg !)) 90 | -- Nat j k njk `o` Nat f g nfg = Nat (j :.: f) (k :.: g) (\x -> njk (g % x) . j % nfg x) -- or k % nfg x . njk (f % x) 91 | 92 | -- | The identity natural transformation of a functor. 93 | natId :: Functor f => f -> Nat (Dom f) (Cod f) f f 94 | natId f = Nat f f (f %) 95 | 96 | pattern NatId :: () => (Functor f, c ~ Dom f, d ~ Cod f) => f -> Nat c d f f 97 | pattern NatId f <- Nat f _ _ where 98 | NatId f = Nat f f (f %) 99 | {-# COMPLETE NatId #-} 100 | 101 | srcF :: Nat c d f g -> f 102 | srcF (Nat f _ _) = f 103 | 104 | tgtF :: Nat c d f g -> g 105 | tgtF (Nat _ g _) = g 106 | 107 | -- | Functor category D^C. 108 | -- Objects of D^C are functors from C to D. 109 | -- Arrows of D^C are natural transformations. 110 | instance Category d => Category (Nat c d) where 111 | 112 | src (Nat f _ _) = natId f 113 | tgt (Nat _ g _) = natId g 114 | 115 | Nat _ h ngh . Nat f _ nfg = Nat f h (\i -> ngh i . nfg i) 116 | 117 | 118 | compAssoc :: (Functor f, Functor g, Functor h, Dom f ~ Cod g, Dom g ~ Cod h) 119 | => f -> g -> h -> Nat (Dom h) (Cod f) ((f :.: g) :.: h) (f :.: (g :.: h)) 120 | compAssoc f g h = Nat ((f :.: g) :.: h) (f :.: (g :.: h)) (\i -> f % g % h % i) 121 | 122 | compAssocInv :: (Functor f, Functor g, Functor h, Dom f ~ Cod g, Dom g ~ Cod h) 123 | => f -> g -> h -> Nat (Dom h) (Cod f) (f :.: (g :.: h)) ((f :.: g) :.: h) 124 | compAssocInv f g h = Nat (f :.: (g :.: h)) ((f :.: g) :.: h) (\i -> f % g % h % i) 125 | 126 | idPrecomp :: Functor f => f -> Nat (Dom f) (Cod f) (f :.: Id (Dom f)) f 127 | idPrecomp f = Nat (f :.: Id) f (f %) 128 | 129 | idPrecompInv :: Functor f => f -> Nat (Dom f) (Cod f) f (f :.: Id (Dom f)) 130 | idPrecompInv f = Nat f (f :.: Id) (f %) 131 | 132 | idPostcomp :: Functor f => f -> Nat (Dom f) (Cod f) (Id (Cod f) :.: f) f 133 | idPostcomp f = Nat (Id :.: f) f (f %) 134 | 135 | idPostcompInv :: Functor f => f -> Nat (Dom f) (Cod f) f (Id (Cod f) :.: f) 136 | idPostcompInv f = Nat f (Id :.: f) (f %) 137 | 138 | 139 | constPrecompIn :: Nat j d (f :.: Const j c x) g -> Nat j d (Const j d (f :% x)) g 140 | constPrecompIn (Nat (f :.: Const x) g n) = Nat (Const (f % x)) g n 141 | 142 | constPrecompOut :: Nat j d f (g :.: Const j c x) -> Nat j d f (Const j d (g :% x)) 143 | constPrecompOut (Nat f (g :.: Const x) n) = Nat f (Const (g % x)) n 144 | 145 | constPostcompIn :: Nat j d (Const k d x :.: f) g -> Nat j d (Const j d x) g 146 | constPostcompIn (Nat (Const x :.: _) g n) = Nat (Const x) g n 147 | 148 | constPostcompOut :: Nat j d f (Const k d x :.: g) -> Nat j d f (Const j d x) 149 | constPostcompOut (Nat f (Const x :.: _) n) = Nat f (Const x) n 150 | 151 | 152 | data FunctorCompose (c :: Type -> Type -> Type) (d :: Type -> Type -> Type) (e :: Type -> Type -> Type) = FunctorCompose 153 | 154 | -- | Composition of functors is a functor. 155 | instance (Category c, Category d, Category e) => Functor (FunctorCompose c d e) where 156 | type Dom (FunctorCompose c d e) = Nat d e :**: Nat c d 157 | type Cod (FunctorCompose c d e) = Nat c e 158 | type FunctorCompose c d e :% (f, g) = f :.: g 159 | 160 | FunctorCompose % (n1 :**: n2) = n1 `o` n2 161 | 162 | 163 | -- | The category of endofunctors. 164 | type Endo k = Nat k k 165 | -- | Composition of endofunctors is a functor. 166 | type EndoFunctorCompose k = FunctorCompose k k k 167 | 168 | type Presheaves k = Nat (Op k) (->) 169 | 170 | type Profunctors c d = Nat (Op d :**: c) (->) 171 | 172 | 173 | -- | @Precompose f e@ is the functor such that @Precompose f e :% g = g :.: f@, 174 | -- for functors @g@ that compose with @f@ and with codomain @e@. 175 | type Precompose f e = FunctorCompose (Dom f) (Cod f) e :.: Tuple2 (Nat (Cod f) e) (Nat (Dom f) (Cod f)) f 176 | pattern Precompose :: (Category e, Functor f) => f -> Precompose f e 177 | pattern Precompose f = FunctorCompose :.: Tuple2 (NatId f) 178 | 179 | -- | @Postcompose f c@ is the functor such that @Postcompose f c :% g = f :.: g@, 180 | -- for functors @g@ that compose with @f@ and with domain @c@. 181 | type Postcompose f c = FunctorCompose c (Dom f) (Cod f) :.: Tuple1 (Nat (Dom f) (Cod f)) (Nat c (Dom f)) f 182 | pattern Postcompose :: (Category c, Functor f) => f -> Postcompose f c 183 | pattern Postcompose f = FunctorCompose :.: Tuple1 (NatId f) 184 | 185 | 186 | type Curry1 c1 c2 f = Postcompose f c2 :.: Tuple c1 c2 187 | -- | Curry on the first "argument" of a functor from a product category. 188 | pattern Curry1 :: (Functor f, Dom f ~ c1 :**: c2, Category c1, Category c2) => f -> Curry1 c1 c2 f 189 | pattern Curry1 f = Postcompose f :.: Tuple 190 | 191 | type Curry2 c1 c2 f = Postcompose f c1 :.: Curry1 c2 c1 (Swap c2 c1) 192 | -- | Curry on the second "argument" of a functor from a product category. 193 | pattern Curry2 :: (Functor f, Dom f ~ c1 :**: c2, Category c1, Category c2) => f -> Curry2 c1 c2 f 194 | pattern Curry2 f = Postcompose f :.: Curry1 Swap 195 | 196 | 197 | data Wrap f h = Wrap f h 198 | 199 | -- | @Wrap f h@ is the functor such that @Wrap f h :% g = f :.: g :.: h@, 200 | -- for functors @g@ that compose with @f@ and @h@. 201 | instance (Functor f, Functor h) => Functor (Wrap f h) where 202 | type Dom (Wrap f h) = Nat (Cod h) (Dom f) 203 | type Cod (Wrap f h) = Nat (Dom h) (Cod f) 204 | type Wrap f h :% g = f :.: g :.: h 205 | 206 | Wrap f h % n = natId f `o` n `o` natId h 207 | 208 | 209 | data Apply (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Apply 210 | -- | 'Apply' is a bifunctor, @Apply :% (f, a)@ applies @f@ to @a@, i.e. @f :% a@. 211 | instance (Category c1, Category c2) => Functor (Apply c1 c2) where 212 | type Dom (Apply c1 c2) = Nat c2 c1 :**: c2 213 | type Cod (Apply c1 c2) = c1 214 | type Apply c1 c2 :% (f, a) = f :% a 215 | Apply % (l :**: r) = l ! r 216 | 217 | data Tuple (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Tuple 218 | -- | 'Tuple' converts an object @a@ to the functor 'Tuple1' @a@. 219 | instance (Category c1, Category c2) => Functor (Tuple c1 c2) where 220 | type Dom (Tuple c1 c2) = c1 221 | type Cod (Tuple c1 c2) = Nat c2 (c1 :**: c2) 222 | type Tuple c1 c2 :% a = Tuple1 c1 c2 a 223 | Tuple % f = Nat (Tuple1 (src f)) (Tuple1 (tgt f)) (f :**:) 224 | 225 | 226 | data Opp (c1 :: Type -> Type -> Type) (c2 :: Type -> Type -> Type) = Opp 227 | -- | Turning a functor into its dual is contravariantly functorial. 228 | instance (Category c1, Category c2) => Functor (Opp c1 c2) where 229 | type Dom (Opp c1 c2) = Op (Nat c1 c2) :**: Op c1 230 | type Cod (Opp c1 c2) = Op c2 231 | type Opp c1 c2 :% (f, a) = f :% a 232 | Opp % (Op n :**: Op f) = Op (n ! f) 233 | 234 | type Opposite f = Opp (Dom f) (Cod f) :.: Tuple1 (Op (Nat (Dom f) (Cod f))) (Op (Dom f)) f 235 | -- | The dual of a functor 236 | pattern Opposite :: Functor f => f -> Opposite f 237 | pattern Opposite f = Opp :.: Tuple1 (Op (NatId f)) 238 | {-# COMPLETE Opposite #-} 239 | 240 | 241 | type HomF f g = Hom (Cod f) :.: (Opposite f :***: g) 242 | pattern HomF :: (Functor f, Functor g, Cod f ~ Cod g) => f -> g -> HomF f g 243 | pattern HomF f g = Hom :.: (Opposite f :***: g) 244 | {-# COMPLETE HomF #-} 245 | 246 | type Star f = HomF (Id (Cod f)) f 247 | pattern Star :: Functor f => f -> Star f 248 | pattern Star f = HomF Id f 249 | {-# COMPLETE Star #-} 250 | 251 | type Costar f = HomF f (Id (Cod f)) 252 | pattern Costar :: Functor f => f -> Costar f 253 | pattern Costar f = HomF f Id 254 | {-# COMPLETE Costar #-} 255 | 256 | type x :*%: f = (x :*-: Cod f) :.: f 257 | -- | The covariant functor Hom(X,F-) 258 | pattern HomXF :: Functor f => Obj (Cod f) x -> f -> x :*%: f 259 | pattern HomXF x f = HomX_ x :.: f 260 | {-# COMPLETE HomXF #-} 261 | 262 | type f :%*: x = (Cod f :-*: x) :.: Opposite f 263 | -- | The contravariant functor Hom(F-,X) 264 | pattern HomFX :: Functor f => f -> Obj (Cod f) x -> f :%*: x 265 | pattern HomFX f x = Hom_X x :.: Opposite f 266 | {-# COMPLETE HomFX #-} -------------------------------------------------------------------------------- /Data/Category/Monoidal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | TypeOperators 3 | , TypeFamilies 4 | , GADTs 5 | , PolyKinds 6 | , DataKinds 7 | , Rank2Types 8 | , ViewPatterns 9 | , TypeSynonymInstances 10 | , FlexibleContexts 11 | , FlexibleInstances 12 | , UndecidableInstances 13 | , NoImplicitPrelude 14 | #-} 15 | ----------------------------------------------------------------------------- 16 | -- | 17 | -- Module : Data.Category.Monoidal 18 | -- License : BSD-style (see the file LICENSE) 19 | -- 20 | -- Maintainer : sjoerd@w3future.com 21 | -- Stability : experimental 22 | -- Portability : non-portable 23 | ----------------------------------------------------------------------------- 24 | module Data.Category.Monoidal where 25 | 26 | import Data.Category 27 | import Data.Category.Functor 28 | import Data.Category.NaturalTransformation 29 | import Data.Category.Adjunction 30 | import Data.Category.Limit 31 | import Data.Category.Product 32 | import Data.Category.KanExtension 33 | 34 | import GHC.Exts (FUN) 35 | import GHC.Types (Multiplicity(One)) 36 | 37 | 38 | -- | A monoidal category is a category with some kind of tensor product. 39 | -- A tensor product is a bifunctor, with a unit object. 40 | class (Functor f, Dom f ~ (Cod f :**: Cod f)) => TensorProduct f where 41 | 42 | type Unit f :: Kind (Cod f) 43 | unitObject :: f -> Obj (Cod f) (Unit f) 44 | 45 | leftUnitor :: Cod f ~ k => f -> Obj k a -> k (f :% (Unit f, a)) a 46 | leftUnitorInv :: Cod f ~ k => f -> Obj k a -> k a (f :% (Unit f, a)) 47 | rightUnitor :: Cod f ~ k => f -> Obj k a -> k (f :% (a, Unit f)) a 48 | rightUnitorInv :: Cod f ~ k => f -> Obj k a -> k a (f :% (a, Unit f)) 49 | 50 | associator :: Cod f ~ k => f -> Obj k a -> Obj k b -> Obj k c -> k (f :% (f :% (a, b), c)) (f :% (a, f :% (b, c))) 51 | associatorInv :: Cod f ~ k => f -> Obj k a -> Obj k b -> Obj k c -> k (f :% (a, f :% (b, c))) (f :% (f :% (a, b), c)) 52 | 53 | class TensorProduct f => SymmetricTensorProduct f where 54 | swap :: Cod f ~ k => f -> Obj k a -> Obj k b -> k (f :% (a, b)) (f :% (b, a)) 55 | 56 | -- | If a category has all products, then the product functor makes it a monoidal category, 57 | -- with the terminal object as unit. 58 | instance (HasTerminalObject k, HasBinaryProducts k) => TensorProduct (ProductFunctor k) where 59 | 60 | type Unit (ProductFunctor k) = TerminalObject k 61 | unitObject _ = terminalObject 62 | 63 | leftUnitor _ a = proj2 terminalObject a 64 | leftUnitorInv _ a = terminate a &&& a 65 | rightUnitor _ a = proj1 a terminalObject 66 | rightUnitorInv _ a = a &&& terminate a 67 | 68 | associator _ a b c = (proj1 a b . proj1 (a *** b) c) &&& (proj2 a b *** c) 69 | associatorInv _ a b c = (a *** proj1 b c) &&& (proj2 b c . proj2 a (b *** c)) 70 | 71 | instance (HasTerminalObject k, HasBinaryProducts k) => SymmetricTensorProduct (ProductFunctor k) where 72 | swap _ a b = proj2 a b &&& proj1 a b 73 | 74 | -- | If a category has all coproducts, then the coproduct functor makes it a monoidal category, 75 | -- with the initial object as unit. 76 | instance (HasInitialObject k, HasBinaryCoproducts k) => TensorProduct (CoproductFunctor k) where 77 | 78 | type Unit (CoproductFunctor k) = InitialObject k 79 | unitObject _ = initialObject 80 | 81 | leftUnitor _ a = initialize a ||| a 82 | leftUnitorInv _ a = inj2 initialObject a 83 | rightUnitor _ a = a ||| initialize a 84 | rightUnitorInv _ a = inj1 a initialObject 85 | 86 | associator _ a b c = (a +++ inj1 b c) ||| (inj2 a (b +++ c) . inj2 b c) 87 | associatorInv _ a b c = (inj1 (a +++ b) c . inj1 a b) ||| (inj2 a b +++ c) 88 | 89 | instance (HasInitialObject k, HasBinaryCoproducts k) => SymmetricTensorProduct (CoproductFunctor k) where 90 | swap _ a b = inj2 b a ||| inj1 b a 91 | 92 | -- | Functor composition makes the category of endofunctors monoidal, with the identity functor as unit. 93 | instance Category k => TensorProduct (EndoFunctorCompose k) where 94 | 95 | type Unit (EndoFunctorCompose k) = Id k 96 | unitObject _ = natId Id 97 | 98 | leftUnitor _ (Nat g _ _) = idPostcomp g 99 | leftUnitorInv _ (Nat g _ _) = idPostcompInv g 100 | rightUnitor _ (Nat g _ _) = idPrecomp g 101 | rightUnitorInv _ (Nat g _ _) = idPrecompInv g 102 | 103 | associator _ (Nat f _ _) (Nat g _ _) (Nat h _ _) = compAssoc f g h 104 | associatorInv _ (Nat f _ _) (Nat g _ _) (Nat h _ _) = compAssocInv f g h 105 | 106 | data LinearTensor = LinearTensor 107 | instance Functor LinearTensor where 108 | type Dom LinearTensor = FUN 'One :**: FUN 'One 109 | type Cod LinearTensor = FUN 'One 110 | type LinearTensor :% (a, b) = (a, b) 111 | 112 | LinearTensor % (f :**: g) = \(a, b) -> (f a, g b) 113 | 114 | instance TensorProduct LinearTensor where 115 | type Unit LinearTensor = () 116 | unitObject _ = obj 117 | 118 | leftUnitor _ _ = \((), a) -> a 119 | leftUnitorInv _ _ = \a -> ((), a) 120 | rightUnitor _ _ = \(a, ()) -> a 121 | rightUnitorInv _ _ = \a -> (a, ()) 122 | associator _ _ _ _ = \((a, b), c) -> (a, (b, c)) 123 | associatorInv _ _ _ _ = \(a, (b, c)) -> ((a, b), c) 124 | 125 | instance SymmetricTensorProduct LinearTensor where 126 | swap _ _ _ = \(a, b) -> (b, a) 127 | 128 | 129 | -- | Day convolution 130 | data Day t = Day t 131 | instance TensorProduct t => Functor (Day t) where 132 | type Dom (Day t) = Nat (Cod t) (->) :**: Nat (Cod t) (->) 133 | type Cod (Day t) = Nat (Cod t) (->) 134 | type Day t :% (f, g) = LanHaskF t (ProductFunctor (->) :.: (f :***: g)) 135 | Day _ % (nf :**: ng) = 136 | Nat LanHaskF LanHaskF (\_ (LanHask x@(x1 :**: x2) tx fgx) -> LanHask x tx ((nf ! x1 *** ng ! x2) fgx)) 137 | 138 | instance TensorProduct t => TensorProduct (Day t) where 139 | type Unit (Day t) = Curry1 (Op (Cod t)) (Cod t) (Hom (Cod t)) :% Unit t 140 | unitObject (Day t) = Curry1 Hom % Op (unitObject t) 141 | leftUnitor (Day t) (NatId a) = 142 | Nat LanHaskF a (\_ (LanHask (_ :**: c2) tcz (uc1, ac2)) -> (a % (tcz . t % (uc1 :**: c2) . leftUnitorInv t c2)) ac2) 143 | leftUnitorInv (Day t) (NatId a) = 144 | Nat a LanHaskF (\z az -> LanHask (unitObject t :**: z) (leftUnitor t z) (unitObject t, az)) 145 | rightUnitor (Day t) (NatId a) = 146 | Nat LanHaskF a (\_ (LanHask (c1 :**: _) tcz (ac1, uc2)) -> (a % (tcz . t % (c1 :**: uc2) . rightUnitorInv t c1)) ac1) 147 | rightUnitorInv (Day t) (NatId a) = 148 | Nat a LanHaskF (\z az -> LanHask (z :**: unitObject t) (rightUnitor t z) (az, unitObject t)) 149 | associator (Day t) _ _ _ = 150 | Nat LanHaskF LanHaskF (\_ (LanHask (_e :**: d) eda (LanHask (b :**: c) bce (fb, gc), hd)) -> 151 | let cd = c :**: d; tcd = t % cd 152 | in LanHask (b :**: tcd) (eda . t % (bce :**: d) . associatorInv t b c d) (fb, LanHask cd tcd (gc, hd))) 153 | associatorInv (Day t) _ _ _ = 154 | Nat LanHaskF LanHaskF (\_ (LanHask (b :**: _c) bca (fb, LanHask (d :**: e) dec (gd, he))) -> 155 | let bd = b :**: d; tbd = t % bd 156 | in LanHask (tbd :**: e) (bca . t % (b :**: dec) . associator t b d e) (LanHask bd tbd (fb, gd), he)) 157 | 158 | 159 | -- | @MonoidObject f a@ defines a monoid @a@ in a monoidal category with tensor product @f@. 160 | data MonoidObject f a = MonoidObject 161 | { unit :: Cod f (Unit f) a 162 | , multiply :: Cod f (f :% (a, a)) a 163 | } 164 | 165 | trivialMonoid :: TensorProduct f => f -> MonoidObject f (Unit f) 166 | trivialMonoid f = MonoidObject (unitObject f) (leftUnitor f (unitObject f)) 167 | 168 | coproductMonoid :: (HasInitialObject k, HasBinaryCoproducts k) => Obj k a -> MonoidObject (CoproductFunctor k) a 169 | coproductMonoid a = MonoidObject (initialize a) (a ||| a) 170 | 171 | 172 | -- | @ComonoidObject f a@ defines a comonoid @a@ in a comonoidal category with tensor product @f@. 173 | data ComonoidObject f a = ComonoidObject 174 | { counit :: Cod f a (Unit f) 175 | , comultiply :: Cod f a (f :% (a, a)) 176 | } 177 | 178 | trivialComonoid :: TensorProduct f => f -> ComonoidObject f (Unit f) 179 | trivialComonoid f = ComonoidObject (unitObject f) (leftUnitorInv f (unitObject f)) 180 | 181 | productComonoid :: (HasTerminalObject k, HasBinaryProducts k) => Obj k a -> ComonoidObject (ProductFunctor k) a 182 | productComonoid a = ComonoidObject (terminate a) (a &&& a) 183 | 184 | 185 | data MonoidAsCategory f m a b where 186 | MonoidValue :: (TensorProduct f, Dom f ~ (k :**: k), Cod f ~ k) 187 | => f -> MonoidObject f m -> k (Unit f) m -> MonoidAsCategory f m m m 188 | 189 | -- | A monoid as a category with one object. 190 | instance Category (MonoidAsCategory f m) where 191 | 192 | src (MonoidValue f m _) = MonoidValue f m (unit m) 193 | tgt (MonoidValue f m _) = MonoidValue f m (unit m) 194 | 195 | MonoidValue f m a . MonoidValue _ _ b = MonoidValue f m (multiply m . f % (a :**: b) . leftUnitorInv f (unitObject f)) 196 | 197 | 198 | -- | A monad is a monoid in the category of endofunctors. 199 | type Monad f = MonoidObject (EndoFunctorCompose (Dom f)) f 200 | 201 | mkMonad :: (Functor f, Dom f ~ k, Cod f ~ k) 202 | => f 203 | -> (forall a. Obj k a -> Component (Id k) f a) 204 | -> (forall a. Obj k a -> Component (f :.: f) f a) 205 | -> Monad f 206 | mkMonad f ret join = MonoidObject 207 | { unit = Nat Id f ret 208 | , multiply = Nat (f :.: f) f join 209 | } 210 | 211 | monadFunctor :: Monad f -> f 212 | monadFunctor (unit -> Nat _ f _) = f 213 | 214 | idMonad :: Category k => Monad (Id k) 215 | idMonad = MonoidObject (natId Id) (idPrecomp Id) 216 | 217 | 218 | -- | A comonad is a comonoid in the category of endofunctors. 219 | type Comonad f = ComonoidObject (EndoFunctorCompose (Dom f)) f 220 | 221 | mkComonad :: (Functor f, Dom f ~ k, Cod f ~ k) 222 | => f 223 | -> (forall a. Obj k a -> Component f (Id k) a) 224 | -> (forall a. Obj k a -> Component f (f :.: f) a) 225 | -> Comonad f 226 | mkComonad f extr dupl = ComonoidObject 227 | { counit = Nat f Id extr 228 | , comultiply = Nat f (f :.: f) dupl 229 | } 230 | 231 | idComonad :: Category k => Comonad (Id k) 232 | idComonad = ComonoidObject (natId Id) (idPrecompInv Id) 233 | 234 | 235 | -- | Every adjunction gives rise to an associated monad. 236 | adjunctionMonad :: Adjunction c d f g -> Monad (g :.: f) 237 | adjunctionMonad adj@(Adjunction f g _ _) = 238 | let MonoidObject ret mult = adjunctionMonadT adj idMonad 239 | in mkMonad (g :.: f) (ret !) (mult !) 240 | 241 | -- | Every adjunction gives rise to an associated monad transformer. 242 | adjunctionMonadT :: (Dom m ~ c) => Adjunction c d f g -> Monad m -> Monad (g :.: m :.: f) 243 | adjunctionMonadT adj@(Adjunction f g _ _) (MonoidObject ret@(Nat _ m _) mult) = mkMonad (g :.: m :.: f) 244 | ((Wrap g f % ret . idPrecompInv g `o` natId f . adjunctionUnit adj) !) 245 | ((Wrap g f % (mult . idPrecomp m `o` natId m . Wrap m m % adjunctionCounit adj)) !) 246 | 247 | -- | Every adjunction gives rise to an associated comonad. 248 | adjunctionComonad :: Adjunction c d f g -> Comonad (f :.: g) 249 | adjunctionComonad adj@(Adjunction f g _ _) = 250 | let ComonoidObject extr dupl = adjunctionComonadT adj idComonad 251 | in mkComonad (f :.: g) (extr !) (dupl !) 252 | 253 | -- | Every adjunction gives rise to an associated comonad transformer. 254 | adjunctionComonadT :: (Dom w ~ d) => Adjunction c d f g -> Comonad w -> Comonad (f :.: w :.: g) 255 | adjunctionComonadT adj@(Adjunction f g _ _) (ComonoidObject extr@(Nat w _ _) dupl) = mkComonad (f :.: w :.: g) 256 | ((adjunctionCounit adj . idPrecomp f `o` natId g . Wrap f g % extr) !) 257 | ((Wrap f g % (Wrap w w % adjunctionUnit adj . idPrecompInv w `o` natId w . dupl)) !) 258 | -------------------------------------------------------------------------------- /Data/Category/Limit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE 2 | FlexibleContexts, 3 | FlexibleInstances, 4 | GADTs, 5 | PolyKinds, 6 | DataKinds, 7 | LinearTypes, 8 | LambdaCase, 9 | EmptyCase, 10 | BlockArguments, 11 | MultiParamTypeClasses, 12 | RankNTypes, 13 | ScopedTypeVariables, 14 | TypeOperators, 15 | TypeFamilies, 16 | TypeSynonymInstances, 17 | UndecidableInstances, 18 | NoImplicitPrelude #-} 19 | ----------------------------------------------------------------------------- 20 | -- | 21 | -- Module : Data.Category.Limit 22 | -- License : BSD-style (see the file LICENSE) 23 | -- 24 | -- Maintainer : sjoerd@w3future.com 25 | -- Stability : experimental 26 | -- Portability : non-portable 27 | ----------------------------------------------------------------------------- 28 | module Data.Category.Limit ( 29 | 30 | -- * Preliminairies 31 | 32 | -- ** Diagonal Functor 33 | Diag(..) 34 | , DiagF 35 | 36 | -- ** Cones 37 | , Cone 38 | , Cocone 39 | , coneVertex 40 | , coconeVertex 41 | 42 | -- * Limits 43 | , HasLimits(..) 44 | , Limit 45 | , LimitFunctor(..) 46 | , limitAdj 47 | , adjLimit 48 | , adjLimitFactorizer 49 | , rightAdjointPreservesLimits 50 | , rightAdjointPreservesLimitsInv 51 | 52 | -- * Colimits 53 | , HasColimits(..) 54 | , Colimit 55 | , ColimitFunctor(..) 56 | , colimitAdj 57 | , adjColimit 58 | , adjColimitFactorizer 59 | , leftAdjointPreservesColimits 60 | , leftAdjointPreservesColimitsInv 61 | 62 | -- * Limits of type Void 63 | , HasTerminalObject(..) 64 | , HasInitialObject(..) 65 | , Zero 66 | 67 | -- * Limits of type Pair 68 | , HasBinaryProducts(..) 69 | , ProductFunctor(..) 70 | , (:*:)(..) 71 | , prodAdj 72 | , type (&)(..) 73 | , HasBinaryCoproducts(..) 74 | , CoproductFunctor(..) 75 | , (:+:)(..) 76 | , coprodAdj 77 | , Either(..) 78 | 79 | ) where 80 | 81 | import Data.Kind (Type) 82 | import GHC.Exts (FUN) 83 | import GHC.Types (Multiplicity(One)) 84 | import Prelude (Either(..)) 85 | 86 | import Data.Category 87 | import Data.Category.Functor 88 | import Data.Category.NaturalTransformation 89 | import Data.Category.Adjunction 90 | 91 | import Data.Category.Product 92 | import Data.Category.Coproduct 93 | import Data.Category.Unit 94 | import Data.Category.Void 95 | 96 | infixl 3 *** 97 | infixl 3 &&& 98 | infixl 2 +++ 99 | infixl 2 ||| 100 | 101 | 102 | data Diag :: (Type -> Type -> Type) -> (Type -> Type -> Type) -> Type where 103 | Diag :: Diag j k 104 | 105 | -- | The diagonal functor from (index-) category J to k. 106 | instance (Category j, Category k) => Functor (Diag j k) where 107 | type Dom (Diag j k) = k 108 | type Cod (Diag j k) = Nat j k 109 | type Diag j k :% a = Const j k a 110 | 111 | Diag % f = Nat (Const (src f)) (Const (tgt f)) (\_ -> f) 112 | 113 | -- | The diagonal functor with the same domain and codomain as @f@. 114 | type DiagF f = Diag (Dom f) (Cod f) 115 | 116 | 117 | 118 | -- | A cone from N to F is a natural transformation from the constant functor to N to F. 119 | type Cone j k f n = Nat j k (Const j k n) f 120 | 121 | -- | A co-cone from F to N is a natural transformation from F to the constant functor to N. 122 | type Cocone j k f n = Nat j k f (Const j k n) 123 | 124 | 125 | -- | The vertex (or apex) of a cone. 126 | coneVertex :: Cone j k f n -> Obj k n 127 | coneVertex (Nat (Const x) _ _) = x 128 | 129 | -- | The vertex (or apex) of a co-cone. 130 | coconeVertex :: Cocone j k f n -> Obj k n 131 | coconeVertex (Nat _ (Const x) _) = x 132 | 133 | 134 | -- | An instance of @HasLimits j k@ says that @k@ has all limits of type @j@. 135 | class (Category j, Category k) => HasLimits j k where 136 | -- | Limits in a category @k@ by means of a diagram of type @j@, which is a functor from @j@ to @k@. 137 | type LimitFam (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) (f :: Type) :: Type 138 | -- | 'limit' returns the limiting cone for a functor @f@. 139 | limit :: Obj (Nat j k) f -> Cone j k f (LimitFam j k f) 140 | -- | 'limitFactorizer' shows that the limiting cone is universal – i.e. any other cone of @f@ factors through it 141 | -- by returning the morphism between the vertices of the cones. 142 | limitFactorizer :: Cone j k f n -> k n (LimitFam j k f) 143 | 144 | type Limit f = LimitFam (Dom f) (Cod f) f 145 | 146 | data LimitFunctor (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) = LimitFunctor 147 | -- | If every diagram of type @j@ has a limit in @k@ there exists a limit functor. 148 | -- It can be seen as a generalisation of @(***)@. 149 | instance HasLimits j k => Functor (LimitFunctor j k) where 150 | type Dom (LimitFunctor j k) = Nat j k 151 | type Cod (LimitFunctor j k) = k 152 | type LimitFunctor j k :% f = LimitFam j k f 153 | 154 | LimitFunctor % n = limitFactorizer (n . limit (src n)) 155 | 156 | -- | The limit functor is right adjoint to the diagonal functor. 157 | limitAdj :: forall j k. HasLimits j k => Adjunction (Nat j k) k (Diag j k) (LimitFunctor j k) 158 | limitAdj = mkAdjunctionTerm Diag LimitFunctor (\_ -> limitFactorizer) limit 159 | 160 | adjLimit :: Category k => Adjunction (Nat j k) k (Diag j k) r -> Obj (Nat j k) f -> Cone j k f (r :% f) 161 | adjLimit adj f = adjunctionCounit adj ! f 162 | 163 | adjLimitFactorizer :: Category k => Adjunction (Nat j k) k (Diag j k) r -> Cone j k f n -> k n (r :% f) 164 | adjLimitFactorizer adj cone = leftAdjunct adj (coneVertex cone) cone 165 | 166 | 167 | -- Cone (g :.: t) (Limit (g :.: t)) 168 | -- Obj j z -> d (Limit (g :.: t)) ((g :.: t) :% z) 169 | -- Obj j z -> d (f :% Limit (g :.: t)) (t :% z) 170 | -- Cone t (f :% Limit (g :.: t)) 171 | -- d (f :% Limit (g :.: t)) (Limit t) 172 | -- d (Limit (g :.: t)) (g :% Limit t) 173 | rightAdjointPreservesLimits 174 | :: (HasLimits j c, HasLimits j d) 175 | => Adjunction c d f g -> Obj (Nat j c) t -> d (Limit (g :.: t)) (g :% Limit t) 176 | rightAdjointPreservesLimits adj@(Adjunction f g _ _) (Nat t _ _) = 177 | leftAdjunct adj x (limitFactorizer cone) 178 | where 179 | l = limit (natId (g :.: t)) 180 | x = coneVertex l 181 | -- cone :: Cone t (f :% Limit (g :.: t)) 182 | cone = Nat (Const (f % x)) t (\z -> rightAdjunct adj (t % z) (l ! z)) 183 | 184 | -- Cone t (Limit t) 185 | -- Cone (g :.: t) (g :% Limit t) 186 | -- d (g :% Limit t) (Limit (g :.: t)) 187 | rightAdjointPreservesLimitsInv 188 | :: (HasLimits j c, HasLimits j d) 189 | => Obj (Nat c d) g -> Obj (Nat j c) t -> d (g :% LimitFam j c t) (LimitFam j d (g :.: t)) 190 | rightAdjointPreservesLimitsInv g t = limitFactorizer (constPrecompIn (g `o` limit t)) 191 | 192 | 193 | -- | An instance of @HasColimits j k@ says that @k@ has all colimits of type @j@. 194 | class (Category j, Category k) => HasColimits j k where 195 | -- | Colimits in a category @k@ by means of a diagram of type @j@, which is a functor from @j@ to @k@. 196 | type ColimitFam (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) (f :: Type) :: Type 197 | -- | 'colimit' returns the limiting co-cone for a functor @f@. 198 | colimit :: Obj (Nat j k) f -> Cocone j k f (ColimitFam j k f) 199 | -- | 'colimitFactorizer' shows that the limiting co-cone is universal – i.e. any other co-cone of @f@ factors through it 200 | -- by returning the morphism between the vertices of the cones. 201 | colimitFactorizer :: Cocone j k f n -> k (ColimitFam j k f) n 202 | 203 | type Colimit f = ColimitFam (Dom f) (Cod f) f 204 | 205 | data ColimitFunctor (j :: Type -> Type -> Type) (k :: Type -> Type -> Type) = ColimitFunctor 206 | -- | If every diagram of type @j@ has a colimit in @k@ there exists a colimit functor. 207 | -- It can be seen as a generalisation of @(+++)@. 208 | instance HasColimits j k => Functor (ColimitFunctor j k) where 209 | type Dom (ColimitFunctor j k) = Nat j k 210 | type Cod (ColimitFunctor j k) = k 211 | type ColimitFunctor j k :% f = ColimitFam j k f 212 | 213 | ColimitFunctor % n = colimitFactorizer (colimit (tgt n) . n) 214 | 215 | -- | The colimit functor is left adjoint to the diagonal functor. 216 | colimitAdj :: forall j k. HasColimits j k => Adjunction k (Nat j k) (ColimitFunctor j k) (Diag j k) 217 | colimitAdj = mkAdjunctionInit ColimitFunctor Diag colimit (\_ -> colimitFactorizer) 218 | 219 | adjColimit :: Category k => Adjunction k (Nat j k) l (Diag j k) -> Obj (Nat j k) f -> Cocone j k f (l :% f) 220 | adjColimit adj f = adjunctionUnit adj ! f 221 | 222 | adjColimitFactorizer :: Category k => Adjunction k (Nat j k) l (Diag j k) -> Cocone j k f n -> k (l :% f) n 223 | adjColimitFactorizer adj cocone = rightAdjunct adj (coconeVertex cocone) cocone 224 | 225 | 226 | leftAdjointPreservesColimits 227 | :: (HasColimits j c, HasColimits j d) 228 | => Adjunction c d f g -> Obj (Nat j d) t -> c (f :% Colimit t) (Colimit (f :.: t)) 229 | leftAdjointPreservesColimits adj@(Adjunction f g _ _) (Nat t _ _) = 230 | rightAdjunct adj x (colimitFactorizer cocone) 231 | where 232 | l = colimit (natId (f :.: t)) 233 | x = coconeVertex l 234 | cocone = Nat t (Const (g % x)) (\z -> leftAdjunct adj (t % z) (l ! z)) 235 | 236 | leftAdjointPreservesColimitsInv 237 | :: (HasColimits j c, HasColimits j d) 238 | => Obj (Nat d c) f -> Obj (Nat j d) t -> c (ColimitFam j c (f :.: t)) (f :% ColimitFam j d t) 239 | leftAdjointPreservesColimitsInv f t = colimitFactorizer (constPrecompOut (f `o` colimit t)) 240 | 241 | 242 | class Category k => HasTerminalObject k where 243 | 244 | type TerminalObject k :: Kind k 245 | 246 | terminalObject :: Obj k (TerminalObject k) 247 | 248 | terminate :: Obj k a -> k a (TerminalObject k) 249 | 250 | 251 | -- | A terminal object is the limit of the functor from /0/ to k. 252 | instance (Category k, HasTerminalObject k) => HasLimits Void k where 253 | type LimitFam Void k f = TerminalObject k 254 | limit (Nat f _ _) = voidNat (Const terminalObject) f 255 | limitFactorizer = terminate . coneVertex 256 | 257 | 258 | -- | @()@ is the terminal object in @Hask@. 259 | instance HasTerminalObject (->) where 260 | type TerminalObject (->) = () 261 | 262 | terminalObject = obj 263 | 264 | terminate _ _ = () 265 | 266 | data Top where 267 | Top :: a %1 -> Top 268 | -- | The terminal object in the category of linear types is `Top`. 269 | instance HasTerminalObject (FUN 'One) where 270 | type TerminalObject (FUN 'One) = Top 271 | 272 | terminalObject = obj 273 | 274 | terminate _ = Top 275 | 276 | -- | @Unit@ is the terminal category. 277 | instance HasTerminalObject Cat where 278 | type TerminalObject Cat = Unit 279 | 280 | terminalObject = CatA Id 281 | 282 | terminate (CatA _) = CatA (Const Unit) 283 | 284 | -- | The constant functor to the terminal object is itself the terminal object in its functor category. 285 | instance (Category c, HasTerminalObject d) => HasTerminalObject (Nat c d) where 286 | type TerminalObject (Nat c d) = Const c d (TerminalObject d) 287 | 288 | terminalObject = natId (Const terminalObject) 289 | 290 | terminate (Nat f _ _) = Nat f (Const terminalObject) (terminate . (f %)) 291 | 292 | -- | The category of one object has that object as terminal object. 293 | instance HasTerminalObject Unit where 294 | type TerminalObject Unit = () 295 | 296 | terminalObject = Unit 297 | 298 | terminate Unit = Unit 299 | 300 | -- | The terminal object of the product of 2 categories is the product of their terminal objects. 301 | instance (HasTerminalObject c1, HasTerminalObject c2) => HasTerminalObject (c1 :**: c2) where 302 | type TerminalObject (c1 :**: c2) = (TerminalObject c1, TerminalObject c2) 303 | 304 | terminalObject = terminalObject :**: terminalObject 305 | 306 | terminate (a1 :**: a2) = terminate a1 :**: terminate a2 307 | 308 | -- | The terminal object of the direct coproduct of categories is the terminal object of the terminal category. 309 | instance (Category c1, HasTerminalObject c2) => HasTerminalObject (c1 :>>: c2) where 310 | type TerminalObject (c1 :>>: c2) = I2 (TerminalObject c2) 311 | 312 | terminalObject = DC (I2A terminalObject) 313 | 314 | terminate (DC (I1A a)) = DC (I12 a terminalObject (Const (\() -> ())) ()) 315 | terminate (DC (I2A a)) = DC (I2A (terminate a)) 316 | 317 | 318 | 319 | class Category k => HasInitialObject k where 320 | type InitialObject k :: Kind k 321 | 322 | initialObject :: Obj k (InitialObject k) 323 | 324 | initialize :: Obj k a -> k (InitialObject k) a 325 | 326 | 327 | -- | An initial object is the colimit of the functor from /0/ to k. 328 | instance (Category k, HasInitialObject k) => HasColimits Void k where 329 | type ColimitFam Void k f = InitialObject k 330 | colimit (Nat f _ _) = voidNat f (Const initialObject) 331 | colimitFactorizer = initialize . coconeVertex 332 | 333 | 334 | data Zero 335 | absurd :: FUN m Zero a 336 | absurd = \case 337 | 338 | -- | Any empty data type is an initial object in @Hask@. 339 | instance HasInitialObject (FUN m) where 340 | type InitialObject (FUN m) = Zero 341 | 342 | initialObject = obj 343 | 344 | initialize _ = absurd 345 | 346 | -- | The empty category is the initial object in @Cat@. 347 | instance HasInitialObject Cat where 348 | type InitialObject Cat = Void 349 | 350 | initialObject = CatA Id 351 | 352 | initialize (CatA _) = CatA Magic 353 | 354 | -- | The constant functor to the initial object is itself the initial object in its functor category. 355 | instance (Category c, HasInitialObject d) => HasInitialObject (Nat c d) where 356 | type InitialObject (Nat c d) = Const c d (InitialObject d) 357 | 358 | initialObject = natId (Const initialObject) 359 | 360 | initialize (Nat f _ _) = Nat (Const initialObject) f (initialize . (f %)) 361 | 362 | -- | The initial object of the product of 2 categories is the product of their initial objects. 363 | instance (HasInitialObject c1, HasInitialObject c2) => HasInitialObject (c1 :**: c2) where 364 | type InitialObject (c1 :**: c2) = (InitialObject c1, InitialObject c2) 365 | 366 | initialObject = initialObject :**: initialObject 367 | 368 | initialize (a1 :**: a2) = initialize a1 :**: initialize a2 369 | 370 | -- | The category of one object has that object as initial object. 371 | instance HasInitialObject Unit where 372 | type InitialObject Unit = () 373 | 374 | initialObject = Unit 375 | 376 | initialize Unit = Unit 377 | 378 | -- | The initial object of the direct coproduct of categories is the initial object of the initial category. 379 | instance (HasInitialObject c1, Category c2) => HasInitialObject (c1 :>>: c2) where 380 | type InitialObject (c1 :>>: c2) = I1 (InitialObject c1) 381 | 382 | initialObject = DC (I1A initialObject) 383 | 384 | initialize (DC (I1A a)) = DC (I1A (initialize a)) 385 | initialize (DC (I2A a)) = DC (I12 initialObject a (Const (\() -> ())) ()) 386 | 387 | 388 | class Category k => HasBinaryProducts k where 389 | type BinaryProduct k (x :: Kind k) (y :: Kind k) :: Kind k 390 | 391 | proj1 :: Obj k x -> Obj k y -> k (BinaryProduct k x y) x 392 | proj2 :: Obj k x -> Obj k y -> k (BinaryProduct k x y) y 393 | 394 | (&&&) :: k a x -> k a y -> k a (BinaryProduct k x y) 395 | 396 | (***) :: k a1 b1 -> k a2 b2 -> k (BinaryProduct k a1 a2) (BinaryProduct k b1 b2) 397 | l *** r = (l . proj1 (src l) (src r)) &&& (r . proj2 (src l) (src r)) 398 | 399 | 400 | -- | If `k` has binary products, we can take the limit of 2 joined diagrams. 401 | instance (HasLimits i k, HasLimits j k, HasBinaryProducts k) => HasLimits (i :++: j) k where 402 | type LimitFam (i :++: j) k f = BinaryProduct k 403 | (LimitFam i k (f :.: Inj1 i j)) 404 | (LimitFam j k (f :.: Inj2 i j)) 405 | 406 | limit = limit' 407 | where 408 | limit' :: forall f. Obj (Nat (i :++: j) k) f -> Cone (i :++: j) k f (LimitFam (i :++: j) k f) 409 | limit' l@Nat{} = Nat (Const (x *** y)) (srcF l) h 410 | where 411 | x = coneVertex lim1 412 | y = coneVertex lim2 413 | lim1 = limit (l `o` natId Inj1) 414 | lim2 = limit (l `o` natId Inj2) 415 | h :: Obj (i :++: j) z -> Component (ConstF f (LimitFam (i :++: j) k f)) f z 416 | h (I1 n) = lim1 ! n . proj1 x y 417 | h (I2 n) = lim2 ! n . proj2 x y 418 | 419 | limitFactorizer c = 420 | limitFactorizer (constPostcompIn (c `o` natId Inj1)) 421 | &&& 422 | limitFactorizer (constPostcompIn (c `o` natId Inj2)) 423 | 424 | 425 | -- | The tuple is the binary product in @Hask@. 426 | instance HasBinaryProducts (->) where 427 | type BinaryProduct (->) x y = (x, y) 428 | 429 | proj1 _ _ = \(x, _) -> x 430 | proj2 _ _ = \(_, y) -> y 431 | 432 | f &&& g = \x -> (f x, g x) 433 | f *** g = \(x, y) -> (f x, g y) 434 | 435 | 436 | newtype x & y = AddConj (forall r. Either (x %1-> r) (y %1-> r) %1-> r) 437 | 438 | -- | The product in the category of linear types is a & b, where you have access to a and b, but not both at the same time. 439 | instance HasBinaryProducts (FUN 'One) where 440 | type BinaryProduct (FUN 'One) x y = x & y 441 | 442 | proj1 _ _ = \(AddConj f) -> f (Left obj) 443 | proj2 _ _ = \(AddConj f) -> f (Right obj) 444 | 445 | f &&& g = \x -> AddConj \case 446 | Left h -> h (f x) 447 | Right h -> h (g x) 448 | f *** g = \(AddConj h) -> AddConj \case 449 | Left l -> h (Left (\x -> l (f x))) 450 | Right r -> h (Right (\x -> r (g x))) 451 | 452 | 453 | 454 | -- | The product of categories ':**:' is the binary product in 'Cat'. 455 | instance HasBinaryProducts Cat where 456 | type BinaryProduct Cat c1 c2 = c1 :**: c2 457 | 458 | proj1 (CatA _) (CatA _) = CatA Proj1 459 | proj2 (CatA _) (CatA _) = CatA Proj2 460 | 461 | CatA f1 &&& CatA f2 = CatA ((f1 :***: f2) :.: DiagProd) 462 | CatA f1 *** CatA f2 = CatA (f1 :***: f2) 463 | 464 | -- | In the category of one object that object is its own product. 465 | instance HasBinaryProducts Unit where 466 | type BinaryProduct Unit () () = () 467 | 468 | proj1 Unit Unit = Unit 469 | proj2 Unit Unit = Unit 470 | 471 | Unit &&& Unit = Unit 472 | Unit *** Unit = Unit 473 | 474 | -- | The binary product of the product of 2 categories is the product of their binary products. 475 | instance (HasBinaryProducts c1, HasBinaryProducts c2) => HasBinaryProducts (c1 :**: c2) where 476 | type BinaryProduct (c1 :**: c2) (x1, x2) (y1, y2) = (BinaryProduct c1 x1 y1, BinaryProduct c2 x2 y2) 477 | 478 | proj1 (x1 :**: x2) (y1 :**: y2) = proj1 x1 y1 :**: proj1 x2 y2 479 | proj2 (x1 :**: x2) (y1 :**: y2) = proj2 x1 y1 :**: proj2 x2 y2 480 | 481 | (f1 :**: f2) &&& (g1 :**: g2) = (f1 &&& g1) :**: (f2 &&& g2) 482 | (f1 :**: f2) *** (g1 :**: g2) = (f1 *** g1) :**: (f2 *** g2) 483 | 484 | instance (HasBinaryProducts c1, HasBinaryProducts c2) => HasBinaryProducts (c1 :>>: c2) where 485 | type BinaryProduct (c1 :>>: c2) (I1 a) (I1 b) = I1 (BinaryProduct c1 a b) 486 | type BinaryProduct (c1 :>>: c2) (I1 a) (I2 b) = I1 a 487 | type BinaryProduct (c1 :>>: c2) (I2 a) (I1 b) = I1 b 488 | type BinaryProduct (c1 :>>: c2) (I2 a) (I2 b) = I2 (BinaryProduct c2 a b) 489 | 490 | proj1 (DC (I1A a)) (DC (I1A b)) = DC (I1A (proj1 a b)) 491 | proj1 (DC (I1A a)) (DC (I2A _)) = DC (I1A a) 492 | proj1 (DC (I2A a)) (DC (I1A b)) = DC (I12 b a (Const (\() -> ())) ()) 493 | proj1 (DC (I2A a)) (DC (I2A b)) = DC (I2A (proj1 a b)) 494 | 495 | proj2 (DC (I1A a)) (DC (I1A b)) = DC (I1A (proj2 a b)) 496 | proj2 (DC (I1A a)) (DC (I2A b)) = DC (I12 a b (Const (\() -> ())) ()) 497 | proj2 (DC (I2A _)) (DC (I1A b)) = DC (I1A b) 498 | proj2 (DC (I2A a)) (DC (I2A b)) = DC (I2A (proj2 a b)) 499 | 500 | DC (I1A a) &&& DC (I1A b) = DC (I1A (a &&& b)) 501 | DC (I1A a) &&& DC I12{} = DC (I1A a) 502 | DC I12{} &&& DC (I1A b) = DC (I1A b) 503 | DC (I2A a) &&& DC (I2A b) = DC (I2A (a &&& b)) 504 | DC (I12 a b1 _ _) &&& DC (I12 _ b2 _ _) = DC (I12 a (b1 *** b2) (Const (\() -> ())) ()) 505 | 506 | 507 | data ProductFunctor (k :: Type -> Type -> Type) = ProductFunctor 508 | -- | Binary product as a bifunctor. 509 | instance HasBinaryProducts k => Functor (ProductFunctor k) where 510 | type Dom (ProductFunctor k) = k :**: k 511 | type Cod (ProductFunctor k) = k 512 | type ProductFunctor k :% (a, b) = BinaryProduct k a b 513 | 514 | ProductFunctor % (a1 :**: a2) = a1 *** a2 515 | 516 | -- | A specialisation of the limit adjunction to products. 517 | prodAdj :: HasBinaryProducts k => Adjunction (k :**: k) k (DiagProd k) (ProductFunctor k) 518 | prodAdj = mkAdjunctionTerm DiagProd ProductFunctor (\_ (l :**: r) -> l &&& r) (\(l :**: r) -> proj1 l r :**: proj2 l r) 519 | 520 | data p :*: q where 521 | (:*:) :: (Functor p, Functor q, Dom p ~ Dom q, Cod p ~ k, Cod q ~ k, HasBinaryProducts k) => p -> q -> p :*: q 522 | -- | The product of two functors, passing the same object to both functors and taking the product of the results. 523 | instance (Category (Dom p), Category (Cod p)) => Functor (p :*: q) where 524 | type Dom (p :*: q) = Dom p 525 | type Cod (p :*: q) = Cod p 526 | type (p :*: q) :% a = BinaryProduct (Cod p) (p :% a) (q :% a) 527 | 528 | (p :*: q) % f = (p % f) *** (q % f) 529 | 530 | -- | The functor product ':*:' is the binary product in functor categories. 531 | instance (Category c, HasBinaryProducts d) => HasBinaryProducts (Nat c d) where 532 | type BinaryProduct (Nat c d) x y = x :*: y 533 | 534 | proj1 (Nat f _ _) (Nat g _ _) = Nat (f :*: g) f (\z -> proj1 (f % z) (g % z)) 535 | proj2 (Nat f _ _) (Nat g _ _) = Nat (f :*: g) g (\z -> proj2 (f % z) (g % z)) 536 | 537 | Nat a f af &&& Nat _ g ag = Nat a (f :*: g) (\z -> af z &&& ag z) 538 | Nat f1 f2 f *** Nat g1 g2 g = Nat (f1 :*: g1) (f2 :*: g2) (\z -> f z *** g z) 539 | 540 | 541 | 542 | class Category k => HasBinaryCoproducts k where 543 | type BinaryCoproduct k (x :: Kind k) (y :: Kind k) :: Kind k 544 | 545 | inj1 :: Obj k x -> Obj k y -> k x (BinaryCoproduct k x y) 546 | inj2 :: Obj k x -> Obj k y -> k y (BinaryCoproduct k x y) 547 | 548 | (|||) :: k x a -> k y a -> k (BinaryCoproduct k x y) a 549 | 550 | (+++) :: k a1 b1 -> k a2 b2 -> k (BinaryCoproduct k a1 a2) (BinaryCoproduct k b1 b2) 551 | l +++ r = (inj1 (tgt l) (tgt r) . l) ||| (inj2 (tgt l) (tgt r) . r) 552 | 553 | 554 | -- | If `k` has binary coproducts, we can take the colimit of 2 joined diagrams. 555 | instance (HasColimits i k, HasColimits j k, HasBinaryCoproducts k) => HasColimits (i :++: j) k where 556 | type ColimitFam (i :++: j) k f = BinaryCoproduct k 557 | (ColimitFam i k (f :.: Inj1 i j)) 558 | (ColimitFam j k (f :.: Inj2 i j)) 559 | 560 | colimit = colimit' 561 | where 562 | colimit' :: forall f. Obj (Nat (i :++: j) k) f -> Cocone (i :++: j) k f (ColimitFam (i :++: j) k f) 563 | colimit' l@Nat{} = Nat (srcF l) (Const (x +++ y)) h 564 | where 565 | x = coconeVertex col1 566 | y = coconeVertex col2 567 | col1 = colimit (l `o` natId Inj1) 568 | col2 = colimit (l `o` natId Inj2) 569 | h :: Obj (i :++: j) z -> Component f (ConstF f (ColimitFam (i :++: j) k f)) z 570 | h (I1 n) = inj1 x y . col1 ! n 571 | h (I2 n) = inj2 x y . col2 ! n 572 | 573 | colimitFactorizer c = 574 | colimitFactorizer (constPostcompOut (c `o` natId Inj1)) 575 | ||| 576 | colimitFactorizer (constPostcompOut (c `o` natId Inj2)) 577 | 578 | 579 | instance HasBinaryCoproducts (FUN m) where 580 | type BinaryCoproduct (FUN m) a b = Either a b 581 | 582 | inj1 _ _ = Left 583 | inj2 _ _ = Right 584 | 585 | f ||| g = \case 586 | Left a -> f a 587 | Right b -> g b 588 | f +++ g = \case 589 | Left a -> Left (f a) 590 | Right b -> Right (g b) 591 | 592 | -- | The coproduct of categories ':++:' is the binary coproduct in 'Cat'. 593 | instance HasBinaryCoproducts Cat where 594 | type BinaryCoproduct Cat c1 c2 = c1 :++: c2 595 | 596 | inj1 (CatA _) (CatA _) = CatA Inj1 597 | inj2 (CatA _) (CatA _) = CatA Inj2 598 | 599 | CatA f1 ||| CatA f2 = CatA (CodiagCoprod :.: (f1 :+++: f2)) 600 | CatA f1 +++ CatA f2 = CatA (f1 :+++: f2) 601 | 602 | -- | In the category of one object that object is its own coproduct. 603 | instance HasBinaryCoproducts Unit where 604 | type BinaryCoproduct Unit () () = () 605 | 606 | inj1 Unit Unit = Unit 607 | inj2 Unit Unit = Unit 608 | 609 | Unit ||| Unit = Unit 610 | Unit +++ Unit = Unit 611 | 612 | -- | The binary coproduct of the product of 2 categories is the product of their binary coproducts. 613 | instance (HasBinaryCoproducts c1, HasBinaryCoproducts c2) => HasBinaryCoproducts (c1 :**: c2) where 614 | type BinaryCoproduct (c1 :**: c2) (x1, x2) (y1, y2) = (BinaryCoproduct c1 x1 y1, BinaryCoproduct c2 x2 y2) 615 | 616 | inj1 (x1 :**: x2) (y1 :**: y2) = inj1 x1 y1 :**: inj1 x2 y2 617 | inj2 (x1 :**: x2) (y1 :**: y2) = inj2 x1 y1 :**: inj2 x2 y2 618 | 619 | (f1 :**: f2) ||| (g1 :**: g2) = (f1 ||| g1) :**: (f2 ||| g2) 620 | (f1 :**: f2) +++ (g1 :**: g2) = (f1 +++ g1) :**: (f2 +++ g2) 621 | 622 | instance (HasBinaryCoproducts c1, HasBinaryCoproducts c2) => HasBinaryCoproducts (c1 :>>: c2) where 623 | type BinaryCoproduct (c1 :>>: c2) (I1 a) (I1 b) = I1 (BinaryCoproduct c1 a b) 624 | type BinaryCoproduct (c1 :>>: c2) (I1 a) (I2 b) = I2 b 625 | type BinaryCoproduct (c1 :>>: c2) (I2 a) (I1 b) = I2 a 626 | type BinaryCoproduct (c1 :>>: c2) (I2 a) (I2 b) = I2 (BinaryCoproduct c2 a b) 627 | 628 | inj1 (DC (I1A a)) (DC (I1A b)) = DC (I1A (inj1 a b)) 629 | inj1 (DC (I1A a)) (DC (I2A b)) = DC (I12 a b (Const (\() -> ())) ()) 630 | inj1 (DC (I2A a)) (DC (I1A _)) = DC (I2A a) 631 | inj1 (DC (I2A a)) (DC (I2A b)) = DC (I2A (inj1 a b)) 632 | 633 | inj2 (DC (I1A a)) (DC (I1A b)) = DC (I1A (inj2 a b)) 634 | inj2 (DC (I1A _)) (DC (I2A b)) = DC (I2A b) 635 | inj2 (DC (I2A a)) (DC (I1A b)) = DC (I12 b a (Const (\() -> ())) ()) 636 | inj2 (DC (I2A a)) (DC (I2A b)) = DC (I2A (inj2 a b)) 637 | 638 | DC (I1A a) ||| DC (I1A b) = DC (I1A (a ||| b)) 639 | DC (I2A a) ||| DC I12{} = DC (I2A a) 640 | DC I12{} ||| DC (I2A b) = DC (I2A b) 641 | DC (I2A a) ||| DC (I2A b) = DC (I2A (a ||| b)) 642 | DC (I12 a1 b _ _) ||| DC (I12 a2 _ _ _) = DC (I12 (a1 +++ a2) b (Const (\() -> ())) ()) 643 | 644 | 645 | data CoproductFunctor (k :: Type -> Type -> Type) = CoproductFunctor 646 | -- | Binary coproduct as a bifunctor. 647 | instance HasBinaryCoproducts k => Functor (CoproductFunctor k) where 648 | type Dom (CoproductFunctor k) = k :**: k 649 | type Cod (CoproductFunctor k) = k 650 | type CoproductFunctor k :% (a, b) = BinaryCoproduct k a b 651 | 652 | CoproductFunctor % (a1 :**: a2) = a1 +++ a2 653 | 654 | -- | A specialisation of the colimit adjunction to coproducts. 655 | coprodAdj :: HasBinaryCoproducts k => Adjunction k (k :**: k) (CoproductFunctor k) (DiagProd k) 656 | coprodAdj = mkAdjunctionInit CoproductFunctor DiagProd (\(l :**: r) -> inj1 l r :**: inj2 l r) (\_ (l :**: r) -> l ||| r) 657 | 658 | data p :+: q where 659 | (:+:) :: (Functor p, Functor q, Dom p ~ Dom q, Cod p ~ k, Cod q ~ k, HasBinaryCoproducts k) => p -> q -> p :+: q 660 | -- | The coproduct of two functors, passing the same object to both functors and taking the coproduct of the results. 661 | instance (Category (Dom p), Category (Cod p)) => Functor (p :+: q) where 662 | type Dom (p :+: q) = Dom p 663 | type Cod (p :+: q) = Cod p 664 | type (p :+: q) :% a = BinaryCoproduct (Cod p) (p :% a) (q :% a) 665 | 666 | (p :+: q) % f = (p % f) +++ (q % f) 667 | 668 | -- | The functor coproduct ':+:' is the binary coproduct in functor categories. 669 | instance (Category c, HasBinaryCoproducts d) => HasBinaryCoproducts (Nat c d) where 670 | type BinaryCoproduct (Nat c d) x y = x :+: y 671 | 672 | inj1 (Nat f _ _) (Nat g _ _) = Nat f (f :+: g) (\z -> inj1 (f % z) (g % z)) 673 | inj2 (Nat f _ _) (Nat g _ _) = Nat g (f :+: g) (\z -> inj2 (f % z) (g % z)) 674 | 675 | Nat f a fa ||| Nat g _ ga = Nat (f :+: g) a (\z -> fa z ||| ga z) 676 | Nat f1 f2 f +++ Nat g1 g2 g = Nat (f1 :+: g1) (f2 :+: g2) (\z -> f z +++ g z) 677 | 678 | -- | Terminal objects are the dual of initial objects. 679 | instance HasInitialObject k => HasTerminalObject (Op k) where 680 | type TerminalObject (Op k) = InitialObject k 681 | terminalObject = Op initialObject 682 | terminate (Op f) = Op (initialize f) 683 | 684 | -- | Terminal objects are the dual of initial objects. 685 | instance HasTerminalObject k => HasInitialObject (Op k) where 686 | type InitialObject (Op k) = TerminalObject k 687 | initialObject = Op terminalObject 688 | initialize (Op f) = Op (terminate f) 689 | 690 | -- | Binary products are the dual of binary coproducts. 691 | instance HasBinaryCoproducts k => HasBinaryProducts (Op k) where 692 | type BinaryProduct (Op k) x y = BinaryCoproduct k x y 693 | 694 | proj1 (Op x) (Op y) = Op (inj1 x y) 695 | proj2 (Op x) (Op y) = Op (inj2 x y) 696 | Op f &&& Op g = Op (f ||| g) 697 | Op f *** Op g = Op (f +++ g) 698 | 699 | -- | Binary products are the dual of binary coproducts. 700 | instance HasBinaryProducts k => HasBinaryCoproducts (Op k) where 701 | type BinaryCoproduct (Op k) x y = BinaryProduct k x y 702 | 703 | inj1 (Op x) (Op y) = Op (proj1 x y) 704 | inj2 (Op x) (Op y) = Op (proj2 x y) 705 | Op f ||| Op g = Op (f &&& g) 706 | Op f +++ Op g = Op (f *** g) 707 | 708 | 709 | 710 | 711 | -- | The limit of a single object is that object. 712 | instance Category k => HasLimits Unit k where 713 | type LimitFam Unit k f = f :% () 714 | limit (Nat f _ _) = Nat (Const (f % Unit)) f (\Unit -> f % Unit) 715 | limitFactorizer n = n ! Unit 716 | 717 | -- | The limit of any diagram with an initial object, has the limit at the initial object. 718 | instance (HasInitialObject (i :>>: j), Category i, Category j, Category k) => HasLimits (i :>>: j) k where 719 | type LimitFam (i :>>: j) k f = f :% InitialObject (i :>>: j) 720 | limit (Nat f _ _) = Nat (Const (f % initialObject)) f (\z -> f % initialize z) 721 | limitFactorizer n = n ! initialObject 722 | 723 | 724 | -- | The colimit of a single object is that object. 725 | instance Category k => HasColimits Unit k where 726 | type ColimitFam Unit k f = f :% () 727 | colimit (Nat f _ _) = Nat f (Const (f % Unit)) (\Unit -> f % Unit) 728 | colimitFactorizer n = n ! Unit 729 | 730 | -- | The colimit of any diagram with a terminal object, has the limit at the terminal object. 731 | instance (HasTerminalObject (i :>>: j), Category i, Category j, Category k) => HasColimits (i :>>: j) k where 732 | type ColimitFam (i :>>: j) k f = f :% TerminalObject (i :>>: j) 733 | colimit (Nat f _ _) = Nat f (Const (f % terminalObject)) (\z -> f % terminate z) 734 | colimitFactorizer n = n ! terminalObject 735 | 736 | 737 | newtype ForAll f = ForAll (forall a. Obj (->) a -> f :% a) 738 | 739 | instance HasLimits (->) (->) where 740 | type LimitFam (->) (->) f = ForAll f 741 | limit (Nat f _ _) = Nat (Const obj) f (\a (ForAll g) -> g a) 742 | limitFactorizer n = \z -> ForAll (\a -> (n ! a) z) 743 | 744 | data Exists f = forall a. Exists (Obj (->) a) (f :% a) 745 | 746 | instance HasColimits (->) (->) where 747 | type ColimitFam (->) (->) f = Exists f 748 | colimit (Nat f _ _) = Nat f (Const obj) Exists 749 | colimitFactorizer n = \(Exists a fa) -> (n ! a) fa 750 | --------------------------------------------------------------------------------