| Safe Haskell | None |
|---|---|
| Language | Haskell2010 |
Proarrow.Category.Instance.Hask
| Safe Haskell | None |
|---|---|
| Language | Haskell2010 |
Proarrow.Category.Instance.Hask
| Safe Haskell | None |
|---|---|
| Language | Haskell2010 |
Proarrow
module Proarrow.Category
module Proarrow.Profunctor
module Proarrow.Object
module Proarrow.Functor
module Proarrow.Adjunction
module Proarrow.Category.Instance.Hask (Type, Hask) where 46 | 51 | import Data.Kind (Type) 74 | 79 | type Hask = (->) 108 | 113 | -- Class instances of (->) are with the class definitions in order to avoid orphan instances 120 |127 | -------------------------------------------------------------------------------- /docs/src/Proarrow.Category.html: -------------------------------------------------------------------------------- 1 | 2 |
module Proarrow.Category 22 | ( CAT 39 | , CategoryOf (..) 64 | , dimapDefault 81 | ) 90 | where 97 | 102 | import Proarrow.Core 117 |124 | -------------------------------------------------------------------------------- /docs/src/Proarrow.Profunctor.html: -------------------------------------------------------------------------------- 1 | 2 |
module Proarrow.Profunctor 22 | ( PRO 39 | , Profunctor (..) 64 | , lmap 81 | , rmap 98 | , (//) 115 | ) where 128 | 133 | import Proarrow.Core 148 |155 | -------------------------------------------------------------------------------- /docs/src/highlight.js: -------------------------------------------------------------------------------- 1 | 2 | var highlight = function (on) { 3 | return function () { 4 | var links = document.getElementsByTagName('a'); 5 | for (var i = 0; i < links.length; i++) { 6 | var that = links[i]; 7 | 8 | if (this.href != that.href) { 9 | continue; 10 | } 11 | 12 | if (on) { 13 | that.classList.add("hover-highlight"); 14 | } else { 15 | that.classList.remove("hover-highlight"); 16 | } 17 | } 18 | } 19 | }; 20 | 21 | window.onload = function () { 22 | var links = document.getElementsByTagName('a'); 23 | for (var i = 0; i < links.length; i++) { 24 | links[i].onmouseover = highlight(true); 25 | links[i].onmouseout = highlight(false); 26 | } 27 | }; 28 | -------------------------------------------------------------------------------- /docs/src/style.css: -------------------------------------------------------------------------------- 1 | body { 2 | background-color: #fdf6e3; 3 | } 4 | 5 | .hs-identifier { 6 | color: #073642; 7 | } 8 | 9 | .hs-identifier.hs-var { 10 | } 11 | 12 | .hs-identifier.hs-type { 13 | color: #5f5faf; 14 | } 15 | 16 | .hs-keyword { 17 | color: #af005f; 18 | } 19 | 20 | .hs-string, .hs-char { 21 | color: #cb4b16; 22 | } 23 | 24 | .hs-number { 25 | color: #268bd2; 26 | } 27 | 28 | .hs-operator { 29 | color: #d33682; 30 | } 31 | 32 | .hs-glyph, .hs-special { 33 | color: #dc322f; 34 | } 35 | 36 | .hs-comment { 37 | color: #8a8a8a; 38 | } 39 | 40 | .hs-pragma { 41 | color: #2aa198; 42 | } 43 | 44 | .hs-cpp { 45 | color: #859900; 46 | } 47 | 48 | a:link, a:visited { 49 | text-decoration: none; 50 | border-bottom: 1px solid #eee8d5; 51 | } 52 | 53 | a:hover, a.hover-highlight { 54 | background-color: #eee8d5; 55 | } 56 | 57 | span.annot{ 58 | position:relative; 59 | color:#000; 60 | text-decoration:none 61 | } 62 | 63 | span.annot:hover{z-index:25; background-color:#ff0} 64 | 65 | span.annot span.annottext{ 66 | display: none; 67 | border-radius: 5px 5px; 68 | 69 | -moz-border-radius: 5px; 70 | -webkit-border-radius: 5px; 71 | 72 | box-shadow: 5px 5px 5px rgba(0, 0, 0, 0.1); 73 | -webkit-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); 74 | -moz-box-shadow: 5px 5px rgba(0, 0, 0, 0.1); 75 | 76 | position: absolute; 77 | left: 1em; top: 2em; 78 | z-index: 99; 79 | margin-left: 5; 80 | background: #FFFFAA; 81 | border: 2px solid #FFAD33; 82 | padding: 0.8em 1em; 83 | } 84 | 85 | span.annot:hover span.annottext{ 86 | display:block; 87 | } 88 | 89 | /* This bridges the gap so you can mouse into the tooltip without it disappearing */ 90 | span.annot span.annottext:before{ 91 | content: ""; 92 | position: absolute; 93 | left: -1em; top: -1em; 94 | background: #FFFFFF00; 95 | z-index:-1; 96 | padding: 2em 2em; 97 | } 98 | -------------------------------------------------------------------------------- /docs/synopsis.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/sjoerdvisscher/proarrow/a774ffea914657dc6590c8d76322531268a6e161/docs/synopsis.png -------------------------------------------------------------------------------- /fourmolu.yaml: -------------------------------------------------------------------------------- 1 | # Number of spaces per indentation step 2 | indentation: 2 3 | 4 | # Max line length for automatic line breaking 5 | column-limit: 120 6 | 7 | # Styling of arrows in type signatures (choices: trailing, leading, or leading-args) 8 | function-arrows: leading 9 | 10 | # How to place commas in multi-line lists, records, etc. (choices: leading or trailing) 11 | comma-style: leading 12 | 13 | # Styling of import/export lists (choices: leading, trailing, or diff-friendly) 14 | import-export-style: leading 15 | 16 | # Whether to full-indent or half-indent 'where' bindings past the preceding body 17 | indent-wheres: true 18 | 19 | # Whether to leave a space before an opening record brace 20 | record-brace-space: false 21 | 22 | # Number of spaces between top-level declarations 23 | newlines-between-decls: 1 24 | 25 | # How to print Haddock comments (choices: single-line, multi-line, or multi-line-compact) 26 | haddock-style: single-line 27 | 28 | # How to print module docstring 29 | haddock-style-module: null 30 | 31 | # Styling of let blocks (choices: auto, inline, newline, or mixed) 32 | let-style: auto 33 | 34 | # How to align the 'in' keyword with respect to the 'let' keyword (choices: left-align, right-align, or no-space) 35 | in-style: no-space 36 | 37 | # Whether to put parentheses around a single constraint (choices: auto, always, or never) 38 | single-constraint-parens: always 39 | 40 | # Whether to put parentheses around a single deriving class (choices: auto, always, or never) 41 | single-deriving-parens: always 42 | 43 | # Output Unicode syntax (choices: detect, always, or never) 44 | unicode: never 45 | 46 | # Give the programmer more choice on where to insert blank lines 47 | respectful: true 48 | 49 | # Fixity information for operators 50 | fixities: 51 | - infixr 0 // 52 | - infixl 1 \\ 53 | - infixl 8 || 54 | - infixl 7 == 55 | - infixl 1 \\\ 56 | - infixl 8 ||| 57 | - infixl 7 === 58 | 59 | # Module reexports Fourmolu should know about 60 | reexports: [] 61 | 62 | -------------------------------------------------------------------------------- /mkdocs.sh: -------------------------------------------------------------------------------- 1 | rm -rf docs 2 | mkdir docs 3 | 4 | cabal haddock \ 5 | --haddock-hyperlink-source \ 6 | --haddock-options=" 7 | --comments-base=https://github.com/sjoerdvisscher/proarrow/ 8 | --comments-module=https://github.com/sjoerdvisscher/proarrow/blob/main/src/%{MODULE/.//}.hs 9 | --comments-entity=https://github.com/sjoerdvisscher/proarrow/blob/main/src/%{MODULE/.//}.hs#L%L 10 | --pretty-html 11 | --odir=docs" 12 | -------------------------------------------------------------------------------- /src/Proarrow.hs: -------------------------------------------------------------------------------- 1 | module Proarrow 2 | ( module Proarrow.Category 3 | , module Proarrow.Profunctor 4 | , module Proarrow.Object 5 | , module Proarrow.Functor 6 | , module Proarrow.Adjunction 7 | ) where 8 | 9 | import Proarrow.Adjunction 10 | import Proarrow.Category 11 | import Proarrow.Functor 12 | import Proarrow.Object 13 | import Proarrow.Profunctor 14 | -------------------------------------------------------------------------------- /src/Proarrow/Adjunction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Proarrow.Adjunction where 5 | 6 | import Data.Kind (Constraint) 7 | import Prelude (($)) 8 | 9 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 10 | import Proarrow.Core (CAT, CategoryOf (..), Obj, Profunctor (..), Promonad (..), rmap, (//), (:~>), type (+->)) 11 | import Proarrow.Functor (Functor (..)) 12 | import Proarrow.Profunctor.Composition ((:.:) (..)) 13 | import Proarrow.Profunctor.Costar (Costar (..)) 14 | import Proarrow.Profunctor.Identity (Id (..)) 15 | import Proarrow.Profunctor.Representable (RepCostar (..), Representable (..), repObj) 16 | import Proarrow.Profunctor.Star (Star (..)) 17 | import Proarrow.Promonad (Procomonad (..)) 18 | import Proarrow.Category.Opposite (Op (..)) 19 | 20 | type Adjunction :: forall {j} {k}. j +-> k -> k +-> j -> Constraint 21 | 22 | -- | Adjunctions between two profunctors. 23 | class (Profunctor p, Profunctor q) => Adjunction (p :: j +-> k) (q :: k +-> j) where 24 | unit :: (Ob a) => (q :.: p) a a -- (~>) :~> q :.: p 25 | counit :: p :.: q :~> (~>) 26 | 27 | unit' :: forall p q a b. (Adjunction p q) => a ~> b -> (q :.: p) a b 28 | unit' f = rmap f (unit @p @q @a) \\ f 29 | 30 | leftAdjunct 31 | :: forall l r a b 32 | . (Adjunction l r, Representable l, Representable r, Ob a) 33 | => (l % a ~> b) 34 | -> r a b 35 | leftAdjunct f = case unit @l @r of r :.: l -> rmap (f . index l) r 36 | 37 | rightAdjunct 38 | :: forall l r a b 39 | . (Adjunction l r, Representable l, Representable r, Ob b) 40 | => r a b 41 | -> (l % a ~> b) 42 | rightAdjunct f = counit (tabulate @l (repMap @l @a id) :.: f) \\ f 43 | 44 | unitFromRepUnit 45 | :: forall l r a. (Representable l, Representable r, Ob a) => (a ~> r % (l % a)) -> (r :.: l) a a 46 | unitFromRepUnit f = tabulate f :.: tabulate id \\ repObj @l @a 47 | 48 | counitFromRepCounit 49 | :: forall l r. (Representable l, Representable r) => (forall c. (Ob c) => l % (r % c) ~> c) -> (l :.: r) :~> (~>) 50 | counitFromRepCounit f (l :.: r) = f . repMap @l (index r) . index l \\ r 51 | 52 | instance (Functor f) => Adjunction (Star f) (Costar f) where 53 | unit = Costar (map id) :.: Star (map id) 54 | counit (Star f :.: Costar g) = g . f 55 | 56 | instance (Representable f) => Adjunction f (RepCostar f) where 57 | unit @a = let fa = repMap @f @a id in RepCostar fa :.: tabulate fa 58 | counit (f :.: RepCostar g) = g . index f 59 | 60 | instance (Functor f, Functor g, Adjunction (Star f) (Star g)) => Adjunction (Costar f) (Costar g) where 61 | unit :: forall a. (Ob a) => (Costar g :.: Costar f) a a 62 | unit = Costar id :.: Costar (counit (Star (map id) :.: Star id)) 63 | counit :: forall a b. (Costar f :.: Costar g) a b -> a ~> b 64 | counit (Costar f :.: Costar g) = case unit @(Star f) @(Star g) @a of Star g' :.: Star f' -> g . map (f . f') . g' 65 | 66 | instance (Adjunction l1 r1, Adjunction l2 r2) => Adjunction (l1 :.: l2) (r2 :.: r1) where 67 | unit :: forall a. (Ob a) => ((r2 :.: r1) :.: (l1 :.: l2)) a a 68 | unit = case unit @l2 @r2 @a of 69 | r2 :.: l2 -> 70 | l2 // case unit @l1 @r1 of 71 | r1 :.: l1 -> (r2 :.: r1) :.: (l1 :.: l2) 72 | counit ((l1 :.: l2) :.: (r2 :.: r1)) = counit (rmap (counit (l2 :.: r2)) l1 :.: r1) 73 | 74 | instance Adjunction (Star ((,) a)) (Star ((->) a)) where 75 | unit = unitFromRepUnit \a b -> (b, a) 76 | counit = counitFromRepCounit \(a, f) -> f a 77 | 78 | instance (CategoryOf k) => Adjunction (Id :: CAT k) Id where 79 | unit = Id id :.: Id id 80 | counit (Id f :.: Id g) = g . f 81 | 82 | instance Adjunction q p => Adjunction (Op p) (Op q) where 83 | unit = case unit @q @p of q :.: p -> Op p :.: Op q 84 | counit (Op q :.: Op p) = Op (counit (p :.: q)) 85 | 86 | instance (Adjunction p q) => Promonad (q :.: p) where 87 | id = unit 88 | (q :.: p) . (q' :.: p') = rmap (counit (p' :.: q)) q' :.: p 89 | 90 | instance (Adjunction p q) => Procomonad (p :.: q) where 91 | extract = counit 92 | duplicate (p :.: q) = p // case unit of q' :.: p' -> (p :.: q') :.: (p' :.: q) 93 | 94 | instance 95 | (MonoidalProfunctor r, Adjunction l r, Representable l, Representable r, Monoidal j, Monoidal k) 96 | => MonoidalProfunctor (RepCostar l :: j +-> k) 97 | where 98 | par0 = RepCostar (counit @l @r (tabulate (repMap @l @Unit id) :.: par0)) \\ (par0 :: Obj (Unit :: k)) 99 | RepCostar @x1 fx `par` RepCostar @y1 fy = 100 | (fx `par` fy) // withOb2 @_ @x1 @y1 $ 101 | RepCostar (rightAdjunct @l @r (leftAdjunct @l @r @x1 fx `par` leftAdjunct @l @r @y1 fy)) 102 | -------------------------------------------------------------------------------- /src/Proarrow/Category.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category 2 | ( CAT 3 | , CategoryOf (..) 4 | , dimapDefault 5 | ) 6 | where 7 | 8 | import Proarrow.Core 9 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Bidiscrete.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.Bidiscrete where 2 | 3 | import Data.Type.Equality (type (~), type (~~)) 4 | 5 | import Proarrow.Category.Bicategory (Bicategory (..)) 6 | import Proarrow.Core (CAT, CategoryOf (..), OB, Profunctor (..), Promonad (..), dimapDefault) 7 | 8 | type DiscreteK :: forall {c}. OB c -> CAT c 9 | type data DiscreteK (ob :: OB c) j k where 10 | DK :: DiscreteK ob j j 11 | type Bidiscrete :: CAT (DiscreteK ob j k) 12 | data Bidiscrete a b where 13 | Bidiscrete :: (ob j) => Bidiscrete (DK :: DiscreteK ob j j) DK 14 | 15 | instance Profunctor Bidiscrete where 16 | dimap = dimapDefault 17 | r \\ Bidiscrete = r 18 | instance Promonad Bidiscrete where 19 | id = Bidiscrete 20 | Bidiscrete . Bidiscrete = Bidiscrete 21 | instance CategoryOf (DiscreteK ob j k) where 22 | type (~>) = Bidiscrete 23 | type Ob (a :: DiscreteK ob j k) = (j ~ k, a ~~ (DK :: DiscreteK ob j j), ob j) 24 | 25 | -- | The bicategory with only identity 1-cells and identity 2-cells between those. 26 | instance CategoryOf c => Bicategory (DiscreteK (ob :: OB c)) where 27 | type Ob0 (DiscreteK ob) k = ob k 28 | type I = DK 29 | type DK `O` DK = DK 30 | withOb2 r = r 31 | Bidiscrete `o` Bidiscrete = Bidiscrete 32 | r \\\ Bidiscrete = r 33 | leftUnitor = Bidiscrete 34 | leftUnitorInv = Bidiscrete 35 | rightUnitor = Bidiscrete 36 | rightUnitorInv = Bidiscrete 37 | associator = Bidiscrete 38 | associatorInv = Bidiscrete 39 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/CategoryAsBi.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.CategoryAsBi where 2 | 3 | import Prelude (Maybe (..), liftA2, (>>), type (~)) 4 | 5 | import Proarrow.Category.Bicategory (Bicategory (..)) 6 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault) 7 | 8 | type PLAINK :: forall k -> CAT k 9 | data PLAINK k i j = PLAIN -- should be @PLAIN (i ~> j)@ storing a value at type level, but that needs dependent types 10 | 11 | type Category :: CAT (PLAINK k i j) 12 | data Category as bs where 13 | Id :: forall {k} a b. (Ob a, Ob b) => Maybe (a ~> b) -> Category (PLAIN :: PLAINK k (a :: k) (b :: k)) PLAIN 14 | 15 | instance (CategoryOf k, Ob i, Ob j) => Profunctor (Category :: CAT (PLAINK k i j)) where 16 | dimap = dimapDefault 17 | r \\ Id{} = r 18 | instance (CategoryOf k, Ob i, Ob j) => Promonad (Category :: CAT (PLAINK k i j)) where 19 | id = Id Nothing 20 | Id f . Id g = Id (f >> g) -- f and g should be the same, but this isn't checked by the type system 21 | instance (CategoryOf k, Ob i, Ob j) => CategoryOf (PLAINK k i j) where 22 | type (~>) = Category 23 | type Ob a = (a ~ PLAIN) 24 | 25 | instance (CategoryOf k) => Bicategory (PLAINK k) where 26 | type Ob0 (PLAINK k) a = Ob a 27 | type I = PLAIN 28 | type O PLAIN PLAIN = PLAIN 29 | withOb2 r = r 30 | r \\\ Id{} = r 31 | Id f `o` Id g = Id (liftA2 (.) f g) 32 | leftUnitor = id 33 | leftUnitorInv = id 34 | rightUnitor = id 35 | rightUnitorInv = id 36 | associator = id 37 | associatorInv = id 38 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Co.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.Co where 2 | 3 | import Proarrow.Category.Bicategory 4 | ( Bicategory (..) 5 | , Comonad (..) 6 | , Monad (..), Adjunction (..) 7 | ) 8 | import Proarrow.Category.Bicategory.Kan 9 | ( LeftKanExtension (..) 10 | , LeftKanLift (..) 11 | , RightKanExtension (..) 12 | , RightKanLift (..) 13 | ) 14 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault) 15 | 16 | type COK :: CAT k -> CAT k 17 | newtype COK kk j k = CO (kk j k) 18 | type instance UN CO (CO k) = k 19 | 20 | type Co :: CAT (COK kk j k) 21 | data Co a b where 22 | Co :: b ~> a -> Co (CO a) (CO b) 23 | 24 | instance (CategoryOf (kk j k)) => Profunctor (Co :: CAT (COK kk j k)) where 25 | dimap = dimapDefault 26 | r \\ Co f = r \\ f 27 | instance (CategoryOf (kk j k)) => Promonad (Co :: CAT (COK kk j k)) where 28 | id = Co id 29 | Co f . Co g = Co (g . f) 30 | instance (CategoryOf (kk j k)) => CategoryOf (COK kk j k) where 31 | type (~>) = Co 32 | type Ob a = (Is CO a, Ob (UN CO a)) 33 | 34 | -- | Create a dual of a bicategory by reversing the 2-cells. 35 | instance (Bicategory kk) => Bicategory (COK kk) where 36 | type Ob0 (COK kk) k = Ob0 kk k 37 | type I = CO I 38 | type a `O` b = CO (UN CO a `O` UN CO b) 39 | withOb2 @(CO a) @(CO b) = withOb2 @kk @a @b 40 | r \\\ Co f = r \\\ f 41 | Co f `o` Co g = Co (f `o` g) 42 | leftUnitor = Co leftUnitorInv 43 | leftUnitorInv = Co leftUnitor 44 | rightUnitor = Co rightUnitorInv 45 | rightUnitorInv = Co rightUnitor 46 | associator @(CO p) @(CO q) @(CO r) = Co (associatorInv @kk @p @q @r) 47 | associatorInv @(CO p) @(CO q) @(CO r) = Co (associator @kk @p @q @r) 48 | 49 | instance Adjunction f g => Adjunction (CO g) (CO f) where 50 | unit = Co (counit @f @g) 51 | counit = Co (unit @f @g) 52 | 53 | instance (Comonad m) => Monad (CO m) where 54 | eta = Co epsilon 55 | mu = Co delta 56 | 57 | instance (Monad m) => Comonad (CO m) where 58 | epsilon = Co eta 59 | delta = Co mu 60 | 61 | instance (RightKanExtension j f) => LeftKanExtension (CO j) (CO f) where 62 | type Lan (CO j) (CO f) = CO (Ran j f) 63 | lan = Co (ran @j @f) 64 | lanUniv (Co n) = Co (ranUniv @j @f n) 65 | 66 | instance (LeftKanExtension j f) => RightKanExtension (CO j) (CO f) where 67 | type Ran (CO j) (CO f) = CO (Lan j f) 68 | ran = Co (lan @j @f) 69 | ranUniv (Co n) = Co (lanUniv @j @f n) 70 | 71 | instance (RightKanLift j f) => LeftKanLift (CO j) (CO f) where 72 | type Lift (CO j) (CO f) = CO (Rift j f) 73 | lift = Co (rift @j @f) 74 | liftUniv (Co n) = Co (riftUniv @j @f n) 75 | 76 | instance (LeftKanLift j f) => RightKanLift (CO j) (CO f) where 77 | type Rift (CO j) (CO f) = CO (Lift j f) 78 | rift = Co (lift @j @f) 79 | riftUniv (Co n) = Co (liftUniv @j @f n) 80 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Hom.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.Hom where 2 | 3 | import Proarrow.Category.Bicategory (Bicategory (..), (==), (||)) 4 | import Proarrow.Category.Bicategory.Co (COK (..), Co (..)) 5 | import Proarrow.Category.Bicategory.Prof (LaxProfunctor (..)) 6 | import Proarrow.Category.Instance.Nat (Nat (..)) 7 | import Proarrow.Category.Instance.Prof (Prof (..)) 8 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, obj, type (+->)) 9 | import Proarrow.Functor (Functor (..)) 10 | import Proarrow.Profunctor.Composition ((:.:) (..)) 11 | import Proarrow.Profunctor.Identity (Id (..)) 12 | 13 | newtype HK kk i j = HomK {unHomK :: kk i j} 14 | type instance UN HomK (HomK k) = k 15 | 16 | type HomW :: CAT (HK kk i j) 17 | data HomW a b where 18 | HomW :: a ~> b -> HomW (HomK a) (HomK b) 19 | instance (Profunctor ((~>) :: CAT (kk i j))) => Profunctor (HomW :: CAT (HK kk i j)) where 20 | dimap = dimapDefault 21 | r \\ HomW f = r \\ f 22 | instance (Promonad ((~>) :: CAT (kk i j))) => Promonad (HomW :: CAT (HK kk i j)) where 23 | id = HomW id 24 | HomW f . HomW g = HomW (f . g) 25 | instance (CategoryOf (kk i j)) => CategoryOf (HK kk i j) where 26 | type (~>) = HomW 27 | type Ob k = (Is HomK k, Ob (UN HomK k)) 28 | 29 | instance 30 | (Bicategory kk, Ob s, Ob t, Ob0 kk h, Ob0 kk i, Ob0 kk j, Ob0 kk k) 31 | => Profunctor (P kk kk (HK kk) (s :: COK kk h i) (t :: kk j k)) 32 | where 33 | dimap (HomW f) (HomW g) (Hom n) = Hom ((obj @t `o` g) . n . (f `o` obj @(UN CO s))) \\\ f \\\ g 34 | r \\ Hom{} = r 35 | instance 36 | (Bicategory kk, Ob s, Ob0 kk h, Ob0 kk i, Ob0 kk j, Ob0 kk k) 37 | => Functor (P kk kk (HK kk) (s :: COK kk h i) :: kk j k -> HK kk h j +-> HK kk i k) 38 | where 39 | map f = (Prof \(Hom @_ @b n) -> Hom ((f `o` obj @b) . n)) \\\ f 40 | instance 41 | (Bicategory kk, Ob0 kk h, Ob0 kk i, Ob0 kk j, Ob0 kk k) 42 | => Functor (P kk kk (HK kk) :: COK kk h i -> kk j k -> HK kk h j +-> HK kk i k) 43 | where 44 | map (Co f) = (Nat (Prof \(Hom @a n) -> Hom (n . (obj @a `o` f)))) \\\ f 45 | 46 | instance (Bicategory kk) => LaxProfunctor kk kk (HK kk) where 47 | data P kk kk (HK kk) s t a b where 48 | Hom 49 | :: forall {h} {i} {j} {k} {kk} (a :: kk i k) (b :: kk h j) (s :: kk h i) (t :: kk j k) 50 | . (Ob a, Ob b, Ob s, Ob t, Ob0 kk h, Ob0 kk i, Ob0 kk j, Ob0 kk k) 51 | => a `O` s ~> t `O` b 52 | -> P kk kk (HK kk) (CO s) t (HomK a) (HomK b) 53 | laxId (Id (HomW f) :: Id (a :: HK kk i j) b) = Hom (leftUnitorInv . f . rightUnitor) \\ f 54 | laxComp (Hom @a @b @s @t n :.: Hom @_ @c @s' @t' m) = 55 | let s = obj @s; t = obj @t; s' = obj @s'; t' = obj @t' 56 | in Hom (associatorInv @_ @a @s @s' == n || s' == associator @_ @t @b @s' == t || m == associatorInv @_ @t @t' @c) 57 | \\\ (s || s') 58 | \\\ (t || t') 59 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Limit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | module Proarrow.Category.Bicategory.Limit where 3 | 4 | import Data.Kind (Constraint) 5 | 6 | import Proarrow.Core (CAT, CategoryOf (..), Obj) 7 | import Proarrow.Category.Bicategory (Bicategory(..)) 8 | 9 | type family TerminalObject (kk :: CAT s) :: s 10 | type HasTerminalObject :: forall {s}. CAT s -> Constraint 11 | class HasTerminalObject (kk :: CAT s) where 12 | type Terminate kk (j :: s) :: kk j (TerminalObject kk) 13 | terminate :: Ob0 kk j => Obj (Terminate kk j) 14 | termUniv :: (Ob0 kk j, Ob f, Ob g) => (f :: kk j (TerminalObject kk)) ~> (g :: kk j (TerminalObject kk)) 15 | 16 | type family Product (kk :: CAT s) (a :: s) (b :: s) :: s 17 | type HasBinaryProducts :: forall {s}. CAT s -> Constraint 18 | class HasBinaryProducts (kk :: CAT s) where 19 | type Fst kk (a :: s) (b :: s) :: kk (Product kk a b) a 20 | type Snd kk (a :: s) (b :: s) :: kk (Product kk a b) b 21 | fstObj :: (Ob0 kk a, Ob0 kk b) => Obj (Fst kk a b) 22 | sndObj :: (Ob0 kk a, Ob0 kk b) => Obj (Snd kk a b) 23 | type (&&&) (f :: kk j a) (g :: kk j b) :: kk j (Product kk a b) 24 | prodObj :: (Ob0 kk j, Ob0 kk a, Ob0 kk b, Ob (f :: kk j a), Ob (g :: kk j b)) => Obj (f &&& g) 25 | prodUniv :: (Ob0 kk j, Ob0 kk a, Ob0 kk b, Ob (h :: kk j (Product kk a b)), Ob (k :: kk j (Product kk a b))) 26 | => (Fst kk a b `O` h ~> Fst kk a b `O` k) -> (Snd kk a b `O` h ~> Snd kk a b `O` k) -> h ~> k 27 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Mod.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.Mod where 2 | 3 | import Proarrow.Category.Bicategory (Bicategory (..), Monad (..)) 4 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, Obj, dimapDefault) 5 | 6 | type data MONK kk where 7 | MON :: kk a a -> MONK kk 8 | type instance UN MON (MON s) = s 9 | type family MONObj0 (s :: MONK (kk :: CAT k)) :: k 10 | type instance MONObj0 (MON (s :: kk a a)) = a 11 | 12 | type data MODK kk (s :: MONK kk) (t :: MONK kk) = MOD (kk (MONObj0 t) (MONObj0 s)) 13 | type family UNMOD (p :: MODK kk s t) :: kk (MONObj0 t) (MONObj0 s) 14 | type instance UNMOD (MOD p) = p 15 | 16 | type IsMON kk s = Is (MON @kk @(MONObj0 s)) s 17 | 18 | type Mod :: forall {kk} {s} {t}. CAT (MODK kk s t) 19 | data Mod p q where 20 | Mod 21 | :: (s :: kk i i) `O` (p :: kk j i) `O` (t :: kk j j) ~> p -> p ~> q -> s `O` q `O` t ~> q -> Mod (MOD p :: MODK kk (MON s) (MON t)) (MOD q) 22 | instance (Bicategory kk, Ob0 kk (MONObj0 s), Ob0 kk (MONObj0 t), IsMON kk s, IsMON kk t) => Profunctor (Mod :: CAT (MODK kk s t)) where 23 | dimap = dimapDefault 24 | r \\ Mod _ f _ = r \\ f 25 | instance (Bicategory kk, Ob0 kk (MONObj0 s), Ob0 kk (MONObj0 t), IsMON kk s, IsMON kk t) => Promonad (Mod :: CAT (MODK kk s t)) where 26 | id :: forall (a :: MODK kk s t). (Ob a) => Mod a a 27 | id = Mod @kk @(UN MON s) @(UNMOD a) @(UN MON t) @(UNMOD a) _ id _ 28 | Mod _ f q . Mod p g _ = Mod p (f . g) q 29 | instance (Bicategory kk, Ob0 kk (MONObj0 s), Ob0 kk (MONObj0 t), IsMON kk s, IsMON kk t) => CategoryOf (MODK kk s t) where 30 | type (~>) = Mod 31 | type Ob (p :: MODK kk s t) = (p ~ MOD (UNMOD p), Ob (UNMOD p)) 32 | 33 | instance (Bicategory kk) => Bicategory (MODK kk) where 34 | type Ob0 (MODK kk) (s :: MONK kk) = (Monad (UN MON s :: kk (MONObj0 s) (MONObj0 s)), Ob0 kk (MONObj0 s), IsMON kk s) 35 | type I @(MODK kk) @(i :: MONK kk) = MOD (UN MON i) 36 | type MOD p `O` MOD q = MOD (q `O` p) 37 | Mod p f q `o` Mod p' g q' = let fg = f `o` g in Mod _ fg _ 38 | -- leftUnitor (Mod p) = let lp = leftUnitor p in Mod lp \\ lp 39 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/MonoidalAsBi.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.MonoidalAsBi where 2 | 3 | import Prelude (type (~)) 4 | 5 | import Proarrow.Category.Bicategory (Adjunction (..), Bicategory (..), Comonad (..), Monad (..)) 6 | import Proarrow.Category.Bicategory.Kan 7 | ( LeftKanExtension (..) 8 | , LeftKanLift (..) 9 | , RightKanExtension (..) 10 | , RightKanLift (..) 11 | ) 12 | import Proarrow.Category.Equipment (Equipment (..), HasCompanions (..)) 13 | import Proarrow.Category.Equipment.Limit (HasColimits (..), HasLimits (..)) 14 | import Proarrow.Category.Monoidal (SymMonoidal) 15 | import Proarrow.Category.Monoidal qualified as M 16 | import Proarrow.Core (CAT, CategoryOf (..), Is, Kind, Profunctor (..), Promonad (..), UN, obj) 17 | import Proarrow.Monoid qualified as M 18 | import Proarrow.Object.Coexponential (Coclosed (..), coeval, coevalUniv) 19 | import Proarrow.Object.Dual qualified as M 20 | import Proarrow.Object.Exponential (Closed (..), curry, eval) 21 | 22 | type MonK :: Kind -> CAT () 23 | newtype MonK k i j = MK k 24 | type instance UN MK (MK k) = k 25 | 26 | type Mon2 :: forall {k} {i} {j}. CAT (MonK k i j) 27 | data Mon2 a b where 28 | Mon2 :: a ~> b -> Mon2 (MK a) (MK b) 29 | deriving (Profunctor, Promonad) via (~>) 30 | 31 | instance (CategoryOf k) => CategoryOf (MonK k i j) where 32 | type (~>) = Mon2 33 | type Ob a = (Is MK a, Ob (UN MK a)) 34 | 35 | -- | A monoidal category as a bicategory. 36 | instance (M.Monoidal k) => Bicategory (MonK k) where 37 | type I = MK M.Unit 38 | type MK a `O` MK b = MK (a M.** b) 39 | withOb2 @(MK a) @(MK b) = M.withOb2 @k @a @b 40 | Mon2 f `o` Mon2 g = Mon2 (f `M.par` g) 41 | r \\\ Mon2 f = r \\ f 42 | leftUnitor = Mon2 M.leftUnitor 43 | leftUnitorInv = Mon2 M.leftUnitorInv 44 | rightUnitor = Mon2 M.rightUnitor 45 | rightUnitorInv = Mon2 M.rightUnitorInv 46 | associator @(MK a) @(MK b) @(MK c) = Mon2 (M.associator @k @a @b @c) 47 | associatorInv @(MK a) @(MK b) @(MK c) = Mon2 (M.associatorInv @k @a @b @c) 48 | 49 | -- | Monoids in a monoidal category are monads when the monoidal category is seen as a bicategory. 50 | instance (M.Monoid m) => Monad (MK m) where 51 | eta = Mon2 M.mempty 52 | mu = Mon2 M.mappend 53 | 54 | -- | Comonoids in a monoidal category are comonads when the monoidal category is seen as a bicategory. 55 | instance (M.Comonoid m) => Comonad (MK m) where 56 | epsilon = Mon2 M.counit 57 | delta = Mon2 M.comult 58 | 59 | instance (M.Monoidal k) => HasCompanions (MonK k) (MonK k) where 60 | type Companion (MonK k) (MK a) = MK a 61 | mapCompanion (Mon2 f) = Mon2 f 62 | withObCompanion r = r 63 | compToId = Mon2 M.unitObj 64 | compFromId = Mon2 M.unitObj 65 | compToCompose (Mon2 f) (Mon2 g) = Mon2 (f `M.par` g) 66 | compFromCompose (Mon2 f) (Mon2 g) = Mon2 (f `M.par` g) 67 | 68 | instance (M.CompactClosed k, Ob (a :: k), b ~ M.Dual a, Ob b) => Adjunction (MK a) (MK b) where 69 | unit = Mon2 (M.swap @k @a @b . M.dualityUnit @a) 70 | counit = Mon2 (M.dualityCounit @a . M.swap @k @a @b) 71 | 72 | instance (M.CompactClosed k) => Equipment (MonK k) (MonK k) where 73 | type Conjoint (MonK k) (MK a) = MK (M.Dual a) 74 | mapConjoint (Mon2 f) = Mon2 (M.dual f) 75 | withObConjoint r = r 76 | conjToId = Mon2 M.dualUnit 77 | conjFromId = Mon2 M.dualUnitInv 78 | conjToCompose (Mon2 @a f) (Mon2 @b g) = Mon2 (M.distribDual @k @b @a . (M.dual (g `M.swap'` f))) \\ f \\ g 79 | conjFromCompose (Mon2 @a f) (Mon2 @b g) = Mon2 ((M.dual (f `M.swap'` g)) . M.combineDual @b @a) \\ f \\ g 80 | 81 | instance (Closed k, Ob j) => HasLimits (MonK k) (MK (j :: k)) '() where 82 | type Limit (MK j) (MK d) = MK (j ~~> d) 83 | withObLimit @(MK d) r = r \\ obj @d ^^^ obj @j 84 | limit @(MK d) = Mon2 (eval @j @d) 85 | limitUniv @_ @(MK p) (Mon2 pj2d) = Mon2 (curry @_ @p @j pj2d) 86 | 87 | instance (M.Monoidal k, Ob j) => HasColimits (MonK k) (MK (j :: k)) '() where 88 | type Colimit (MK j) (MK d) = MK (d M.** j) 89 | withObColimit @(MK d) = M.withOb2 @k @d @j 90 | colimit @(MK d) = Mon2 (obj @d `M.par` obj @j) 91 | colimitUniv (Mon2 f) = Mon2 f 92 | 93 | instance (Closed k, Ob (p ~~> q), Ob p, Ob q) => RightKanExtension (MK (p :: k)) (MK (q :: k)) where 94 | type Ran (MK p) (MK q) = MK (p ~~> q) 95 | ran = Mon2 (eval @p @q) 96 | ranUniv @(MK g) (Mon2 f) = Mon2 (curry @k @g @p @q f) 97 | 98 | instance (Closed k, SymMonoidal k, Ob (p ~~> q), Ob p, Ob q) => RightKanLift (MK (p :: k)) (MK (q :: k)) where 99 | type Rift (MK p) (MK q) = MK (p ~~> q) 100 | rift = Mon2 (eval @p @q . M.swap @k @p @(p ~~> q)) 101 | riftUniv @(MK g) (Mon2 f) = Mon2 (curry @k @g @p @q (f . M.swap @k @g @p)) 102 | 103 | instance (Coclosed k, Ob (q <~~ p), Ob p, Ob q) => LeftKanExtension (MK (p :: k)) (MK (q :: k)) where 104 | type Lan (MK p) (MK q) = MK (q <~~ p) 105 | lan = Mon2 (coeval @k @q @p) 106 | lanUniv @(MK g) (Mon2 f) = Mon2 (coevalUniv @k @p @g f) 107 | 108 | instance (Coclosed k, SymMonoidal k, Ob (q <~~ p), Ob p, Ob q) => LeftKanLift (MK (p :: k)) (MK (q :: k)) where 109 | type Lift (MK p) (MK q) = MK (q <~~ p) 110 | lift = Mon2 (M.swap @k @(q <~~ p) @p . coeval @k @q @p) 111 | liftUniv @(MK g) (Mon2 f) = Mon2 (coevalUniv @k @p @g (M.swap @k @p @g . f)) 112 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Product.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.Product where 2 | 3 | import Prelude (type (~)) 4 | 5 | import Proarrow.Category.Bicategory (Bicategory (..), Adjunction (..), Monad (..), Comonad (..)) 6 | import Proarrow.Category.Equipment (Equipment (..), HasCompanions (..)) 7 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault) 8 | 9 | type PRODK :: CAT j -> CAT k -> CAT (j, k) 10 | data PRODK jj kk j k where 11 | PROD :: jj (Fst ik) (Fst jl) -> kk (Snd ik) (Snd jl) -> PRODK jj kk ik jl 12 | 13 | type family PRODFST (p :: PRODK jj kk j k) :: jj (Fst j) (Fst k) where 14 | PRODFST (PROD p q) = p 15 | type family PRODSND (p :: PRODK jj kk j k) :: kk (Snd j) (Snd k) where 16 | PRODSND (PROD p q) = q 17 | type family Fst (p :: (j, k)) :: j where 18 | Fst '(a, b) = a 19 | type family Snd (p :: (j, k)) :: k where 20 | Snd '(a, b) = b 21 | 22 | type Prod :: CAT (PRODK jj kk j k) 23 | data Prod a b where 24 | Prod :: { fst :: a ~> b, snd :: c ~> d } -> Prod (PROD a c) (PROD b d) 25 | 26 | instance (CategoryOf (jj (Fst ik) (Fst jl)), CategoryOf (kk (Snd ik) (Snd jl))) => Profunctor (Prod :: CAT (PRODK jj kk ik jl)) where 27 | dimap = dimapDefault 28 | r \\ Prod f g = r \\ f \\ g 29 | instance (CategoryOf (jj (Fst ik) (Fst jl)), CategoryOf (kk (Snd ik) (Snd jl))) => Promonad (Prod :: CAT (PRODK jj kk ik jl)) where 30 | id = Prod id id 31 | Prod f1 g1 . Prod f2 g2 = Prod (f1 . f2) (g1 . g2) 32 | instance (CategoryOf (jj (Fst ik) (Fst jl)), CategoryOf (kk (Snd ik) (Snd jl))) => CategoryOf (PRODK jj kk ik jl) where 33 | type (~>) = Prod 34 | type Ob (p :: PRODK jj kk ik jl) = (Ob (PRODFST p), Ob (PRODSND p), p ~ PROD (PRODFST p) (PRODSND p)) 35 | 36 | instance (Bicategory jj, Bicategory kk) => Bicategory (PRODK jj kk) where 37 | type Ob0 (PRODK jj kk) jk = (Ob0 jj (Fst jk), Ob0 kk (Snd jk)) 38 | type I = PROD I I 39 | type PROD a b `O` PROD c d = PROD (a `O` c) (b `O` d) 40 | withOb2 @(PROD a b) @(PROD c d) r = withOb2 @jj @a @c (withOb2 @kk @b @d r) 41 | r \\\ Prod f g = r \\\ f \\\ g 42 | Prod f g `o` Prod h i = Prod (f `o` h) (g `o` i) 43 | leftUnitor = Prod leftUnitor leftUnitor 44 | leftUnitorInv = Prod leftUnitorInv leftUnitorInv 45 | rightUnitor = Prod rightUnitor rightUnitor 46 | rightUnitorInv = Prod rightUnitorInv rightUnitorInv 47 | associator @(PROD p q) @(PROD r s) @(PROD t u) = Prod (associator @jj @p @r @t) (associator @kk @q @s @u) 48 | associatorInv @(PROD p q) @(PROD r s) @(PROD t u) = Prod (associatorInv @jj @p @r @t) (associatorInv @kk @q @s @u) 49 | 50 | instance (Adjunction (PRODFST l) (PRODFST r), Adjunction (PRODSND l) (PRODSND r), Ob l, Ob r) => Adjunction l r where 51 | unit = Prod (unit @(PRODFST l) @(PRODFST r)) (unit @(PRODSND l) @(PRODSND r)) 52 | counit = Prod (counit @(PRODFST l) @(PRODFST r)) (counit @(PRODSND l) @(PRODSND r)) 53 | 54 | instance (Monad (PRODFST m), Monad (PRODSND m), Ob m) => Monad m where 55 | eta = Prod eta eta 56 | mu = Prod mu mu 57 | 58 | instance (Comonad (PRODFST m), Comonad (PRODSND m), Ob m) => Comonad m where 59 | epsilon = Prod epsilon epsilon 60 | delta = Prod delta delta 61 | 62 | instance (HasCompanions hj vj, HasCompanions hk vk) => HasCompanions (PRODK hj hk) (PRODK vj vk) where 63 | type Companion (PRODK hj hk) fg = PROD (Companion hj (PRODFST fg)) (Companion hk (PRODSND fg)) 64 | mapCompanion (Prod f g) = Prod (mapCompanion f) (mapCompanion g) 65 | withObCompanion @(PROD f g) r = withObCompanion @hj @vj @f (withObCompanion @hk @vk @g r) 66 | compToId = Prod compToId compToId 67 | compFromId = Prod compFromId compFromId 68 | compToCompose (Prod fl fr) (Prod gl gr) = Prod (compToCompose fl gl) (compToCompose fr gr) 69 | compFromCompose (Prod fl fr) (Prod gl gr) = Prod (compFromCompose fl gl) (compFromCompose fr gr) 70 | 71 | instance (Equipment hj vj, Equipment hk vk) => Equipment (PRODK hj hk) (PRODK vj vk) where 72 | type Conjoint (PRODK hj hk) fg = PROD (Conjoint hj (PRODFST fg)) (Conjoint hk (PRODSND fg)) 73 | mapConjoint (Prod f g) = Prod (mapConjoint f) (mapConjoint g) 74 | withObConjoint @(PROD f g) r = withObConjoint @hj @vj @f (withObConjoint @hk @vk @g r) 75 | conjToId = Prod conjToId conjToId 76 | conjFromId = Prod conjFromId conjFromId 77 | conjToCompose (Prod fl fr) (Prod gl gr) = Prod (conjToCompose fl gl) (conjToCompose fr gr) 78 | conjFromCompose (Prod fl fr) (Prod gl gr) = Prod (conjFromCompose fl gl) (conjFromCompose fr gr) 79 | comConUnit (Prod f g) = Prod (comConUnit f) (comConUnit g) 80 | comConCounit (Prod f g) = Prod (comConCounit f) (comConCounit g) -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Relative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | module Proarrow.Category.Bicategory.Relative where 3 | 4 | import Data.Kind (Constraint) 5 | 6 | import Proarrow.Core (CategoryOf(..), CAT) 7 | import Proarrow.Category.Bicategory (Bicategory(..)) 8 | 9 | -- | A @j@-relative monad @t@. Note that @j@ is the opposite of the usual convention. 10 | -- See 'Proarrow.Squares.Relative' how to use this with a conjoint and a companion to get the regular definition. 11 | type Monad :: forall {s} {kk :: CAT s} {a :: s} {e :: s}. kk e a -> kk a e -> Constraint 12 | class (Bicategory kk, Ob0 kk a, Ob0 kk e, Ob j, Ob t) => Monad (j :: kk e a) (t :: kk a e) where 13 | unit :: I ~> j `O` t 14 | mult :: t `O` j `O` t ~> t 15 | 16 | type Algebra :: forall {s} {kk :: CAT s} {a :: s} {d :: s} {e :: s}. kk e a -> kk a e -> kk d e -> Constraint 17 | class (Bicategory kk, Ob0 kk a, Ob0 kk d, Ob0 kk e, Ob j, Ob t) => Algebra (j :: kk e a) (t :: kk a e) (car :: kk d e) where 18 | act :: t `O` j `O` car ~> car 19 | 20 | type Opalgebra :: forall {s} {kk :: CAT s} {a :: s} {b :: s} {e :: s}. kk e a -> kk a e -> kk a b -> Constraint 21 | class (Bicategory kk, Ob0 kk a, Ob0 kk b, Ob0 kk e, Ob j, Ob t) => Opalgebra (j :: kk e a) (t :: kk a e) (car :: kk a b) where 22 | opact :: car `O` j `O` t ~> car 23 | 24 | type Adjunction :: forall {s} {kk :: CAT s} {a} {c} {e}. kk e a -> kk a c -> kk c e -> Constraint 25 | class (Bicategory kk, Ob0 kk a, Ob0 kk c, Ob0 kk e) => Adjunction (j :: kk e a) (l :: kk a c) (r :: kk c e) where 26 | eta :: I ~> j `O` r `O` l 27 | epsilon :: l `O` j `O` r ~> I 28 | 29 | type Comonad :: forall {s} {kk :: CAT s} {a :: s} {e :: s}. kk e a -> kk a e -> Constraint 30 | class (Bicategory kk, Ob0 kk a, Ob0 kk e, Ob j, Ob t) => Comonad (j :: kk e a) (t :: kk a e) where 31 | counit :: j `O` t ~> I 32 | comult :: t ~> t `O` j `O` t 33 | 34 | type Coalgebra :: forall {s} {kk :: CAT s} {a :: s} {d :: s} {e :: s}. kk e a -> kk a e -> kk d e -> Constraint 35 | class (Bicategory kk, Ob0 kk a, Ob0 kk d, Ob0 kk e, Ob j, Ob t) => Coalgebra (j :: kk e a) (t :: kk a e) (car :: kk d e) where 36 | coact :: car ~> t `O` j `O` car 37 | 38 | type Coopalgebra :: forall {s} {kk :: CAT s} {a :: s} {b :: s} {e :: s}. kk e a -> kk a e -> kk a b -> Constraint 39 | class (Bicategory kk, Ob0 kk a, Ob0 kk b, Ob0 kk e, Ob j, Ob t) => Coopalgebra (j :: kk e a) (t :: kk a e) (car :: kk a b) where 40 | coopact :: car ~> car `O` j `O` t 41 | 42 | type Coadjunction :: forall {s} {kk :: CAT s} {a} {c} {e}. kk e a -> kk a c -> kk c e -> Constraint 43 | class (Bicategory kk, Ob0 kk a, Ob0 kk c, Ob0 kk e) => Coadjunction (j :: kk e a) (l :: kk a c) (r :: kk c e) where 44 | coeta :: j `O` r `O` l ~> I 45 | coepsilon :: I ~> l `O` j `O` r 46 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Sub.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Bicategory.Sub where 2 | 3 | import Data.Kind (Type, Constraint) 4 | import Prelude (($)) 5 | 6 | import Proarrow.Category.Bicategory (Bicategory (..)) 7 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault) 8 | 9 | type family IsOb (tag :: Type) (a :: k) :: Constraint 10 | 11 | type SUBCAT :: forall {k}. Type -> CAT k -> CAT k 12 | type data SUBCAT tag kk i j = SUB (kk i j) 13 | type instance UN SUB (SUB p) = p 14 | 15 | type Sub :: CAT (SUBCAT ob kk i j) 16 | data Sub a b where 17 | Sub :: (IsOb tag a, IsOb tag b) => a ~> b -> Sub (SUB a :: SUBCAT tag kk i j) (SUB b) 18 | 19 | instance (Profunctor ((~>) :: CAT (kk i j))) => Profunctor (Sub :: CAT (SUBCAT tag kk i j)) where 20 | dimap = dimapDefault 21 | r \\ Sub p = r \\ p 22 | 23 | instance (Promonad ((~>) :: CAT (kk i j))) => Promonad (Sub :: CAT (SUBCAT tag kk i j)) where 24 | id = Sub id 25 | Sub f . Sub g = Sub (f . g) 26 | 27 | -- | The subcategory with objects with instances of the given constraint `IsOb tag`. 28 | instance (CategoryOf (kk i j)) => CategoryOf (SUBCAT tag kk i j) where 29 | type (~>) = Sub 30 | type Ob (a :: SUBCAT tag kk i j) = (Is SUB a, Ob (UN SUB a), IsOb tag (UN SUB a)) 31 | 32 | class (IsOb tag (a `O` b)) => IsObO tag kk i j k (a :: kk j k) (b :: kk i j) 33 | instance (IsOb tag (a `O` b)) => IsObO tag kk i j k (a :: kk j k) (b :: kk i j) 34 | 35 | class (IsOb tag (I :: kk i i)) => IsObI tag kk i 36 | instance (IsOb tag (I :: kk i i)) => IsObI tag kk i 37 | 38 | instance 39 | ( Bicategory kk 40 | , forall i. (Ob0 kk i) => IsObI tag kk i 41 | , forall i j k (a :: kk j k) (b :: kk i j). (IsOb tag a, IsOb tag b) => IsObO tag kk i j k a b 42 | ) 43 | => Bicategory (SUBCAT tag kk) 44 | where 45 | type Ob0 (SUBCAT tag kk) k = Ob0 kk k 46 | type I = SUB I 47 | type p `O` q = SUB (UN SUB p `O` UN SUB q) 48 | withOb2 @(SUB a) @(SUB b) r = withOb2 @kk @a @b r 49 | Sub m `o` Sub n = Sub $ m `o` n 50 | r \\\ Sub f = r \\\ f 51 | leftUnitor = Sub leftUnitor 52 | leftUnitorInv = Sub leftUnitorInv 53 | rightUnitor = Sub rightUnitor 54 | rightUnitorInv = Sub rightUnitorInv 55 | associator @(SUB p) @(SUB q) @(SUB r) = Sub $ associator @kk @p @q @r 56 | associatorInv @(SUB p) @(SUB q) @(SUB r) = Sub $ associatorInv @kk @p @q @r -------------------------------------------------------------------------------- /src/Proarrow/Category/Bicategory/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Category.Bicategory.Terminal where 4 | 5 | import Data.Type.Equality (type (~), type (~~)) 6 | 7 | import Proarrow.Category.Bicategory (Bicategory (..), Monad (..)) 8 | import Proarrow.Category.Instance.Unit (Unit (..)) 9 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault) 10 | 11 | type Terminal :: CAT (Unit j k) 12 | data Terminal a b where 13 | Terminal :: Terminal 'Unit 'Unit 14 | 15 | instance Profunctor (Terminal :: CAT (Unit '() '())) where 16 | dimap = dimapDefault 17 | r \\ Terminal = r 18 | instance Promonad (Terminal :: CAT (Unit '() '())) where 19 | id = Terminal 20 | Terminal . Terminal = Terminal 21 | instance (j ~ '(), k ~ '()) => CategoryOf (Unit j k) where 22 | type (~>) = Terminal 23 | type Ob @(Unit j k) p = (p ~~ 'Unit) 24 | 25 | instance Bicategory Unit where 26 | type Ob0 Unit k = (k ~ '()) 27 | type I = 'Unit 28 | type O a b = 'Unit 29 | withOb2 r = r 30 | r \\\ Terminal = r 31 | Terminal `o` Terminal = Terminal 32 | leftUnitor = Terminal 33 | leftUnitorInv = Terminal 34 | rightUnitor = Terminal 35 | rightUnitorInv = Terminal 36 | associator = Terminal 37 | associatorInv = Terminal 38 | 39 | instance Monad 'Unit where 40 | eta = Terminal 41 | mu = Terminal 42 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Colimit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Colimit where 4 | 5 | import Data.Function (($)) 6 | import Data.Kind (Constraint) 7 | 8 | import Proarrow.Adjunction (Adjunction (..), unit') 9 | import Proarrow.Category.Instance.Coproduct ((:++:)(..), COPRODUCT(..)) 10 | import Proarrow.Category.Instance.Unit (Unit (..)) 11 | import Proarrow.Category.Instance.Zero (VOID) 12 | import Proarrow.Core (CategoryOf (..), Kind, Profunctor (..), Promonad (..), lmap, src, (//), (:~>), type (+->)) 13 | import Proarrow.Object (Obj) 14 | import Proarrow.Object.BinaryCoproduct (HasBinaryCoproducts (..), lft, rgt) 15 | import Proarrow.Object.Initial (HasInitialObject (..), initiate') 16 | import Proarrow.Profunctor.Composition ((:.:) (..)) 17 | import Proarrow.Profunctor.Representable (Representable (..), dimapRep, withRepOb) 18 | import Proarrow.Profunctor.Terminal (TerminalProfunctor (..)) 19 | 20 | type Unweighted = TerminalProfunctor 21 | 22 | class (Representable (Colimit j d)) => IsRepresentableColimit j d 23 | instance (Representable (Colimit j d)) => IsRepresentableColimit j d 24 | 25 | -- | profunctor-weighted colimits 26 | type HasColimits :: forall {i} {a}. a +-> i -> Kind -> Constraint 27 | class (forall (d :: i +-> k). (Representable d) => IsRepresentableColimit j d) => HasColimits (j :: a +-> i) k where 28 | type Colimit (j :: a +-> i) (d :: i +-> k) :: a +-> k 29 | colimit :: (Representable (d :: i +-> k)) => d :.: j :~> Colimit j d 30 | colimitUniv :: (Representable (d :: i +-> k), Representable p) => (d :.: j :~> p) -> Colimit j d :~> p 31 | 32 | leftAdjointPreservesColimits 33 | :: forall {k} {k'} {i} {a} (f :: k +-> k') g (d :: i +-> k) (j :: a +-> i) 34 | . (Adjunction f g, Representable d, Representable f, Representable g, HasColimits j k, HasColimits j k') 35 | => f :.: Colimit j d :~> Colimit j (f :.: d) 36 | leftAdjointPreservesColimits (f :.: colim) = 37 | colim // case colimitUniv @j @k @d @(g :.: Colimit j (f :.: d)) 38 | (\(d :.: j) -> case unit' @f @g (src d) of g :.: f' -> g :.: colimit @j @k' @(f :.: d) ((f' :.: d) :.: j)) 39 | colim of 40 | g :.: colim' -> lmap (counit (f :.: g)) colim' 41 | 42 | leftAdjointPreservesColimitsInv 43 | :: forall {k} {k'} {i} {a} (f :: k +-> k') (d :: i +-> k) (j :: a +-> i) 44 | . (Representable d, Representable f, HasColimits j k, HasColimits j k') 45 | => Colimit j (f :.: d) :~> f :.: Colimit j d 46 | leftAdjointPreservesColimitsInv = colimitUniv @j @k' @(f :.: d) (\((f :.: d) :.: j) -> f :.: colimit (d :.: j)) 47 | 48 | type InitialLimit :: VOID +-> k -> () +-> k 49 | data InitialLimit d a b where 50 | InitialLimit :: forall {k} d a. a ~> InitialObject -> InitialLimit (d :: VOID +-> k) a '() 51 | 52 | instance (HasInitialObject k) => Profunctor (InitialLimit (d :: VOID +-> k)) where 53 | dimap = dimapRep 54 | r \\ InitialLimit f = r \\ f 55 | instance (HasInitialObject k) => Representable (InitialLimit (d :: VOID +-> k)) where 56 | type InitialLimit d % '() = InitialObject 57 | index (InitialLimit f) = f 58 | tabulate = InitialLimit 59 | repMap Unit = id 60 | instance (HasInitialObject k) => HasColimits (Unweighted :: () +-> VOID) k where 61 | type Colimit Unweighted d = InitialLimit d 62 | colimit = \case {} 63 | colimitUniv @_ @p _ (InitialLimit f) = tabulate @p (initiate' (repMap @p Unit) . f) 64 | 65 | type CoproductColimit :: COPRODUCT () () +-> k -> () +-> k 66 | data CoproductColimit d a b where 67 | CoproductColimit :: forall d a. a ~> ((d % L '()) || (d % R '())) -> CoproductColimit d a '() 68 | 69 | instance (HasBinaryCoproducts k, Representable d) => Profunctor (CoproductColimit d :: () +-> k) where 70 | dimap = dimapRep 71 | r \\ (CoproductColimit f) = r \\ f 72 | 73 | instance (HasBinaryCoproducts k, Representable d) => Representable (CoproductColimit d :: () +-> k) where 74 | type CoproductColimit d % '() = (d % L '()) || (d % R '()) 75 | index (CoproductColimit f) = f 76 | tabulate = CoproductColimit 77 | repMap Unit = (+++) @_ @(d % L '()) @(d % R '()) (repMap @d (InjL Unit)) (repMap @d (InjR Unit)) 78 | 79 | instance (HasBinaryCoproducts k) => HasColimits (Unweighted :: () +-> COPRODUCT () ()) k where 80 | type Colimit Unweighted d = CoproductColimit d 81 | colimit @d (d :.: TerminalProfunctor' b Unit) = CoproductColimit (cochoose @k @d b . index d) 82 | colimitUniv @d @p n (CoproductColimit f) = 83 | let l = index @p (n (tabulate @d (repMap @d (InjL Unit)) :.: TerminalProfunctor' (InjL Unit) Unit)) 84 | r = index @p (n (tabulate @d (repMap @d (InjR Unit)) :.: TerminalProfunctor' (InjR Unit) Unit)) 85 | in tabulate @p ((l ||| r) . f) 86 | 87 | cochoose 88 | :: forall k (d :: COPRODUCT () () +-> k) b 89 | . (HasBinaryCoproducts k, Representable d) 90 | => Obj b 91 | -> (d % b) ~> ((d % L '()) || (d % R '())) 92 | cochoose b = withRepOb @d @(L '()) $ withRepOb @d @(R '()) $ case b of 93 | (InjL Unit) -> lft @_ @(d % L '()) @(d % R '()) 94 | (InjR Unit) -> rgt @_ @(d % L '()) @(d % R '()) 95 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Dagger.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Dagger where 2 | 3 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor) 4 | 5 | class (Profunctor p) => DaggerProfunctor p where 6 | dagger :: p a b -> p b a 7 | 8 | class (DaggerProfunctor ((~>) :: CAT k)) => Dagger k 9 | instance (DaggerProfunctor ((~>) :: CAT k)) => Dagger k 10 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Enriched.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Enriched where 4 | 5 | import Data.Kind (Constraint, Type) 6 | import Prelude (($), type (~)) 7 | 8 | import Proarrow.Category.Bicategory (Bicategory (I, O), Monad (..)) 9 | import Proarrow.Category.Bicategory.MonoidalAsBi (Mon2 (..), MonK (..)) 10 | import Proarrow.Core (CAT, CategoryOf (..), Is, Kind, Promonad (..), UN) 11 | import Proarrow.Object.BinaryProduct () 12 | -- import Proarrow.Preorder (PreorderOf(..), CPromonad(..), (\\), POS) 13 | -- import Proarrow.Category.Instance.PreorderAsCategory (POCATK(..), PoAsCat (..)) 14 | 15 | type family V (vk :: k -> Type) :: CAT k 16 | type family Arr (v :: CAT k) (a :: vk exta) (b :: vk extb) :: v exta extb 17 | type (a :: vk exta) %~> (b :: vk extb) = Arr (V vk) a b 18 | 19 | class (Bicategory (V vk)) => ECategory (vk :: k -> Type) where 20 | type EOb (a :: vk exta) :: Constraint 21 | eid :: (EOb (a :: vk exta)) => I ~> a %~> a 22 | ecomp 23 | :: (EOb (a :: vk exta), EOb (b :: vk extb), EOb (c :: vk extc)) 24 | => ((b :: vk extb) %~> c) `O` (a %~> b) ~> a %~> c 25 | 26 | type CATK :: Kind -> () -> Kind 27 | data CATK k ext where 28 | CK :: k -> CATK k i 29 | type instance UN CK (CK a) = a 30 | 31 | type instance V (CATK k) = MonK Type 32 | type instance Arr (MonK Type) (CK a) (CK b) = MK (a ~> b) 33 | 34 | -- | A regular category as a Type-enriched category 35 | instance (CategoryOf k) => ECategory (CATK k) where 36 | type EOb (a :: CATK k exta) = (Is CK a, Ob (UN CK a)) 37 | eid = Mon2 $ \() -> id 38 | ecomp = Mon2 $ \(f, g) -> f . g 39 | 40 | -- type POSK :: Kind -> () -> Kind 41 | -- data POSK k ext where 42 | -- PK :: k -> POSK k i 43 | -- type instance UN PK (PK a) = a 44 | 45 | -- type instance V (POSK k) = MonK (POCATK Constraint) 46 | -- type instance Arr (MonK (POCATK Constraint)) a b = MK (PC (UN PK a <= UN PK b)) 47 | 48 | -- -- | A poset as a Constraint-enriched category 49 | -- instance (PreorderOf k) => ECategory (POSK k) where 50 | -- type EOb (a :: POSK k exta) = (Is PK a, COb (UN PK a)) 51 | -- eid @_ @a = Mon2 $ PoAsCat \\ (cid @((<=) :: POS k) @(UN PK a)) 52 | -- ecomp @_ @a @_ @b @_ @c = Mon2 $ _ -- PoAsCat \\ (ccomp @((<=) :: POS k) @(UN PK a) @(UN PK b) @(UN PK c)) 53 | 54 | 55 | type MONADK :: forall {k} {kk} {a}. kk (a :: k) a -> k -> Type 56 | data MONADK t ext where 57 | MDK :: () -> MONADK (t :: kk a a) exta 58 | 59 | type instance V (MONADK (t :: kk a a)) = kk 60 | type instance Arr kk (m :: MONADK (t :: kk a a) a) (n :: MONADK t a) = t 61 | 62 | -- | A monad in a bicategory as a one object enriched category 63 | instance (Monad t) => ECategory (MONADK (t :: kk a a)) where 64 | type EOb (m :: MONADK (t :: kk a a) exta) = (Is MDK m, exta ~ a) 65 | eid = eta 66 | ecomp = mu 67 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Enriched/Bipara.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Enriched.Bipara where 2 | 3 | import Data.Kind (Type) 4 | import Prelude (($), type (~)) 5 | 6 | import Proarrow.Category.Bicategory (Bicategory (I)) 7 | import Proarrow.Category.Bicategory.MonoidalAsBi (Mon2 (..), MonK (..)) 8 | import Proarrow.Category.Enriched (Arr, ECategory (..), V, type (%~>)) 9 | import Proarrow.Category.Instance.Prof (Prof (..)) 10 | import Proarrow.Category.Monoidal 11 | ( Monoidal (..) 12 | , associator' 13 | , associatorInv' 14 | , first 15 | , leftUnitorInv' 16 | , par 17 | , rightUnitor' 18 | , second 19 | ) 20 | import Proarrow.Core (CategoryOf (..), Is, Kind, PRO, Profunctor (..), Promonad (..), UN, obj, (//)) 21 | import Proarrow.Profunctor.Day (Day (..), DayUnit (..)) 22 | 23 | type BIPARAK :: Kind -> () -> Kind 24 | data BIPARAK k ext where 25 | BIPARA :: k -> BIPARAK k i 26 | type instance UN BIPARA (BIPARA a) = a 27 | 28 | type instance V (BIPARAK k) = MonK (PRO k k) 29 | type instance Arr (MonK (PRO k k)) (BIPARA a) (BIPARA b) = MK (Bipara a b) 30 | 31 | type Bipara :: k -> k -> k -> k -> Type 32 | data Bipara a b p q where 33 | Bipara :: (Ob p, Ob q) => b ** p ~> q ** a -> Bipara a b p q 34 | 35 | instance (Monoidal k, Ob a, Ob b) => Profunctor (Bipara (a :: k) b) where 36 | dimap f g (Bipara h) = Bipara (first @a g . h . second @b f) \\ f \\ g 37 | r \\ Bipara{} = r 38 | 39 | -- | Bipara as a profunctor enriched category. 40 | instance (Monoidal k) => ECategory (BIPARAK k) where 41 | type EOb a = (Is BIPARA a, Ob (UN BIPARA a)) 42 | 43 | eid :: forall {exta} (a :: k) (a' :: BIPARAK k exta). (a' ~ BIPARA a, EOb a') => I ~> (a' %~> a') 44 | eid = Mon2 $ Prof $ \(DayUnit f g) -> 45 | f // g // Bipara $ 46 | let a = obj @a 47 | in (g `par` a) . leftUnitorInv' a . rightUnitor' a . (a `par` f) 48 | 49 | ecomp = Mon2 $ Prof $ \(Day g (Bipara @c @d @aa p) (Bipara @e @f @bb @cc q) h) -> 50 | g // h // Bipara $ 51 | let c = obj @c; d = obj @d; e = obj @e; f = obj @f; aa = obj @aa; bb = obj @bb; cc = obj @cc 52 | in (h `par` cc) 53 | . associatorInv' d f cc 54 | . (d `par` q) 55 | . associator' d bb e 56 | . (p `par` e) 57 | . associatorInv' aa c e 58 | . (aa `par` g) 59 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Equipment/BiAsEquipment.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Equipment.BiAsEquipment where 2 | 3 | import Proarrow.Category.Bicategory (Bicategory (..), Ob0', leftUnitor', leftUnitorInv') 4 | import Proarrow.Category.Bicategory.Bidiscrete (Bidiscrete (..), DiscreteK (..)) 5 | import Proarrow.Category.Equipment 6 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault) 7 | 8 | type data WKK kk i j = WK (kk i j) 9 | type instance UN WK (WK p) = p 10 | 11 | type W :: CAT (WKK kk i j) 12 | data W a b where 13 | W :: a ~> b -> W (WK a) (WK b) 14 | instance (CategoryOf (kk i j)) => Profunctor (W :: CAT (WKK kk i j)) where 15 | dimap = dimapDefault 16 | r \\ W p = r \\ p 17 | instance (CategoryOf (kk i j)) => Promonad (W :: CAT (WKK kk i j)) where 18 | id = W id 19 | W f . W g = W (f . g) 20 | instance (CategoryOf (kk i j)) => CategoryOf (WKK kk i j) where 21 | type (~>) = W 22 | type Ob (a :: WKK kk i j) = (Is WK a, Ob (UN WK a)) 23 | 24 | instance (Bicategory kk) => Bicategory (WKK kk) where 25 | type Ob0 (WKK kk) k = Ob0 kk k 26 | type I = WK I 27 | type O a b = WK (UN WK a `O` UN WK b) 28 | withOb2 @(WK a) @(WK b) = withOb2 @kk @a @b 29 | r \\\ W f = r \\\ f 30 | W f `o` W g = W (f `o` g) 31 | leftUnitor = W leftUnitor 32 | leftUnitorInv = W leftUnitorInv 33 | rightUnitor = W rightUnitor 34 | rightUnitorInv = W rightUnitorInv 35 | associator @(WK p) @(WK q) @(WK r) = W (associator @kk @p @q @r) 36 | associatorInv @(WK p) @(WK q) @(WK r) = W (associatorInv @kk @p @q @r) 37 | 38 | -- | A bicategory as a proarrow equipment with only identity arrows vertically. 39 | instance (Bicategory kk) => HasCompanions (WKK kk) (DiscreteK (Ob0' kk)) where 40 | type Companion (WKK kk) DK = WK I 41 | mapCompanion Bidiscrete = id 42 | withObCompanion r = r 43 | compToId = W id 44 | compFromId = W id 45 | compToCompose Bidiscrete Bidiscrete = W (leftUnitorInv' id) 46 | compFromCompose Bidiscrete Bidiscrete = W (leftUnitor' id) 47 | 48 | instance (Bicategory kk) => Equipment (WKK kk) (DiscreteK (Ob0' kk)) where 49 | type Conjoint (WKK kk) DK = WK I 50 | mapConjoint Bidiscrete = id 51 | withObConjoint r = r 52 | conjToId = W id 53 | conjFromId = W id 54 | conjToCompose Bidiscrete Bidiscrete = W (leftUnitorInv' id) 55 | conjFromCompose Bidiscrete Bidiscrete = W (leftUnitor' id) 56 | comConUnit Bidiscrete = W (leftUnitorInv' id) 57 | comConCounit Bidiscrete = W (leftUnitor' id) -------------------------------------------------------------------------------- /src/Proarrow/Category/Equipment/Limit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Equipment.Limit where 4 | 5 | import Data.Kind (Constraint) 6 | 7 | import Proarrow.Category.Bicategory (Bicategory (..)) 8 | import Proarrow.Category.Equipment (HasCompanions (..), Sq) 9 | import Proarrow.Core (CAT, CategoryOf (..), Obj) 10 | 11 | -- | weighted limits 12 | type HasLimits :: forall {s} {hk :: CAT s} {a :: s} {i :: s}. CAT s -> hk i a -> s -> Constraint 13 | class (HasCompanions hk vk, Ob j) => HasLimits vk (j :: hk i a) k where 14 | type Limit (j :: hk i a) (d :: vk i k) :: vk a k 15 | withObLimit :: (Ob (d :: vk i k)) => ((Ob (Limit j d)) => r) -> r 16 | limit :: (Ob (d :: vk i k)) => Companion hk (Limit j d) `O` j ~> Companion hk d 17 | limitUniv :: (Ob (d :: vk i k), Ob p) => Companion hk p `O` j ~> Companion hk d -> p ~> Limit j d 18 | 19 | -- | weighted colimits 20 | type HasColimits :: forall {s} {hk :: CAT s} {a :: s} {i :: s}. CAT s -> hk a i -> s -> Constraint 21 | class (HasCompanions hk vk, Ob j) => HasColimits vk (j :: hk a i) k where 22 | type Colimit (j :: hk a i) (d :: vk i k) :: vk a k 23 | withObColimit :: (Ob (d :: vk i k)) => (Ob (Colimit j d) => r) -> r 24 | colimit :: (Ob (d :: vk i k)) => Companion hk d `O` j ~> Companion hk (Colimit j d) 25 | colimitUniv :: (Ob (d :: vk i k), Ob p) => Companion hk d `O` j ~> Companion hk p -> Colimit j d ~> p 26 | 27 | type family TerminalObject (hk :: CAT s) (vk :: CAT s) :: s 28 | type HasTerminalObject :: forall {s}. CAT s -> CAT s -> Constraint 29 | class (HasCompanions hk vk) => HasTerminalObject (hk :: CAT s) (vk :: CAT s) where 30 | type Terminate hk vk (j :: s) :: vk j (TerminalObject hk vk) 31 | terminate :: (Ob0 vk j) => Obj (Terminate hk vk j) 32 | termUniv :: (Ob0 vk i, Ob0 vk j, Ob (p :: hk i j)) => Sq '(p, Terminate hk vk j) '(I, Terminate hk vk i) 33 | 34 | type family InitialObject (hk :: CAT s) (vk :: CAT s) :: s 35 | type HasInitialObject :: forall {s}. CAT s -> CAT s -> Constraint 36 | class (HasCompanions hk vk) => HasInitialObject (hk :: CAT s) (vk :: CAT s) where 37 | type Initiate hk vk (j :: s) :: vk (InitialObject hk vk) j 38 | initiate :: (Ob0 vk j) => Obj (Initiate hk vk j) 39 | initUniv :: (Ob0 vk i, Ob0 vk j, Ob (p :: hk i j)) => Sq '(I, Initiate hk vk j) '(p, Initiate hk vk i) 40 | 41 | type family Product (hk :: CAT s) (vk :: CAT s) (a :: s) (b :: s) :: s 42 | type HasBinaryProducts :: forall {s}. CAT s -> CAT s -> Constraint 43 | class HasBinaryProducts (hk :: CAT s) (vk :: CAT s) where 44 | type Fst hk vk (i :: s) (j :: s) :: vk (Product hk vk i j) i 45 | type Snd hk vk (i :: s) (j :: s) :: vk (Product hk vk i j) j 46 | fstObj :: (Ob0 vk i, Ob0 vk j) => Obj (Fst hk vk i j) 47 | sndObj :: (Ob0 vk i, Ob0 vk j) => Obj (Snd hk vk i j) 48 | type ProdV hk vk (f :: vk k i) (g :: vk k j) :: vk k (Product hk vk i j) 49 | type ProdH hk vk (p :: hk j k) (q :: hk j' k') :: hk (Product hk vk j j') (Product hk vk k k') 50 | prodObj :: (Ob0 vk j, Ob0 vk a, Ob0 vk b, Ob (f :: vk j a), Ob (g :: vk j b)) => Obj (ProdV hk vk f g) 51 | prodUniv 52 | :: Sq '(p :: hk k k', f' :: vk k' i') '(a, f) 53 | -> Sq '(p, g' :: vk k' j') '(b, g) 54 | -> Sq '(p, ProdV hk vk f' g') '(ProdH hk vk a b, ProdV hk vk f g) 55 | 56 | type family Coproduct (hk :: CAT s) (vk :: CAT s) (a :: s) (b :: s) :: s 57 | type HasBinaryCoproducts :: forall {s}. CAT s -> CAT s -> Constraint 58 | class HasBinaryCoproducts (hk :: CAT s) (vk :: CAT s) where 59 | type Lft hk vk (i :: s) (j :: s) :: vk i (Coproduct hk vk i j) 60 | type Rgt hk vk (i :: s) (j :: s) :: vk j (Coproduct hk vk i j) 61 | lftObj :: (Ob0 vk i, Ob0 vk j) => Obj (Lft hk vk i j) 62 | rgtObj :: (Ob0 vk i, Ob0 vk j) => Obj (Rgt hk vk i j) 63 | type CoprodV hk vk (f :: vk i k) (g :: vk j k) :: vk (Coproduct hk vk i j) k 64 | type CoprodH hk vk (p :: hk j k) (q :: hk j' k') :: hk (Coproduct hk vk j j') (Coproduct hk vk k k') 65 | coprodObj :: (Ob0 vk j, Ob0 vk a, Ob0 vk b, Ob (f :: vk a j), Ob (g :: vk b j)) => Obj (CoprodV hk vk f g) 66 | coprodUniv 67 | :: Sq '(a :: hk i i', f' :: vk i' k') '(p :: hk k k', f :: vk i k) 68 | -> Sq '(b :: hk j j', g' :: vk j' k') '(p :: hk k k', g :: vk j k) 69 | -> Sq '(CoprodH hk vk a b, CoprodV hk vk f' g') '(p, CoprodV hk vk f g) -------------------------------------------------------------------------------- /src/Proarrow/Category/Equipment/Quintet.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Equipment.Quintet where 2 | 3 | import Proarrow.Category.Bicategory (Bicategory (..)) 4 | import Proarrow.Category.Bicategory.MonoidalAsBi (Mon2 (..), MonK (..)) 5 | import Proarrow.Category.Equipment (HasCompanions (..), Sq (..), vArr) 6 | import Proarrow.Category.Monoidal qualified as M 7 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault) 8 | 9 | type data QKK kk i j = QK (kk i j) 10 | type instance UN QK (QK p) = p 11 | 12 | type QuintetSq (f :: kk a b) (g :: kk a c) (h :: kk b d) (k :: kk c d) = Sq '(QK f, h) '(QK k, g) 13 | 14 | type Q2 :: CAT (QKK kk i j) 15 | data Q2 a b where 16 | Q2 :: a ~> b -> Q2 (QK a) (QK b) 17 | instance (CategoryOf (kk i j)) => Profunctor (Q2 :: CAT (QKK kk i j)) where 18 | dimap = dimapDefault 19 | r \\ Q2 p = r \\ p 20 | instance (CategoryOf (kk i j)) => Promonad (Q2 :: CAT (QKK kk i j)) where 21 | id = Q2 id 22 | Q2 f . Q2 g = Q2 (f . g) 23 | instance (CategoryOf (kk i j)) => CategoryOf (QKK kk i j) where 24 | type (~>) = Q2 25 | type Ob (a :: QKK kk i j) = (Is QK a, Ob (UN QK a)) 26 | 27 | instance (Bicategory kk) => Bicategory (QKK kk) where 28 | type Ob0 (QKK kk) k = Ob0 kk k 29 | type I = QK I 30 | type O a b = QK (UN QK a `O` UN QK b) 31 | withOb2 @(QK a) @(QK b) = withOb2 @kk @a @b 32 | r \\\ Q2 f = r \\\ f 33 | Q2 f `o` Q2 g = Q2 (f `o` g) 34 | leftUnitor = Q2 leftUnitor 35 | leftUnitorInv = Q2 leftUnitorInv 36 | rightUnitor = Q2 rightUnitor 37 | rightUnitorInv = Q2 rightUnitorInv 38 | associator @(QK p) @(QK q) @(QK r) = Q2 (associator @kk @p @q @r) 39 | associatorInv @(QK p) @(QK q) @(QK r) = Q2 (associatorInv @kk @p @q @r) 40 | 41 | instance (Bicategory kk) => HasCompanions (QKK kk) kk where 42 | type Companion (QKK kk) f = QK f 43 | mapCompanion f = Q2 f 44 | withObCompanion r = r 45 | compToId = Q2 id 46 | compFromId = Q2 id 47 | compToCompose f g = Q2 (f `o` g) 48 | compFromCompose f g = Q2 (f `o` g) 49 | 50 | -- | BiPara as a quintet construction. 51 | type BiParaSq (a :: k) b p q = QuintetSq (MK p :: MonK k '() '()) (MK b) (MK a) (MK q :: MonK k '() '()) 52 | 53 | bipara :: (Ob p, Ob q, Ob a, Ob b) => a M.** p ~> q M.** b -> BiParaSq a b p q 54 | bipara n = Sq (Q2 (Mon2 n)) 55 | 56 | reparam :: forall {k} (a :: k) (b :: k). (M.Monoidal k) => a ~> b -> BiParaSq a b M.Unit M.Unit 57 | reparam f = vArr (Mon2 f) -------------------------------------------------------------------------------- /src/Proarrow/Category/Equipment/Stateful.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Equipment.Stateful where 2 | 3 | import Proarrow.Category.Bicategory (Adjunction (..), Bicategory (..)) 4 | import Proarrow.Category.Bicategory.MonoidalAsBi (Mon2 (..), MonK (..)) 5 | import Proarrow.Category.Bicategory.Prof (PROFK (..), Prof (..)) 6 | import Proarrow.Category.Equipment (Equipment (..), HasCompanions (..), Sq (..)) 7 | import Proarrow.Category.Instance.Prof (unProf) 8 | import Proarrow.Category.Monoidal (par) 9 | import Proarrow.Category.Monoidal qualified as M 10 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 11 | import Proarrow.Category.Opposite (OPPOSITE (..), Op (..)) 12 | import Proarrow.Core 13 | ( CAT 14 | , CategoryOf (..) 15 | , Is 16 | , Kind 17 | , Profunctor (..) 18 | , Promonad (..) 19 | , UN 20 | , dimapDefault 21 | , lmap 22 | , obj 23 | , rmap 24 | , src 25 | , tgt 26 | , (//) 27 | , (:~>) 28 | , type (+->) 29 | ) 30 | import Proarrow.Functor (map) 31 | import Proarrow.Profunctor.Composition ((:.:) (..)) 32 | import Proarrow.Profunctor.Identity (Id (..)) 33 | import Proarrow.Promonad.Reader (Reader) 34 | import Proarrow.Promonad.Writer (Writer (..)) 35 | 36 | type STT :: Kind -> Kind -> CAT () 37 | newtype STT m k i j = ST (k +-> k) 38 | type instance UN ST (ST p) = p 39 | 40 | type StT :: CAT (STT m k i j) 41 | data StT a b where 42 | StT :: (Strong m p, Strong m q) => p :~> q -> StT (ST p :: STT m k i j) (ST q) 43 | instance (MonoidalAction m k) => Profunctor (StT :: CAT (STT m k i j)) where 44 | dimap = dimapDefault 45 | r \\ StT p = r \\ p 46 | instance (MonoidalAction m k) => Promonad (StT :: CAT (STT m k i j)) where 47 | id = StT id 48 | StT f . StT g = StT (f . g) 49 | instance (MonoidalAction m k) => CategoryOf (STT m k i j) where 50 | type (~>) = StT 51 | type Ob (a :: STT m k i j) = (Is ST a, Strong m (UN ST a)) 52 | 53 | instance (MonoidalAction m k) => Bicategory (STT m k) where 54 | type I = ST Id 55 | type ST a `O` ST b = ST (a :.: b) 56 | withOb2 r = r 57 | StT m `o` StT n = StT \(p :.: q) -> m p :.: n q 58 | r \\\ StT{} = r 59 | leftUnitor = StT \(Id h :.: q) -> lmap h q 60 | leftUnitorInv = StT \p -> Id (src p) :.: p 61 | rightUnitor = StT \(p :.: Id h) -> rmap h p 62 | rightUnitorInv = StT \p -> p :.: Id (tgt p) 63 | associator = StT \((p :.: q) :.: r) -> p :.: (q :.: r) 64 | associatorInv = StT \(p :.: (q :.: r)) -> (p :.: q) :.: r 65 | 66 | -- | Stateful transformers. 67 | -- https://arxiv.org/pdf/2305.16899 definition 6 68 | -- Generalized to any monoidal action. 69 | instance (MonoidalAction m k, M.SymMonoidal m, Ob (M.Unit @m)) => HasCompanions (STT m k) (MonK m) where 70 | type Companion (STT m k) (MK a) = ST (Writer a) 71 | mapCompanion (Mon2 f) = StT (unProf (map f)) \\ f 72 | withObCompanion r = r 73 | compToId = StT \(Writer f) -> Id (unitor @m . f) 74 | compFromId = StT \(Id f) -> Writer (unitorInv @m . f) \\ f 75 | compToCompose (Mon2 @m1 m1) (Mon2 @m2 m2) = 76 | m1 // m2 // m1 `par` m2 // StT \(Writer @b f) -> 77 | let m2b = m2 `act` obj @b in Writer (multiplicatorInv @m @k @m1 @m2 @b . f) :.: Writer m2b \\ m2b 78 | compFromCompose (Mon2 m1) (Mon2 m2) = 79 | m1 // m2 // m1 `par` m2 // StT \(Writer @_ @_ @m1 f :.: Writer @c @_ @m2 g) -> 80 | Writer (multiplicator @m @k @m1 @m2 @c . act m1 g . f) 81 | 82 | instance 83 | (MonoidalAction m k, M.SymMonoidal m, Adjunction (PK l) (PK r), Ob l, Ob r, Strong m r, Strong m l) 84 | => Adjunction (ST l :: STT m k i j) (ST r) 85 | where 86 | unit = StT (case unit @(PK l) @(PK r) of Prof f -> f) 87 | counit = StT (case counit @(PK l) @(PK r) of Prof f -> f) 88 | 89 | instance (MonoidalAction m k, M.SymMonoidal m, Ob (M.Unit @m)) => Equipment (STT m k) (MonK m) where 90 | type Conjoint (STT m k) (MK a) = ST (Reader (OP a)) 91 | mapConjoint (Mon2 f) = StT (unProf (map (Op f))) \\ f 92 | withObConjoint r = r 93 | 94 | type STSq (p :: k +-> k) (q :: k +-> k) (a :: m) (b :: m) = 95 | Sq '(ST p :: STT m k '() '(), MK a :: MonK m '() '()) '(ST q, MK b :: MonK m '() '()) 96 | 97 | crossing 98 | :: forall {k} {m} p a. (Strong m (p :: k +-> k), Ob (a :: m), MonoidalAction m k, M.SymMonoidal m) => STSq p p a a 99 | crossing = 100 | Sq 101 | ( StT \(Writer @_ @_ @w f :.: p) -> 102 | lmap f ((act (obj @a) p)) :.: Writer id 103 | \\ f 104 | \\ p 105 | \\ obj @w `act` tgt p 106 | ) -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Collage.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.Collage where 2 | 3 | import Data.Kind (Constraint) 4 | 5 | import Proarrow.Core 6 | ( CAT 7 | , CategoryOf (..) 8 | , Kind 9 | , Obj 10 | , Profunctor (..) 11 | , Promonad (..) 12 | , dimapDefault 13 | , lmap 14 | , rmap 15 | , type (+->), obj 16 | ) 17 | import Proarrow.Object.Initial (HasInitialObject (..), initiate') 18 | import Proarrow.Object.Terminal (HasTerminalObject (..), terminate') 19 | import Proarrow.Preorder.ThinCategory (Codiscrete (..), Thin, ThinProfunctor (..)) 20 | import Proarrow.Profunctor.Representable (Representable (..), dimapRep) 21 | 22 | type COLLAGE :: forall {j} {k}. k +-> j -> Kind 23 | type data COLLAGE (p :: k +-> j) = L j | R k 24 | 25 | type Collage :: CAT (COLLAGE p) 26 | data Collage a b where 27 | InL :: a ~> b -> Collage (L a :: COLLAGE p) (L b :: COLLAGE p) 28 | InR :: a ~> b -> Collage (R a :: COLLAGE p) (R b :: COLLAGE p) 29 | L2R :: p a b -> Collage (L a :: COLLAGE p) (R b :: COLLAGE p) 30 | 31 | type IsLR :: forall {p}. COLLAGE p -> Constraint 32 | class IsLR (a :: COLLAGE p) where 33 | lrId :: Obj a 34 | instance (Ob a, Promonad ((~>) :: CAT k)) => IsLR (L a :: (COLLAGE (p :: j +-> k))) where 35 | lrId = InL id 36 | instance (Ob a, Promonad ((~>) :: CAT j)) => IsLR (R a :: (COLLAGE (p :: j +-> k))) where 37 | lrId = InR id 38 | 39 | instance (Profunctor p) => Profunctor (Collage :: CAT (COLLAGE p)) where 40 | dimap = dimapDefault 41 | r \\ InL f = r \\ f 42 | r \\ InR f = r \\ f 43 | r \\ L2R p = r \\ p 44 | 45 | instance (Profunctor p) => Promonad (Collage :: CAT (COLLAGE p)) where 46 | id = lrId 47 | InL g . InL f = InL (g . f) 48 | InR g . L2R p = L2R (rmap g p) 49 | L2R p . InL f = L2R (lmap f p) 50 | InR g . InR f = InR (g . f) 51 | 52 | instance (Profunctor p) => CategoryOf (COLLAGE p) where 53 | type (~>) = Collage 54 | type Ob a = IsLR a 55 | 56 | instance (HasInitialObject j, CategoryOf k, Codiscrete p) => HasInitialObject (COLLAGE (p :: k +-> j)) where 57 | type InitialObject = L InitialObject 58 | initiate @a = case obj @a of 59 | InL a -> InL (initiate' a) 60 | InR b -> L2R anyArr \\ b 61 | 62 | instance (HasTerminalObject k, CategoryOf j, Codiscrete p) => HasTerminalObject (COLLAGE (p :: k +-> j)) where 63 | type TerminalObject = R TerminalObject 64 | terminate @a = case obj @a of 65 | InL a -> L2R anyArr \\ a 66 | InR b -> InR (terminate' b) 67 | 68 | class HasArrowCollage p (a :: COLLAGE p) b where arrCoprod :: a ~> b 69 | instance (Thin j, HasArrow (~>) (a :: j) b, Ob a, Ob b) => HasArrowCollage (p :: k +-> j) (L a) (L b) where 70 | arrCoprod = InL arr 71 | instance (ThinProfunctor p, HasArrow p a b, Ob a, Ob b) => HasArrowCollage (p :: k +-> j) (L a) (R b) where 72 | arrCoprod = L2R arr 73 | instance (Thin k, HasArrow (~>) (a :: k) b, Ob a, Ob b) => HasArrowCollage (p :: k +-> j) (R a) (R b) where 74 | arrCoprod = InR arr 75 | 76 | instance (Thin j, Thin k, ThinProfunctor p) => ThinProfunctor (Collage :: CAT (COLLAGE (p :: k +-> j))) where 77 | type HasArrow (Collage :: CAT (COLLAGE p)) a b = HasArrowCollage p a b 78 | arr = arrCoprod 79 | withArr (InL f) r = withArr f r \\ f 80 | withArr (L2R p) r = withArr p r \\ p 81 | withArr (InR f) r = withArr f r \\ f 82 | 83 | type InjL :: forall (p :: k +-> j) -> j +-> COLLAGE p 84 | data InjL p a b where 85 | InjL :: (Ob b) => {unInL :: a ~> InjL p % b} -> InjL p a b 86 | instance (Profunctor p) => Profunctor (InjL p) where 87 | dimap = dimapRep 88 | r \\ InjL p = r \\ p 89 | instance (Profunctor p) => Representable (InjL p) where 90 | type InjL p % a = L a 91 | index (InjL f) = f 92 | tabulate f = InjL f \\ f 93 | repMap = InL 94 | 95 | type InjR :: forall (p :: k +-> j) -> k +-> COLLAGE p 96 | data InjR p a b where 97 | InjR :: (Ob b) => {unInjR :: a ~> InjR p % b} -> InjR p a b 98 | instance (Profunctor p) => Profunctor (InjR p) where 99 | dimap = dimapRep 100 | r \\ InjR p = r \\ p 101 | instance (Profunctor p) => Representable (InjR p) where 102 | type InjR p % a = R a 103 | index (InjR f) = f 104 | tabulate f = InjR f \\ f 105 | repMap = InR 106 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# HLINT ignore "Use id" #-} 2 | {-# HLINT ignore "Avoid lambda" #-} 3 | {-# HLINT ignore "Use const" #-} 4 | {-# LANGUAGE AllowAmbiguousTypes #-} 5 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 6 | 7 | module Proarrow.Category.Instance.Constraint where 8 | 9 | import Data.Kind (Constraint) 10 | import Prelude qualified as P 11 | 12 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) 13 | import Proarrow.Core (CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault) 14 | import Proarrow.Monoid (Comonoid (..), Monoid (..)) 15 | import Proarrow.Object.BinaryProduct (HasBinaryProducts (..)) 16 | import Proarrow.Object.BinaryProduct qualified as P 17 | import Proarrow.Object.Exponential (Closed (..)) 18 | import Proarrow.Object.Terminal (HasTerminalObject (..)) 19 | import Proarrow.Preorder.ThinCategory (ThinProfunctor (..)) 20 | 21 | newtype CONSTRAINT = CNSTRNT Constraint 22 | type instance UN CNSTRNT (CNSTRNT a) = a 23 | 24 | data (:-) a b where 25 | Entails :: {unEntails :: forall r. (((a) => b) => r) -> r} -> CNSTRNT a :- CNSTRNT b 26 | 27 | instance CategoryOf CONSTRAINT where 28 | type (~>) = (:-) 29 | type Ob a = (Is CNSTRNT a) 30 | 31 | instance Promonad (:-) where 32 | id = Entails \r -> r 33 | Entails f . Entails g = Entails \r -> f (g r) 34 | 35 | instance Profunctor (:-) where 36 | dimap = dimapDefault 37 | r \\ Entails{} = r 38 | 39 | instance ThinProfunctor (:-) where 40 | type HasArrow (:-) (CNSTRNT a) (CNSTRNT b) = a :=> b 41 | arr = Entails \r -> r 42 | withArr (Entails f) r = f r 43 | 44 | instance HasTerminalObject CONSTRAINT where 45 | type TerminalObject = CNSTRNT () 46 | terminate = Entails \r -> r 47 | 48 | instance HasBinaryProducts CONSTRAINT where 49 | type CNSTRNT l && CNSTRNT r = CNSTRNT (l, r) 50 | withObProd r = r 51 | fst = Entails \r -> r 52 | snd = Entails \r -> r 53 | Entails f &&& Entails g = Entails \r -> f (g r) 54 | 55 | instance MonoidalProfunctor (:-) where 56 | par0 = id 57 | f `par` g = f *** g 58 | 59 | instance Monoidal CONSTRAINT where 60 | type Unit = TerminalObject 61 | type a ** b = a && b 62 | withOb2 r = r 63 | leftUnitor = P.leftUnitorProd 64 | leftUnitorInv = P.leftUnitorProdInv 65 | rightUnitor = P.rightUnitorProd 66 | rightUnitorInv = P.rightUnitorProdInv 67 | associator = P.associatorProd 68 | associatorInv = P.associatorProdInv 69 | 70 | instance SymMonoidal CONSTRAINT where 71 | swap = Entails \r -> r 72 | 73 | instance Monoid (CNSTRNT ()) where 74 | mempty = id 75 | mappend = Entails \r -> r 76 | 77 | instance Comonoid (CNSTRNT a) where 78 | counit = Entails \r -> r 79 | comult = Entails \r -> r 80 | 81 | class ((b) => c) => b :=> c 82 | instance ((b) => c) => b :=> c 83 | 84 | instance Closed CONSTRAINT where 85 | type CNSTRNT a ~~> CNSTRNT b = CNSTRNT (a :=> b) 86 | withObExp r = r 87 | Entails f ^^^ Entails g = Entails \r -> f (g r) 88 | curry (Entails f) = Entails f 89 | uncurry @b @c @a (Entails f) = Entails (h @(UN CNSTRNT a) @(UN CNSTRNT b) @(UN CNSTRNT c) f) 90 | where 91 | h :: ((((x) => y :=> z) => r) -> r) -> (((x, y) => z) => r) -> r 92 | h g = g 93 | 94 | -- I am solving the constraint ‘Eq a’ in a way that might turn out to loop at runtime. 95 | -- See § Undecidable instances and loopy superclasses. 96 | -- eqIsSuperOrd :: CNSTRNT (P.Ord a) :- CNSTRNT (P.Eq a) 97 | -- eqIsSuperOrd = Entails \r -> r 98 | 99 | maybeLiftsSemigroup :: CNSTRNT (P.Semigroup a) :- CNSTRNT (Monoid (P.Maybe a)) 100 | maybeLiftsSemigroup = Entails \r -> r 101 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Coproduct.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.Coproduct where 2 | 3 | import Data.Kind (Constraint) 4 | 5 | import Proarrow.Core (CategoryOf (..), type (+->), Profunctor, Promonad) 6 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 7 | import Proarrow (Profunctor(..)) 8 | import Proarrow.Promonad (Promonad(..)) 9 | 10 | type data COPRODUCT j k = L j | R k 11 | 12 | type (:++:) :: (j1 +-> k1) -> (j2 +-> k2) -> COPRODUCT j1 j2 +-> COPRODUCT k1 k2 13 | data (:++:) p q a b where 14 | InjL :: p a b -> (p :++: q) (L a) (L b) 15 | InjR :: q a b -> (p :++: q) (R a) (R b) 16 | 17 | type IsLR :: forall {j} {k}. COPRODUCT j k -> Constraint 18 | class IsLR (a :: COPRODUCT j k) where 19 | lrId :: (Promonad p, Promonad q) => (p :++: q) a a 20 | instance (Ob a) => IsLR (L a :: COPRODUCT j k) where 21 | lrId = InjL id 22 | instance (Ob a) => IsLR (R a :: COPRODUCT j k) where 23 | lrId = InjR id 24 | 25 | instance (Profunctor p, Profunctor q) => Profunctor (p :++: q) where 26 | dimap (InjL f) (InjL g) (InjL p) = InjL (dimap f g p) 27 | dimap (InjR f) (InjR g) (InjR q) = InjR (dimap f g q) 28 | dimap InjL{} InjR{} p = case p of 29 | dimap InjR{} InjL{} q = case q of 30 | r \\ InjL p = r \\ p 31 | r \\ InjR q = r \\ q 32 | instance (Promonad p, Promonad q) => Promonad (p :++: q) where 33 | id = lrId 34 | InjL p . InjL q = InjL (p . q) 35 | InjR q . InjR r = InjR (q . r) 36 | instance (CategoryOf j, CategoryOf k) => CategoryOf (COPRODUCT j k) where 37 | type (~>) @(COPRODUCT j k) = (~>) @j :++: (~>) @k 38 | type Ob (a :: COPRODUCT j k) = IsLR a 39 | 40 | instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :++: q) where 41 | dagger = \case 42 | InjL f -> InjL (dagger f) 43 | InjR f -> InjR (dagger f) 44 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Free.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.Free where 2 | 3 | import Data.Kind (Type) 4 | 5 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, (:~>)) 6 | 7 | infixr 4 :| 8 | 9 | newtype FREE (g :: k -> k -> Type) = F k 10 | type instance UN F (F k) = k 11 | 12 | type Free :: CAT (FREE g) 13 | data Free a b where 14 | FreeId :: Free (F a) (F a) 15 | (:|) :: g a b -> Free (F b :: FREE g) (F c) -> Free (F a :: FREE g) (F c) 16 | 17 | class Rewrite g where 18 | rewriteAfterCons :: (Free :: CAT (FREE g)) :~> (Free :: CAT (FREE g)) 19 | 20 | instance (Rewrite g) => CategoryOf (FREE g) where 21 | type (~>) = Free 22 | type Ob a = Is F a 23 | 24 | instance (Rewrite g) => Promonad (Free :: CAT (FREE g)) where 25 | id = FreeId 26 | FreeId . a = a 27 | a . FreeId = a 28 | a . (g :| b) = rewriteAfterCons (g :| (a . b)) \\ a 29 | 30 | instance (Rewrite g) => Profunctor (Free :: CAT (FREE g)) where 31 | dimap = dimapDefault 32 | r \\ FreeId = r 33 | r \\ _ :| _ = r 34 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Hask.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.Hask (Type, Hask) where 2 | 3 | import Data.Kind (Type) 4 | 5 | type Hask = (->) 6 | 7 | -- Class instances of (->) are with the class definitions in order to avoid orphan instances 8 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/List.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# OPTIONS_GHC -Wno-orphans #-} 3 | 4 | module Proarrow.Category.Instance.List where 5 | 6 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 7 | import Proarrow.Category.Monoidal.Strictified qualified as Str 8 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, obj) 9 | 10 | type data LIST k = L [k] 11 | type instance UN L (L as) = as 12 | 13 | type List :: CAT (LIST k) 14 | 15 | -- | The free monoid in CAT 16 | data List as bs where 17 | SNil :: List (L '[]) (L '[]) 18 | SCons :: (Str.IsList as, Str.IsList bs) => a ~> b -> List (L as) (L bs) -> List (L (a ': as)) (L (b ': bs)) 19 | 20 | mkCons :: (CategoryOf k) => (a :: k) ~> b -> L as ~> L bs -> L (a ': as) ~> L (b ': bs) 21 | mkCons f fs = SCons f fs \\ fs 22 | 23 | instance (CategoryOf k) => CategoryOf (LIST k) where 24 | type (~>) = List 25 | type Ob as = (Is L as, Str.IsList (UN L as)) 26 | 27 | instance (CategoryOf k) => Promonad (List :: CAT (LIST k)) where 28 | id @(L bs) = case Str.sList @bs of 29 | Str.SNil -> SNil 30 | Str.SSing @a -> SCons (obj @a) SNil 31 | Str.SCons @a @as -> SCons (obj @a) (obj @(L as)) 32 | SNil . SNil = SNil 33 | SCons f fs . SCons g gs = SCons (f . g) (fs . gs) 34 | 35 | instance (CategoryOf k) => Profunctor (List :: CAT (LIST k)) where 36 | dimap = dimapDefault 37 | r \\ SNil = r 38 | r \\ SCons f SNil = r \\ f 39 | r \\ SCons f fs@SCons{} = r \\ f \\ fs 40 | 41 | instance (CategoryOf k) => MonoidalProfunctor (List :: CAT (LIST k)) where 42 | par0 = SNil 43 | SNil `par` SNil = SNil 44 | SNil `par` gs@SCons{} = gs 45 | SCons f fs `par` SNil = mkCons f (fs `par` SNil) 46 | SCons f fs `par` SCons g gs = mkCons f (fs `par` SCons g gs) 47 | 48 | instance (CategoryOf k) => Monoidal (LIST k) where 49 | type Unit = L '[] 50 | type p ** q = L (UN L p Str.++ UN L q) 51 | withOb2 @(L as) @(L bs) = Str.withIsList2 @as @bs 52 | leftUnitor = id 53 | leftUnitorInv = id 54 | rightUnitor = id 55 | rightUnitorInv = id 56 | associator @as @bs @cs = withOb2 @_ @as @bs (withOb2 @_ @(as ** bs) @cs (id @List)) 57 | associatorInv @as @bs @cs = withOb2 @_ @bs @cs (withOb2 @_ @as @(bs ** cs) (id @List)) -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/PointedHask.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.PointedHask where 2 | 3 | import Data.Kind (Type) 4 | import Prelude (Maybe (..), type (~), const, ($), (>>=)) 5 | 6 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN, dimapDefault) 7 | import Proarrow.Object.BinaryProduct (HasBinaryProducts(..)) 8 | import Proarrow.Object.Terminal (HasTerminalObject(..)) 9 | import Data.Void (Void, absurd) 10 | import Proarrow.Category.Monoidal (Monoidal(..), MonoidalProfunctor (..), SymMonoidal (..)) 11 | import Proarrow.Object.BinaryCoproduct (HasBinaryCoproducts (..)) 12 | import Proarrow.Object.Initial (HasInitialObject (..)) 13 | import Proarrow.Category.Monoidal.Applicative (liftA2) 14 | import Proarrow.Monoid (Monoid (..), Comonoid (..)) 15 | import Proarrow.Object.Exponential (Closed (..)) 16 | 17 | type data POINTED = P Type 18 | type instance UN P (P a) = a 19 | 20 | type Pointed :: CAT POINTED 21 | data Pointed a b where 22 | Pt :: (a -> Maybe b) -> Pointed (P a) (P b) 23 | 24 | toHask :: P a ~> P b -> (Maybe a -> Maybe b) 25 | toHask (Pt f) = (>>= f) 26 | 27 | instance Profunctor Pointed where 28 | dimap = dimapDefault 29 | r \\ Pt{} = r 30 | instance Promonad Pointed where 31 | id = Pt Just 32 | Pt f . Pt g = Pt (\a -> g a >>= f) 33 | -- | The category of types with an added point and point-preserving morphisms. 34 | instance CategoryOf POINTED where 35 | type (~>) = Pointed 36 | type Ob a = (a ~ P (UN P a)) 37 | 38 | data These a b = This a | That b | These a b 39 | instance HasBinaryProducts POINTED where 40 | type P a && P b = P (These a b) 41 | withObProd r = r 42 | fst = Pt (\case This a -> Just a; That _ -> Nothing; These a _ -> Just a) 43 | snd = Pt (\case This _ -> Nothing; That b -> Just b; These _ b -> Just b) 44 | Pt f &&& Pt g = Pt (\a -> case (f a, g a) of 45 | (Just a', Just b') -> Just (These a' b') 46 | (Just a', Nothing) -> Just (This a') 47 | (Nothing, Just b') -> Just (That b') 48 | (Nothing, Nothing) -> Nothing) 49 | instance HasTerminalObject POINTED where 50 | type TerminalObject = P Void 51 | terminate = Pt (const Nothing) 52 | 53 | instance HasBinaryCoproducts POINTED where 54 | type P a || P b = P (a || b) 55 | withObCoprod r = r 56 | lft = Pt (Just . lft) 57 | rgt = Pt (Just . rgt) 58 | Pt f ||| Pt g = Pt (f ||| g) 59 | instance HasInitialObject POINTED where 60 | type InitialObject = P Void 61 | initiate = Pt absurd 62 | 63 | instance MonoidalProfunctor Pointed where 64 | par0 = Pt Just 65 | Pt f `par` Pt g = Pt (\(a, b) -> liftA2 id (f a, g b)) 66 | -- | The smash product of pointed sets. 67 | -- Monoids relative to the smash product are absorption monoids. 68 | instance Monoidal POINTED where 69 | type Unit = P () 70 | type P a ** P b = P (a, b) 71 | withOb2 r = r 72 | leftUnitor = Pt (Just . snd) 73 | leftUnitorInv = Pt (Just . ((),)) 74 | rightUnitor = Pt (Just . fst) 75 | rightUnitorInv = Pt (Just . (,())) 76 | associator = Pt (\((a, b), c) -> Just (a, (b, c))) 77 | associatorInv = Pt (\(a, (b, c)) -> Just ((a, b), c)) 78 | instance SymMonoidal POINTED where 79 | swap = Pt (Just . swap) 80 | instance Closed POINTED where 81 | type P a ~~> P b = P (a -> Maybe b) 82 | withObExp r = r 83 | curry (Pt f) = Pt (\a -> Just (\b -> f (a, b))) 84 | uncurry (Pt f) = Pt (\(a, b) -> f a >>= ($ b)) 85 | 86 | instance Monoid (P Void) where 87 | mempty = Pt (const Nothing) 88 | mappend = Pt (Just . fst) 89 | 90 | -- | Lift Hask monoids. 91 | memptyDefault :: Monoid a => Unit ~> P a 92 | memptyDefault = Pt (Just . mempty) 93 | 94 | mappendDefault :: Monoid a => P a ** P a ~> P a 95 | mappendDefault = Pt (Just . mappend) 96 | 97 | -- | Conjunction with False = Nothing, True = Just () 98 | instance Monoid (P ()) where 99 | mempty = memptyDefault 100 | mappend = mappendDefault 101 | 102 | instance Monoid (P [a]) where 103 | mempty = memptyDefault 104 | mappend = mappendDefault 105 | 106 | instance Comonoid (P x) where 107 | counit = Pt (Just . counit) 108 | comult = Pt (Just . comult) -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/PreorderAsCategory.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.PreorderAsCategory where 2 | 3 | import Data.Kind (Constraint) 4 | 5 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 6 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor, Promonad (..), UN, dimapDefault) 7 | import Proarrow.Core qualified as Core 8 | import Proarrow.Object.BinaryProduct (HasBinaryProducts (..)) 9 | import Proarrow.Object.BinaryProduct qualified as P 10 | import Proarrow.Object.Terminal (HasTerminalObject (..)) 11 | import Proarrow.Preorder (CProfunctor (..), CPromonad (..), PreorderOf (..), (\\)) 12 | import Proarrow.Preorder.Constraint () 13 | import Proarrow.Preorder.ThinCategory (ThinProfunctor (..)) 14 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 15 | import Proarrow.Preorder.Discrete (DISCRETE) 16 | 17 | newtype POCATK k = PC k 18 | type instance UN PC (PC k) = k 19 | 20 | data PoAsCat a b where 21 | PoAsCat :: (a <= b) => PoAsCat (PC a) (PC b) 22 | 23 | instance (PreorderOf k) => Profunctor (PoAsCat :: CAT (POCATK k)) where 24 | dimap = dimapDefault 25 | r \\ PoAsCat @a @b = r \\ obs @((<=) @k) @a @b 26 | instance (PreorderOf k) => Promonad (PoAsCat :: CAT (POCATK k)) where 27 | id @a = PoAsCat \\ cid @((<=) @k) @(UN PC a) 28 | (.) @b @c @a PoAsCat PoAsCat = PoAsCat \\ ccomp @((<=) @k) @(UN PC a) @(UN PC b) @(UN PC c) 29 | instance (PreorderOf k) => CategoryOf (POCATK k) where 30 | type (~>) = PoAsCat 31 | type Ob a = (Is PC a, COb (UN PC a)) 32 | 33 | instance (PreorderOf k) => ThinProfunctor (PoAsCat :: CAT (POCATK k)) where 34 | type HasArrow PoAsCat (PC a) (PC b) = a <= b 35 | arr = PoAsCat 36 | withArr PoAsCat r = r 37 | 38 | instance HasTerminalObject (POCATK Constraint) where 39 | type TerminalObject = PC (() :: Constraint) 40 | terminate = PoAsCat 41 | 42 | instance HasBinaryProducts (POCATK Constraint) where 43 | type l && r = PC ((UN PC l, UN PC r) :: Constraint) 44 | withObProd r = r 45 | fst = PoAsCat 46 | snd = PoAsCat 47 | PoAsCat &&& PoAsCat = PoAsCat 48 | 49 | instance MonoidalProfunctor (PoAsCat :: CAT (POCATK Constraint)) where 50 | par0 = id 51 | f `par` g = f *** g 52 | 53 | instance Monoidal (POCATK Constraint) where 54 | type Unit = TerminalObject 55 | type a ** b = a && b 56 | withOb2 r = r 57 | leftUnitor = P.leftUnitorProd 58 | leftUnitorInv = P.leftUnitorProdInv 59 | rightUnitor = P.rightUnitorProd 60 | rightUnitorInv = P.rightUnitorProdInv 61 | associator = P.associatorProd 62 | associatorInv = P.associatorProdInv 63 | 64 | instance DaggerProfunctor (PoAsCat :: CAT (POCATK (DISCRETE k))) where 65 | dagger PoAsCat = PoAsCat -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Product.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Category.Instance.Product where 4 | 5 | import Prelude (type (~)) 6 | 7 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 8 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal(..)) 9 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 10 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->)) 11 | import Proarrow.Preorder.ThinCategory (Codiscrete, Discrete (..), ThinProfunctor (..), anyArr) 12 | import Proarrow.Profunctor.Representable (Representable (..)) 13 | 14 | type Fst :: (a, b) -> a 15 | type family Fst a where 16 | Fst '(a, b) = a 17 | type Snd :: (a, b) -> b 18 | type family Snd a where 19 | Snd '(a, b) = b 20 | 21 | type (:**:) :: j1 +-> k1 -> j2 +-> k2 -> (j1, j2) +-> (k1, k2) 22 | data (c :**: d) a b where 23 | (:**:) :: c a1 b1 -> d a2 b2 -> (c :**: d) '(a1, a2) '(b1, b2) 24 | 25 | instance (CategoryOf k1, CategoryOf k2) => CategoryOf (k1, k2) where 26 | type (~>) = (~>) :**: (~>) 27 | type Ob a = (a ~ '(Fst a, Snd a), Ob (Fst a), Ob (Snd a)) 28 | 29 | -- | The product promonad of promonads `p` and `q`. 30 | instance (Promonad p, Promonad q) => Promonad (p :**: q) where 31 | id = id :**: id 32 | (f1 :**: f2) . (g1 :**: g2) = (f1 . g1) :**: (f2 . g2) 33 | 34 | instance (Profunctor p, Profunctor q) => Profunctor (p :**: q) where 35 | dimap (l1 :**: l2) (r1 :**: r2) (f1 :**: f2) = dimap l1 r1 f1 :**: dimap l2 r2 f2 36 | r \\ (f :**: g) = r \\ f \\ g 37 | 38 | instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :**: q) where 39 | dagger (f :**: g) = dagger f :**: dagger g 40 | 41 | instance (ThinProfunctor p, ThinProfunctor q) => ThinProfunctor (p :**: q) where 42 | type HasArrow (p :**: q) '(a1, a2) '(b1, b2) = (HasArrow p a1 b1, HasArrow q a2 b2) 43 | arr = arr :**: arr 44 | withArr (f :**: g) r = withArr f (withArr g r) 45 | 46 | instance (Codiscrete p, Codiscrete q) => Codiscrete (p :**: q) where 47 | anyArr = anyArr :**: anyArr 48 | 49 | instance (Discrete p, Discrete q) => Discrete (p :**: q) where 50 | withEq (f :**: g) r = withEq f (withEq g r) 51 | 52 | instance (Representable p, Representable q) => Representable (p :**: q) where 53 | type (p :**: q) % '(a, b) = '(p % a, q % b) 54 | index (p :**: q) = index p :**: index q 55 | tabulate (f :**: g) = tabulate f :**: tabulate g 56 | repMap (f :**: g) = repMap @p f :**: repMap @q g 57 | 58 | instance (MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (p :**: q) where 59 | par0 = par0 :**: par0 60 | (f1 :**: f2) `par` (g1 :**: g2) = (f1 `par` g1) :**: (f2 `par` g2) 61 | 62 | instance (Monoidal j, Monoidal k) => Monoidal (j, k) where 63 | type Unit = '(Unit, Unit) 64 | type '(a1, a2) ** '(b1, b2) = '(a1 ** b1, a2 ** b2) 65 | withOb2 @'(a1, a2) @'(b1, b2) r = withOb2 @j @a1 @b1 (withOb2 @k @a2 @b2 r) 66 | leftUnitor @'(a1, a2) = leftUnitor @j @a1 :**: leftUnitor @k @a2 67 | leftUnitorInv @'(a1, a2) = leftUnitorInv @j @a1 :**: leftUnitorInv @k @a2 68 | rightUnitor @'(a1, a2) = rightUnitor @j @a1 :**: rightUnitor @k @a2 69 | rightUnitorInv @'(a1, a2) = rightUnitorInv @j @a1 :**: rightUnitorInv @k @a2 70 | associator @'(a1, a2) @'(b1, b2) @'(c1, c2) = associator @j @a1 @b1 @c1 :**: associator @k @a2 @b2 @c2 71 | associatorInv @'(a1, a2) @'(b1, b2) @'(c1, c2) = associatorInv @j @a1 @b1 @c1 :**: associatorInv @k @a2 @b2 @c2 72 | 73 | instance (SymMonoidal j, SymMonoidal k) => SymMonoidal (j, k) where 74 | swap @'(a1, a2) @'(b1, b2) = swap @j @a1 @b1 :**: swap @k @a2 @b2 75 | 76 | instance (Strong m p, Strong m' q) => Strong (m, m') (p :**: q) where 77 | act (p :**: q) (x :**: y) = act p x :**: act q y 78 | instance (MonoidalAction n j, MonoidalAction m k) => MonoidalAction (n, m) (j, k) where 79 | type Act '(p, q) '(x, y) = '(Act p x, Act q y) 80 | withObAct @'(p, q) @'(x, y) r = withObAct @n @j @p @x (withObAct @m @k @q @y r) 81 | unitor = unitor @n :**: unitor @m 82 | unitorInv = unitorInv @n :**: unitorInv @m 83 | multiplicator @'(p, q) @'(r, s) @'(x, y) = multiplicator @n @j @p @r @x :**: multiplicator @m @k @q @s @y 84 | multiplicatorInv @'(p, q) @'(r, s) @'(x, y) = multiplicatorInv @n @j @p @r @x :**: multiplicatorInv @m @k @q @s @y 85 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Prof.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Category.Instance.Prof where 4 | 5 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, (:~>), type (+->)) 6 | 7 | type Prof :: CAT (j +-> k) 8 | data Prof p q where 9 | Prof 10 | :: (Profunctor p, Profunctor q) 11 | => {unProf :: p :~> q} 12 | -> Prof p q 13 | 14 | -- | The category of profunctors and natural transformations between them. 15 | instance CategoryOf (j +-> k) where 16 | type (~>) = Prof 17 | type Ob p = Profunctor p 18 | 19 | instance Promonad Prof where 20 | id = Prof id 21 | Prof f . Prof g = Prof (f . g) 22 | 23 | instance Profunctor Prof where 24 | dimap = dimapDefault 25 | r \\ Prof{} = r 26 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Simplex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Instance.Simplex where 4 | 5 | import Data.Kind (Type) 6 | 7 | import Prelude (type (~)) 8 | 9 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 10 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, src, type (+->)) 11 | import Proarrow.Monoid (Monoid (..)) 12 | import Proarrow.Object.Initial (HasInitialObject (..)) 13 | import Proarrow.Object.Terminal (HasTerminalObject (..)) 14 | import Proarrow.Profunctor.Representable (Representable (..), dimapRep) 15 | 16 | type data Nat = Z | S Nat 17 | data SNat :: Nat -> Type where 18 | SZ :: SNat Z 19 | SS :: (IsNat n) => SNat (S n) 20 | 21 | class ((a + b) + c ~ a + (b + c)) => Assoc a b c 22 | instance ((a + b) + c ~ a + (b + c)) => Assoc a b c 23 | 24 | class (a + Z ~ a, forall b c. Assoc a b c) => IsNat (a :: Nat) where singNat :: SNat a 25 | instance IsNat Z where singNat = SZ 26 | instance (IsNat a) => IsNat (S a) where singNat = SS 27 | 28 | type Simplex :: CAT Nat 29 | data Simplex a b where 30 | ZZ :: Simplex Z Z 31 | Y :: Simplex x y -> Simplex x (S y) 32 | X :: Simplex x (S y) -> Simplex (S x) (S y) 33 | 34 | suc :: Simplex a b -> Simplex (S a) (S b) 35 | suc = X . Y 36 | 37 | instance CategoryOf Nat where 38 | type (~>) = Simplex 39 | type Ob a = IsNat a 40 | 41 | instance Promonad Simplex where 42 | id @a = case singNat @a of 43 | SZ -> ZZ 44 | SS -> suc id 45 | ZZ . f = f 46 | Y f . g = Y (f . g) 47 | X f . Y g = f . g 48 | X f . X g = X (X f . g) 49 | 50 | instance Profunctor Simplex where 51 | dimap = dimapDefault 52 | r \\ ZZ = r 53 | r \\ Y f = r \\ f 54 | r \\ X f = r \\ f 55 | 56 | instance HasInitialObject Nat where 57 | type InitialObject = Z 58 | initiate @a = case singNat @a of 59 | SZ -> ZZ 60 | SS @a' -> Y (initiate @_ @a') 61 | 62 | instance HasTerminalObject Nat where 63 | type TerminalObject = S Z 64 | terminate @a = case singNat @a of 65 | SZ -> Y ZZ 66 | SS @n -> X (terminate @_ @n) 67 | 68 | data Fin :: Nat -> Type where 69 | Fz :: Fin (S n) 70 | Fs :: Fin n -> Fin (S n) 71 | 72 | type Forget :: Nat +-> Type 73 | data Forget a b where 74 | Forget :: (Ob b) => {unForget :: a -> Fin b} -> Forget a b 75 | 76 | instance Profunctor Forget where 77 | dimap = dimapRep 78 | r \\ Forget f = r \\ f 79 | instance Representable Forget where 80 | type Forget % n = Fin n 81 | index = unForget 82 | tabulate = Forget 83 | repMap ZZ = id 84 | repMap (Y f) = Fs . repMap @Forget f 85 | repMap (X f) = \case 86 | Fz -> Fz 87 | Fs n -> repMap @Forget f n 88 | 89 | type family (a :: Nat) + (b :: Nat) :: Nat where 90 | Z + b = b 91 | S a + b = S (a + b) 92 | 93 | instance MonoidalProfunctor Simplex where 94 | par0 = ZZ 95 | ZZ `par` g = g 96 | Y f `par` g = Y (f `par` g) 97 | X f `par` g = X (f `par` g) 98 | 99 | instance Monoidal Nat where 100 | type Unit = Z 101 | type a ** b = a + b 102 | withOb2 @a @b r = case singNat @a of 103 | SZ -> r 104 | SS @a' -> withOb2 @_ @a' @b r 105 | leftUnitor = id 106 | leftUnitorInv = id 107 | rightUnitor = id 108 | rightUnitorInv = id 109 | associator @a @b @c = withOb2 @_ @a @b (withOb2 @_ @(a ** b) @c (id @Simplex)) 110 | associatorInv @a @b @c = withOb2 @_ @b @c (withOb2 @_ @a @(b ** c) (id @Simplex)) 111 | 112 | instance Monoid (S Z) where 113 | mempty = Y ZZ 114 | mappend = X (X (Y ZZ)) 115 | 116 | type Replicate :: k -> Nat +-> k 117 | data Replicate m a b where 118 | Replicate :: (Ob b) => a ~> (Replicate m % b) -> Replicate m a b 119 | instance (Monoid m) => Profunctor (Replicate m) where 120 | dimap = dimapRep 121 | r \\ Replicate f = r \\ f 122 | instance (Monoid m) => Representable (Replicate m) where 123 | type Replicate m % Z = Unit 124 | type Replicate m % S b = m ** (Replicate m % b) 125 | index (Replicate f) = f 126 | tabulate = Replicate 127 | repMap ZZ = par0 128 | repMap (Y f) = let g = repMap @(Replicate m) f in (mempty @m `par` g) . leftUnitorInv \\ g 129 | repMap (X (Y f)) = obj @m `par` repMap @(Replicate m) f 130 | repMap (X (X @x f)) = 131 | let g = repMap @(Replicate m) (X f) 132 | b = repMap @(Replicate m) (src f) 133 | in g . (mappend @m `par` b) . associatorInv @_ @m @m @(Replicate m % x) \\ b 134 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Sub.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.Sub where 2 | 3 | import Data.Kind (Constraint, Type) 4 | 5 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) 6 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 7 | import Proarrow.Core (CAT, CategoryOf (..), Is, OB, Profunctor (..), Promonad (..), UN) 8 | import Proarrow.Profunctor.Representable (Representable (..)) 9 | 10 | type SUBCAT :: forall {k}. OB k -> Type 11 | type data SUBCAT (ob :: OB k) = SUB k 12 | type instance UN SUB (SUB k) = k 13 | 14 | type Sub :: CAT k -> CAT (SUBCAT (ob :: OB k)) 15 | data Sub p a b where 16 | Sub :: (ob a, ob b) => {unSub :: p a b} -> Sub p (SUB a :: SUBCAT ob) (SUB b) 17 | 18 | instance (Profunctor p) => Profunctor (Sub p) where 19 | dimap (Sub l) (Sub r) (Sub p) = Sub (dimap l r p) 20 | r \\ Sub p = r \\ p 21 | 22 | instance (Promonad p) => Promonad (Sub p) where 23 | id = Sub id 24 | Sub f . Sub g = Sub (f . g) 25 | 26 | -- | The subcategory with objects with instances of the given constraint `ob`. 27 | instance (CategoryOf k) => CategoryOf (SUBCAT (ob :: OB k)) where 28 | type (~>) = Sub (~>) 29 | type Ob (a :: SUBCAT ob) = (Is SUB a, Ob (UN SUB a), ob (UN SUB a)) 30 | 31 | type On :: (k -> Constraint) -> forall (ob :: OB k) -> SUBCAT ob -> Constraint 32 | class (c (UN SUB a)) => (c `On` ob) a 33 | instance (c (UN SUB a)) => (c `On` ob) a 34 | 35 | class (CategoryOf k, ob (a ** b)) => IsObMult (ob :: OB k) a b 36 | instance (CategoryOf k, ob (a ** b)) => IsObMult (ob :: OB k) a b 37 | 38 | instance 39 | (MonoidalProfunctor p, ob Unit, forall a b. (ob a, ob b) => IsObMult ob a b) 40 | => MonoidalProfunctor (Sub p :: CAT (SUBCAT (ob :: OB k))) 41 | where 42 | par0 = Sub par0 43 | Sub f `par` Sub g = Sub (f `par` g) 44 | 45 | instance (Monoidal k, ob Unit, forall a b. (ob a, ob b) => IsObMult ob a b) => Monoidal (SUBCAT (ob :: OB k)) where 46 | type Unit = SUB Unit 47 | type a ** b = SUB (UN SUB a ** UN SUB b) 48 | withOb2 @(SUB a) @(SUB b) r = withOb2 @k @a @b r 49 | leftUnitor = Sub leftUnitor 50 | leftUnitorInv = Sub leftUnitorInv 51 | rightUnitor = Sub rightUnitor 52 | rightUnitorInv = Sub rightUnitorInv 53 | associator @(SUB a) @(SUB b) @(SUB c) = Sub (associator @_ @a @b @c) 54 | associatorInv @(SUB a) @(SUB b) @(SUB c) = Sub (associatorInv @_ @a @b @c) 55 | 56 | instance (SymMonoidal k, ob Unit, forall a b. (ob a, ob b) => IsObMult ob a b) => SymMonoidal (SUBCAT (ob :: OB k)) where 57 | swap @(SUB a) @(SUB b) = Sub (swap @k @a @b) 58 | 59 | instance (Representable p, forall a. (ob a) => ob (p % a)) => Representable (Sub p :: CAT (SUBCAT (ob :: OB k))) where 60 | type Sub p % a = SUB (p % UN SUB a) 61 | index (Sub p) = Sub (index p) 62 | tabulate (Sub f) = Sub (tabulate f) 63 | repMap (Sub f) = Sub (repMap @p f) 64 | 65 | instance (MonoidalAction m Type, Monoidal (SUBCAT (ob :: OB m))) => Strong (SUBCAT (ob :: OB m)) (->) where 66 | Sub f `act` g = f `act` g 67 | instance (MonoidalAction m Type, Monoidal (SUBCAT (ob :: OB m))) => MonoidalAction (SUBCAT (ob :: OB m)) Type where 68 | type Act (p :: SUBCAT ob) (x :: Type) = Act (UN SUB p) x 69 | withObAct r = r 70 | unitor = unitor @m 71 | unitorInv = unitorInv @m 72 | multiplicator @(SUB p) @(SUB q) @x = multiplicator @_ @_ @p @q @x 73 | multiplicatorInv @(SUB p) @(SUB q) @x = multiplicatorInv @_ @_ @p @q @x 74 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Unit.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Category.Instance.Unit where 4 | 5 | import Prelude (type (~)) 6 | 7 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault) 8 | import Proarrow.Object.Initial (HasInitialObject (..)) 9 | import Proarrow.Object.Terminal (HasTerminalObject (..)) 10 | import Proarrow.Preorder.ThinCategory (ThinProfunctor (..), Codiscrete, Discrete (..)) 11 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 12 | 13 | type Unit :: CAT () 14 | data Unit a b where 15 | Unit :: Unit '() '() 16 | 17 | -- | The category with one object, the terminal category. 18 | instance CategoryOf () where 19 | type (~>) = Unit 20 | type Ob a = a ~ '() 21 | 22 | instance Promonad Unit where 23 | id = Unit 24 | Unit . Unit = Unit 25 | 26 | instance Profunctor Unit where 27 | dimap = dimapDefault 28 | r \\ Unit = r 29 | 30 | instance DaggerProfunctor Unit where 31 | dagger Unit = Unit 32 | 33 | instance ThinProfunctor Unit where 34 | type HasArrow Unit '() '() = () 35 | arr = Unit 36 | withArr Unit r = r 37 | 38 | instance Codiscrete Unit 39 | instance Discrete Unit where 40 | withEq Unit r = r 41 | 42 | instance HasTerminalObject () where 43 | type TerminalObject = '() 44 | terminate = Unit 45 | 46 | instance HasInitialObject () where 47 | type InitialObject = '() 48 | initiate = Unit 49 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Instance/Zero.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Instance.Zero where 2 | 3 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault) 4 | import Proarrow.Preorder.ThinCategory (ThinProfunctor (..)) 5 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 6 | 7 | type data VOID 8 | 9 | type Zero :: CAT VOID 10 | data Zero a b 11 | 12 | -- Stolen from the constraints package 13 | class Bottom where 14 | no :: a 15 | 16 | -- | The category with no objects, the initial category. 17 | instance CategoryOf VOID where 18 | type (~>) = Zero 19 | type Ob a = Bottom 20 | 21 | instance Promonad Zero where 22 | id = no 23 | (.) = \case {} 24 | 25 | instance Profunctor Zero where 26 | dimap = dimapDefault 27 | _ \\ x = case x of {} 28 | 29 | instance ThinProfunctor Zero where 30 | arr = no 31 | withArr = \case {} 32 | 33 | instance DaggerProfunctor Zero where 34 | dagger = \case {} -------------------------------------------------------------------------------- /src/Proarrow/Category/Monoidal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Monoidal where 4 | 5 | import Data.Kind (Constraint) 6 | import Prelude (($)) 7 | 8 | import Proarrow.Core (CAT, CategoryOf (..), Kind, Obj, Profunctor (..), Promonad (..), obj, src, tgt, type (+->)) 9 | 10 | -- This is equal to a monoidal functor for Star 11 | -- and to an oplax monoidal functor for Costar 12 | type MonoidalProfunctor :: forall {j} {k}. j +-> k -> Constraint 13 | class (Monoidal j, Monoidal k, Profunctor p) => MonoidalProfunctor (p :: j +-> k) where 14 | par0 :: p Unit Unit 15 | par :: p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2) 16 | 17 | type Monoidal :: Kind -> Constraint 18 | class (CategoryOf k, MonoidalProfunctor ((~>) :: CAT k), Ob (Unit :: k)) => Monoidal k where 19 | type Unit :: k 20 | type (a :: k) ** (b :: k) :: k 21 | withOb2 :: (Ob (a :: k), Ob b) => ((Ob (a ** b)) => r) -> r 22 | leftUnitor :: (Ob (a :: k)) => Unit ** a ~> a 23 | leftUnitorInv :: (Ob (a :: k)) => a ~> Unit ** a 24 | rightUnitor :: (Ob (a :: k)) => a ** Unit ~> a 25 | rightUnitorInv :: (Ob (a :: k)) => a ~> a ** Unit 26 | associator :: (Ob (a :: k), Ob b, Ob c) => (a ** b) ** c ~> a ** (b ** c) 27 | associatorInv :: (Ob (a :: k), Ob b, Ob c) => a ** (b ** c) ~> (a ** b) ** c 28 | 29 | obj2 :: forall {k} a b. (Monoidal k, Ob (a :: k), Ob b) => Obj (a ** b) 30 | obj2 = obj @a `par` obj @b 31 | 32 | leftUnitor' :: (Monoidal k) => (a :: k) ~> b -> Unit ** a ~> b 33 | leftUnitor' f = f . leftUnitor \\ f 34 | 35 | leftUnitorInv' :: (Monoidal k) => (a :: k) ~> b -> a ~> Unit ** b 36 | leftUnitorInv' f = leftUnitorInv . f \\ f 37 | 38 | rightUnitor' :: (Monoidal k) => (a :: k) ~> b -> a ** Unit ~> b 39 | rightUnitor' f = f . rightUnitor \\ f 40 | 41 | rightUnitorInv' :: (Monoidal k) => (a :: k) ~> b -> a ~> b ** Unit 42 | rightUnitorInv' f = rightUnitorInv . f \\ f 43 | 44 | associator' :: forall {k} a b c. (Monoidal k) => Obj (a :: k) -> Obj b -> Obj c -> (a ** b) ** c ~> a ** (b ** c) 45 | associator' a b c = associator @k @a @b @c \\ a \\ b \\ c 46 | 47 | associatorInv' :: forall {k} a b c. (Monoidal k) => Obj (a :: k) -> Obj b -> Obj c -> a ** (b ** c) ~> (a ** b) ** c 48 | associatorInv' a b c = associatorInv @k @a @b @c \\ a \\ b \\ c 49 | 50 | leftUnitorWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => b ~> Unit -> b ** a ~> a 51 | leftUnitorWith f = leftUnitor . (f `par` obj @a) 52 | 53 | leftUnitorInvWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => Unit ~> b -> a ~> b ** a 54 | leftUnitorInvWith f = (f `par` obj @a) . leftUnitorInv 55 | 56 | rightUnitorWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => b ~> Unit -> a ** b ~> a 57 | rightUnitorWith f = rightUnitor . (obj @a `par` f) 58 | 59 | rightUnitorInvWith :: forall {k} a b. (Monoidal k, Ob (a :: k)) => Unit ~> b -> a ~> a ** b 60 | rightUnitorInvWith f = (obj @a `par` f) . rightUnitorInv 61 | 62 | unitObj :: (Monoidal k) => Obj (Unit :: k) 63 | unitObj = par0 64 | 65 | class (Monoidal k) => SymMonoidal k where 66 | swap :: (Ob (a :: k), Ob b) => (a ** b) ~> (b ** a) 67 | 68 | swap' :: forall {k} (a :: k) a' b b'. (SymMonoidal k) => a ~> a' -> b ~> b' -> (a ** b) ~> (b' ** a') 69 | swap' f g = swap @k @a' @b' . (f `par` g) \\ f \\ g 70 | 71 | first :: forall {k} c a b. (Monoidal k, Ob (c :: k)) => (a ~> b) -> (a ** c) ~> (b ** c) 72 | first f = f `par` obj @c 73 | 74 | second :: forall {k} c a b. (Monoidal k, Ob (c :: k)) => (a ~> b) -> (c ** a) ~> (c ** b) 75 | second f = obj @c `par` f 76 | 77 | swapInner' 78 | :: (SymMonoidal k) 79 | => (a :: k) ~> a' 80 | -> b ~> b' 81 | -> c ~> c' 82 | -> d ~> d' 83 | -> ((a ** b) ** (c ** d)) ~> ((a' ** c') ** (b' ** d')) 84 | swapInner' a b c d = 85 | associatorInv' (tgt a) (tgt c) (tgt b `par` tgt d) 86 | . (a `par` (associator' (tgt c) (tgt b) (tgt d) . (swap' b c `par` d) . associatorInv' (src b) (src c) (src d))) 87 | . associator' (src a) (src b) (src c `par` src d) 88 | 89 | swapInner 90 | :: forall {k} a b c d. (SymMonoidal k, Ob (a :: k), Ob b, Ob c, Ob d) => ((a ** b) ** (c ** d)) ~> ((a ** c) ** (b ** d)) 91 | swapInner = 92 | withOb2 @k @b @d $ 93 | withOb2 @k @c @d $ 94 | associatorInv @k @a @c @(b ** d) 95 | . (obj @a `par` (associator @k @c @b @d . (swap @k @b @c `par` obj @d) . associatorInv @k @b @c @d)) 96 | . associator @k @a @b @(c ** d) 97 | 98 | swapFst 99 | :: forall {k} (a :: k) b c d. (SymMonoidal k, Ob a, Ob b, Ob c, Ob d) => (a ** b) ** (c ** d) ~> (c ** b) ** (a ** d) 100 | swapFst = (swap @k @b @c `par` obj2 @a @d) . swapInner @b @a @c @d . (swap @k @a @b `par` obj2 @c @d) 101 | 102 | swapSnd 103 | :: forall {k} a (b :: k) c d. (SymMonoidal k, Ob a, Ob b, Ob c, Ob d) => (a ** b) ** (c ** d) ~> (a ** d) ** (c ** b) 104 | swapSnd = (obj2 @a @d `par` swap @k @b @c) . swapInner @a @b @d @c . (obj2 @a @b `par` swap @k @c @d) 105 | 106 | swapOuter 107 | :: forall {k} a b c d. (SymMonoidal k, Ob (a :: k), Ob b, Ob c, Ob d) => ((a ** b) ** (c ** d)) ~> ((d ** b) ** (c ** a)) 108 | swapOuter = (obj2 @d @b `par` swap @k @a @c) . swapFst @a @b @d @c . (obj2 @a @b `par` swap @k @c @d) 109 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Monoidal/Action.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Monoidal.Action where 4 | 5 | import Data.Kind (Constraint) 6 | import Prelude (type (~)) 7 | 8 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) 9 | import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj, type (+->)) 10 | 11 | -- | Profuntorial strength for a monoidal action. 12 | -- Gives functorial strength for Star, and functorial costrength for Costar. 13 | type Strong :: forall {j} {k}. Kind -> j +-> k -> Constraint 14 | class (MonoidalAction m c, MonoidalAction m d, Profunctor p) => Strong m (p :: c +-> d) where 15 | act :: forall (a :: m) b x y. a ~> b -> p x y -> p (Act a x) (Act b y) 16 | 17 | class (Monoidal m, CategoryOf k, Strong m ((~>) :: CAT k)) => MonoidalAction m k where 18 | -- I would like to default Act to `**`, but that doesn't seem possible without GHC thinking `m` and `k` are the same. 19 | type Act (a :: m) (x :: k) :: k 20 | withObAct :: (Ob (a :: m), Ob (x :: k)) => ((Ob (Act a x)) => r) -> r 21 | unitor :: (Ob (x :: k)) => Act (Unit :: m) x ~> x 22 | unitorInv :: (Ob (x :: k)) => x ~> Act (Unit :: m) x 23 | multiplicator :: (Ob (a :: m), Ob (b :: m), Ob (x :: k)) => Act a (Act b x) ~> Act (a ** b) x 24 | multiplicatorInv :: (Ob (a :: m), Ob (b :: m), Ob (x :: k)) => Act (a ** b) x ~> Act a (Act b x) 25 | 26 | class (Act a b ~ a ** b) => ActIsTensor a b 27 | instance (Act a b ~ a ** b) => ActIsTensor a b 28 | class (Act a (Act b c) ~ a ** (b ** c), a ** (Act b c) ~ a ** (b ** c), Act a (b ** c) ~ a ** (b ** c)) => ActIsTensor3 a b c 29 | instance (Act a (Act b c) ~ a ** (b ** c), a ** (Act b c) ~ a ** (b ** c), Act a (b ** c) ~ a ** (b ** c)) => ActIsTensor3 a b c 30 | class 31 | ( MonoidalAction k k 32 | , SymMonoidal k 33 | , forall (a :: k) (b :: k). ActIsTensor a b 34 | , forall (a :: k) (b :: k) (c :: k). ActIsTensor3 a b c 35 | ) => 36 | SelfAction k 37 | instance 38 | ( MonoidalAction k k 39 | , SymMonoidal k 40 | , forall (a :: k) (b :: k). ActIsTensor a b 41 | , forall (a :: k) (b :: k) (c :: k). ActIsTensor3 a b c 42 | ) 43 | => SelfAction k 44 | 45 | composeActs 46 | :: forall {m} {k} (x :: m) y (c :: k) a b 47 | . (MonoidalAction m k, Ob x, Ob y, Ob c) 48 | => a ~> Act x b 49 | -> b ~> Act y c 50 | -> a ~> Act (x ** y) c 51 | composeActs f g = multiplicator @m @k @x @y @c . act (obj @x) g . f 52 | 53 | decomposeActs 54 | :: forall {m} {k} (x :: m) y (c :: k) a b 55 | . (MonoidalAction m k, Ob x, Ob y, Ob c) 56 | => Act y c ~> b 57 | -> Act x b ~> a 58 | -> Act (x ** y) c ~> a 59 | decomposeActs f g = g . act (obj @x) f . multiplicatorInv @m @k @x @y @c 60 | 61 | first' :: forall {k} {p :: CAT k} c a b. (SelfAction k, Strong k p, Ob c) => p a b -> p (a ** c) (b ** c) 62 | first' p = dimap (swap @k @a @c) (swap @k @c @b) (second' @c p) \\ p 63 | 64 | second' :: forall {k} {p :: CAT k} c a b. (SelfAction k, Strong k p, Ob c) => p a b -> p (c ** a) (c ** b) 65 | second' p = act (obj @c) p 66 | 67 | -- | This is not monoidal `par` but premonoidal, i.e. no sliding. 68 | -- So with `prepar f g` the effects of f happen before the effects of g. 69 | -- p needs to be a commutative promonad for this to be monoidal `par`. 70 | prepar :: forall {k} {p :: CAT k} a b c d. (SelfAction k, Strong k p, Promonad p) => p a b -> p c d -> p (a ** c) (b ** d) 71 | prepar f g = second' @b g . first' @c f \\ f \\ g 72 | 73 | strongPar0 :: forall {k} {p :: CAT k} a. (SelfAction k, Strong k p, MonoidalProfunctor p, Ob a) => p a a 74 | strongPar0 = dimap rightUnitorInv rightUnitor (act (obj @a) par0) 75 | 76 | type Costrong :: forall {j} {k}. Kind -> j +-> k -> Constraint 77 | class (MonoidalAction m c, MonoidalAction m d, Profunctor p) => Costrong m (p :: c +-> d) where 78 | coact :: forall (a :: m) x y. (Ob a, Ob x, Ob y) => p (Act a x) (Act a y) -> p x y 79 | 80 | trace :: forall {k} (p :: k +-> k) u x y. (SelfAction k, Costrong k p, Ob x, Ob y, Ob u) => p (x ** u) (y ** u) -> p x y 81 | trace p = coact @k @p @u @x @y (dimap (swap @k @u @x) (swap @k @y @u) p) \\ p 82 | 83 | class (SelfAction k, Costrong k ((~>) :: CAT k), SymMonoidal k) => TracedMonoidal k 84 | instance (SelfAction k, Costrong k ((~>) :: CAT k), SymMonoidal k) => TracedMonoidal k 85 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Monoidal/Applicative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Monoidal.Applicative where 4 | 5 | import Control.Applicative qualified as P 6 | import Data.Function (($)) 7 | import Data.Kind (Constraint) 8 | import Data.List.NonEmpty qualified as P 9 | import Prelude qualified as P 10 | 11 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 12 | import Proarrow.Category.Monoidal.Distributive (Distributive) 13 | import Proarrow.Core (CategoryOf (..), Profunctor (..), type (+->)) 14 | import Proarrow.Functor (FromProfunctor (..), Functor (..), Prelude (..)) 15 | import Proarrow.Monoid (Comonoid (..)) 16 | import Proarrow.Object.BinaryCoproduct (HasBinaryCoproducts (..)) 17 | 18 | type Applicative :: forall {j} {k}. (j -> k) -> Constraint 19 | class (Monoidal j, Monoidal k, Functor f) => Applicative (f :: j -> k) where 20 | pure :: Unit ~> a -> Unit ~> f a 21 | liftA2 :: (Ob a, Ob b) => (a ** b ~> c) -> f a ** f b ~> f c 22 | 23 | instance (MonoidalProfunctor (p :: j +-> k), Comonoid x) => Applicative (FromProfunctor p x) where 24 | pure a () = FromProfunctor $ dimap counit a par0 25 | liftA2 abc (FromProfunctor pxa, FromProfunctor pxb) = FromProfunctor $ dimap comult abc (pxa `par` pxb) 26 | 27 | instance (P.Applicative f) => Applicative (Prelude f) where 28 | pure a () = Prelude (P.pure (a ())) 29 | liftA2 f (Prelude fa, Prelude fb) = Prelude (P.liftA2 (P.curry f) fa fb) 30 | 31 | deriving via Prelude ((,) a) instance (P.Monoid a) => Applicative ((,) a) 32 | deriving via Prelude ((->) a) instance Applicative ((->) a) 33 | deriving via Prelude [] instance Applicative [] 34 | deriving via Prelude (P.Either e) instance Applicative (P.Either e) 35 | deriving via Prelude P.IO instance Applicative P.IO 36 | deriving via Prelude P.Maybe instance Applicative P.Maybe 37 | deriving via Prelude P.NonEmpty instance Applicative P.NonEmpty 38 | 39 | type Alternative :: forall {j} {k}. (j -> k) -> Constraint 40 | class (Distributive j, Applicative f) => Alternative (f :: j -> k) where 41 | empty :: (Ob a) => Unit ~> f a 42 | alt :: (Ob a, Ob b) => (a || b ~> c) -> f a ** f b ~> f c 43 | 44 | instance (P.Alternative f) => Alternative (Prelude f) where 45 | empty () = Prelude P.empty 46 | alt abc (Prelude fl, Prelude fr) = Prelude (P.fmap abc $ P.fmap P.Left fl P.<|> P.fmap P.Right fr) 47 | 48 | deriving via Prelude [] instance Alternative [] 49 | deriving via Prelude P.Maybe instance Alternative P.Maybe 50 | deriving via Prelude P.IO instance Alternative P.IO 51 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Monoidal/Endo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Category.Monoidal.Endo where 4 | 5 | import Proarrow.Category.Bicategory (Bicategory (..), Comonad (..), Monad (..)) 6 | import Proarrow.Category.Bicategory qualified as B 7 | import Proarrow.Category.Bicategory.Kan (LeftKanExtension (..), RightKanExtension (..), dimapRan, dimapLan) 8 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 9 | import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, obj) 10 | import Proarrow.Monoid (Comonoid (..), Monoid (..)) 11 | import Proarrow.Object.Coexponential (Coclosed (..)) 12 | import Proarrow.Object.Exponential (Closed (..)) 13 | 14 | type data ENDO (kk :: CAT j) (k :: j) = E (kk k k) 15 | type instance UN E (E p) = p 16 | 17 | type Endo :: forall {kk} {k}. CAT (ENDO kk k) 18 | data Endo p q where 19 | Endo :: p ~> q -> Endo (E p) (E q) 20 | 21 | mkEndo :: (CategoryOf (kk k k)) => (p :: kk k k) ~> q -> Endo (E p) (E q) 22 | mkEndo pq = Endo pq \\ pq 23 | 24 | instance (Bicategory kk, Ob0 kk k) => Profunctor (Endo :: CAT (ENDO kk k)) where 25 | dimap = dimapDefault 26 | r \\ Endo f = r \\ f 27 | instance (Bicategory kk, Ob0 kk k) => Promonad (Endo :: CAT (ENDO kk k)) where 28 | id = Endo id 29 | Endo m . Endo n = Endo (m . n) 30 | instance (Bicategory kk, Ob0 kk k) => CategoryOf (ENDO kk k) where 31 | type (~>) = Endo 32 | type Ob p = (Is E p, Ob (UN E p)) 33 | 34 | instance (Bicategory kk, Ob0 kk k, (Ob (I :: kk k k))) => MonoidalProfunctor (Endo :: CAT (ENDO kk k)) where 35 | par0 = Endo id 36 | Endo f `par` Endo g = mkEndo (f `o` g) 37 | 38 | -- | The monoidal subcategory of a bicategory for a single object. 39 | instance (Bicategory kk, Ob0 kk k, (Ob (I :: kk k k))) => Monoidal (ENDO kk k) where 40 | type Unit = E I 41 | type E p ** E q = E (p `O` q) 42 | withOb2 @(E a) @(E b) r = r \\\ (obj @a `o` obj @b) 43 | leftUnitor = mkEndo B.leftUnitor 44 | leftUnitorInv = mkEndo B.leftUnitorInv 45 | rightUnitor = mkEndo B.rightUnitor 46 | rightUnitorInv = mkEndo B.rightUnitorInv 47 | associator @(E p) @(E q) @(E r) = mkEndo (B.associator @kk @p @q @r) 48 | associatorInv @(E p) @(E q) @(E r) = mkEndo (B.associatorInv @kk @p @q @r) 49 | 50 | instance 51 | (Bicategory kk, Ob0 kk k, Ob (I :: kk k k), forall (f :: kk k k) (g :: kk k k). (Ob f, Ob g) => RightKanExtension f g) 52 | => Closed (ENDO kk k) 53 | where 54 | type E f ~~> E g = E (Ran f g) 55 | withObExp @(E a) @(E b) r = r \\ dimapRan (obj @a) (obj @b) 56 | curry @(E g) @(E j) (Endo h) = Endo (ranUniv @j @_ @g h) \\ h 57 | uncurry @(E j) @(E f) (Endo h) = Endo (ran @j @f . (h `o` obj @j)) 58 | (^^^) (Endo f) (Endo g) = Endo (dimapRan g f) \\ f \\ g 59 | 60 | instance 61 | (Bicategory kk, Ob0 kk k, Ob (I :: kk k k), forall (f :: kk k k) (g :: kk k k). (Ob f, Ob g) => LeftKanExtension f g) 62 | => Coclosed (ENDO kk k) 63 | where 64 | type E f <~~ E g = E (Lan g f) 65 | withObCoExp @(E f) @(E g) r = r \\ dimapLan (obj @g) (obj @f) 66 | coeval @(E g) @(E j) = Endo (lan @j @g) 67 | coevalUniv @(E j) @(E f) (Endo h) = Endo (lanUniv @j @_ @f h) \\ h 68 | 69 | -- | Monads are monoids in the category of endo-1-cells. 70 | instance (Bicategory kk, Ob (I :: kk a a), Monad m, Ob m) => Monoid (E m :: ENDO kk a) where 71 | mempty = mkEndo eta 72 | mappend = mkEndo mu 73 | 74 | -- | Comonads are comonoids in the category of endo-1-cells. 75 | instance (Bicategory kk, Ob (I :: kk a a), Comonad c, Ob c) => Comonoid (E c :: ENDO kk a) where 76 | counit = mkEndo epsilon 77 | comult = mkEndo delta 78 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Monoidal/Rev.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Monoidal.Rev where 2 | 3 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) 4 | import Proarrow.Core (CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, type (+->)) 5 | 6 | type data REV k = R k 7 | type instance UN R (R a) = a 8 | 9 | type Rev :: j +-> k -> REV j +-> REV k 10 | data Rev p a b where 11 | Rev :: p a b -> Rev p (R a) (R b) 12 | 13 | instance (Profunctor p) => Profunctor (Rev p) where 14 | dimap (Rev l) (Rev r) (Rev p) = Rev (dimap l r p) 15 | r \\ Rev p = r \\ p 16 | 17 | instance (Promonad p) => Promonad (Rev p) where 18 | id = Rev id 19 | Rev f . Rev g = Rev (f . g) 20 | 21 | instance (CategoryOf k) => CategoryOf (REV k) where 22 | type (~>) = Rev (~>) 23 | type Ob a = (Is R a, Ob (UN R a)) 24 | 25 | instance (MonoidalProfunctor p) => MonoidalProfunctor (Rev p) where 26 | par0 = Rev par0 27 | Rev f `par` Rev g = Rev (g `par` f) 28 | 29 | instance (Monoidal k) => Monoidal (REV k) where 30 | type Unit = R Unit 31 | type R a ** R b = R (b ** a) 32 | withOb2 @(R a) @(R b) = withOb2 @k @b @a 33 | leftUnitor = Rev rightUnitor 34 | leftUnitorInv = Rev rightUnitorInv 35 | rightUnitor = Rev leftUnitor 36 | rightUnitorInv = Rev leftUnitorInv 37 | associator @(R a) @(R b) @(R c) = Rev (associatorInv @k @c @b @a) 38 | associatorInv @(R a) @(R b) @(R c) = Rev (associator @k @c @b @a) 39 | 40 | instance (SymMonoidal k) => SymMonoidal (REV k) where 41 | swap @(R a) @(R b) = Rev (swap @k @b @a) 42 | -------------------------------------------------------------------------------- /src/Proarrow/Category/Opposite.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Category.Opposite where 2 | 3 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) 4 | import Proarrow.Core (CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, lmap, type (+->)) 5 | import Proarrow.Functor (Functor (..)) 6 | import Proarrow.Monoid (Comonoid (..), Monoid (..)) 7 | import Proarrow.Object.BinaryCoproduct (HasBinaryCoproducts (..)) 8 | import Proarrow.Object.BinaryProduct (HasBinaryProducts (..)) 9 | import Proarrow.Object.Initial (HasInitialObject (..)) 10 | import Proarrow.Object.Terminal (HasTerminalObject (..)) 11 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..)) 12 | import Proarrow.Profunctor.Representable (Representable (..)) 13 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 14 | 15 | newtype OPPOSITE k = OP k 16 | type instance UN OP (OP k) = k 17 | 18 | type Op :: j +-> k -> OPPOSITE k +-> OPPOSITE j 19 | data Op p a b where 20 | Op :: {unOp :: p b a} -> Op p (OP a) (OP b) 21 | 22 | instance (Profunctor p) => Functor (Op p a) where 23 | map (Op f) (Op p) = Op (lmap f p) 24 | 25 | instance (Profunctor p) => Profunctor (Op p) where 26 | dimap (Op l) (Op r) = Op . dimap r l . unOp 27 | r \\ Op f = r \\ f 28 | 29 | -- | The opposite category of the category of `k`. 30 | instance (CategoryOf k) => CategoryOf (OPPOSITE k) where 31 | type (~>) = Op (~>) 32 | type Ob a = (Is OP a, Ob (UN OP a)) 33 | 34 | instance (Promonad c) => Promonad (Op c) where 35 | id = Op id 36 | Op f . Op g = Op (g . f) 37 | 38 | instance (HasInitialObject k) => HasTerminalObject (OPPOSITE k) where 39 | type TerminalObject = OP InitialObject 40 | terminate = Op initiate 41 | 42 | instance (HasTerminalObject k) => HasInitialObject (OPPOSITE k) where 43 | type InitialObject = OP TerminalObject 44 | initiate = Op terminate 45 | 46 | instance (HasBinaryCoproducts k) => HasBinaryProducts (OPPOSITE k) where 47 | type a && b = OP (UN OP a || UN OP b) 48 | withObProd @(OP a) @(OP b) = withObCoprod @k @a @b 49 | fst @(OP a) @(OP b) = Op (lft @_ @a @b) 50 | snd @(OP a) @(OP b) = Op (rgt @_ @a @b) 51 | Op a &&& Op b = Op (a ||| b) 52 | 53 | instance (HasBinaryProducts k) => HasBinaryCoproducts (OPPOSITE k) where 54 | type a || b = OP (UN OP a && UN OP b) 55 | withObCoprod @(OP a) @(OP b) = withObProd @k @a @b 56 | lft @(OP a) @(OP b) = Op (fst @_ @a @b) 57 | rgt @(OP a) @(OP b) = Op (snd @_ @a @b) 58 | Op a ||| Op b = Op (a &&& b) 59 | 60 | instance (MonoidalProfunctor p) => MonoidalProfunctor (Op p) where 61 | par0 = Op par0 62 | Op l `par` Op r = Op (l `par` r) 63 | 64 | instance (Monoidal k) => Monoidal (OPPOSITE k) where 65 | type Unit = OP Unit 66 | type a ** b = OP (UN OP a ** UN OP b) 67 | withOb2 @(OP a) @(OP b) = withOb2 @k @a @b 68 | leftUnitor = Op leftUnitorInv 69 | leftUnitorInv = Op leftUnitor 70 | rightUnitor = Op rightUnitorInv 71 | rightUnitorInv = Op rightUnitor 72 | associator @(OP a) @(OP b) @(OP c) = Op (associatorInv @k @a @b @c) 73 | associatorInv @(OP a) @(OP b) @(OP c) = Op (associator @k @a @b @c) 74 | 75 | instance (SymMonoidal k) => SymMonoidal (OPPOSITE k) where 76 | swap @(OP a) @(OP b) = Op (swap @k @b @a) 77 | 78 | instance (Comonoid c) => Monoid (OP c) where 79 | mempty = Op counit 80 | mappend = Op comult 81 | 82 | instance (Monoid c) => Comonoid (OP c) where 83 | counit = Op mempty 84 | comult = Op mappend 85 | 86 | instance (Representable p) => Corepresentable (Op p) where 87 | type Op p %% OP a = OP (p % a) 88 | coindex (Op f) = Op (index f) 89 | cotabulate (Op f) = Op (tabulate f) 90 | corepMap (Op f) = Op (repMap @p f) 91 | 92 | instance (Corepresentable p) => Representable (Op p) where 93 | type Op p % OP a = OP (p %% a) 94 | index (Op f) = Op (coindex f) 95 | tabulate (Op f) = Op (cotabulate f) 96 | repMap (Op f) = Op (corepMap @p f) 97 | 98 | type UnOp :: OPPOSITE k +-> OPPOSITE j -> j +-> k 99 | data UnOp p a b where 100 | UnOp :: {unUnOp :: p (OP b) (OP a)} -> UnOp p a b 101 | instance (CategoryOf j, CategoryOf k, Profunctor p) => Profunctor (UnOp p :: j +-> k) where 102 | dimap l r = UnOp . dimap (Op r) (Op l) . unUnOp 103 | r \\ UnOp f = r \\ f 104 | 105 | instance Strong k p => Strong (OPPOSITE k) (Op p) where 106 | act (Op w) (Op p) = Op (act w p) 107 | instance MonoidalAction m k => MonoidalAction (OPPOSITE m) (OPPOSITE k) where 108 | type Act (OP a) (OP b) = OP (Act a b) 109 | withObAct @(OP a) @(OP b) = withObAct @m @k @a @b 110 | unitor = Op (unitorInv @m) 111 | unitorInv = Op (unitor @m) 112 | multiplicator @(OP a) @(OP b) @(OP x) = Op (multiplicatorInv @m @k @a @b @x) 113 | multiplicatorInv @(OP a) @(OP b) @(OP x) = Op (multiplicator @m @k @a @b @x) 114 | -------------------------------------------------------------------------------- /src/Proarrow/Core.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} 2 | 3 | {-# HLINT ignore "Redundant lambda" #-} 4 | {-# HLINT ignore "Avoid lambda" #-} 5 | module Proarrow.Core where 6 | 7 | import Data.Kind (Constraint, Type) 8 | import Prelude (type (~)) 9 | 10 | infixr 0 ~>, :~>, +-> 11 | infixl 1 \\ 12 | infixr 0 // 13 | infixr 9 . 14 | 15 | type PRO j k = j -> k -> Type 16 | type j +-> k = PRO k j 17 | 18 | type CAT k = PRO k k 19 | type BI k = (k, k) -> k 20 | type OB k = k -> Constraint 21 | type Kind = Type 22 | 23 | class Any (a :: k) 24 | instance Any a 25 | 26 | class (Promonad ((~>) :: CAT k)) => CategoryOf k where 27 | type (~>) :: CAT k 28 | type Ob (a :: k) :: Constraint 29 | type Ob a = Any a 30 | 31 | class (Promonad cat, CategoryOf k, cat ~ (~>) @k) => Category (cat :: CAT k) 32 | instance (Promonad cat, CategoryOf k, cat ~ (~>) @k) => Category (cat :: CAT k) 33 | 34 | type p :~> q = forall a b. p a b -> q a b 35 | 36 | type Profunctor :: forall {j} {k}. PRO j k -> Constraint 37 | class (CategoryOf j, CategoryOf k) => Profunctor (p :: PRO j k) where 38 | dimap :: c ~> a -> b ~> d -> p a b -> p c d 39 | (\\) :: ((Ob a, Ob b) => r) -> p a b -> r 40 | default (\\) :: (Ob a, Ob b) => ((Ob a, Ob b) => r) -> p a b -> r 41 | r \\ _ = r 42 | 43 | (//) :: (Profunctor p) => p a b -> ((Ob a, Ob b) => r) -> r 44 | p // r = r \\ p 45 | 46 | lmap :: (Profunctor p) => c ~> a -> p a b -> p c b 47 | lmap l p = dimap l id p \\ p 48 | 49 | rmap :: (Profunctor p) => b ~> d -> p a b -> p a d 50 | rmap r p = dimap id r p \\ p 51 | 52 | dimapDefault :: (Promonad p) => p c a -> p b d -> p a b -> p c d 53 | dimapDefault f g h = g . h . f 54 | 55 | class (Profunctor p) => Promonad p where 56 | id :: (Ob a) => p a a 57 | (.) :: p b c -> p a b -> p a c 58 | 59 | arr :: (Promonad p) => a ~> b -> p a b 60 | arr f = rmap f id \\ f 61 | 62 | type Obj a = a ~> a 63 | 64 | obj :: forall {k} (a :: k). (CategoryOf k, Ob a) => Obj a 65 | obj = id @_ @a 66 | 67 | src :: forall {k} a b p. (Profunctor p) => p (a :: k) b -> Obj a 68 | src p = obj @a \\ p 69 | 70 | tgt :: forall {k} a b p. (Profunctor p) => p (a :: k) b -> Obj b 71 | tgt p = obj @b \\ p 72 | 73 | instance Profunctor (->) where 74 | dimap = dimapDefault 75 | 76 | instance Promonad (->) where 77 | id = \a -> a 78 | f . g = \x -> f (g x) 79 | 80 | instance CategoryOf Type where 81 | type (~>) = (->) 82 | 83 | -- | A helper type family to unwrap a wrapped kind. 84 | -- This is needed because the field selector functions of newtypes have to be 85 | -- lower case and therefore cannot be used at the type level. 86 | type family UN (w :: j -> k) (wa :: k) :: j 87 | 88 | -- | @Is w a@ checks that the kind @a@ is a kind wrapped by @w@. 89 | type Is w a = a ~ w (UN w a) 90 | -------------------------------------------------------------------------------- /src/Proarrow/Functor.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Functor where 2 | 3 | import Data.Functor.Compose (Compose (..)) 4 | import Data.Functor.Const (Const (..)) 5 | import Data.Functor.Identity (Identity) 6 | import Data.Kind (Constraint, Type) 7 | import Data.List.NonEmpty qualified as P 8 | import Prelude qualified as P 9 | 10 | import Proarrow.Core (CategoryOf (..), Promonad (..), Profunctor, rmap, type (+->)) 11 | import Proarrow.Object (Ob') 12 | 13 | infixr 0 .~> 14 | type f .~> g = forall a. (Ob a) => f a ~> g a 15 | 16 | type Functor :: forall {k1} {k2}. (k1 -> k2) -> Constraint 17 | class (CategoryOf k1, CategoryOf k2, forall a. (Ob a) => Ob' (f a)) => Functor (f :: k1 -> k2) where 18 | map :: a ~> b -> f a ~> f b 19 | 20 | -- Can't make an instance Functor (f :: Type -> Type) because that would overlap with instances of kind k -> Type 21 | newtype Prelude f a = Prelude {unPrelude :: f a} 22 | deriving (P.Functor, P.Foldable, P.Traversable) 23 | instance (P.Functor f) => Functor (Prelude f) where 24 | map f = Prelude . P.fmap f . unPrelude 25 | 26 | deriving via Prelude ((,) a) instance Functor ((,) a) 27 | deriving via Prelude (P.Either a) instance Functor (P.Either a) 28 | deriving via Prelude P.IO instance Functor P.IO 29 | deriving via Prelude P.Maybe instance Functor P.Maybe 30 | deriving via Prelude P.NonEmpty instance Functor P.NonEmpty 31 | deriving via Prelude ((->) a) instance Functor ((->) a) 32 | deriving via Prelude [] instance Functor [] 33 | deriving via Prelude Identity instance Functor Identity 34 | 35 | instance (CategoryOf k) => Functor (Const x :: k -> Type) where 36 | map _ (Const x) = Const x 37 | 38 | instance (Functor f, Functor g) => Functor (Compose f g) where 39 | map f = Compose . map (map f) . getCompose 40 | 41 | newtype FromProfunctor p a b = FromProfunctor {unFromProfunctor :: p a b} 42 | instance (Profunctor p) => Functor (FromProfunctor p a) where 43 | map f = FromProfunctor . rmap f . unFromProfunctor 44 | instance (Profunctor p) => P.Functor (FromProfunctor p a) where 45 | fmap = map 46 | 47 | -- | Presheaves are functors but it makes more sense in proarrow to represent them as profunctors from the unit category. 48 | type Presheaf k = () +-> k 49 | -- | Copresheaves are functors but it makes more sense in proarrow to represent them as profunctors into the unit category. 50 | type Copresheaf k = k +-> () -------------------------------------------------------------------------------- /src/Proarrow/Monoid.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Monoid where 4 | 5 | import Data.Kind (Constraint, Type) 6 | import Prelude qualified as P 7 | 8 | import Proarrow.Category.Monoidal (Monoidal (..)) 9 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 10 | import Proarrow.Core (CategoryOf (..), Promonad (..), arr, obj) 11 | import Proarrow.Object.BinaryCoproduct (COPROD (..), Coprod (..), HasCoproducts, codiag) 12 | import Proarrow.Object.BinaryProduct (Cartesian, HasProducts, PROD (..), Prod (..), diag, (&&&)) 13 | import Proarrow.Object.Initial (initiate) 14 | import Proarrow.Object.Terminal (terminate) 15 | import Proarrow.Profunctor.Identity (Id(..)) 16 | 17 | type Monoid :: forall {k}. k -> Constraint 18 | class (Monoidal k, Ob m) => Monoid (m :: k) where 19 | mempty :: Unit ~> m 20 | mappend :: m ** m ~> m 21 | 22 | instance (P.Monoid m) => Monoid (m :: Type) where 23 | mempty () = P.mempty 24 | mappend = P.uncurry (P.<>) 25 | 26 | newtype GenElt x m = GenElt (x ~> m) 27 | 28 | instance (Monoid m, Cartesian k) => P.Semigroup (GenElt x (m :: k)) where 29 | GenElt f <> GenElt g = GenElt (mappend . (f &&& g)) 30 | instance (Monoid m, Cartesian k, Ob x) => P.Monoid (GenElt x (m :: k)) where 31 | mempty = GenElt (mempty . arr terminate) 32 | 33 | instance (HasCoproducts k, Ob a) => Monoid (COPR (a :: k)) where 34 | mempty = Coprod (Id initiate) 35 | mappend = Coprod (Id codiag) 36 | 37 | memptyAct :: forall {m} {c} (a :: m) (n :: c). (MonoidalAction m c, Monoid a, Ob n) => n ~> Act a n 38 | memptyAct = act (mempty @a) (obj @n) . unitorInv @m 39 | 40 | mappendAct :: forall {m} {c} (a :: m) (n :: c). (MonoidalAction m c, Monoid a, Ob n) => Act a (Act a n) ~> Act a n 41 | mappendAct = act (mappend @a) (obj @n) . multiplicator @m @c @a @a @n 42 | 43 | type ModuleObject :: forall {m} {c}. m -> c -> Constraint 44 | class (MonoidalAction m c, Monoid a, Ob n) => ModuleObject (a :: m) (n :: c) where 45 | action :: Act a n ~> n 46 | 47 | type Comonoid :: forall {k}. k -> Constraint 48 | class (Monoidal k, Ob c) => Comonoid (c :: k) where 49 | counit :: c ~> Unit 50 | comult :: c ~> c ** c 51 | 52 | instance Comonoid (a :: Type) where 53 | counit _ = () 54 | comult a = (a, a) 55 | 56 | instance (HasProducts k, Ob a) => Comonoid (PR (a :: k)) where 57 | counit = Prod terminate 58 | comult = Prod diag 59 | 60 | counitAct :: forall {m} {c} (a :: m) (n :: c). (MonoidalAction m c, Comonoid a, Ob n) => Act a n ~> n 61 | counitAct = unitor @m . act (counit @a) (obj @n) 62 | 63 | comultAct :: forall {m} {c} (a :: m) (n :: c). (MonoidalAction m c, Comonoid a, Ob n) => Act a n ~> Act a (Act a n) 64 | comultAct = multiplicatorInv @m @c @a @a @n . act (comult @a) (obj @n) -------------------------------------------------------------------------------- /src/Proarrow/Object.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Object 2 | ( Obj 3 | , pattern Obj 4 | , pattern Objs 5 | , obj 6 | , src 7 | , tgt 8 | , Ob' 9 | , VacuusOb 10 | ) where 11 | 12 | import Data.Kind (Type) 13 | 14 | import Proarrow.Core (CategoryOf (..), Obj, obj, src, tgt, (\\)) 15 | 16 | class (Ob a, CategoryOf k) => Ob' (a :: k) 17 | instance (Ob a, CategoryOf k) => Ob' (a :: k) 18 | type VacuusOb k = forall a. Ob' (a :: k) 19 | 20 | type ObjDict :: forall {k}. k -> Type 21 | data ObjDict a where 22 | ObjDict :: (Ob a) => ObjDict a 23 | 24 | objDict :: (CategoryOf k) => a ~> a' -> (ObjDict (a :: k), ObjDict a') 25 | objDict a = (ObjDict \\ a, ObjDict \\ a) 26 | 27 | pattern Obj :: (CategoryOf k) => (Ob (a :: k)) => Obj a 28 | pattern Obj <- (objDict -> (ObjDict, ObjDict)) 29 | where 30 | Obj = obj 31 | 32 | pattern Objs :: (CategoryOf k) => (Ob (a :: k), Ob (b :: k)) => a ~> b 33 | pattern Objs <- (objDict -> (ObjDict, ObjDict)) -------------------------------------------------------------------------------- /src/Proarrow/Object/Coexponential.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Object.Coexponential where 4 | 5 | import Proarrow.Category.Monoidal (Monoidal (..)) 6 | import Proarrow.Core (CategoryOf (..)) 7 | import Proarrow.Object.BinaryCoproduct (Cocartesian) 8 | 9 | class (Monoidal k) => Coclosed k where 10 | type (a :: k) <~~ (b :: k) :: k 11 | withObCoExp :: (Ob (a :: k), Ob b) => ((Ob (a <~~ b)) => r) -> r 12 | coeval :: (Ob (a :: k), Ob b) => a ~> (a <~~ b) ** b 13 | coevalUniv :: (Ob (b :: k), Ob c) => a ~> c ** b -> (a <~~ b) ~> c 14 | 15 | class (Cocartesian k, Coclosed k) => CoCCC k 16 | instance (Cocartesian k, Coclosed k) => CoCCC k 17 | -------------------------------------------------------------------------------- /src/Proarrow/Object/Exponential.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Object.Exponential where 4 | 5 | import Data.Kind (Type) 6 | import Prelude qualified as P 7 | 8 | import Proarrow.Category.Instance.Product ((:**:) (..)) 9 | import Proarrow.Category.Instance.Prof (Prof (..)) 10 | import Proarrow.Category.Instance.Unit qualified as U 11 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), associator, leftUnitor) 12 | import Proarrow.Category.Opposite (OPPOSITE (..), Op (..)) 13 | import Proarrow.Core (CategoryOf (..), PRO, Profunctor (..), Promonad (..), UN, (//)) 14 | import Proarrow.Object (Obj, obj) 15 | import Proarrow.Object.BinaryCoproduct (HasCoproducts) 16 | import Proarrow.Object.BinaryProduct (Cartesian, PROD (..), Prod (..), diag) 17 | import Proarrow.Profunctor.Exponential ((:~>:) (..)) 18 | import Proarrow.Profunctor.Product ((:*:) (..)) 19 | import Proarrow.Profunctor.Representable (Representable (..), dimapRep) 20 | 21 | infixr 2 ~~> 22 | 23 | class (Monoidal k) => Closed k where 24 | type (a :: k) ~~> (b :: k) :: k 25 | withObExp :: (Ob (a :: k), Ob b) => ((Ob (a ~~> b)) => r) -> r 26 | curry :: (Ob (a :: k), Ob b) => a ** b ~> c -> a ~> b ~~> c 27 | uncurry :: (Ob (b :: k), Ob c) => a ~> b ~~> c -> a ** b ~> c 28 | (^^^) :: forall (a :: k) b x y. b ~> y -> x ~> a -> a ~~> b ~> x ~~> y 29 | f ^^^ g = 30 | f // 31 | g // 32 | withObExp @k @a @b P.$ 33 | let ab = obj @(a ~~> b) in curry @k @(a ~~> b) @x (f . uncurry @_ @a @b ab . (ab `par` g)) 34 | 35 | curry' :: forall {k} a b c. (Closed k) => Obj (a :: k) -> Obj b -> a ** b ~> c -> a ~> b ~~> c 36 | curry' a b = curry @k @a @b \\ a \\ b 37 | 38 | uncurry' :: forall {k} b c a. (Closed k) => Obj (b :: k) -> Obj c -> a ~> b ~~> c -> a ** b ~> c 39 | uncurry' b c = uncurry @k @b @c \\ b \\ c 40 | 41 | comp :: forall {k} (a :: k) b c. (Closed k, Ob a, Ob b, Ob c) => (b ~~> c) ** (a ~~> b) ~> a ~~> c 42 | comp = 43 | withObExp @k @b @c P.$ 44 | withObExp @k @a @b P.$ 45 | withOb2 @k @(b ~~> c) @(a ~~> b) P.$ 46 | curry @_ @_ @a (eval @b @c . (obj @(b ~~> c) `par` eval @a @b) . associator @k @(b ~~> c) @(a ~~> b) @a) 47 | 48 | mkExponential :: forall {k} a b. (Closed k) => (a :: k) ~> b -> Unit ~> (a ~~> b) 49 | mkExponential ab = curry @_ @_ @a (ab . leftUnitor) \\ ab 50 | 51 | lower :: forall {k} (a :: k) b. (Closed k, Ob a, Ob b) => (Unit ~> (a ~~> b)) -> a ~> b 52 | lower f = uncurry @k @a @b f . leftUnitorInv 53 | 54 | eval :: forall {k} a b. (Closed k, Ob a, Ob b) => ((a :: k) ~~> b) ** a ~> b 55 | eval = withObExp @k @a @b (uncurry @k @a @b @(a ~~> b) id) 56 | 57 | instance Closed Type where 58 | type a ~~> b = a -> b 59 | withObExp r = r 60 | curry = P.curry 61 | uncurry = P.uncurry 62 | (^^^) = P.flip dimap 63 | 64 | instance Closed () where 65 | type '() ~~> '() = '() 66 | withObExp r = r 67 | curry U.Unit = U.Unit 68 | uncurry U.Unit = U.Unit 69 | U.Unit ^^^ U.Unit = U.Unit 70 | 71 | instance (CategoryOf j, CategoryOf k) => Closed (PROD (PRO j k)) where 72 | type p ~~> q = PR (UN PR p :~>: UN PR q) 73 | withObExp r = r 74 | curry (Prod (Prof n)) = Prod (Prof \p -> p // Exp \ca bd q -> n (dimap ca bd p :*: q)) 75 | uncurry (Prod (Prof n)) = Prod (Prof \(p :*: q) -> case n p of Exp f -> f id id q \\ q) 76 | Prod (Prof m) ^^^ Prod (Prof n) = Prod (Prof \(Exp f) -> Exp \ca bd p -> m (f ca bd (n p))) 77 | 78 | instance (Closed j, Closed k) => Closed (j, k) where 79 | type '(a1, a2) ~~> '(b1, b2) = '(a1 ~~> b1, a2 ~~> b2) 80 | withObExp @'(a1, a2) @'(b1, b2) r = withObExp @j @a1 @b1 (withObExp @k @a2 @b2 r) 81 | curry @'(a1, a2) @'(b1, b2) (f1 :**: f2) = curry @j @a1 @b1 f1 :**: curry @k @a2 @b2 f2 82 | uncurry @'(a1, a2) @'(b1, b2) (f1 :**: f2) = uncurry @j @a1 @b1 f1 :**: uncurry @k @a2 @b2 f2 83 | (f1 :**: f2) ^^^ (g1 :**: g2) = (f1 ^^^ g1) :**: (f2 ^^^ g2) 84 | 85 | type ExponentialFunctor :: PRO k (OPPOSITE k, k) 86 | data ExponentialFunctor a b where 87 | ExponentialFunctor :: (Ob c, Ob d) => a ~> (c ~~> d) -> ExponentialFunctor a '(OP c, d) 88 | 89 | instance (Closed k) => Profunctor (ExponentialFunctor :: PRO k (OPPOSITE k, k)) where 90 | dimap = dimapRep 91 | r \\ ExponentialFunctor f = r \\ f 92 | 93 | instance (Closed k) => Representable (ExponentialFunctor :: PRO k (OPPOSITE k, k)) where 94 | type ExponentialFunctor % '(OP a, b) = a ~~> b 95 | index (ExponentialFunctor f) = f 96 | tabulate = ExponentialFunctor 97 | repMap (Op f :**: g) = g ^^^ f 98 | 99 | class (Cartesian k, Closed k) => CCC k 100 | instance (Cartesian k, Closed k) => CCC k 101 | 102 | class (CCC k, HasCoproducts k) => BiCCC k 103 | instance (CCC k, HasCoproducts k) => BiCCC k 104 | 105 | ap 106 | :: forall {j} {k} y a x p 107 | . (Cartesian j, Closed k, MonoidalProfunctor (p :: PRO j k), Ob y) 108 | => p a (x ~~> y) 109 | -> p a x 110 | -> p a y 111 | ap pf px = dimap diag (eval @x @y) (pf `par` px) \\ px 112 | -------------------------------------------------------------------------------- /src/Proarrow/Object/Initial.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Object.Initial where 2 | 3 | import Data.Kind (Type) 4 | import Data.Void (Void, absurd) 5 | 6 | import Proarrow.Category.Instance.Product ((:**:) (..)) 7 | import Proarrow.Category.Instance.Prof (Prof (..)) 8 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->)) 9 | import Proarrow.Profunctor.Initial (InitialProfunctor) 10 | 11 | class (CategoryOf k, Ob (InitialObject :: k)) => HasInitialObject k where 12 | type InitialObject :: k 13 | initiate :: (Ob (a :: k)) => InitialObject ~> a 14 | 15 | initiate' :: forall {k} a' a. (HasInitialObject k) => (a' :: k) ~> a -> InitialObject ~> a 16 | initiate' a = a . initiate @k @a' \\ a 17 | 18 | instance HasInitialObject Type where 19 | type InitialObject = Void 20 | initiate = absurd 21 | 22 | instance (HasInitialObject j, HasInitialObject k) => HasInitialObject (j, k) where 23 | type InitialObject = '(InitialObject, InitialObject) 24 | initiate = initiate :**: initiate 25 | 26 | instance (CategoryOf j, CategoryOf k) => HasInitialObject (j +-> k) where 27 | type InitialObject = InitialProfunctor 28 | initiate = Prof \case {} 29 | -------------------------------------------------------------------------------- /src/Proarrow/Object/Terminal.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Object.Terminal where 2 | 3 | import Data.Kind (Type) 4 | import Prelude (type (~)) 5 | 6 | import Proarrow.Category.Instance.Product ((:**:) (..)) 7 | import Proarrow.Category.Instance.Prof (Prof (..)) 8 | import Proarrow.Category.Monoidal (Monoidal (..)) 9 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->)) 10 | import Proarrow.Profunctor.Terminal (TerminalProfunctor (..)) 11 | 12 | class (CategoryOf k, Ob (TerminalObject :: k)) => HasTerminalObject k where 13 | type TerminalObject :: k 14 | terminate :: (Ob (a :: k)) => a ~> TerminalObject 15 | 16 | terminate' :: forall {k} a a'. (HasTerminalObject k) => (a :: k) ~> a' -> a ~> TerminalObject 17 | terminate' a = terminate @k @a' . a \\ a 18 | 19 | -- | The type of elements of `a`. 20 | type El a = TerminalObject ~> a 21 | 22 | instance HasTerminalObject Type where 23 | type TerminalObject = () 24 | terminate _ = () 25 | 26 | instance (HasTerminalObject j, HasTerminalObject k) => HasTerminalObject (j, k) where 27 | type TerminalObject = '(TerminalObject, TerminalObject) 28 | terminate = terminate :**: terminate 29 | 30 | instance (CategoryOf j, CategoryOf k) => HasTerminalObject (j +-> k) where 31 | type TerminalObject = TerminalProfunctor 32 | terminate = Prof \a -> TerminalProfunctor \\ a 33 | 34 | class ((Unit :: k) ~ TerminalObject, HasTerminalObject k, Monoidal k) => Semicartesian k 35 | instance ((Unit :: k) ~ TerminalObject, HasTerminalObject k, Monoidal k) => Semicartesian k -------------------------------------------------------------------------------- /src/Proarrow/Preorder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | module Proarrow.Preorder where 3 | 4 | import Data.Kind (Constraint) 5 | import Prelude (type (~)) 6 | 7 | infixl 1 \\ 8 | 9 | type POS k = k -> k -> Constraint 10 | 11 | data Dict a where 12 | Dict :: (a) => Dict a 13 | newtype a :- b = Sub ((a) => Dict b) 14 | 15 | (\\) :: (a) => ((c) => r) -> (a :- c) -> r 16 | r \\ Sub Dict = r 17 | 18 | class (CPromonad ((<=) :: POS k)) => PreorderOf k where 19 | type (<=) :: POS k 20 | type COb (a :: k) :: Constraint 21 | type COb a = () 22 | 23 | type IsPosetOf k pos = (PreorderOf k, pos ~ (<=) @k, CPromonad pos) 24 | 25 | class CProfunctor p where 26 | cdimap :: (c <= a, b <= d, p a b) :- p c d 27 | obs :: p a b :- (COb a, COb b) 28 | class CProfunctor p => CPromonad p where 29 | cid :: (COb a) => () :- p a a 30 | ccomp :: forall a b c. (p b c, p a b) :- p a c 31 | 32 | cdimapDefault :: forall p a b c d. (CPromonad p) => (p c a, p b d, p a b) :- p c d 33 | cdimapDefault = Sub (Dict \\ ccomp @p @c @b @d \\ ccomp @p @c @a @b) 34 | -------------------------------------------------------------------------------- /src/Proarrow/Preorder/Constraint.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Preorder.Constraint where 4 | 5 | import Data.Kind (Constraint) 6 | 7 | import Proarrow.Preorder (CProfunctor (..), CPromonad (..), Dict (..), POS, PreorderOf (..), type (:-) (..)) 8 | 9 | class ((a) => b) => a :=> b where 10 | entails :: a :- b 11 | instance ((a) => b) => a :=> b where 12 | entails = Sub Dict 13 | 14 | instance CProfunctor ((:=>) :: POS Constraint) where 15 | cdimap = Sub Dict 16 | obs = Sub Dict 17 | instance CPromonad ((:=>) :: POS Constraint) where 18 | cid = Sub Dict 19 | ccomp = Sub Dict 20 | instance PreorderOf Constraint where 21 | type (<=) = (:=>) 22 | -------------------------------------------------------------------------------- /src/Proarrow/Preorder/Discrete.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Preorder.Discrete where 2 | 3 | import Prelude (type (~)) 4 | 5 | import Proarrow.Preorder (CProfunctor (..), CPromonad (..), Dict (..), POS, PreorderOf (..), type (:-) (..)) 6 | 7 | newtype DISCRETE k = D k 8 | instance CProfunctor ((~) :: POS (DISCRETE k)) where 9 | cdimap = Sub Dict 10 | obs = Sub Dict 11 | instance CPromonad ((~) :: POS (DISCRETE k)) where 12 | cid = Sub Dict 13 | ccomp = Sub Dict 14 | instance PreorderOf (DISCRETE k) where 15 | type (<=) = (~) -------------------------------------------------------------------------------- /src/Proarrow/Preorder/ThinCategory.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Preorder.ThinCategory where 2 | 3 | import Data.Kind (Constraint) 4 | import Prelude (type (~)) 5 | 6 | import Proarrow.Core (CategoryOf(..), UN, Is, obj, Promonad (..), Profunctor (..), CAT, type (+->)) 7 | import Proarrow.Preorder (CProfunctor (..), POS, cdimapDefault, CPromonad (..), PreorderOf(..), type (:-) (..), Dict (..)) 8 | 9 | type ThinProfunctor :: forall {j} {k}. j +-> k -> Constraint 10 | class Profunctor p => ThinProfunctor (p :: j +-> k) where 11 | type HasArrow (p :: j +-> k) (a :: k) (b :: j) :: Constraint 12 | type HasArrow p a b = () 13 | arr :: (Ob a, Ob b, HasArrow p a b) => p a b 14 | withArr :: p a b -> (HasArrow p a b => r) -> r 15 | 16 | class (ThinProfunctor ((~>) :: CAT k)) => Thin k 17 | instance (ThinProfunctor ((~>) :: CAT k)) => Thin k 18 | 19 | class HasArrow p a b => HasArrow' p a b 20 | instance HasArrow p a b => HasArrow' p a b 21 | 22 | class (ThinProfunctor p) => Codiscrete p where 23 | anyArr :: (Ob a, Ob b) => p a b 24 | default anyArr :: (Ob a, Ob b, forall c d. (Ob c, Ob d) => HasArrow' p c d) => p a b 25 | anyArr = arr 26 | 27 | class (ThinProfunctor p) => Discrete p where 28 | withEq :: p a b -> (a ~ b => r) -> r 29 | default withEq :: (forall c d. HasArrow' p c d => c ~ d) => p a b -> (a ~ b => r) -> r 30 | withEq = withArr 31 | 32 | newtype THIN k = T k 33 | type instance UN T (T a) = a 34 | 35 | class (Thin k, HasArrow (~>) (UN T a) (UN T b), COb a, COb b) => ThinCategory (a :: THIN k) b 36 | instance (Thin k, HasArrow (~>) (UN T a) (UN T b), COb a, COb b) => ThinCategory (a :: THIN k) b 37 | 38 | instance Thin k => CProfunctor (ThinCategory :: POS (THIN k)) where 39 | cdimap = cdimapDefault 40 | obs = Sub Dict 41 | instance Thin k => CPromonad (ThinCategory :: POS (THIN k)) where 42 | cid @(T a) = Sub (withArr (obj @a) Dict) 43 | ccomp @a @b @c = Sub (withArr (arr @(~>) @(UN T b) @(UN T c) . arr @(~>) @(UN T a) @(UN T b)) Dict) 44 | 45 | instance Thin k => PreorderOf (THIN k) where 46 | type (<=) = ThinCategory 47 | type COb a = (Is T a, Ob (UN T a)) -------------------------------------------------------------------------------- /src/Proarrow/Profunctor.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor 2 | ( PRO 3 | , Profunctor (..) 4 | , lmap 5 | , rmap 6 | , (//) 7 | ) where 8 | 9 | import Proarrow.Core 10 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Cofree.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Profunctor.Cofree where 4 | 5 | import Data.Kind (Constraint) 6 | import Prelude (Int) 7 | 8 | import Proarrow.Adjunction (Adjunction (..)) 9 | import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..)) 10 | import Proarrow.Core (CategoryOf (..), OB, Profunctor (..), Promonad (..), type (+->)) 11 | import Proarrow.Profunctor.Composition ((:.:) (..)) 12 | import Proarrow.Profunctor.Forget (Forget (..)) 13 | import Proarrow.Profunctor.Representable (Representable (..), repObj) 14 | import Proarrow.Profunctor.Star (Star (..)) 15 | 16 | type HasCofree :: forall {k}. (k -> Constraint) -> Constraint 17 | class 18 | (CategoryOf k, Representable (Cofree ob), forall b. (Ob b) => ob (Cofree ob % b)) => 19 | HasCofree (ob :: k -> Constraint) 20 | where 21 | type Cofree ob :: k +-> k 22 | lower' :: Cofree ob a b -> a ~> b 23 | section' :: (ob a) => a ~> b -> Cofree ob a b 24 | 25 | lower :: forall ob a. (HasCofree ob, Ob a) => Cofree ob % a ~> a 26 | lower = lower' @ob (tabulate @(Cofree ob) (repObj @(Cofree ob) @a)) 27 | 28 | section :: forall ob a. (HasCofree ob, ob a, Ob a) => a ~> Cofree ob % a 29 | section = index @(Cofree ob) (section' @ob id) 30 | 31 | type CofreeSub :: forall (ob :: OB k) -> k +-> SUBCAT ob 32 | data CofreeSub ob a b where 33 | CofreeSub :: (ob a) => a ~> b -> CofreeSub ob (SUB a) b 34 | 35 | instance (CategoryOf k) => Profunctor (CofreeSub (ob :: OB k)) where 36 | dimap (Sub f) g (CofreeSub h) = CofreeSub (g . h . f) 37 | r \\ CofreeSub p = r \\ p 38 | 39 | instance (HasCofree ob) => Representable (CofreeSub ob) where 40 | type CofreeSub ob % a = SUB (Cofree ob % a) 41 | index (CofreeSub f) = Sub (index (section' @ob f)) \\ f 42 | tabulate (Sub f) = CofreeSub (lower' @ob (tabulate f)) 43 | repMap f = Sub (repMap @(Cofree ob) f) \\ f 44 | 45 | instance (HasCofree ob) => Adjunction (Forget ob) (CofreeSub ob) where 46 | unit = CofreeSub id :.: Forget id 47 | counit (Forget f :.: CofreeSub g) = g . f 48 | 49 | class Test a where 50 | test :: a -> Int 51 | instance HasCofree Test where 52 | type Cofree Test = Star ((,) Int) 53 | lower' (Star f) a = case f a of (_, b) -> b 54 | section' f = Star \a -> (test a, f a) 55 | instance Test (Int, a) where 56 | test (i, _) = i -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Composition.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Composition where 2 | 3 | import Proarrow.Category.Instance.Nat (Nat (..)) 4 | import Proarrow.Category.Instance.Prof (Prof (..)) 5 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..)) 6 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, rmap, type (+->), tgt) 7 | import Proarrow.Functor (Functor (..)) 8 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..), withCorepOb) 9 | import Proarrow.Profunctor.Representable (Representable (..), withRepOb) 10 | import Proarrow.Category.Monoidal.Action (Strong (..)) 11 | import Proarrow.Object.BinaryCoproduct (Coprod (..), copar0, copar) 12 | 13 | type (:.:) :: (j +-> k) -> (i +-> j) -> (i +-> k) 14 | data (p :.: q) a c where 15 | (:.:) :: p a b -> q b c -> (p :.: q) a c 16 | 17 | instance (Profunctor p, Profunctor q) => Profunctor (p :.: q) where 18 | dimap l r (p :.: q) = lmap l p :.: rmap r q 19 | r \\ p :.: q = r \\ p \\ q 20 | 21 | instance (Profunctor p) => Functor ((:.:) p) where 22 | map (Prof n) = Prof \(p :.: q) -> p :.: n q 23 | 24 | instance Functor (:.:) where 25 | map (Prof n) = Nat (Prof \(p :.: q) -> n p :.: q) 26 | 27 | bimapComp :: (a ~> b) -> (c ~> d) -> a :.: c ~> b :.: d 28 | bimapComp f g = unNat (map f) . map g \\ f \\ g 29 | 30 | instance (Representable p, Representable q) => Representable (p :.: q) where 31 | type (p :.: q) % a = p % (q % a) 32 | index (p :.: q) = repMap @p (index q) . index p 33 | tabulate :: forall a b. (Ob b) => (a ~> ((p :.: q) % b)) -> (:.:) p q a b 34 | tabulate f = withRepOb @q @b (tabulate f :.: tabulate id) 35 | repMap f = repMap @p (repMap @q f) 36 | 37 | instance (Corepresentable p, Corepresentable q) => Corepresentable (p :.: q) where 38 | type (p :.: q) %% a = q %% (p %% a) 39 | coindex (p :.: q) = coindex q . corepMap @q (coindex p) 40 | cotabulate :: forall a b. (Ob a) => (((p :.: q) %% a) ~> b) -> (:.:) p q a b 41 | cotabulate f = withCorepOb @p @a (cotabulate id :.: cotabulate f) 42 | corepMap f = corepMap @q (corepMap @p f) 43 | 44 | instance (MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (p :.: q) where 45 | par0 = par0 :.: par0 46 | (p :.: q) `par` (r :.: s) = (p `par` r) :.: (q `par` s) 47 | 48 | instance (Profunctor f, Profunctor g, MonoidalProfunctor (Coprod f), MonoidalProfunctor (Coprod g)) => MonoidalProfunctor (Coprod (f :.: g)) where 49 | par0 = Coprod (copar0 :.: copar0) 50 | Coprod (f :.: g) `par` Coprod (h :.: i) = Coprod ((f `copar` h) :.: (g `copar` i)) 51 | 52 | instance (Strong m p, Strong m q) => Strong m (p :.: q) where 53 | act f (p :.: q) = act f p :.: act (tgt f) q 54 | 55 | -- | Horizontal composition 56 | o 57 | :: forall {i} {j} {k} (p :: j +-> k) (q :: j +-> k) (r :: i +-> j) (s :: i +-> j) 58 | . Prof p q 59 | -> Prof r s 60 | -> Prof (p :.: r) (q :.: s) 61 | Prof pq `o` Prof rs = Prof \(p :.: r) -> pq p :.: rs r 62 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Constant.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Constant where 2 | 3 | import Data.Kind (Type) 4 | import Prelude (Monoid (..), ($)) 5 | 6 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 7 | import Proarrow.Category.Monoidal.Action (SelfAction, strongPar0) 8 | import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..)) 9 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->)) 10 | import Proarrow.Profunctor.Composition ((:.:) ((:.:))) 11 | 12 | type Constant :: Type -> j +-> k 13 | data Constant c a b where 14 | Constant :: (Ob a, Ob b) => c -> Constant c a b 15 | 16 | instance (CategoryOf j, CategoryOf k) => Profunctor (Constant c :: j +-> k) where 17 | dimap l r (Constant c) = Constant c \\ l \\ r 18 | r \\ Constant{} = r 19 | 20 | instance (Monoid c, CategoryOf k) => Promonad (Constant c :: k +-> k) where 21 | id = Constant mempty 22 | Constant c1 . Constant c2 = Constant (mappend c1 c2) 23 | 24 | instance (Monoid c, Monoidal j, Monoidal k) => MonoidalProfunctor (Constant c :: j +-> k) where 25 | par0 = Constant mempty 26 | Constant @a1 @b1 c1 `par` Constant @a2 @b2 c2 = withOb2 @k @a1 @a2 $ withOb2 @j @b1 @b2 $ Constant (mappend c1 c2) 27 | 28 | instance (SelfAction k) => Traversable (Constant c :: k +-> k) where 29 | traverse (Constant c :.: r) = strongPar0 :.: Constant c \\ r 30 | 31 | instance (SelfAction k) => Cotraversable (Constant c :: k +-> k) where 32 | cotraverse (r :.: Constant c) = Constant c :.: strongPar0 \\ r 33 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Coproduct.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Coproduct where 2 | 3 | import Proarrow.Core (PRO, Profunctor (..), (:~>)) 4 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 5 | 6 | type (:+:) :: PRO j k -> PRO j k -> PRO j k 7 | data (p :+: q) a b where 8 | InjL :: p a b -> (p :+: q) a b 9 | InjR :: q a b -> (p :+: q) a b 10 | 11 | instance (Profunctor p, Profunctor q) => Profunctor (p :+: q) where 12 | dimap l r (InjL p) = InjL (dimap l r p) 13 | dimap l r (InjR q) = InjR (dimap l r q) 14 | r \\ InjL p = r \\ p 15 | r \\ InjR q = r \\ q 16 | 17 | coproduct :: (p :~> r) -> (q :~> r) -> p :+: q :~> r 18 | coproduct l _ (InjL p) = l p 19 | coproduct _ r (InjR q) = r q 20 | 21 | instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :+: q) where 22 | dagger (InjL p) = InjL (dagger p) 23 | dagger (InjR q) = InjR (dagger q) -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Corepresentable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Profunctor.Corepresentable where 4 | 5 | import Data.Kind (Constraint) 6 | 7 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->)) 8 | import Proarrow.Object (obj) 9 | 10 | infixl 8 %% 11 | 12 | type Corepresentable :: forall {j} {k}. (j +-> k) -> Constraint 13 | class (Profunctor p) => Corepresentable (p :: j +-> k) where 14 | type p %% (a :: k) :: j 15 | coindex :: p a b -> p %% a ~> b 16 | cotabulate :: (Ob a) => (p %% a ~> b) -> p a b 17 | corepMap :: (a ~> b) -> p %% a ~> p %% b 18 | 19 | instance Corepresentable (->) where 20 | type (->) %% a = a 21 | coindex f = f 22 | cotabulate f = f 23 | corepMap f = f 24 | 25 | withCorepOb :: forall p a r. (Corepresentable p, Ob a) => ((Ob (p %% a)) => r) -> r 26 | withCorepOb r = r \\ corepMap @p (obj @a) 27 | 28 | dimapCorep :: forall p a b c d. (Corepresentable p) => (c ~> a) -> (b ~> d) -> p a b -> p c d 29 | dimapCorep l r = cotabulate @p . dimap (corepMap @p l) r . coindex \\ l 30 | 31 | type Corep :: (j +-> k) -> (j +-> k) 32 | data Corep p a b where 33 | Corep :: Ob a => { getCorep :: p %% a ~> b } -> Corep p a b 34 | instance (Corepresentable p) => Profunctor (Corep p) where 35 | dimap f g (Corep h) = Corep (g . h . corepMap @p f) \\ f 36 | r \\ Corep f = r \\ f 37 | instance (Corepresentable p) => Corepresentable (Corep p) where 38 | type Corep p %% a = p %% a 39 | coindex (Corep f) = f 40 | cotabulate = Corep 41 | corepMap = corepMap @p -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Costar.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | module Proarrow.Profunctor.Costar where 3 | 4 | import Control.Monad qualified as P 5 | import Data.Functor.Compose (Compose (..)) 6 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (:~>), type (+->), (//), rmap, obj) 7 | import Proarrow.Functor (Functor (..), Prelude (..)) 8 | import Proarrow.Profunctor.Composition ((:.:) (..)) 9 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..), dimapCorep) 10 | import Proarrow.Promonad (Procomonad (..)) 11 | import Prelude qualified as P 12 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..), withOb2) 13 | import Proarrow.Object.Terminal (HasTerminalObject(..)) 14 | import Proarrow.Object.BinaryProduct (Cartesian, HasBinaryProducts (..)) 15 | import Proarrow.Category.Monoidal.Distributive (Traversable (..), Cotraversable (..)) 16 | import Proarrow.Profunctor.Star (Star (..)) 17 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 18 | 19 | type Costar :: (j -> k) -> k +-> j 20 | data Costar f a b where 21 | Costar :: (Ob a) => {unCostar :: f a ~> b} -> Costar f a b 22 | 23 | instance (Functor f) => Profunctor (Costar f) where 24 | dimap = dimapCorep 25 | r \\ Costar f = r \\ f 26 | 27 | instance (Functor f) => Corepresentable (Costar f) where 28 | type Costar f %% a = f a 29 | coindex = unCostar 30 | cotabulate = Costar 31 | corepMap = map 32 | 33 | instance (P.Monad m) => Procomonad (Costar (Prelude m)) where 34 | extract (Costar f) = f . Prelude . P.pure 35 | duplicate (Costar f) = Costar unPrelude :.: Costar (f . Prelude . P.join . unPrelude) 36 | 37 | composeCostar :: (Functor g) => Costar f :.: Costar g :~> Costar (Compose g f) 38 | composeCostar (Costar f :.: Costar g) = Costar (g . map f . getCompose) 39 | 40 | -- | Every functor between cartesian categories is a colax monoidal functor. 41 | instance (Cartesian j, Cartesian k, Functor (f :: j -> k)) => MonoidalProfunctor (Costar f) where 42 | par0 = Costar terminate 43 | Costar @a f `par` Costar @b g = withOb2 @j @a @b (Costar (f . map (fst @j @a @b) &&& g . map (snd @j @a @b))) 44 | 45 | instance (Functor t, Traversable (Star t)) => Cotraversable (Costar t) where 46 | cotraverse (p :.: Costar f) = p // Costar id :.: case traverse (Star id :.: p) of p' :.: Star g -> rmap (f . g) p' 47 | 48 | costrength :: forall {m} f a b. (Functor f, Strong m (Costar f), Ob (a :: m), Ob b) => f (Act a b) ~> Act a (f b) 49 | costrength = unCostar (act (obj @a) (Costar (obj @(f b)))) -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Coyoneda.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Profunctor.Coyoneda where 4 | 5 | import Data.Kind (Type) 6 | 7 | import Proarrow.Category.Instance.Prof (Prof (..)) 8 | import Proarrow.Core (CategoryOf (..), PRO, Profunctor (..), Promonad (..), (:~>)) 9 | import Proarrow.Functor (Functor (..)) 10 | import Proarrow.Profunctor.Free (HasFree (..)) 11 | import Proarrow.Profunctor.Star (Star (..)) 12 | 13 | type Coyoneda :: (j -> k -> Type) -> PRO j k 14 | data Coyoneda p a b where 15 | Coyoneda :: (a ~> c) -> (d ~> b) -> p c d -> Coyoneda p a b 16 | 17 | instance (CategoryOf j, CategoryOf k) => Profunctor (Coyoneda (p :: j -> k -> Type)) where 18 | dimap l r (Coyoneda f g p) = Coyoneda (f . l) (r . g) p 19 | r \\ Coyoneda f g _ = r \\ f \\ g 20 | 21 | instance (Functor Coyoneda) where 22 | map (Prof n) = Prof \(Coyoneda g h p) -> Coyoneda g h (n p) 23 | 24 | instance HasFree Profunctor where 25 | type Free Profunctor = Star Coyoneda 26 | lift' (Prof n) = Star (Prof \p -> coyoneda (n p) \\ p) 27 | retract' (Star (Prof f)) = Prof (unCoyoneda . f) 28 | 29 | coyoneda :: (CategoryOf j, CategoryOf k, Ob a, Ob b) => p a b -> Coyoneda (p :: j -> k -> Type) a b 30 | coyoneda = Coyoneda id id 31 | 32 | unCoyoneda :: (Profunctor p) => Coyoneda p :~> p 33 | unCoyoneda (Coyoneda f g p) = dimap f g p -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Exponential.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Exponential where 2 | 3 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (//)) 4 | 5 | data (p :~>: q) a b where 6 | Exp :: (Ob a, Ob b) => (forall c d. c ~> a -> b ~> d -> p c d -> q c d) -> (p :~>: q) a b 7 | 8 | instance (Profunctor p, Profunctor q) => Profunctor (p :~>: q) where 9 | dimap l r (Exp f) = l // r // Exp \ca bd p -> f (l . ca) (bd . r) p 10 | r \\ Exp{} = r 11 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Fix.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Fix where 2 | 3 | import Data.Functor.Const (Const (..)) 4 | 5 | import Proarrow.Category.Instance.Nat (Nat (..)) 6 | import Proarrow.Category.Instance.Prof (Prof (..)) 7 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..)) 8 | import Proarrow.Category.Monoidal.Distributive (Traversable (..), Cotraversable (..)) 9 | import Proarrow.Core (Profunctor (..), Promonad (..), (:~>), type (+->)) 10 | import Proarrow.Functor (Functor (..)) 11 | import Proarrow.Profunctor.Composition ((:.:) (..)) 12 | import Proarrow.Profunctor.Star (Star (..)) 13 | 14 | type Fix :: k +-> k -> k +-> k 15 | data Fix p a b where 16 | In :: {out :: ~((p :.: Fix p) a b)} -> Fix p a b 17 | 18 | instance (Profunctor p) => Profunctor (Fix p) where 19 | dimap l r = In . dimap l r . out \\ l \\ r 20 | r \\ In p = r \\ p 21 | 22 | instance (Promonad p) => Promonad (Fix p) where 23 | id = In (id :.: id) 24 | qs . In (p :.: ps) = In (p :.: (qs . ps)) 25 | 26 | instance Functor Fix where 27 | map n@Prof{} = Prof (In . unProf (unNat (map n) . map (map n)) . out) 28 | 29 | instance (MonoidalProfunctor p) => MonoidalProfunctor (Fix p) where 30 | par0 = In par0 31 | In p `par` In q = In (p `par` q) 32 | 33 | instance (Traversable p) => Traversable (Fix p) where 34 | traverse (In pfp :.: r) = case traverse (pfp :.: r) of r' :.: pfp' -> r' :.: In pfp' 35 | 36 | instance (Cotraversable p) => Cotraversable (Fix p) where 37 | cotraverse (r :.: In pfp) = case cotraverse (r :.: pfp) of pfp' :.: r' -> In pfp' :.: r' 38 | 39 | hylo :: (Profunctor p, Profunctor a, Profunctor b) => (p :.: b :~> b) -> (a :~> p :.: a) -> a :~> b 40 | hylo alg coalg = unProf go where go = Prof alg . map go . Prof coalg 41 | 42 | cata :: (Profunctor p, Profunctor r) => (p :.: r :~> r) -> Fix p :~> r 43 | cata alg = hylo alg out 44 | 45 | ana :: (Profunctor p, Profunctor r) => (r :~> p :.: r) -> r :~> Fix p 46 | ana coalg = hylo In coalg 47 | 48 | data ListF x l = Nil | Cons x l 49 | instance Functor (ListF x) where 50 | map _ Nil = Nil 51 | map f (Cons x l) = Cons x (f l) 52 | 53 | embed :: ListF x [x] -> [x] 54 | embed Nil = [] 55 | embed (Cons x xs) = x : xs 56 | 57 | project :: [x] -> ListF x [x] 58 | project [] = Nil 59 | project (x : xs) = Cons x xs 60 | 61 | embed' :: Star (ListF x) :.: Star (Const [x]) :~> Star (Const [x]) 62 | embed' (Star f :.: Star g) = Star (Const . embed . map (getConst . g) . f) 63 | 64 | project' :: Star (Const [x]) :~> Star (ListF x) :.: Star (Const [x]) 65 | project' (Star f) = Star (project . getConst . f) :.: Star Const 66 | 67 | toList :: Fix (Star (ListF x)) :~> Star (Const [x]) 68 | toList = cata embed' 69 | 70 | fromList :: Star (Const [x]) :~> Fix (Star (ListF x)) 71 | fromList = ana project' 72 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Fold.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | -- from Data.Fold.M of the Folds package 4 | module Proarrow.Profunctor.Fold where 5 | 6 | import Data.Kind (Type) 7 | import Prelude qualified as P 8 | 9 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, swapInner) 10 | import Proarrow.Category.Monoidal.Action (Strong (..), Costrong (..), MonoidalAction (..)) 11 | import Proarrow.Category.Monoidal.Applicative (Applicative (..)) 12 | import Proarrow.Category.Monoidal.Distributive (distLProd, distRProd) 13 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (//), type (+->), obj) 14 | import Proarrow.Functor (map) 15 | import Proarrow.Monoid (Monoid (..)) 16 | import Proarrow.Object.BinaryCoproduct (COPROD (..), Coprod (..), CoprodAction, HasBinaryCoproducts (..), right) 17 | import Proarrow.Object.BinaryProduct (HasBinaryProducts (..), ProdAction) 18 | import Proarrow.Object.Exponential (BiCCC) 19 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..)) 20 | import Proarrow.Promonad (Procomonad (..)) 21 | import Proarrow.Profunctor.Composition ((:.:) (..)) 22 | import Proarrow.Profunctor.Identity (Id(..)) 23 | 24 | 25 | 26 | data Fold a b where 27 | Fold :: (Ob m) => (m ~> b) -> (a ~> m) -> (m ** m ~> m) -> (Unit ~> m) -> Fold a b 28 | 29 | instance (CategoryOf k) => Profunctor (Fold :: k +-> k) where 30 | dimap f g (Fold k h m z) = Fold (g . k) (h . f) m z 31 | r \\ Fold f g _ _ = r \\ f \\ g 32 | 33 | instance CategoryOf k => Procomonad (Fold :: k +-> k) where 34 | extract (Fold f g _ _) = f . g 35 | duplicate (Fold f g m z) = Fold id g m z :.: Fold f id m z 36 | 37 | instance (SymMonoidal k) => MonoidalProfunctor (Fold :: k +-> k) where 38 | par0 = Fold id id leftUnitor id 39 | Fold @m f g m z `par` Fold @n f' g' m' z' = 40 | withOb2 @k @m @n P.$ 41 | Fold (f `par` f') (g `par` g') ((m `par` m') . swapInner @m @n @m @n) ((z `par` z') . leftUnitorInv) 42 | 43 | instance (CoprodAction k, BiCCC k) => Strong (COPROD k) (Fold :: k +-> k) where 44 | act (Coprod @_ @a (Id f)) (Fold @m k h m z) = f // withObCoprod @k @a @m P.$ Fold (f +++ k) (right @a h) (step m) (rgt @_ @a @m . z) 45 | where 46 | step :: (Ob m, Ob a, Ob (a || m)) => (m && m) ~> m -> (a || m) && (a || m) ~> (a || m) 47 | step mult = (lft @k @a @m . fst @k @a @(a || m) ||| (snd @k @m @a +++ mult) . distLProd @m @a @m) . distRProd @a @m @(a || m) 48 | 49 | instance (ProdAction k) => Costrong k (Fold :: k +-> k) where 50 | coact @a @x @y (Fold f g m z) = Fold (snd @k @a @y . f) (g . act (fst @k @a @y . f . z) (obj @x) . unitorInv @k @k @x) m z 51 | 52 | trav :: (Applicative f) => Fold a b -> Fold (f a) (f b) 53 | trav (Fold @m k h m z) = Fold (map k) (map h) (liftA2 @_ @m @m m) (pure z) 54 | 55 | instance Corepresentable (Fold :: Type +-> Type) where 56 | type Fold %% a = [a] 57 | cotabulate f = Fold f (: []) mappend mempty 58 | coindex (Fold f g m z) xs = f (go xs) 59 | where 60 | go [] = z () 61 | go (x : xs') = m (g x, go xs') 62 | corepMap = map 63 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Forget.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Forget where 2 | 3 | import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..)) 4 | import Proarrow.Core (CategoryOf (..), OB, Profunctor (..), Promonad (..), type (+->)) 5 | import Proarrow.Profunctor.Representable (Representable (..)) 6 | 7 | type Forget :: forall (ob :: OB k) -> SUBCAT ob +-> k 8 | data Forget ob a b where 9 | Forget :: (ob b) => a ~> b -> Forget ob a (SUB b) 10 | 11 | instance (CategoryOf k) => Profunctor (Forget (ob :: OB k)) where 12 | dimap l (Sub r) (Forget f) = Forget (r . f . l) 13 | r \\ Forget f = r \\ f 14 | 15 | instance (CategoryOf k) => Representable (Forget (ob :: OB k)) where 16 | type Forget ob % (SUB a) = a 17 | index (Forget f) = f 18 | tabulate = Forget 19 | repMap (Sub f) = f 20 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Identity.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Identity where 2 | 3 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..)) 4 | import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..)) 5 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..)) 6 | import Proarrow.Profunctor.Representable (Representable (..)) 7 | import Proarrow.Category.Dagger (DaggerProfunctor (..), Dagger) 8 | import Proarrow.Category.Monoidal.Action (Strong (..), MonoidalAction) 9 | 10 | type Id :: CAT k 11 | newtype Id a b = Id {unId :: a ~> b} 12 | 13 | instance (CategoryOf k) => Profunctor (Id :: CAT k) where 14 | dimap l r (Id f) = Id (r . f . l) 15 | r \\ Id f = r \\ f 16 | 17 | instance (CategoryOf k) => Promonad (Id :: CAT k) where 18 | id = Id id 19 | Id f . Id g = Id (f . g) 20 | 21 | instance (CategoryOf k) => Representable (Id :: CAT k) where 22 | type Id % a = a 23 | index = unId 24 | tabulate = Id 25 | repMap = id 26 | 27 | instance (CategoryOf k) => Corepresentable (Id :: CAT k) where 28 | type Id %% a = a 29 | coindex = unId 30 | cotabulate = Id 31 | corepMap = id 32 | 33 | instance (Monoidal k) => MonoidalProfunctor (Id :: CAT k) where 34 | par0 = Id par0 35 | Id f `par` Id g = Id (f `par` g) 36 | 37 | instance (Dagger k) => DaggerProfunctor (Id :: CAT k) where 38 | dagger (Id p) = Id (dagger p) 39 | 40 | instance (Strong m ((~>) :: CAT k), MonoidalAction m k) => Strong m (Id :: CAT k) where 41 | act f (Id g) = Id (act f g) 42 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Initial.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Initial where 2 | 3 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 4 | import Proarrow.Core (CategoryOf, Profunctor (..), type (+->)) 5 | 6 | type InitialProfunctor :: j +-> k 7 | data InitialProfunctor a b 8 | 9 | instance (CategoryOf j, CategoryOf k) => Profunctor (InitialProfunctor :: j +-> k) where 10 | dimap _ _ = \case {} 11 | (\\) _ = \case {} 12 | 13 | instance (CategoryOf k) => DaggerProfunctor (InitialProfunctor :: k +-> k) where 14 | dagger = \case {} 15 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Product.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Product where 2 | 3 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..)) 4 | import Proarrow.Core (PRO, Profunctor (..), (:~>)) 5 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 6 | 7 | type (:*:) :: PRO j k -> PRO j k -> PRO j k 8 | data (p :*: q) a b where 9 | (:*:) :: {fstP :: p a b, sndP :: q a b} -> (p :*: q) a b 10 | 11 | prod :: (r :~> p) -> (r :~> q) -> r :~> p :*: q 12 | prod l r p = l p :*: r p 13 | 14 | instance (Profunctor p, Profunctor q) => Profunctor (p :*: q) where 15 | dimap l r (p :*: q) = dimap l r p :*: dimap l r q 16 | r \\ (p :*: _) = r \\ p 17 | 18 | instance (MonoidalProfunctor p, MonoidalProfunctor q) => MonoidalProfunctor (p :*: q) where 19 | par0 = par0 :*: par0 20 | par (p1 :*: p2) (q1 :*: q2) = par p1 q1 :*: par p2 q2 21 | 22 | instance (DaggerProfunctor p, DaggerProfunctor q) => DaggerProfunctor (p :*: q) where 23 | dagger (p :*: q) = dagger p :*: dagger q -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Ran.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | 3 | module Proarrow.Profunctor.Ran where 4 | 5 | import Prelude (type (~)) 6 | 7 | import Proarrow.Adjunction (Adjunction (..), counitFromRepCounit, unitFromRepUnit) 8 | import Proarrow.Category.Instance.Nat (Nat (..)) 9 | import Proarrow.Category.Instance.Prof (Prof (..)) 10 | import Proarrow.Category.Opposite (OPPOSITE (..), Op (..)) 11 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, rmap, (//), type (+->)) 12 | import Proarrow.Functor (Functor (..)) 13 | import Proarrow.Profunctor.Composition ((:.:) (..)) 14 | import Proarrow.Profunctor.Costar (Costar (..)) 15 | import Proarrow.Profunctor.Star (Star (..)) 16 | 17 | -- Note: Ran and Rift are swapped compared to the profunctors package. 18 | 19 | type j |> p = Ran (OP j) p 20 | 21 | type Ran :: OPPOSITE (i +-> j) -> i +-> k -> j +-> k 22 | data Ran j p a b where 23 | Ran :: (Ob a, Ob b) => {unRan :: forall x. (Ob x) => j b x -> p a x} -> Ran (OP j) p a b 24 | 25 | runRan :: (Profunctor j) => j b x -> Ran (OP j) p a b -> p a x 26 | runRan j (Ran k) = k j \\ j 27 | 28 | flipRan :: (Functor j, Profunctor p) => Costar j |> p ~> p :.: Star j 29 | flipRan = Prof \(Ran k) -> k (Costar id) :.: Star id 30 | 31 | flipRanInv :: (Functor j, Profunctor p) => p :.: Star j ~> Costar j |> p 32 | flipRanInv = Prof \(p :.: Star f) -> p // Ran \(Costar g) -> rmap (g . f) p 33 | 34 | instance (Profunctor p, Profunctor j) => Profunctor (Ran (OP j) p) where 35 | dimap l r (Ran k) = l // r // Ran (lmap l . k . lmap r) 36 | r \\ Ran{} = r 37 | 38 | instance (Profunctor j) => Functor (Ran (OP j)) where 39 | map (Prof n) = Prof \(Ran k) -> Ran (n . k) 40 | 41 | instance Functor Ran where 42 | map (Op (Prof n)) = Nat (Prof \(Ran k) -> Ran (k . n)) 43 | 44 | instance (p ~ j, Profunctor p) => Promonad (Ran (OP p) p) where 45 | id = Ran id 46 | Ran l . Ran r = Ran (r . l) 47 | 48 | newtype Precompose j p a b = Precompose {unPrecompose :: (p :.: j) a b} 49 | instance (Profunctor j, Profunctor p) => Profunctor (Precompose j p) where 50 | dimap l r (Precompose pj) = Precompose (dimap l r pj) 51 | r \\ Precompose pj = r \\ pj 52 | instance (Profunctor j) => Functor (Precompose j) where 53 | map f = f // Prof \(Precompose pj) -> Precompose (unProf (unNat (map f)) pj) 54 | 55 | instance (Profunctor j) => Adjunction (Star (Precompose j)) (Star (Ran (OP j))) where 56 | unit = unitFromRepUnit (Prof \p -> p // Ran \j -> Precompose (p :.: j)) 57 | counit = counitFromRepCounit (Prof \(Precompose (r :.: j)) -> runRan j r) 58 | 59 | ranCompose :: (Profunctor i, Profunctor j, Profunctor p) => i |> (j |> p) ~> (i :.: j) |> p 60 | ranCompose = Prof \k -> k // Ran \(i :.: j) -> runRan j (runRan i k) 61 | 62 | ranComposeInv :: (Profunctor i, Profunctor j, Profunctor p) => (i :.: j) |> p ~> i |> (j |> p) 63 | ranComposeInv = Prof \k -> k // Ran \i -> Ran \j -> runRan (i :.: j) k 64 | 65 | ranHom :: Profunctor p => p ~> (~>) |> p 66 | ranHom = Prof \p -> p // Ran \j -> rmap j p 67 | 68 | ranHomInv :: Profunctor p => (~>) |> p ~> p 69 | ranHomInv = Prof \(Ran k) -> k id -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Representable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Profunctor.Representable where 4 | 5 | import Data.Kind (Constraint) 6 | 7 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->), (:~>)) 8 | import Proarrow.Object (Obj, obj) 9 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..), dimapCorep) 10 | 11 | infixl 8 % 12 | 13 | type Representable :: forall {j} {k}. j +-> k -> Constraint 14 | class (Profunctor p) => Representable (p :: j +-> k) where 15 | type p % (a :: j) :: k 16 | index :: p a b -> a ~> p % b 17 | tabulate :: (Ob b) => (a ~> p % b) -> p a b 18 | repMap :: (a ~> b) -> p % a ~> p % b 19 | 20 | instance Representable (->) where 21 | type (->) % a = a 22 | index f = f 23 | tabulate f = f 24 | repMap f = f 25 | 26 | repObj :: forall p a. (Representable p, Ob a) => Obj (p % a) 27 | repObj = repMap @p (obj @a) 28 | 29 | withRepOb :: forall p a r. (Representable p, Ob a) => ((Ob (p % a)) => r) -> r 30 | withRepOb r = r \\ repObj @p @a 31 | 32 | dimapRep :: forall p a b c d. (Representable p) => (c ~> a) -> (b ~> d) -> p a b -> p c d 33 | dimapRep l r = tabulate @p . dimap l (repMap @p r) . index \\ r 34 | 35 | type RepStar :: (j +-> k) -> (j +-> k) 36 | data RepStar p a b where 37 | RepStar :: (Ob b) => {unRepStar :: a ~> p % b} -> RepStar p a b 38 | instance (Representable p) => Profunctor (RepStar p) where 39 | dimap = dimapRep 40 | r \\ RepStar f = r \\ f 41 | instance (Representable p) => Representable (RepStar p) where 42 | type RepStar p % a = p % a 43 | index (RepStar f) = f 44 | tabulate = RepStar 45 | repMap = repMap @p 46 | 47 | type CorepStar :: (k +-> j) -> (j +-> k) 48 | data CorepStar p a b where 49 | CorepStar :: (Ob b) => {unCorepStar :: a ~> p %% b} -> CorepStar p a b 50 | instance (Corepresentable p) => Profunctor (CorepStar p) where 51 | dimap = dimapRep 52 | r \\ CorepStar f = r \\ f 53 | instance (Corepresentable p) => Representable (CorepStar p) where 54 | type CorepStar p % a = p %% a 55 | index (CorepStar f) = f 56 | tabulate = CorepStar 57 | repMap = corepMap @p 58 | 59 | type RepCostar :: (k +-> j) -> (j +-> k) 60 | data RepCostar p a b where 61 | RepCostar :: (Ob a) => {unRepCostar :: p % a ~> b} -> RepCostar p a b 62 | instance (Representable p) => Profunctor (RepCostar p) where 63 | dimap = dimapCorep 64 | r \\ RepCostar f = r \\ f 65 | instance (Representable p) => Corepresentable (RepCostar p) where 66 | type RepCostar p %% a = p % a 67 | coindex (RepCostar f) = f 68 | cotabulate = RepCostar 69 | corepMap = repMap @p 70 | 71 | flipRep :: forall p q. (Representable p, Corepresentable q) => RepCostar p :~> q -> CorepStar q :~> p 72 | flipRep n (CorepStar @b q) = tabulate @p (coindex @q @b (n (RepCostar (repMap @p (obj @b)))) . q) -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Rift.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Rift where 2 | 3 | import Prelude (type (~)) 4 | 5 | import Proarrow.Adjunction (Adjunction (..), counitFromRepCounit, unitFromRepUnit) 6 | import Proarrow.Category.Instance.Nat (Nat (..)) 7 | import Proarrow.Category.Instance.Prof (Prof (..)) 8 | import Proarrow.Category.Opposite (OPPOSITE (..), Op (..)) 9 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, rmap, (//), type (+->)) 10 | import Proarrow.Functor (Functor (..)) 11 | import Proarrow.Profunctor.Composition ((:.:) (..)) 12 | import Proarrow.Profunctor.Costar (Costar (..)) 13 | import Proarrow.Profunctor.Star (Star (..)) 14 | 15 | -- Note: Ran and Rift are swapped compared to the profunctors package. 16 | 17 | type p <| j = Rift (OP j) p 18 | 19 | type Rift :: OPPOSITE (k +-> i) -> j +-> i -> j +-> k 20 | data Rift j p a b where 21 | Rift :: (Ob a, Ob b) => {unRift :: forall x. (Ob x) => j x a -> p x b} -> Rift (OP j) p a b 22 | 23 | runRift :: (Profunctor j) => j x a -> Rift (OP j) p a b -> p x b 24 | runRift j (Rift k) = k j \\ j 25 | 26 | flipRift :: (Functor j, Profunctor p) => p <| Star j ~> Costar j :.: p 27 | flipRift = Prof \(Rift k) -> Costar id :.: k (Star id) 28 | 29 | flipRiftInv :: (Functor j, Profunctor p) => Costar j :.: p ~> p <| Star j 30 | flipRiftInv = Prof \(Costar f :.: p) -> p // Rift \(Star g) -> lmap (f . g) p 31 | 32 | instance (Profunctor p, Profunctor j) => Profunctor (Rift (OP j) p) where 33 | dimap l r (Rift k) = r // l // Rift (rmap r . k . rmap l) 34 | r \\ Rift{} = r 35 | 36 | instance (Profunctor j) => Functor (Rift (OP j)) where 37 | map (Prof n) = Prof \(Rift k) -> Rift (n . k) 38 | 39 | instance Functor Rift where 40 | map (Op (Prof n)) = Nat (Prof \(Rift k) -> Rift (k . n)) 41 | 42 | instance (Profunctor j) => Adjunction (Star ((:.:) j)) (Star (Rift (OP j))) where 43 | unit = unitFromRepUnit (Prof \p -> p // Rift (:.: p)) 44 | counit = counitFromRepCounit (Prof \(j :.: r) -> runRift j r) 45 | 46 | instance (p ~ j, Profunctor p) => Promonad (Rift (OP p) p) where 47 | id = Rift id 48 | Rift l . Rift r = Rift (l . r) 49 | 50 | riftCompose :: (Profunctor i, Profunctor j, Profunctor p) => (p <| j) <| i ~> p <| (j :.: i) 51 | riftCompose = Prof \k -> k // Rift \(j :.: i) -> runRift j (runRift i k) 52 | 53 | riftComposeInv :: (Profunctor i, Profunctor j, Profunctor p) => p <| (j :.: i) ~> (p <| j) <| i 54 | riftComposeInv = Prof \k -> k // Rift \i -> Rift \j -> runRift (j :.: i) k 55 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Star.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | 3 | module Proarrow.Profunctor.Star where 4 | 5 | import Data.Functor.Compose (Compose (..)) 6 | import Data.Kind (Type) 7 | import Prelude qualified as P 8 | 9 | import Proarrow.Category.Instance.Nat (Nat (..)) 10 | import Proarrow.Category.Instance.Sub (SUBCAT, Sub (..)) 11 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..), Monoidal (..)) 12 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), Strong (..)) 13 | import Proarrow.Category.Monoidal.Applicative (Alternative (..), Applicative (..)) 14 | import Proarrow.Category.Monoidal.Distributive (Traversable (..), Distributive) 15 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, obj, (:~>), type (+->)) 16 | import Proarrow.Functor (Functor (..), Prelude (..)) 17 | import Proarrow.Object.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), copar) 18 | import Proarrow.Profunctor.Composition ((:.:) (..)) 19 | import Proarrow.Profunctor.Representable (Representable (..), dimapRep) 20 | import Proarrow.Object.Initial (initiate) 21 | import Proarrow.Profunctor.Identity (Id(..)) 22 | 23 | type Star :: (k1 -> k2) -> k1 +-> k2 24 | data Star f a b where 25 | Star :: (Ob b) => {unStar :: a ~> f b} -> Star f a b 26 | 27 | instance (Functor f) => Profunctor (Star f) where 28 | dimap = dimapRep 29 | r \\ Star f = r \\ f 30 | 31 | instance (Functor f) => Representable (Star f) where 32 | type Star f % a = f a 33 | index = unStar 34 | tabulate = Star 35 | repMap = map 36 | 37 | instance (P.Monad m) => Promonad (Star (Prelude m)) where 38 | id = Star (Prelude . P.pure) 39 | Star g . Star f = Star \a -> Prelude (unPrelude (f a) P.>>= (unPrelude . g)) 40 | 41 | composeStar :: (Functor f) => Star f :.: Star g :~> Star (Compose f g) 42 | composeStar (Star f :.: Star g) = Star (Compose . map g . f) 43 | 44 | instance (Applicative f, Monoidal j, Monoidal k) => MonoidalProfunctor (Star (f :: j -> k)) where 45 | par0 = Star (pure id) 46 | Star @a f `par` Star @b g = withOb2 @_ @a @b (Star (liftA2 @f @a @b id . (f `par` g))) 47 | 48 | instance (Functor f, Distributive j, Distributive k) => MonoidalProfunctor (Coprod (Star (f :: j -> k))) where 49 | par0 = Coprod (Star initiate) 50 | Coprod (Star @a f) `par` Coprod (Star @b g) = withObCoprod @_ @a @b (Coprod (Star ((map (lft @_ @a @b) . f ||| map (rgt @_ @a @b) . g)))) 51 | 52 | -- Hmm, another wrapper required... 53 | type CoprodDom :: j +-> k -> COPROD j +-> k 54 | data CoprodDom p a b where 55 | Co :: {unCo :: p a b} -> CoprodDom p a (COPR b) 56 | instance (Profunctor p) => Profunctor (CoprodDom p) where 57 | dimap l (Coprod (Id r)) (Co p) = Co (dimap l r p) 58 | r \\ Co p = r \\ p 59 | 60 | instance (Alternative f, Monoidal k, Distributive j) => MonoidalProfunctor (CoprodDom (Star (f :: j -> k))) where 61 | par0 = Co (Star empty) 62 | Co (Star @a f) `par` Co (Star @b g) = let ab = obj @a +++ obj @b in Co (Star (alt @f @a @b ab . (f `par` g))) \\ ab 63 | 64 | instance (Functor (f :: Type -> Type)) => Strong Type (Star f) where 65 | act f (Star k) = Star (\(a, x) -> map (f a,) (k x)) 66 | 67 | instance (Functor f, P.Applicative f) => Strong (SUBCAT P.Traversable) (Star (Prelude f)) where 68 | act (Sub (Nat n)) (Star f) = Star (\t -> Prelude (P.traverse (unPrelude . f) (n t))) 69 | 70 | instance Traversable (Star P.Maybe) where 71 | traverse (Star a2mb :.: p) = lmap a2mb go :.: Star id 72 | where 73 | go = 74 | dimap 75 | (P.maybe (P.Left ()) P.Right) 76 | (P.const P.Nothing ||| P.Just) 77 | (par0 `copar` p) 78 | 79 | instance Traversable (Star []) where 80 | traverse (Star a2bs :.: p) = lmap a2bs go :.: Star id 81 | where 82 | go = 83 | dimap 84 | (\l -> case l of [] -> P.Left (); (x : xs) -> P.Right (x, xs)) 85 | (P.const [] ||| \(x, xs) -> x : xs) 86 | (par0 `copar` (p `par` go)) 87 | 88 | strength :: forall {m} f a b. (Functor f, Strong m (Star f), Ob (a :: m), Ob b) => Act a (f b) ~> f (Act a b) 89 | strength = unStar (act (obj @a) (Star (obj @(f b)))) -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Terminal.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Terminal (TerminalProfunctor (.., TerminalProfunctor)) where 2 | 3 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 4 | import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor (..)) 5 | import Proarrow.Core (CategoryOf (..), Profunctor (..), type (+->), Promonad (..)) 6 | import Proarrow.Object (pattern Obj, type Obj) 7 | import Proarrow.Preorder.ThinCategory (Codiscrete, ThinProfunctor (..)) 8 | 9 | type TerminalProfunctor :: j +-> k 10 | data TerminalProfunctor a b where 11 | TerminalProfunctor' :: Obj a -> Obj b -> TerminalProfunctor (a :: j) (b :: k) 12 | 13 | instance (CategoryOf j, CategoryOf k) => Profunctor (TerminalProfunctor :: j +-> k) where 14 | dimap l r TerminalProfunctor = TerminalProfunctor \\ l \\ r 15 | r \\ TerminalProfunctor = r 16 | 17 | instance (CategoryOf k) => Promonad (TerminalProfunctor :: k +-> k) where 18 | id = TerminalProfunctor 19 | TerminalProfunctor . TerminalProfunctor = TerminalProfunctor 20 | 21 | instance (Monoidal j, Monoidal k) => MonoidalProfunctor (TerminalProfunctor :: j +-> k) where 22 | par0 = TerminalProfunctor' par0 par0 23 | TerminalProfunctor' a1 b1 `par` TerminalProfunctor' a2 b2 = TerminalProfunctor' (a1 `par` a2) (b1 `par` b2) 24 | 25 | instance (CategoryOf k) => DaggerProfunctor (TerminalProfunctor :: k +-> k) where 26 | dagger TerminalProfunctor = TerminalProfunctor 27 | 28 | pattern TerminalProfunctor :: forall {j} {k} a b. (CategoryOf j, CategoryOf k) => (Ob (a :: j), Ob (b :: k)) => TerminalProfunctor a b 29 | pattern TerminalProfunctor = TerminalProfunctor' Obj Obj 30 | 31 | {-# COMPLETE TerminalProfunctor #-} 32 | 33 | instance (CategoryOf j, CategoryOf k) => ThinProfunctor (TerminalProfunctor :: j +-> k) where 34 | arr = TerminalProfunctor 35 | withArr TerminalProfunctor r = r 36 | 37 | instance (CategoryOf j, CategoryOf k) => Codiscrete (TerminalProfunctor :: j +-> k) -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Wrapped.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Profunctor.Wrapped where 2 | 3 | import Proarrow.Category.Instance.Prof (Prof (..)) 4 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..)) 5 | import Proarrow.Core (Profunctor (..), Promonad (..)) 6 | import Proarrow.Monoid (Comonoid (..), Monoid (..)) 7 | import Proarrow.Profunctor.Day (Day (..), DayUnit (..)) 8 | import Proarrow.Category.Dagger (DaggerProfunctor (..)) 9 | 10 | newtype Wrapped p a b = Wrapped {unWrapped :: p a b} 11 | 12 | instance (Profunctor p) => Profunctor (Wrapped p) where 13 | dimap f g = Wrapped . dimap f g . unWrapped 14 | r \\ Wrapped p = r \\ p 15 | 16 | instance (Promonad p) => Promonad (Wrapped p) where 17 | id = Wrapped id 18 | Wrapped f . Wrapped g = Wrapped (f . g) 19 | 20 | instance (MonoidalProfunctor p) => MonoidalProfunctor (Wrapped p) where 21 | par0 = Wrapped par0 22 | Wrapped l `par` Wrapped r = Wrapped (l `par` r) 23 | 24 | instance (DaggerProfunctor p) => DaggerProfunctor (Wrapped p) where 25 | dagger = Wrapped . dagger . unWrapped 26 | 27 | instance (Comonoid c, Monoid m, MonoidalProfunctor p) => Monoid (Wrapped p c m) where 28 | mempty () = dimap counit mempty par0 29 | mappend (l, r) = dimap comult mappend (l `par` r) 30 | 31 | instance (MonoidalProfunctor p) => Monoid (Wrapped p) where 32 | mempty = Prof \(DayUnit f g) -> Wrapped (dimap f g par0) 33 | mappend = Prof \(Day f (Wrapped p) (Wrapped q) g) -> Wrapped (dimap f g (p `par` q)) 34 | -------------------------------------------------------------------------------- /src/Proarrow/Profunctor/Yoneda.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Profunctor.Yoneda where 4 | 5 | import Data.Function (($)) 6 | 7 | import Proarrow.Category.Instance.Prof (Prof (Prof)) 8 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (//), (:~>), type (+->)) 9 | import Proarrow.Functor (Functor (..)) 10 | import Proarrow.Profunctor.Cofree (HasCofree (..)) 11 | import Proarrow.Profunctor.Star (Star (..)) 12 | import Proarrow.Category.Opposite (OPPOSITE(..), Op(..)) 13 | import Proarrow.Category.Instance.Nat (Nat(..)) 14 | 15 | type Yoneda :: (j +-> k) -> j +-> k 16 | data Yoneda p a b where 17 | Yoneda :: (Ob a, Ob b) => {unYoneda :: Yo a (OP b) :~> p} -> Yoneda p a b 18 | 19 | instance (CategoryOf j, CategoryOf k) => Profunctor (Yoneda (p :: j +-> k)) where 20 | dimap l r (Yoneda k) = l // r // Yoneda \(Yo ca bd) -> k $ Yo (l . ca) (bd . r) 21 | r \\ Yoneda{} = r 22 | 23 | instance Functor Yoneda where 24 | map (Prof n) = Prof \(Yoneda k) -> Yoneda (n . k) 25 | 26 | instance HasCofree Profunctor where 27 | type Cofree Profunctor = Star Yoneda 28 | lower' (Star (Prof n)) = Prof (yoneda . n) 29 | section' (Prof n) = Star (Prof (mkYoneda . n)) 30 | 31 | yoneda :: (CategoryOf j, CategoryOf k) => Yoneda (p :: j +-> k) :~> p 32 | yoneda (Yoneda k) = k $ Yo id id 33 | 34 | mkYoneda :: (Profunctor p) => p :~> Yoneda p 35 | mkYoneda p = p // Yoneda \(Yo ca bd) -> dimap ca bd p 36 | 37 | -- | Yoneda embedding 38 | type Yo :: k -> OPPOSITE j -> j +-> k 39 | data Yo a b c d where 40 | Yo :: c ~> a -> b ~> d -> Yo a (OP b) c d 41 | 42 | instance (CategoryOf j, CategoryOf k) => Profunctor (Yo (a :: k) (OP b :: OPPOSITE j) :: j +-> k) where 43 | dimap l r (Yo f g) = Yo (f . l) (r . g) 44 | r \\ Yo f g = r \\ f \\ g 45 | instance (CategoryOf j, CategoryOf k) => Functor (Yo (a :: k) :: OPPOSITE j -> j +-> k) where 46 | map (Op f) = Prof \(Yo ca bd) -> Yo ca (bd . f) 47 | instance (CategoryOf j, CategoryOf k) => Functor (Yo :: k -> OPPOSITE j -> j +-> k) where 48 | map f = Nat (Prof \(Yo ca bd) -> Yo (f . ca) bd) -------------------------------------------------------------------------------- /src/Proarrow/Promonad.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-orphans #-} 2 | 3 | module Proarrow.Promonad 4 | ( Promonad (..) 5 | , Procomonad (..) 6 | ) where 7 | 8 | import Proarrow.Core (CAT, CategoryOf, Profunctor, Promonad (..), src, (:~>), type (~>)) 9 | import Proarrow.Profunctor.Composition ((:.:) (..)) 10 | import Proarrow.Profunctor.Identity (Id (..)) 11 | 12 | class (Profunctor p) => Procomonad p where 13 | extract :: p :~> (~>) 14 | duplicate :: p :~> p :.: p 15 | 16 | instance (CategoryOf k) => Procomonad (Id :: CAT k) where 17 | extract (Id f) = f 18 | duplicate (Id f) = Id (src f) :.: Id f 19 | -------------------------------------------------------------------------------- /src/Proarrow/Promonad/Cont.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Promonad.Cont where 2 | 3 | import Data.Kind (Type) 4 | 5 | import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..)) 6 | import Proarrow.Category.Monoidal.Action (Strong (..)) 7 | import Proarrow.Core (Profunctor (..), Promonad (..)) 8 | import Proarrow.Object.Dual (ExpSA, StarAutonomous (..), currySA, expSA, uncurrySA) 9 | import Proarrow.Object.Exponential (Closed (..), curry, uncurry) 10 | import Proarrow.Category.Monoidal (MonoidalProfunctor (..)) 11 | 12 | newtype Cont r a b = Cont {runCont :: (b -> r) -> (a -> r)} 13 | instance Profunctor (Cont r) where 14 | dimap l r (Cont f) = Cont ((. l) . f . (. r)) 15 | r \\ _ = r 16 | instance Promonad (Cont r) where 17 | id = Cont id 18 | Cont f . Cont g = Cont (g . f) 19 | instance Strong Type (Cont r) where 20 | act ab (Cont yrxy) = Cont \byr -> uncurry (yrxy . curry byr . ab) 21 | -- | Only premonoidal not monoidal? 22 | instance MonoidalProfunctor (Cont r) where 23 | par0 = Cont id 24 | Cont f `par` Cont g = Cont \k (x1, y1) -> f (\x2 -> g (\y2 -> k (x2, y2)) y1) x1 25 | instance StarAutonomous (KLEISLI (Cont r)) where 26 | type Dual @(KLEISLI (Cont r)) (KL a) = KL (a -> r) 27 | dual (Kleisli (Cont f)) = Kleisli (Cont \k br -> k (f br)) 28 | dualInv (Kleisli (Cont f)) = Kleisli (Cont \k b -> f (\g -> g b) k) 29 | linDist (Kleisli (Cont f)) = Kleisli (Cont \k a -> k (\(b, c) -> f (\g -> g c) (a, b))) 30 | linDistInv (Kleisli (Cont f)) = Kleisli (Cont \k (a, b) -> k (\c -> f (\g -> g (b, c)) a)) 31 | instance Closed (KLEISLI (Cont r)) where 32 | type a ~~> b = ExpSA a b 33 | withObExp r = r 34 | curry = currySA 35 | uncurry = uncurrySA 36 | (^^^) = expSA 37 | -------------------------------------------------------------------------------- /src/Proarrow/Promonad/Reader.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Promonad.Reader where 2 | 3 | import Prelude (($)) 4 | 5 | import Proarrow.Adjunction (Adjunction (..)) 6 | import Proarrow.Category.Instance.Prof (Prof (..)) 7 | import Proarrow.Category.Monoidal 8 | ( Monoidal (..) 9 | , MonoidalProfunctor (..) 10 | , SymMonoidal (..) 11 | , first 12 | , second 13 | , swap' 14 | , unitObj 15 | ) 16 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), SelfAction, Strong (..), strongPar0) 17 | import Proarrow.Category.Monoidal.Distributive (Cotraversable (..)) 18 | import Proarrow.Category.Opposite (OPPOSITE (..), Op (..)) 19 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, rmap, src, (//), type (+->)) 20 | import Proarrow.Functor (Functor (..)) 21 | import Proarrow.Monoid (Comonoid (..), Monoid (..), comultAct, counitAct, mappendAct, memptyAct) 22 | import Proarrow.Profunctor.Composition ((:.:) (..)) 23 | import Proarrow.Promonad (Procomonad (..)) 24 | import Proarrow.Promonad.Writer (Writer (..)) 25 | import Proarrow.Profunctor.Corepresentable (Corepresentable (..)) 26 | 27 | data Reader r a b where 28 | Reader :: forall a b r. (Ob a) => Act r a ~> b -> Reader (OP r) a b 29 | 30 | instance (Ob (r :: m), MonoidalAction m k) => Profunctor (Reader (OP r) :: k +-> k) where 31 | dimap l r (Reader f) = Reader (r . f . (act (obj @r) l)) \\ r \\ l 32 | r \\ Reader f = r \\ f 33 | 34 | instance (Ob (r :: m), MonoidalAction m k) => Corepresentable (Reader (OP r) :: k +-> k) where 35 | type Reader (OP r) %% a = Act r a 36 | coindex (Reader f) = f 37 | cotabulate f = Reader f 38 | corepMap f = act (obj @r) f 39 | 40 | instance (MonoidalAction m k) => Functor (Reader :: OPPOSITE m -> k +-> k) where 41 | map (Op f) = f // Prof \(Reader @a g) -> Reader (g . act f (obj @a)) 42 | 43 | instance (Comonoid (r :: m), MonoidalAction m k) => Promonad (Reader (OP r) :: k +-> k) where 44 | id = Reader (counitAct @r) 45 | Reader g . Reader @a f = Reader (g . act (obj @r) f . comultAct @r @a) 46 | 47 | instance (Monoid (r :: m), MonoidalAction m k) => Procomonad (Reader (OP r) :: k +-> k) where 48 | extract (Reader f) = f . memptyAct @r 49 | duplicate (Reader @a f) = Reader id :.: Reader (f . mappendAct @r @a) \\ f 50 | 51 | instance (Ob (r :: m), MonoidalAction m k, SymMonoidal m) => Strong m (Reader (OP r) :: k +-> k) where 52 | act @a @b @x @y f (Reader g) = 53 | Reader (act f g . multiplicatorInv @m @k @a @r @x . act (swap @_ @r @a) (obj @x) . multiplicator @m @k @r @a @x) 54 | \\ act (obj @a) (obj @x) 55 | \\ act (obj @b) (obj @y) 56 | \\ f 57 | \\ g 58 | 59 | -- | Note: This is only premonoidal, not monoidal, unless the comonoid is cocommutative. 60 | instance (Comonoid (r :: k), SelfAction k, SymMonoidal k) => MonoidalProfunctor (Reader (OP r) :: k +-> k) where 61 | par0 = id \\ unitObj @k 62 | Reader @x1 @x2 f `par` Reader @y1 @y2 g = 63 | f // 64 | g // 65 | withOb2 @_ @x1 @y1 $ 66 | withOb2 @_ @x2 @y2 $ 67 | Reader 68 | ( second @x2 g 69 | . associator @k @x2 @r @y1 70 | . ((swap' (obj @r) f . associator @k @r @r @x1 . first @x1 (comult @r)) `par` obj @y1) 71 | . associatorInv @k @r @x1 @y1 72 | ) 73 | 74 | instance (Comonoid (r :: k), SelfAction k) => Cotraversable (Reader (OP r) :: k +-> k) where 75 | cotraverse (p :.: Reader f) = let rp = strongPar0 @r `act` p in Reader (src rp) :.: rmap f rp \\ rp \\ p 76 | 77 | instance (Ob (r :: m), MonoidalAction m k) => Adjunction (Writer r :: k +-> k) (Reader (OP r)) where 78 | unit @a = Reader id :.: Writer id \\ act (obj @r) (obj @a) 79 | counit (Writer f :.: Reader g) = g . f 80 | -------------------------------------------------------------------------------- /src/Proarrow/Promonad/State.hs: -------------------------------------------------------------------------------- 1 | module Proarrow.Promonad.State where 2 | 3 | import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), swap') 4 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj) 5 | 6 | data State s a b where 7 | State :: (Ob a, Ob b) => (s ** a) ~> (s ** b) -> State s a b 8 | 9 | instance (Monoidal k, Ob s) => Profunctor (State (s :: k)) where 10 | dimap l r (State f) = State ((obj @s `par` r) . f . (obj @s `par` l)) \\ l \\ r 11 | r \\ State f = r \\ f 12 | 13 | instance (Monoidal k, Ob s) => Promonad (State (s :: k)) where 14 | id :: forall a. (Ob a) => State s a a 15 | id = State (obj @s `par` obj @a) 16 | State f . State g = State (f . g) 17 | 18 | -- | Note: This is only premonoidal, not monoidal. 19 | instance (SymMonoidal k, Ob s) => MonoidalProfunctor (State (s :: k)) where 20 | par0 = State (obj @s `par` par0) \\ (par0 :: (Unit :: k) ~> Unit) 21 | par (State @a1 @b1 f) (State @a2 @b2 g) = 22 | let s = obj @s; a1 = obj @a1; b1 = obj @b1; a2 = obj @a2; b2 = obj @b2 23 | in State 24 | ( (s `par` swap' b2 b1) 25 | . associator @_ @s @b2 @b1 26 | . (g `par` b1) 27 | . associatorInv @_ @s @a2 @b1 28 | . (s `par` swap' b1 a2) 29 | . associator @_ @s @b1 @a2 30 | . (f `par` a2) 31 | . associatorInv @_ @s @a1 @a2 32 | ) 33 | \\ (a1 `par` a2) 34 | \\ (b1 `par` b2) 35 | -------------------------------------------------------------------------------- /src/Proarrow/Promonad/Writer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | module Proarrow.Promonad.Writer where 4 | 5 | import Prelude (($)) 6 | 7 | import Proarrow.Category.Instance.Prof (Prof (..)) 8 | import Proarrow.Category.Monoidal 9 | ( Monoidal (..) 10 | , MonoidalProfunctor (..) 11 | , SymMonoidal (..) 12 | , first 13 | , second 14 | , swap' 15 | , unitObj 16 | ) 17 | import Proarrow.Category.Monoidal.Action (MonoidalAction (..), SelfAction, Strong (..), strongPar0) 18 | import Proarrow.Category.Monoidal.Distributive (Traversable (..)) 19 | import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, obj, tgt, (//), type (+->)) 20 | import Proarrow.Functor (Functor (..)) 21 | import Proarrow.Monoid (Comonoid, Monoid (..), comultAct, counitAct, mappendAct, memptyAct) 22 | import Proarrow.Profunctor.Composition ((:.:) (..)) 23 | import Proarrow.Profunctor.Representable (Representable (..), dimapRep) 24 | import Proarrow.Promonad (Procomonad (..)) 25 | 26 | data Writer w a b where 27 | Writer :: (Ob b) => a ~> Act w b -> Writer w a b 28 | 29 | instance (Ob (w :: m), MonoidalAction m k) => Profunctor (Writer w :: k +-> k) where 30 | dimap = dimapRep 31 | r \\ Writer f = r \\ f 32 | 33 | instance (Ob (w :: m), MonoidalAction m k) => Representable (Writer w :: k +-> k) where 34 | type Writer w % a = Act w a 35 | index (Writer f) = f 36 | tabulate f = Writer f 37 | repMap f = act (obj @w) f 38 | 39 | instance (MonoidalAction m k) => Functor (Writer :: m -> k +-> k) where 40 | map f = f // Prof \(Writer @b g) -> Writer (act f (obj @b) . g) 41 | 42 | instance (Monoid (w :: m), MonoidalAction m k) => Promonad (Writer w :: k +-> k) where 43 | id = Writer (memptyAct @w) 44 | Writer @c g . Writer f = Writer (mappendAct @w @c . act (obj @w) g . f) 45 | 46 | instance (Comonoid (w :: m), MonoidalAction m k) => Procomonad (Writer w :: k +-> k) where 47 | extract (Writer f) = counitAct @w . f 48 | duplicate (Writer @b f) = Writer (comultAct @w @b . f) :.: Writer id \\ f 49 | 50 | instance (Ob (w :: m), MonoidalAction m k, SymMonoidal m) => Strong m (Writer w :: k +-> k) where 51 | act @a @b @x @y f (Writer g) = 52 | Writer (multiplicatorInv @m @k @w @b @y . act (swap @_ @b @w) (obj @y) . multiplicator @m @k @b @w @y . act f g) 53 | \\ act (obj @a) (obj @x) 54 | \\ act (obj @b) (obj @y) 55 | \\ f 56 | \\ g 57 | 58 | -- | Note: This is only premonoidal, not monoidal, unless the monoid is commutative. 59 | instance (Monoid (w :: k), SelfAction k) => MonoidalProfunctor (Writer w :: k +-> k) where 60 | par0 = id \\ unitObj @k 61 | Writer @x2 @x1 f `par` Writer @y2 @y1 g = 62 | f // 63 | g // 64 | withOb2 @_ @x1 @y1 $ 65 | withOb2 @_ @x2 @y2 $ 66 | Writer 67 | ( associator @k @w @x2 @y2 68 | . ((first @x2 (mappend @w) . associatorInv @k @w @w @x2 . swap' f (obj @w)) `par` obj @y2) 69 | . associatorInv @k @x1 @w @y2 70 | . second @x1 g 71 | ) 72 | 73 | instance (Monoid (w :: k), SelfAction k) => Traversable (Writer w :: k +-> k) where 74 | traverse (Writer f :.: p) = let wp = strongPar0 @w `act` p in lmap f wp :.: Writer (tgt wp) \\ wp \\ p -------------------------------------------------------------------------------- /src/Proarrow/Squares/Relative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | module Proarrow.Squares.Relative where 3 | 4 | import Proarrow.Category.Bicategory.Relative qualified as Rel 5 | import Proarrow.Category.Bicategory.Strictified (Path (..), SPath (..), Strictified (..)) 6 | import Proarrow.Category.Equipment (Equipment (..), HasCompanions (..), Sq (..)) 7 | import Proarrow.Core (CategoryOf (..), obj) 8 | import Proarrow.Category.Bicategory (Bicategory(..)) 9 | 10 | -- | The unit square for a @j@-relative monad @t@. 11 | -- 12 | -- > A-----A 13 | -- > | /-