Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Some fun with natural transformations.

  • Loading branch information...
commit 7625a7c1588f50d57e8f4ba9bc6b60491b7d1050 1 parent ac44fc2
Sjoerd Visscher authored
21 Data/Category/Boolean.hs
... ... @@ -1,4 +1,4 @@
1   -{-# LANGUAGE TypeFamilies, MultiParamTypeClasses, GADTs, EmptyDataDecls, FlexibleInstances #-}
  1 +{-# LANGUAGE TypeFamilies, GADTs, EmptyDataDecls, TypeOperators, ScopedTypeVariables, UndecidableInstances #-}
2 2 -----------------------------------------------------------------------------
3 3 -- |
4 4 -- Module : Data.Category.Boolean
@@ -18,6 +18,9 @@ module Data.Category.Boolean where
18 18 import Prelude hiding ((.), id, Functor)
19 19
20 20 import Data.Category
  21 +import Data.Category.Functor
  22 +import Data.Category.NaturalTransformation
  23 +import Data.Category.Product
21 24 import Data.Category.Limit
22 25
23 26
@@ -114,3 +117,19 @@ instance HasBinaryCoproducts Boolean where
114 117 Tru ||| F2T = Tru
115 118 Tru ||| Tru = Tru
116 119 _ ||| _ = error "Other combinations should not type check"
  120 +
  121 +
  122 +
  123 +-- | A natural transformation @Nat c d@ is isomorphic to a functor from @c :**: 2@ to @d@.
  124 +data NatAsFunctor f g = NatAsFunctor (Nat (Dom f) (Cod f) f g)
  125 +type instance Dom (NatAsFunctor f g) = (Dom f) :**: Boolean
  126 +type instance Cod (NatAsFunctor f g) = Cod f
  127 +type instance NatAsFunctor f g :% (a, Fls) = f :% a
  128 +type instance NatAsFunctor f g :% (a, Tru) = g :% a
  129 +instance (Functor f, Functor g, Category c, Category d, Dom f ~ c, Cod f ~ d, Dom g ~ c, Cod g ~ d) => Functor (NatAsFunctor f g) where
  130 + NatAsFunctor n % (a :**: b) = natAsFunctor n a b
  131 + where
  132 + natAsFunctor :: Nat c d f g -> c a1 a2 -> Boolean b1 b2 -> d (NatAsFunctor f g :% (a1, b1)) (NatAsFunctor f g :% (a2, b2))
  133 + natAsFunctor (Nat f _ _) a Fls = f % a
  134 + natAsFunctor (Nat _ g _) a Tru = g % a
  135 + natAsFunctor n a F2T = n ! a
66 Data/Category/CartesianClosed.hs
... ... @@ -1,7 +1,7 @@
1   -{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, Rank2Types, UndecidableInstances #-}
  1 +{-# LANGUAGE TypeOperators, TypeFamilies, GADTs, Rank2Types, ScopedTypeVariables, UndecidableInstances #-}
2 2 -----------------------------------------------------------------------------
3 3 -- |
4   --- Module : Data.Category.Void
  4 +-- Module : Data.Category.CartesianClosed
5 5 -- Copyright : (c) Sjoerd Visscher 2010
6 6 -- License : BSD-style (see the file LICENSE)
7 7 --
@@ -26,9 +26,9 @@ type family Exponential (~>) y z :: *
26 26
27 27 class (HasTerminalObject (~>), HasBinaryProducts (~>)) => CartesianClosed (~>) where
28 28
29   - (^^^) :: (z1 ~> z2) -> (y2 ~> y1) -> (Exponential (~>) y1 z1 ~> Exponential (~>) y2 z2)
30   - eval :: Obj (~>) y -> Obj (~>) z -> BinaryProduct (~>) (Exponential (~>) y z) y ~> z
  29 + apply :: Obj (~>) y -> Obj (~>) z -> BinaryProduct (~>) (Exponential (~>) y z) y ~> z
31 30 tuple :: Obj (~>) y -> Obj (~>) z -> z ~> Exponential (~>) y (BinaryProduct (~>) z y)
  31 + (^^^) :: (z1 ~> z2) -> (y2 ~> y1) -> (Exponential (~>) y1 z1 ~> Exponential (~>) y2 z2)
32 32
33 33
34 34 data ExpFunctor ((~>) :: * -> * -> *) = ExpFunctor
@@ -38,41 +38,27 @@ type instance (ExpFunctor (~>)) :% (y, z) = Exponential (~>) y z
38 38 instance CartesianClosed (~>) => Functor (ExpFunctor (~>)) where
39 39 ExpFunctor % (Op y :**: z) = z ^^^ y
40 40
41   -data ProductWith (~>) y = ProductWith (Obj (~>) y)
42   -type instance Dom (ProductWith (~>) y) = (~>)
43   -type instance Cod (ProductWith (~>) y) = (~>)
44   -type instance ProductWith (~>) y :% z = ProductFunctor (~>) :% (z, y)
45   -instance HasBinaryProducts (~>) => Functor (ProductWith (~>) y) where
46   - ProductWith y % f = f *** y
47   -
48   -data ExponentialWith (~>) y = ExponentialWith (Obj (~>) y)
49   -type instance Dom (ExponentialWith (~>) y) = (~>)
50   -type instance Cod (ExponentialWith (~>) y) = (~>)
51   -type instance ExponentialWith (~>) y :% z = Exponential (~>) y z
52   -instance CartesianClosed (~>) => Functor (ExponentialWith (~>) y) where
53   - ExponentialWith y % f = f ^^^ y
54   -
55 41
56 42
57 43 type instance Exponential (->) y z = y -> z
58 44
59 45 instance (CartesianClosed (->)) where
60 46
61   - f ^^^ h = \g -> f . g . h
62   - eval _ _ (f, y) = f y
63   - tuple _ _ z = \y -> (z, y)
  47 + apply _ _ (f, y) = f y
  48 + tuple _ _ z = \y -> (z, y)
  49 + f ^^^ h = \g -> f . g . h
64 50
65 51
66 52
67   -data CatEval (y :: * -> * -> *) (z :: * -> * -> *) = CatEval
68   -type instance Dom (CatEval y z) = Nat y z :**: y
69   -type instance Cod (CatEval y z) = z
70   -type instance CatEval y z :% (f, a) = f :% a
71   -instance (Category y, Category z) => Functor (CatEval y z) where
72   - CatEval % (l :**: r) = catEval l r
  53 +data CatApply (y :: * -> * -> *) (z :: * -> * -> *) = CatApply
  54 +type instance Dom (CatApply y z) = Nat y z :**: y
  55 +type instance Cod (CatApply y z) = z
  56 +type instance CatApply y z :% (f, a) = f :% a
  57 +instance (Category y, Category z) => Functor (CatApply y z) where
  58 + CatApply % (l :**: r) = catApply l r
73 59 where
74   - catEval :: (Category y, Category z) => Nat y z f g -> y a b -> z (f :% a) (g :% b)
75   - catEval (Nat f _ n) h = n (tgt h) . f % h -- g % h . n (src h)
  60 + catApply :: Nat y z f g -> y a b -> z (f :% a) (g :% b)
  61 + catApply n@Nat{} h = n ! h
76 62
77 63 data CatTuple (y :: * -> * -> *) (z :: * -> * -> *) = CatTuple
78 64 type instance Dom (CatTuple y z) = z
@@ -86,14 +72,28 @@ type instance Exponential Cat (CatW c) (CatW d) = CatW (Nat c d)
86 72
87 73 instance (CartesianClosed Cat) where
88 74
89   - (CatA f) ^^^ (CatA h) = CatA (Wrap f h)
90   - eval CatA{} CatA{} = CatA CatEval
  75 + apply CatA{} CatA{} = CatA CatApply
91 76 tuple CatA{} CatA{} = CatA CatTuple
  77 + (CatA f) ^^^ (CatA h) = CatA (Wrap f h)
92 78
93 79
94 80
  81 +data ProductWith (~>) y = ProductWith (Obj (~>) y)
  82 +type instance Dom (ProductWith (~>) y) = (~>)
  83 +type instance Cod (ProductWith (~>) y) = (~>)
  84 +type instance ProductWith (~>) y :% z = ProductFunctor (~>) :% (z, y)
  85 +instance HasBinaryProducts (~>) => Functor (ProductWith (~>) y) where
  86 + ProductWith y % f = f *** y
  87 +
  88 +data ExponentialWith (~>) y = ExponentialWith (Obj (~>) y)
  89 +type instance Dom (ExponentialWith (~>) y) = (~>)
  90 +type instance Cod (ExponentialWith (~>) y) = (~>)
  91 +type instance ExponentialWith (~>) y :% z = Exponential (~>) y z
  92 +instance CartesianClosed (~>) => Functor (ExponentialWith (~>) y) where
  93 + ExponentialWith y % f = f ^^^ y
  94 +
95 95 curryAdj :: CartesianClosed (~>) => Obj (~>) y -> Adjunction (~>) (~>) (ProductWith (~>) y) (ExponentialWith (~>) y)
96   -curryAdj y = mkAdjunction (ProductWith y) (ExponentialWith y) (tuple y) (eval y)
  96 +curryAdj y = mkAdjunction (ProductWith y) (ExponentialWith y) (tuple y) (apply y)
97 97
98 98 curry :: CartesianClosed (~>) => Obj (~>) x -> Obj (~>) y -> Obj (~>) z -> (ProductWith (~>) y :% x) ~> z -> x ~> (ExponentialWith (~>) y :% z)
99 99 curry x y _ = leftAdjunct (curryAdj y) x
@@ -116,4 +116,4 @@ contextComonadExtract :: CartesianClosed (~>) => Obj (~>) s -> Obj (~>) a -> Con
116 116 contextComonadExtract s a = M.counit (adjunctionComonad $ curryAdj s) ! a
117 117
118 118 contextComonadDuplicate :: CartesianClosed (~>) => Obj (~>) s -> Obj (~>) a -> Context (~>) s a ~> Context (~>) s (Context (~>) s a)
119   -contextComonadDuplicate s a = M.comultiply (adjunctionComonad $ curryAdj s) ! a
  119 +contextComonadDuplicate s a = M.comultiply (adjunctionComonad $ curryAdj s) ! a
2  Data/Category/Monoidal.hs
... ... @@ -1,7 +1,7 @@
1 1 {-# LANGUAGE TypeOperators, TypeFamilies, GADTs, Rank2Types #-}
2 2 -----------------------------------------------------------------------------
3 3 -- |
4   --- Module : Data.Category.Void
  4 +-- Module : Data.Category.Monoidal
5 5 -- Copyright : (c) Sjoerd Visscher 2010
6 6 -- License : BSD-style (see the file LICENSE)
7 7 --
5 Data/Category/NaturalTransformation.hs
@@ -63,8 +63,9 @@ type Component f g z = Cod f (f :% z) (g :% z)
63 63 newtype Com f g z = Com { unCom :: Component f g z }
64 64
65 65 -- | 'n ! a' returns the component for the object @a@ of a natural transformation @n@.
66   -(!) :: (Cod f ~ d, Cod g ~ d) => Nat (~>) d f g -> Obj (~>) a -> d (f :% a) (g :% a)
67   -Nat _ _ n ! x = n x
  66 +-- This can be generalized to any arrow (instead of just identity arrows).
  67 +(!) :: (Category (~>), Category d, Cod f ~ d, Cod g ~ d) => Nat (~>) d f g -> a ~> b -> d (f :% a) (g :% b)
  68 +Nat f _ n ! h = n (tgt h) . f % h -- or g % h . n (src h), or n h when h is an identity arrow
68 69
69 70
70 71 -- | Horizontal composition of natural transformations.
4 data-category.cabal
@@ -9,6 +9,10 @@ description: Data-category is a collection of categories, and some categ
9 9 The corresponding identity arrow of the object is used for that.
10 10 .
11 11 See the 'Monoid', '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.
12 16
13 17 category: Data
14 18 license: BSD3

0 comments on commit 7625a7c

Please sign in to comment.
Something went wrong with that request. Please try again.