packages feed

proarrow 0.1.0.0 → 0.2.0.0

raw patch · 66 files changed

+3686/−644 lines, 66 files

Files

CHANGELOG.md view
@@ -1,5 +1,41 @@ # Revision history for proarrow +## 0.2.0.0 -- 2026-10-04++* New `Proarrow.Tools.SMC`: linear HOAS for symmetric monoidal categories, with `do` notation,+  traces, duals, additives, and polarised System L inputs and outputs (`Consumer`, `Command`,+  `cut`, `cont`, `ret`, `classical`, the shifts `Up a = Not (Not a)` and `Dn` with `thunk` and+  `force`, and `recast` between type expressions for one object; a `do` bind of an `Up` runs it)+  over any dialogue category. With optimisation a compiled term is the category's own structure+  maps, composed.+* New `Proarrow.Category.Instance.Cps`: a closed symmetric monoidal category with a chosen answer+  object as a dialogue category, `Dual a = a ~~> r`. With `r = IO ()` this is call by push value;+  see the `Examples.Cbpv` test module. It is isomix exactly when `r` is the unit (`answerUnit`).+* New `Proarrow.Category.Monoidal.Dialogue`, now the superclass of `StarAutonomous`: `Dual`,+  `dual`, `linDist`, `linDistInv`, `doubleNegInv`, `Par` and its functions, `DualF` and the+  related helpers move there, with their laws (`DialogueStructures`, `testDialogue`, witness+  `DialogueW`). `StarAutonomous` keeps `dualInv`, `doubleNeg` and `ExpSA`. Instances split+  accordingly. New: `tripleNeg` and `bindDual`.+* New `Proarrow.Category.Monoidal.IsoMix`: dialogue categories with `Dual Unit ≅ Unit`+  (`dualUnit`, `dualUnitInv`, `dualityCounit`). It is a superclass of `CompactClosed`, which+  loses `dualUnit` and `dualityCounit` and lists `StarAutonomous` itself. `LINEAR` is isomix.+* `Proarrow.Testing` has `check`, which fails with a message unless a condition holds.+* GHC 9.14 support+  * `Testable` no longer has the quantified superclass `forall a. (TestOb a) => Ob' a`.+    `obFromTestOb` is now a `Testable` method instead, defaulting to the identity when `TestOb` is+    `Ob`; instances with their own `TestOb` define it (usually `obFromTestOb r = r`), and calls+    take the kind first (`obFromTestOb @_ @a`). `testObFromOb` is the converse.+  * `Proarrow.Testing` has `withTestOb2Def`, `withTestObProdDef`, `withTestObCoprodDef`,+    `withTestObExpDef` and `withTestObDualDef`, the objecthood witnesses for when `TestOb` is `Ob`.+  * `Functor` no longer has the quantified superclass `forall a. Ob a => Ob' (f a)`: `withObF`+    gives `Ob (f a)`.+  * The associativity superclass of `Strictly` no longer asks for `Ob b` and `Ob c`.+* Fixed: in `LINEAR`, `doubleNeg`, `dualInv` and the par eliminators returned stale values when+  compiled with optimisation, because every call of `dn` shared one reference.+* Fixed: in the Int construction, the tensor of morphisms, the associators, `linDist`,+  `linDistInv` and `distribDual` looped forever. The Int construction over `FinRel` is now+  law-tested.+ ## 0.1.0.0 -- 2026-09-28  * First release
README.md view
@@ -1,4 +1,4 @@-[![Haskell-CI](https://github.com/sjoerdvisscher/proarrow/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/sjoerdvisscher/proarrow/actions/workflows/haskell-ci.yml)+[![Haskell-CI](https://github.com/sjoerdvisscher/proarrow/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/sjoerdvisscher/proarrow/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/proarrow.svg)](https://hackage.haskell.org/package/proarrow)  # proarrow
proarrow.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               proarrow-version:            0.1.0.0+version:            0.2.0.0 synopsis:           Category theory with a central role for profunctors description:     A library for doing category theory in Haskell with profunctors, rather@@ -21,7 +21,7 @@ author:             Sjoerd Visscher maintainer:         sjoerd@w3future.com category:           Math, Categories-tested-with:        GHC ==9.10.3 || ==9.12.2+tested-with:        GHC ==9.10.3 || ==9.12.2 || == 9.14.1  extra-doc-files:     CHANGELOG.md@@ -74,6 +74,7 @@         Proarrow.Category.Instance.Constraint         Proarrow.Category.Instance.Coproduct         Proarrow.Category.Instance.Cospan+        Proarrow.Category.Instance.Cps         Proarrow.Category.Instance.Cost         Proarrow.Category.Instance.Discrete         Proarrow.Category.Instance.Duploid@@ -109,6 +110,8 @@         Proarrow.Category.Monoidal.Closed         Proarrow.Category.Monoidal.Coclosed         Proarrow.Category.Monoidal.CompactClosed+        Proarrow.Category.Monoidal.Dialogue+        Proarrow.Category.Monoidal.IsoMix         Proarrow.Category.Monoidal.CopyDiscard         Proarrow.Category.Monoidal.Distributive         Proarrow.Category.Monoidal.EndoProf@@ -202,6 +205,7 @@         Proarrow.Promonad.Writer         Proarrow.Squares         Proarrow.Tools.CCC+        Proarrow.Tools.SMC         Proarrow.Tools.DPO         Proarrow.Tools.Laws         Proarrow.Tools.Diagrams.Dot@@ -238,6 +242,7 @@     hs-source-dirs:   test     main-is:          Main.hs     other-modules:+        Examples.Cbpv         Examples.Cofree         Examples.CustomLaws         Examples.Database@@ -247,16 +252,22 @@         Examples.Graph         Examples.UntypedLambdaCalculus         Examples.SimplyTypedLambdaCalculus+        Examples.IntComposition+        Examples.LinearLogic+        Examples.Sessions+        Examples.Toffoli         Examples.Vitrea         Props.Bool         Props.DPO         Props.Discrete         Props.Cospan+        Props.Cps         Props.Cost         Props.Dot         Props.Svg         Props.FinHask         Props.FinRel+        Props.IntConstruction         Props.FinSet         Props.Finitary         Props.Finitary.Graph
src/Proarrow/Category/Instance/Bool.hs view
@@ -26,7 +26,7 @@   If TRU t e = t   If FLS t e = e --- | Negation; the 'Proarrow.Category.Monoidal.StarAutonomous.Dual' of @BOOL@.+-- | Negation; the 'Proarrow.Category.Monoidal.Dialogue.Dual' of @BOOL@. type family Not (b :: BOOL) :: BOOL where   Not FLS = TRU   Not TRU = FLS
src/Proarrow/Category/Instance/Cospan.hs view
@@ -10,7 +10,9 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Hypergraph (ExpHG, Frobenius, Hypergraph, applyHG, cap, cup, curryHG)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Colimit.BinaryCoproduct   ( HasBinaryCoproducts (..)@@ -89,20 +91,25 @@   curry @a @b = curryHG @a @b   apply @b @c = applyHG @b @c -instance (HasPushouts k, HasCoproducts k) => StarAutonomous (COSPAN k) where+instance (HasPushouts k, HasCoproducts k) => Dialogue (COSPAN k) where   type Dual a = a   withObDual r = r   dual = dagger-  dualInv = dagger   linDist @(CS a) @(CS b) (Cospan f g) = Cospan (f . lft @k @a @b) (f . rgt @k @a @b ||| g)   linDistInv @_ @(CS b) @(CS c) (Cospan f g) = Cospan (f ||| g . lft @k @b @c) (g . rgt @k @b @c)-  doubleNeg = id   doubleNegInv = id++instance (HasPushouts k, HasCoproducts k) => StarAutonomous (COSPAN k) where+  dualInv = dagger+  doubleNeg = id+instance (HasPushouts k, HasCoproducts k) => IsoMix (COSPAN k) where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a+ instance (HasPushouts k, HasCoproducts k) => CompactClosed (COSPAN k) where   distribDual @(CS a) @(CS b) = withObCoprod @k @a @b id-  dualUnit = id   dualityUnit @a = cup @a-  dualityCounit @a = cap @a  instance (HasPushouts k) => DaggerProfunctor (Cospan :: CAT (COSPAN k)) where   dagger (Cospan f g) = Cospan g f
+ src/Proarrow/Category/Instance/Cps.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | A closed symmetric monoidal category with a chosen answer object @r@ is a dialogue category,+-- with @'Dual' a = a '~~>' r@. 'CPS' wraps the category to say which object. The morphisms are+-- those of the category itself, so with @r@ an object of effects, as @IO ()@ in 'Data.Kind.Type',+-- a morphism is pure and a term of @'Proarrow.Tools.SMC.Up' a@ is a computation+-- @(a -> IO ()) -> IO ()@: call by push value, with the effects in the computations only.+--+-- @CPS r@ is isomix exactly when @r@ is the unit ('answerUnit'), and *-autonomous only in+-- degenerate cases, since @(a ~~> r) ~~> r@ is rarely @a@.+module Proarrow.Category.Instance.Cps (CPS (..), Cps (..), answerUnit) where++import Prelude (type (~))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..), swapClosed, toEl, uncurry)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN, WrappedOb, dimapDefault, obj)+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Optic (PIso', iso)++type data CPS (r :: k) = C k++-- | The arrows of the category, wrapped as a category on the 'CPS'-wrapped kind.+type Cps :: CAT (CPS r)+data Cps (a :: CPS r) b where+  Cps :: {unCps :: a ~> b} -> Cps (C a :: CPS r) (C b)++instance (CategoryOf k) => Profunctor (Cps :: CAT (CPS (r :: k))) where+  dimap = dimapDefault+  r \\ Cps f = r \\ f++instance (CategoryOf k) => Promonad (Cps :: CAT (CPS (r :: k))) where+  id = Cps id+  Cps f . Cps g = Cps (f . g)++instance (CategoryOf k) => CategoryOf (CPS (r :: k)) where+  type (~>) = Cps+  type Ob a = WrappedOb C a++instance (Monoidal k) => MonoidalProfunctor (Cps :: CAT (CPS (r :: k))) where+  one = Cps one+  Cps f ** Cps g = Cps (f ** g)++instance (Monoidal k) => Monoidal (CPS (r :: k)) where+  type Unit = C Unit+  type a ** b = C (UN C a ** UN C b)+  withOb2 @(C a) @(C b) r = withOb2 @k @a @b r+  leftUnitor @(C a) = Cps (leftUnitor @k @a)+  leftUnitorInv @(C a) = Cps (leftUnitorInv @k @a)+  rightUnitor @(C a) = Cps (rightUnitor @k @a)+  rightUnitorInv @(C a) = Cps (rightUnitorInv @k @a)+  associator @(C a) @(C b) @(C c) = Cps (associator @k @a @b @c)+  associatorInv @(C a) @(C b) @(C c) = Cps (associatorInv @k @a @b @c)++instance (SymMonoidal k) => SymMonoidal (CPS (r :: k)) where+  swap @(C a) @(C b) = Cps (swap @k @a @b)++instance (Closed k) => Closed (CPS (r :: k)) where+  type a ~~> b = C (UN C a ~~> UN C b)+  withObExp @(C a) @(C b) r = withObExp @k @a @b r+  curry @(C a) @(C b) (Cps f) = Cps (curry @k @a @b f)+  apply @(C a) @(C b) = Cps (apply @k @a @b)+  Cps f ^^^ Cps g = Cps (f ^^^ g)++-- | The dual of @a@ is @a '~~>' r@, the functor 'Proarrow.Category.Monoidal.Closed.Not' @r@ on+-- objects: linear distribution is uncurrying, reassociating and currying.+instance (Closed k, SymMonoidal k, Ob r) => Dialogue (CPS (r :: k)) where+  type Dual (a :: CPS r) = C (UN C a ~~> r)+  withObDual @(C a) r' = withObExp @k @a @r r'+  dual (Cps f) = Cps (obj @r ^^^ f)+  linDist @(C a) @(C b) @(C c) (Cps f) =+    withOb2 @k @b @c (Cps (curry @k @a @(b ** c) (uncurry @c @r f . associatorInv @k @a @b @c)))+  linDistInv @(C a) @(C b) @(C c) (Cps f) =+    withOb2 @k @a @b (withOb2 @k @b @c (Cps (curry @k @(a ** b) @c (uncurry @(b ** c) @r f . associator @k @a @b @c))))+  doubleNegInv @(C a) = withObExp @k @a @r (Cps (swapClosed @r (obj @(a ~~> r))))++-- | With the unit as the answer object, @'Dual' 'Unit' = Unit ~~> Unit ≅ Unit@, and a consumer meets+-- its value in 'apply'. With any other answer object the units differ, so this is the only isomix+-- instance; the constraint on @r@ says so, since 'Unit' is a type family and cannot head an+-- instance.+instance (Closed k, SymMonoidal k, r ~ Unit) => IsoMix (CPS (r :: k)) where+  dualUnit = withObExp @k @Unit @Unit (Cps (apply @k @Unit @Unit . rightUnitorInv @k @(Unit ~~> Unit)))+  dualUnitInv = Cps (toEl @Unit)+  dualityCounit @(C a) = Cps (apply @k @a @Unit)++-- | The converse: an isomix structure on @CPS r@ makes @r@ the unit, through @Unit ~~> r ≅ r@.+answerUnit :: forall {k} (r :: k). (Closed k, Ob r, IsoMix (CPS r)) => PIso' r Unit+answerUnit =+  withObExp @k @Unit @r+    ( iso+        (unCps (dualUnit @(CPS r)) . toEl @r)+        (apply @k @Unit @r . rightUnitorInv @k @(Unit ~~> r) . unCps (dualUnitInv @(CPS r)))+    )++instance (Comonoid a) => Comonoid (C a :: CPS r) where+  counit = Cps counit+  comult = Cps comult++instance (CocommutativeComonoid a) => CocommutativeComonoid (C a :: CPS r)
src/Proarrow/Category/Instance/FinRel.hs view
@@ -21,8 +21,10 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Distributive (Distributive (..)) import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..), HasBiproducts)@@ -191,21 +193,26 @@   apply @y @z = applySA @y @z   (^^^) = expSA -instance StarAutonomous FINREL where+instance Dialogue FINREL where   type Dual n = n   withObDual r = r   dual = dagger-  dualInv = dagger   linDist @(FR a) @(FR b) @(FR c) (FinRel m) = withOb2 @_ @(FR b) @(FR c) $ FinRel (P.fmap combines (chunks @a @b m))   linDistInv @(FR a) @(FR b) @(FR c) (FinRel m) = withOb2 @_ @(FR a) @(FR b) $ FinRel (concatMap @_ @b @_ @a (splits @b @c) m)-  doubleNeg = id   doubleNegInv = id +instance StarAutonomous FINREL where+  dualInv = dagger+  doubleNeg = id++instance IsoMix FINREL where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a+ instance CompactClosed FINREL where   distribDual @m @n = dagger (obj @m) ** dagger (obj @n)-  dualUnit = id   dualityUnit @a = cup @a-  dualityCounit @a = cap @a  instance (MonoidalAction (t :: (FINREL, FINREL) +-> FINREL)) => Costrong t FinRel where   coact @x = coactCC @t @x
src/Proarrow/Category/Instance/IntConstruction.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecursiveDo #-}+ -- | The __Int construction__ (Joyal-Street-Verity) on a traced monoidal category @k@: objects are -- formal differences @'I' plus minus@ of @k@-objects, and morphisms are @k@-morphisms between the -- appropriately tensored halves, composed by tracing out the middle. The result is compact closed@@ -6,22 +10,17 @@  import Prelude (($), type (~)) -import Proarrow.Category.Monoidal-  ( Monoidal (..)-  , MonoidalProfunctor (..)-  , SymMonoidal (..)-  , obj2-  , swap-  , swapFst-  , swapInner-  , swapOuter-  , (**)-  )+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor, SymMonoidal (..), first, second, swap)+import Proarrow.Category.Monoidal qualified as M import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)-import Proarrow.Category.Monoidal.Strength (TracedMonoidal, trace)-import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj)+import Proarrow.Category.Monoidal.Strength (TracedMonoidal)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, (\\))+import Proarrow.Tools.SMC (SYN (F, (:**)), lift, toSMC, (**))+import Proarrow.Tools.SMC qualified as SMC  data INT k = I k k @@ -35,13 +34,16 @@   Int :: (Ob ap, Ob am, Ob bp, Ob bm) => ap ** bm ~> am ** bp -> IntConstruction (I ap am) (I bp bm)  toInt :: forall {k} (a :: k) b m. (TracedMonoidal k, Ob m) => (a ~> b) -> I a m ~> I b m-toInt f = Int (swap @k @b @m . (f ** obj @m)) \\ f+toInt f = Int (swap @k @b @m . (f M.** obj @m)) \\ f  isoToInt :: forall {k} (a :: k) b. (TracedMonoidal k) => (a ~> b) -> (b ~> a) -> I a a ~> I b b-isoToInt f g = Int (swap @k @b @a . (f ** g)) \\ f \\ g+isoToInt f g = Int (swap @k @b @a . (f M.** g)) \\ f \\ g  fromInt :: forall {k} (a :: k) b m. (TracedMonoidal k) => (I a m ~> I b m) -> a ~> b-fromInt (Int f) = trace @(~>) @m @a @b (swap @k @m @b . f)+fromInt (Int f) = toSMC @(F a) \a -> SMC.do+  let f' = lift @(F a :** F m) @(F m :** F b) f+  rec (m, b) <- f' (a ** m)+  b  instance (TracedMonoidal k) => Profunctor (IntConstruction :: CAT (INT k)) where   dimap = dimapDefault@@ -49,13 +51,12 @@ instance (TracedMonoidal k) => Promonad (IntConstruction :: CAT (INT k)) where   id @a = Int (swap @k @(IntPlus a) @(IntMinus a))   Int @bp @bm @cp @cm f . Int @ap @am g =-    Int-      ( trace @_ @(bp ** bm) @(ap ** cm) @(am ** cp)-          (swapOuter @bm @cp @bp @am . (f ** (swap @k @am @bp . g)) . swapFst @ap @cm @bp @bm)-      )-      \\ obj2 @ap @cm-      \\ obj2 @am @cp-      \\ obj2 @bp @bm+    Int $ toSMC @(F ap :** F cm) \x -> SMC.do+      let g' = lift @(F ap :** F bm) @(F am :** F bp) g+          f' = lift @(F bp :** F cm) @(F bm :** F cp) f+      (ap, cm) <- x+      rec ((am, bp), (bm, cp)) <- g' (ap ** bm) ** f' (bp ** cm)+      am ** cp  -- | The Int construction, a.k.a. the geometry of interaction, -- the free compact closed category on a traced monoidal category.@@ -66,9 +67,15 @@ instance (TracedMonoidal k) => MonoidalProfunctor (IntConstruction :: CAT (INT k)) where   one = Int (swap @k @Unit @Unit)   Int @ap @am @bp @bm f ** Int @cp @cm @dp @dm g =-    Int (swapInner @am @bp @cm @dp . (f ** g) . swapInner @ap @cp @bm @dm)-      \\ obj2 @(I ap am) @(I cp cm)-      \\ obj2 @(I bp bm) @(I dp dm)+    withOb2 @(INT k) @(I ap am) @(I cp cm) $+      withOb2 @(INT k) @(I bp bm) @(I dp dm) $+        Int $ toSMC @((F ap :** F cp) :** (F bm :** F dm)) \x -> SMC.do+          let f' = lift @(F ap :** F bm) @(F am :** F bp) f+              g' = lift @(F cp :** F dm) @(F cm :** F dp) g+          ((ap, cp), (bm, dm)) <- x+          (am, bp) <- f' (ap ** bm)+          (cm, dp) <- g' (cp ** dm)+          (am ** cm) ** (bp ** dp)  -- | The monoidal tensor is pointwise, tensoring of the plus and minus parts. instance (TracedMonoidal k) => Monoidal (INT k) where@@ -76,29 +83,39 @@   type a ** b = I (IntPlus a ** IntPlus b) (IntMinus a ** IntMinus b)   withOb2 @a @b r = withOb2 @k @(IntPlus a) @(IntPlus b) (withOb2 @k @(IntMinus a) @(IntMinus b) r)   leftUnitor @(I ap am) =-    Int ((leftUnitorInv @k @am ** obj @ap) . swap @k @ap @am . (leftUnitor @k @ap ** obj @am))-      \\ obj2 @Unit @ap-      \\ obj2 @Unit @am+    withOb2 @k @Unit @ap $+      withOb2 @k @Unit @am $+        Int (first @ap (leftUnitorInv @k @am) . swap @k @ap @am . first @am (leftUnitor @k @ap))   leftUnitorInv @(I ap am) =-    Int ((obj @am ** leftUnitorInv @k @ap) . swap @k @ap @am . (obj @ap ** leftUnitor @k @am))-      \\ obj2 @Unit @ap-      \\ obj2 @Unit @am+    withOb2 @k @Unit @ap $+      withOb2 @k @Unit @am $+        Int (second @am (leftUnitorInv @k @ap) . swap @k @ap @am . second @ap (leftUnitor @k @am))   rightUnitor @(I ap am) =-    Int ((rightUnitorInv @k @am ** obj @ap) . swap @k @ap @am . (rightUnitor @k @ap ** obj @am))-      \\ obj2 @ap @Unit-      \\ obj2 @am @Unit+    withOb2 @k @ap @Unit $+      withOb2 @k @am @Unit $+        Int (first @ap (rightUnitorInv @k @am) . swap @k @ap @am . first @am (rightUnitor @k @ap))   rightUnitorInv @(I ap am) =-    Int ((obj @am ** rightUnitorInv @k @ap) . swap @k @ap @am . (obj @ap ** rightUnitor @k @am))-      \\ obj2 @ap @Unit-      \\ obj2 @am @Unit+    withOb2 @k @ap @Unit $+      withOb2 @k @am @Unit $+        Int (second @am (rightUnitorInv @k @ap) . swap @k @ap @am . second @ap (rightUnitor @k @am))   associator @(I ap am) @(I bp bm) @(I cp cm) =-    Int (swap @k @(ap ** (bp ** cp)) @((am ** bm) ** cm) . (associator @k @ap @bp @cp ** associatorInv @k @am @bm @cm))-      \\ obj2 @(I ap am) @(I bp bm) ** obj @(I cp cm)-      \\ obj @(I ap am) ** obj2 @(I bp bm) @(I cp cm)+    withOb2 @(INT k) @(I ap am) @(I bp bm) $+      withOb2 @(INT k) @(I ap am ** I bp bm) @(I cp cm) $+        withOb2 @(INT k) @(I bp bm) @(I cp cm) $+          withOb2 @(INT k) @(I ap am) @(I bp bm ** I cp cm) $+            Int+              ( swap @k @(ap ** (bp ** cp)) @((am ** bm) ** cm)+                  . (associator @k @ap @bp @cp M.** associatorInv @k @am @bm @cm)+              )   associatorInv @(I ap am) @(I bp bm) @(I cp cm) =-    Int (swap @k @((ap ** bp) ** cp) @(am ** (bm ** cm)) . (associatorInv @k @ap @bp @cp ** associator @k @am @bm @cm))-      \\ obj2 @(I ap am) @(I bp bm) ** obj @(I cp cm)-      \\ obj @(I ap am) ** obj2 @(I bp bm) @(I cp cm)+    withOb2 @(INT k) @(I ap am) @(I bp bm) $+      withOb2 @(INT k) @(I ap am ** I bp bm) @(I cp cm) $+        withOb2 @(INT k) @(I bp bm) @(I cp cm) $+          withOb2 @(INT k) @(I ap am) @(I bp bm ** I cp cm) $+            Int+              ( swap @k @((ap ** bp) ** cp) @(am ** (bm ** cm))+                  . (associatorInv @k @ap @bp @cp M.** associator @k @am @bm @cm)+              )  instance (TracedMonoidal k) => SymMonoidal (INT k) where   swap @(I ap am) @(I bp bm) =@@ -106,7 +123,7 @@       withOb2 @k @am @bm $         withOb2 @k @bp @ap $           withOb2 @k @bm @am $-            Int ((swap @k @bm @am ** swap @k @ap @bp) . swap @k @(ap ** bp) @(bm ** am))+            Int ((swap @k @bm @am M.** swap @k @ap @bp) . swap @k @(ap ** bp) @(bm ** am))  instance (TracedMonoidal k) => Closed (INT k) where   type a ~~> b = ExpSA a b@@ -115,20 +132,27 @@   apply @b @c = applySA @b @c   (^^^) = expSA -instance (TracedMonoidal k) => StarAutonomous (INT k) where+instance (TracedMonoidal k) => Dialogue (INT k) where   type Dual (I p n) = I n p   withObDual r = r   dual (Int @ap @am @bp @bm f) = Int (swap @k @am @bp . f . swap @k @bm @ap)+  linDist @(I ap am) @(I bp bm) @(I cp cm) (Int f) =+    withOb2 @(INT k) @(I bp bm) @(I cp cm) (Int (associator @k @am @bm @cm . f . associatorInv @k @ap @bp @cp))+  linDistInv @(I ap am) @(I bp bm) @(I cp cm) (Int f) =+    withOb2 @(INT k) @(I ap am) @(I bp bm) (Int (associatorInv @k @am @bm @cm . f . associator @k @ap @bp @cp))+  doubleNegInv = id++instance (TracedMonoidal k) => StarAutonomous (INT k) where   dualInv (Int @ap @am @bp @bm f) = Int (swap @k @am @bp . f . swap @k @bm @ap)-  linDist @(I ap am) @(I bp bm) @(I cp cm) (Int f) = Int (associator @k @am @bm @cm . f . associatorInv @k @ap @bp @cp) \\ obj2 @(I bp bm) @(I cp cm)-  linDistInv @(I ap am) @(I bp bm) @(I cp cm) (Int f) = Int (associatorInv @k @am @bm @cm . f . associator @k @ap @bp @cp) \\ obj2 @(I ap am) @(I bp bm)   doubleNeg = id-  doubleNegInv = id -instance (TracedMonoidal k) => CompactClosed (INT k) where-  distribDual @(I ap am) @(I bp bm) = Int (swap @k @(am ** bm) @(ap ** bp)) \\ obj2 @(I ap am) @(I bp bm)+instance (TracedMonoidal k) => IsoMix (INT k) where   dualUnit = id-  dualityUnit @(I p n) =-    withOb2 @k @p @n $ withOb2 @k @n @p $ Int (leftUnitorInv @k @(p ** n) . swap @k @n @p . leftUnitor @k @(n ** p))+  dualUnitInv = id   dualityCounit @(I p n) =     withOb2 @k @p @n $ withOb2 @k @n @p $ Int (rightUnitorInv @k @(p ** n) . swap @k @n @p . rightUnitor @k @(n ** p))++instance (TracedMonoidal k) => CompactClosed (INT k) where+  distribDual @(I ap am) @(I bp bm) = withOb2 @(INT k) @(I ap am) @(I bp bm) (Int (swap @k @(am ** bm) @(ap ** bp)))+  dualityUnit @(I p n) =+    withOb2 @k @p @n $ withOb2 @k @n @p $ Int (leftUnitorInv @k @(p ** n) . swap @k @n @p . leftUnitor @k @(n ** p))
src/Proarrow/Category/Instance/Linear.hs view
@@ -12,17 +12,21 @@ -- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard'. module Proarrow.Category.Instance.Linear where +import Control.Exception (evaluate) import Data.IORef (newIORef, readIORef, writeIORef) import Data.Kind (Type) import Data.Void (Void)-import System.IO.Unsafe (unsafeDupablePerformIO)+import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) import Unsafe.Coerce (unsafeCoerce) import Prelude (Bool (..), Either (..), Eq (..), Show (..), error, showParen, showString, (&&), (>))+import Prelude qualified as P  import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) import Proarrow.Category.Monoidal.Action (CoprodAction) import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..))@@ -51,6 +55,8 @@   dimap = dimapDefault   r \\ Linear{} = r instance Promonad Linear where+  {-# INLINE id #-}+  {-# INLINE (.) #-}   id = Linear \x -> x   Linear f . Linear g = Linear \x -> f (g x) @@ -60,11 +66,20 @@   type Ob (a :: LINEAR) = Is L a  instance MonoidalProfunctor Linear where+  {-# INLINE one #-}+  {-# INLINE (**) #-}   one = id   Linear f ** Linear g = Linear \(x, y) -> (f x, g y)  -- | Tuples as monoidal tensor. Tuples are not the binary product in LINEAR. instance Monoidal LINEAR where+  {-# INLINE withOb2 #-}+  {-# INLINE leftUnitor #-}+  {-# INLINE leftUnitorInv #-}+  {-# INLINE rightUnitor #-}+  {-# INLINE rightUnitorInv #-}+  {-# INLINE associator #-}+  {-# INLINE associatorInv #-}   type Unit = L ()   type L a ** L b = L (a, b)   withOb2 r = r@@ -76,6 +91,7 @@   associatorInv = Linear \(x, (y, z)) -> ((x, y), z)  instance SymMonoidal LINEAR where+  {-# INLINE swap #-}   swap = Linear \(x, y) -> (y, x)  instance Closed LINEAR where@@ -100,11 +116,15 @@  -- | Forget is a lax monoidal functor instance MonoidalProfunctor (Rep Forget) where+  {-# INLINE one #-}+  {-# INLINE (**) #-}   one = Rep \() -> ()   Rep f ** Rep g = Rep \(x, y) -> (f x, g y)  -- | Forget is also a colax monoidal functor instance MonoidalProfunctor (Corep Forget) where+  {-# INLINE one #-}+  {-# INLINE (**) #-}   one = Corep id   Corep f ** Corep g = Corep \(x, y) -> (f x, g y) @@ -193,6 +213,8 @@   uncopower (Linear f) n = Linear \x -> f (Ur n, x)  instance MonoidalProfunctor (Coprod Linear) where+  {-# INLINE one #-}+  {-# INLINE (**) #-}   one = Coprod (Linear \x -> x)   Coprod f ** Coprod g = Coprod (f +++ g) @@ -243,25 +265,42 @@  -- LINEAR is not CompactClosed. And hence it is also not traced, -- since any star autonomous category with a trace is compact closed.-instance StarAutonomous LINEAR where+instance Dialogue LINEAR where+  {-# INLINE withObDual #-}+  {-# INLINE dual #-}+  {-# INLINE linDist #-}+  {-# INLINE linDistInv #-}+  {-# INLINE doubleNegInv #-}   type Dual (L a) = L (Not a)   withObDual r = r   dual (Linear f) = Linear (\nb a -> nb (f a))-  dualInv (Linear f) = Linear (\b -> dn (\na -> f na b))   linDist (Linear f) = Linear (\a (b, c) -> f (a, b) c)   linDistInv (Linear f) = Linear (\(a, b) c -> f a (b, c))-  doubleNeg = Linear dn   doubleNegInv = Linear (\a na -> na a) --- | Double negation is possible with linear functions, though using `unsafeDupablePerformIO`.+instance StarAutonomous LINEAR where+  {-# INLINE dualInv #-}+  {-# INLINE doubleNeg #-}+  dualInv (Linear f) = Linear (\b -> dn (\na -> f na b))+  doubleNeg = Linear dn++-- | The unit of par is @() %1 -> ()@, which has one value, just like @()@: apply it to @()@, or+-- give back the identity. So LINEAR is isomix, while tensor and par still differ.+instance IsoMix LINEAR where+  dualUnit = Linear (\f -> f ())+  dualUnitInv = Linear (\() u -> u)+  dualityCounit = Linear (\(na, a) -> na a)++-- | Double negation is possible with linear functions, though using `unsafePerformIO`. -- Derived from https://gist.github.com/ant-arctica/7563282c57d9d1ce0c4520c543187932--- TODO: only tested in GHCi, might get ruined by optimizations dn :: Not (Not a) %1 -> a-dn nna =-  let ref = unsafeDupablePerformIO (newIORef (error "Linear.dn: write failed"))-  in case nna (unsafeLinear (fill ref)) of () -> unsafeDupablePerformIO (readIORef ref)-  where-    fill ref x = unsafeDupablePerformIO (writeIORef ref x)+-- One IO action that depends on the argument, so that optimisation can't share the reference+-- between calls by floating it out.+dn = unsafeLinear \nna ->+  unsafePerformIO+    ( newIORef (error "Linear.dn: the continuation was not called") P.>>= \ref ->+        evaluate (nna (unsafeLinear \x -> unsafeDupablePerformIO (writeIORef ref x))) P.>> readIORef ref+    )  unsafeLinear :: (a -> b) -> (a %1 -> b) unsafeLinear = unsafeCoerce
src/Proarrow/Category/Instance/Mat.hs view
@@ -24,8 +24,10 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Distributive (Distributive (..), distLInv, distRInv) import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Category.Topos (HasEpiMonoFactorization (..))@@ -310,24 +312,29 @@   apply @y @z = applySA @y @z   (^^^) = expSA -instance (P.Num a) => StarAutonomous (MatK a) where+instance (P.Num a) => Dialogue (MatK a) where   type Dual n = n   withObDual r = r    -- The dual of the compact-closed structure is the transpose, /not/ the conjugate-transpose:   -- it is the bilinear pairing, so it must not conjugate. See 'transpose'.   dual = transpose-  dualInv = transpose   linDist @(M x) @(M y) @(M z) (Mat m) = withMultNat @z @y $ Mat (concat (P.fmap (chunks @y @x) m))   linDistInv @(M x) @(M y) @(M z) (Mat m) = withMultNat @y @x $ Mat (P.fmap concat (chunks @z @y m))-  doubleNeg = id   doubleNegInv = id +instance (P.Num a) => StarAutonomous (MatK a) where+  dualInv = transpose+  doubleNeg = id++instance (P.Num a) => IsoMix (MatK a) where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @x = cap @x+ instance (P.Num a) => CompactClosed (MatK a) where   distribDual @m @n = withMultNat @(UN M m) @(UN M n) $ transpose (obj @m) ** transpose (obj @n)-  dualUnit = id   dualityUnit @x = cup @x-  dualityCounit @x = cap @x  instance (P.Num a, MonoidalAction (t :: (MatK a, MatK a) +-> MatK a)) => Costrong t (Mat :: CAT (MatK a)) where   coact @x = coactCC @t @x
src/Proarrow/Category/Instance/Monoid.hs view
@@ -15,6 +15,8 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault) import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..), combine)@@ -50,20 +52,25 @@ instance (CommutativeMonoid m) => SymMonoidal (MONOID m) where   swap = Mon mempty -instance (CommutativeMonoid m) => StarAutonomous (MONOID m) where+instance (CommutativeMonoid m) => Dialogue (MONOID m) where   type Dual (M :: MONOID m) = M   withObDual r = r   dual f@Mon{} = f-  dualInv f = f   linDist _ = id   linDistInv _ = id-  doubleNeg = id   doubleNegInv = id++instance (CommutativeMonoid m) => StarAutonomous (MONOID m) where+  dualInv f = f+  doubleNeg = id+instance (CommutativeMonoid m) => IsoMix (MONOID m) where+  dualUnit = Mon mempty+  dualUnitInv = Mon mempty+  dualityCounit = Mon mempty+ instance (CommutativeMonoid m) => CompactClosed (MONOID m) where   distribDual = Mon mempty-  dualUnit = Mon mempty   dualityUnit = Mon mempty-  dualityCounit = Mon mempty instance (CommutativeMonoid m) => Closed (MONOID m) where   type a ~~> b = M   withObExp r = r
src/Proarrow/Category/Instance/Product.hs view
@@ -11,15 +11,13 @@  import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..)) import Proarrow.Category.Enriched.Thin-  ( CodiscreteProfunctor (..)-  , Discrete (..)-  , Enumerable (..)+  ( Enumerable (..)   , Finite (..)   , Indexed (..)   , ThinProfunctor (..)   ) import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..))-import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), obj, type (+->))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, type (+->)) import Proarrow.Functor (FunctorForRep (..))  type (:**:) :: j1 +-> k1 -> j2 +-> k2 -> (j1, j2) +-> (k1, k2)@@ -44,7 +42,7 @@   dagger (f :**: g) = dagger f :**: dagger g  instance (ThinProfunctor p, ThinProfunctor q) => ThinProfunctor (p :**: q) where-  type HasArrow (p :**: q) '(a1, a2) '(b1, b2) = (HasArrow p a1 b1, HasArrow q a2 b2)+  type HasArrow (p :**: q) a b = (HasArrow p (Fst @ a) (Fst @ b), HasArrow q (Snd @ a) (Snd @ b))   arr = arr :**: arr   withArr (f :**: g) r = withArr f (withArr g r) @@ -62,16 +60,6 @@ instance (CategoryOf k) => FunctorForRep (Diag :: k +-> (k, k)) where   type Diag @ a = '(a, a)   fmap f = f :**: f--checkDiscrete :: (Discrete j, Discrete k) => Hom (j, k) a b -> ((a ~ b) => r) -> r-checkDiscrete f r = withEq f r---- Does not work--- checkDiscreteProfunctor :: (DiscreteProfunctor p, DiscreteProfunctor q) => (p :**: q) a b -> r--- checkDiscreteProfunctor f = exfalso f--checkCodiscreteProfunctor :: (CodiscreteProfunctor p, CodiscreteProfunctor q, Ob a, Ob b) => (p :**: q) a b-checkCodiscreteProfunctor = anyArr  -- | The product of two enumerable kinds is enumerable, but numbering one in general needs type-level -- division to invert the pairing, which @fin@ does not provide, so this instance for
src/Proarrow/Category/Instance/Span.hs view
@@ -9,7 +9,9 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Hypergraph (ExpHG, Frobenius, Hypergraph, applyHG, cap, cup, curryHG)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, src) import Proarrow.Limit.BinaryProduct@@ -86,20 +88,25 @@   curry @a @b = curryHG @a @b   apply @b @c = applyHG @b @c -instance (HasPullbacks k, HasProducts k) => StarAutonomous (SPAN k) where+instance (HasPullbacks k, HasProducts k) => Dialogue (SPAN k) where   type Dual a = a   withObDual r = r   dual (Span f g) = Span g f-  dualInv (Span f g) = Span g f   linDist @(SP a) @(SP b) (Span f g) = Span (fst @k @a @b . f) (snd @k @a @b . f &&& g)   linDistInv @_ @(SP b) @(SP c) (Span f g) = Span (f &&& fst @k @b @c . g) (snd @k @b @c . g)-  doubleNeg = id   doubleNegInv = id++instance (HasPullbacks k, HasProducts k) => StarAutonomous (SPAN k) where+  dualInv (Span f g) = Span g f+  doubleNeg = id+instance (HasPullbacks k, HasProducts k) => IsoMix (SPAN k) where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a+ instance (HasPullbacks k, HasProducts k) => CompactClosed (SPAN k) where   distribDual @(SP a) @(SP b) = withObProd @k @a @b id-  dualUnit = id   dualityUnit @a = cup @a-  dualityCounit @a = cap @a  instance (HasPullbacks k, HasProducts k) => DaggerProfunctor (Span :: CAT (SPAN k)) where   dagger = dual
src/Proarrow/Category/Instance/ZX.hs view
@@ -29,7 +29,9 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, type (+->))@@ -174,25 +176,30 @@   apply @y @z = applySA @y @z   (^^^) = expSA -instance StarAutonomous Nat where+instance Dialogue Nat where   type Dual x = x   withObDual r = r   dual (ZX m) = ZX (transpose m)-  dualInv = dual   linDist @_ @b @c (ZX m) =     withOb2 @_ @b @c $       ZX (Map.mapKeys (\(c, ab) -> case split ab of (a, b) -> (combine b c, a)) m)   linDistInv @a @b (ZX m) =     withOb2 @_ @a @b $       ZX (Map.mapKeys (\(bc, a) -> case split bc of (b, c) -> (c, combine a b)) m)-  doubleNeg = id   doubleNegInv = id +instance StarAutonomous Nat where+  dualInv = dual+  doubleNeg = id++instance IsoMix Nat where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a+ instance CompactClosed Nat where   distribDual @a @b = withOb2 @_ @a @b id-  dualUnit = id   dualityUnit @a = cup @a-  dualityCounit @a = cap @a  instance (MonoidalAction (t :: (Nat, Nat) +-> Nat)) => Costrong t ZX where   coact @x = coactCC @t @x
src/Proarrow/Category/Monoidal.hs view
@@ -228,10 +228,10 @@ -- associatorInv \@a \@b \@c = associatorDefault \@a \@b \@c -- @ type Strictly :: forall {k}. k -> Constraint-class (a ** Unit ~ a, Unit ** a ~ a, forall b c. (Ob b, Ob c) => StrictlyAssoc a b c) => Strictly (a :: k) where+class (a ** Unit ~ a, Unit ** a ~ a, forall b c. StrictlyAssoc a b c) => Strictly (a :: k) where   associatorDefault :: forall b c. (Monoidal k, Ob a, Ob b, Ob c) => (a ** b) ** c ~> a ** (b ** c) -instance (a ** Unit ~ a, Unit ** a ~ a, forall b c. (Ob b, Ob c) => StrictlyAssoc a b c) => Strictly (a :: k) where+instance (a ** Unit ~ a, Unit ** a ~ a, forall b c. StrictlyAssoc a b c) => Strictly (a :: k) where   associatorDefault @b @c = withOb2 @_ @b @c (withOb2 @_ @a @(b ** c) id)  instance Monoidal () where@@ -284,8 +284,10 @@ (==) :: (CategoryOf k) => (a :: k) ~> b -> b ~> c -> a ~> c f == g = g . f +-- | The identity on a tensor. It is built from 'withOb2' rather than as @obj \@a '**' obj \@b@,+-- so that an instance's own '**' can use it without calling itself. obj2 :: forall {k} a b. (Monoidal k, Ob (a :: k), Ob b) => Obj (a ** b)-obj2 = obj @a ** obj @b+obj2 = withOb2 @k @a @b (obj @(a ** b))  leftUnitor' :: (Monoidal k) => (a :: k) ~> b -> Unit ** a ~> b leftUnitor' f = f . leftUnitor \\ f
src/Proarrow/Category/Monoidal/Applicative.hs view
@@ -18,7 +18,7 @@ import Proarrow.Colimit.BinaryCoproduct (COPROD (..), HasBinaryCoproducts (..), nil, unCoprod, (++)) import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))-import Proarrow.Functor (FromProfunctor (..), Functor (..), Prelude (..))+import Proarrow.Functor (FromProfunctor (..), Functor (..), Prelude (..), withObF) import Proarrow.Monoid (Comonoid (..))  type Applicative :: forall {j} {k}. (j -> k) -> Constraint@@ -27,13 +27,17 @@   liftA2 :: (Ob a, Ob b) => (a ** b ~> c) -> f a ** f b ~> f c  ap :: forall {j} {k} f a b. (Applicative (f :: j -> k), Closed j, Closed k, Ob a, Ob b) => f (a ~~> b) ~> f a ~~> f b-ap = withObExp @j @a @b $ curry @k @_ @(f a) @(f b) (liftA2 @f @(a ~~> b) @a (apply @j @a))+ap =+  withObExp @j @a @b $+    withObF @f @(a ~~> b) $+      withObF @f @a $+        curry @k @_ @(f a) @(f b) (liftA2 @f @(a ~~> b) @a (apply @j @a))  fmapDefault :: forall f a b. (Applicative f) => a ~> b -> f a ~> f b-fmapDefault f = liftA2 @_ @Unit @a (f . leftUnitor @_ @a) . leftUnitorInvWith (pure @f id) \\ f+fmapDefault f = withObF @f @a (liftA2 @_ @Unit @a (f . leftUnitor @_ @a) . leftUnitorInvWith (pure @f id)) \\ f  liftA3 :: forall f a b c d. (Applicative f, Ob a, Ob b, Ob c) => (a ** b ** c ~> d) -> f a ** f b ** f c ~> f d-liftA3 f = withOb2 @_ @a @b (liftA2 @_ @(a ** b) @c f . first @(f c) (liftA2 @f @a @b id))+liftA3 f = withObF @f @c $ withOb2 @_ @a @b (liftA2 @_ @(a ** b) @c f . first @(f c) (liftA2 @f @a @b id))  instance (MonoidalProfunctor (p :: j +-> k), Comonoid x) => Applicative (FromProfunctor p x) where   pure a () = FromProfunctor $ dimap counit a one
src/Proarrow/Category/Monoidal/Closed.hs view
@@ -26,9 +26,10 @@ import Proarrow.Category.Instance.Unit qualified as U import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), type (**!)) import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), concatMany, obj1, singleton, splitMany, (==))-import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj, (//), type (+->))+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj, type (+->)) import Proarrow.Functor (FunctorForRep (..)) import Proarrow.Limit.BinaryProduct ()+import Proarrow.Object (pattern Objs) import Proarrow.Profunctor.Corepresentable (Corepresentable (..)) import Proarrow.Profunctor.Representable (Rep (..)) import Proarrow.Tools.Laws (Bijection (..), Law (..), Laws (..), bijection, (===))@@ -67,11 +68,9 @@    -- | The exponential's action on arrows: covariant in the result, contravariant in the argument.   (^^^) :: forall (a :: k) b x y. b ~> y -> x ~> a -> a ~~> b ~> x ~~> y-  f ^^^ g =-    f //-      g //-        withObExp @k @a @b $-          let ab = obj @(a ~~> b) in curry @k @(a ~~> b) @x (f . apply @k @a @b . (ab ** g))+  f@Objs ^^^ g@Objs =+    withObExp @k @a @b $+      let ab = obj @(a ~~> b) in curry @k @(a ~~> b) @x (f . apply @k @a @b . (ab ** g))  uncurry :: forall {k} b c (a :: k). (Closed k) => (Ob b, Ob c) => a ~> b ~~> c -> a ** b ~> c uncurry f = apply @k @b @c . (f ** obj @b)
src/Proarrow/Category/Monoidal/CompactClosed.hs view
@@ -2,9 +2,10 @@ {-# LANGUAGE RequiredTypeArguments #-} {-# OPTIONS_GHC -Wno-unused-foralls #-} --- | Compact closed categories: star-autonomous categories whose dual distributes over the tensor--- ('distribDual', 'dualUnit'), so that every object has a duality unit and counit ('dualityUnit',--- 'dualityCounit') and every morphism @x ** u ~> y ** u@ has a trace ('traceCC').+-- | Compact closed categories: isomix categories whose dual distributes over the tensor+-- ('distribDual', with 'dualUnit' from 'IsoMix'), so that every object has a duality unit and+-- counit ('dualityUnit', 'dualityCounit') and every morphism @x ** u ~> y ** u@ has a trace+-- ('traceCC'). module Proarrow.Category.Monoidal.CompactClosed where  import Data.Kind (Constraint)@@ -18,7 +19,6 @@   ( Monoidal (..)   , MonoidalProfunctor (..)   , SymMonoidal (..)-  , UnitF   , leftUnitorWith   , swap   , unitObj@@ -26,33 +26,21 @@   ) import Proarrow.Category.Monoidal.Action (Act, MonoidalAction (..), actHom) import Proarrow.Category.Monoidal.Closed (Closed)-import Proarrow.Category.Monoidal.StarAutonomous-  ( DualF-  , StarAutonomous (..)-  , doubleNeg-  , dualObj-  , dualityCounitSA-  , dualityUnitSA-  )+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), DualF, dualObj, dualityUnitSA)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1, swap2, (==)) import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj, type (+->)) import Proarrow.Tools.Laws (Inverses (..), Labelled (..), Law (..), Laws (..), inverses, (===)) -class (StarAutonomous k, SymMonoidal k) => CompactClosed k where+class (IsoMix k, StarAutonomous k) => CompactClosed k where   distribDual :: forall (a :: k) b. (Ob a, Ob b) => Dual (a ** b) ~> Dual a ** Dual b-  dualUnit :: Dual (Unit :: k) ~> Unit    -- | The unit of the duality between @a@ and its dual. 'dualityUnitDefault' gives it from the   -- *-autonomous structure; an instance with cups of its own can use them. (There is no default   -- method: @a@ occurs only under type families, so GHC could not instantiate one.)   dualityUnit :: (Ob (a :: k)) => Unit ~> a ** Dual a -  -- | The counit of the duality between @a@ and its dual; see 'dualityCounitDefault'.-  dualityCounit :: (Ob (a :: k)) => Dual a ** a ~> Unit--dualUnitInv :: forall {k}. (CompactClosed k) => (Unit :: k) ~> Dual Unit-dualUnitInv = leftUnitor @k @(Dual Unit) . dualityUnit @k @Unit \\ dualObj @(Unit :: k)- -- | 'dualityUnit' from the *-autonomous structure. dualityUnitDefault :: forall {k} (a :: k). (CompactClosed k, Ob a) => Unit ~> a ** Dual a dualityUnitDefault = let dualA = dualObj @a in (doubleNeg @k @a ** dualA) . distribDual @k @(Dual a) @a . dualityUnitSA @a \\ dualA@@ -60,10 +48,6 @@ dualityUnitS :: forall {k} (a :: k). (CompactClosed k, Ob a) => '[] ~> [a, Dual a] dualityUnitS = withObDual @k @a (Str @'[] @[a, Dual a] (dualityUnit @k @a)) --- | 'dualityCounit' from the *-autonomous structure.-dualityCounitDefault :: forall {k} (a :: k). (CompactClosed k, Ob a) => Dual a ** a ~> Unit-dualityCounitDefault = dualUnit . dualityCounitSA @a- dualityCounitS :: forall {k} (a :: k). (CompactClosed k, Ob a) => [Dual a, a] ~> '[] dualityCounitS = withObDual @k @a (Str @[Dual a, a] @'[] (dualityCounit @k @a)) @@ -110,19 +94,15 @@  instance CompactClosed () where   distribDual = U.Unit-  dualUnit = U.Unit   dualityUnit = U.Unit-  dualityCounit = U.Unit  instance (CompactClosed j, CompactClosed k) => CompactClosed (j, k) where   distribDual @'(a, a') @'(b, b') = distribDual @j @a @b :**: distribDual @k @a' @b'-  dualUnit = dualUnit :**: dualUnit   dualityUnit @'(a, a') = dualityUnit @j @a :**: dualityUnit @k @a'-  dualityCounit @'(a, a') = dualityCounit @j @a :**: dualityCounit @k @a'  -- | The structures the free category needs for 'CompactClosed', and those its laws are stated for. type CompactClosedStructures :: [Kind -> Constraint]-type CompactClosedStructures = '[Monoidal, SymMonoidal, Closed, StarAutonomous, CompactClosed]+type CompactClosedStructures = '[Monoidal, SymMonoidal, Closed, Dialogue, StarAutonomous, IsoMix, CompactClosed]  instance   (CompactClosedStructures `Elems` cs)@@ -130,31 +110,24 @@   where   data Struct CompactClosed a b where     DistribDual :: (Ob a, Ob b) => Struct CompactClosed (DualF (a **! b)) (DualF a **! DualF b)-    DualUnit :: Struct CompactClosed (DualF UnitF) UnitF   foldStructure @f _ (DistribDual @a @b) =     withLowerOb @f @a (withLowerOb @f @b (distribDual @_ @(Lower f a) @(Lower f b)))-  foldStructure _ DualUnit = dualUnit instance P.Show (Struct CompactClosed a b) where   showsPrec _ DistribDual = P.showString "distribDual"-  showsPrec _ DualUnit = P.showString "dualUnit"  instance   (CompactClosedStructures `Elems` cs)   => CompactClosed (FREE cs (p :: CAT k))   where   distribDual @a @b = St (DistribDual @a @b) Nil-  dualUnit = St DualUnit Nil   dualityUnit @a = dualityUnitDefault @a-  dualityCounit @a = dualityCounitDefault @a --- | 'distribDual' and 'dualUnit' are isomorphisms (so 'Dual' is strong monoidal), and 'dualityUnit'+-- | 'distribDual' is an isomorphism (with 'dualUnit' from 'IsoMix', so 'Dual' is strong monoidal), and 'dualityUnit' -- and 'dualityCounit' satisfy the zigzag identities, making @Dual a@ dual to @a@. instance Laws CompactClosedStructures where   laws =     inverses "distribDual" (\ @a @b -> Inverses (distribDual @_ @a @b) (label "combineDual" (combineDual @a @b)))-      P.++ inverses "dualUnit" (Inverses dualUnit (label "dualUnitInv" dualUnitInv))       P.++ [ Law "dualityUnit definition" \ @a _ -> withObDual @_ @a (dualityUnit @_ @a === dualityUnitDefault @a)-           , Law "dualityCounit definition" \ @a _ -> withObDual @_ @a (dualityCounit @_ @a === dualityCounitDefault @a)            , Law                "zigzag (a)"                \ @a _ ->
+ src/Proarrow/Category/Monoidal/Dialogue.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Dialogue categories (Melliès): symmetric monoidal categories with a tensorial negation 'Dual',+-- where morphisms @a ** b ~> Dual c@ correspond to @a ~> Dual (b ** c)@ ('linDist'). Unlike in a+-- *-autonomous category, double negation @'Dual' ('Dual' a) ~> a@ need not exist: only its inverse+-- 'doubleNegInv' does, which 'tripleNeg' undoes on a dual. Any closed category with a chosen+-- answer object is one, with @'Dual' a = a ~~> r@, which is why the continuation passing+-- reading of System L in "Proarrow.Tools.SMC" needs no more than this.+--+-- The *-autonomous categories of "Proarrow.Category.Monoidal.StarAutonomous" are the dialogue+-- categories whose double negation is an isomorphism.+module Proarrow.Category.Monoidal.Dialogue where++import Data.Kind (Constraint)+import Prelude (($))+import Prelude qualified as P++import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), Not)+import Proarrow.Category.Instance.Free+  ( Elem (..)+  , Elems+  , FREE (..)+  , Free (..)+  , HasStructure (..)+  , IsFreeOb (..)+  , Lower+  , WithShow+  , withLowerOb+  )+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), swap, type (**!))+import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1, singleton)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Obj, Profunctor (..), Promonad (..), obj)+import Proarrow.Limit.BinaryProduct ()+import Proarrow.Tools.Laws (Bijection (..), Law (..), Laws (..), bijection, (===))++-- | A dialogue category: a symmetric monoidal category with a tensorial negation, so that 'Dual'+-- is a contravariant functor and @Hom(a '**' b, 'Dual' c) ≅ Hom(a, 'Dual' (b '**' c))@.+--+-- __Laws:__+--+-- * 'dual' is a contravariant functor: @'dual' 'id' = 'id'@ and @'dual' (f . g) = 'dual' g . 'dual' f@+-- * 'linDist' and 'linDistInv' are mutually inverse, giving+--   @Hom(a '**' b, 'Dual' c) ≅ Hom(a, 'Dual' (b '**' c))@, natural in all three variables+-- * 'doubleNegInv' is 'doubleNegInvDefault', the one the rest of the structure gives+--+-- Stated as code by the 'Proarrow.Tools.Laws.Laws' instance for 'DialogueStructures', and+-- checked by @Proarrow.Testing.Laws.testDialogue@.+class (SymMonoidal k) => Dialogue k where+  -- | The dual of an object.+  type Dual (a :: k) :: k++  -- | Recovers @'Ob' ('Dual' a)@ from the objecthood of @a@.+  withObDual :: (Ob (a :: k)) => ((Ob (Dual a)) => r) -> r++  -- | 'Dual'\'s contravariant action on arrows.+  dual :: (a :: k) ~> b -> Dual b ~> Dual a++  -- | Linear distribution: transposes a tensor factor across the dual.+  linDist :: (Ob (a :: k), Ob b, Ob c) => a ** b ~> Dual c -> a ~> Dual (b ** c)++  -- | Inverse to 'linDist'.+  linDistInv :: (Ob (a :: k), Ob b, Ob c) => a ~> Dual (b ** c) -> a ** b ~> Dual c++  -- | Double-negation introduction. Defaults to 'doubleNegInvDefault'.+  doubleNegInv :: (Ob (a :: k)) => a ~> Dual (Dual a)+  doubleNegInv @a = doubleNegInvDefault @a++dualObj :: forall {k} (a :: k). (Dialogue k, Ob a) => Obj (Dual a)+dualObj = dual (obj @a)++-- | 'doubleNegInv' from the rest of the structure, through 'linDistInv' and the duality unit.+doubleNegInvDefault :: forall {k} (a :: k). (Dialogue k, Ob a) => a ~> Dual (Dual a)+doubleNegInvDefault =+  linDistInv @k @Unit @a @(Dual a) (dual (swap @k @a @(Dual a)) . dualityUnitSA @a) . leftUnitorInv @k @a+    \\ dualObj @a++-- | Triple negation elimination: a dual is a retract of its double negation, with 'doubleNegInv' as+-- the section, @'tripleNeg' . 'doubleNegInv' = 'id'@. For the computations of "Proarrow.Tools.SMC"+-- it runs a computation of a computation into one, like @join@. It is an isomorphism only in a+-- *-autonomous category: in 'Data.Kind.Type' with answer object 'Prelude.Bool', @Dual ()@ has two+-- elements and @Dual (Dual (Dual ()))@ sixteen.+tripleNeg :: forall {k} (a :: k). (Dialogue k, Ob a) => Dual (Dual (Dual a)) ~> Dual a+tripleNeg = dual (doubleNegInv @k @a)++-- | The Kleisli extension of the double negation monad at a dual: a morphism out of @a@ into a dual,+-- extended to double negations of @a@. This is the bind of the continuation reading of System L in+-- "Proarrow.Tools.SMC". It moves @a@ to the other side of the hom, @g ** y ~> Dual a@, and dualizes.+{-# INLINE bindDual #-}+bindDual+  :: forall {k} (g :: k) a y+   . (Dialogue k, Ob g, Ob a, Ob y)+  => g ** a ~> Dual y+  -> Dual (Dual a) ** g ~> Dual y+bindDual f =+  withObDual @k @a $+    withObDual @k @(Dual a) $+      linDistInv @k @(Dual (Dual a)) @g @y $+        dual $+          linDistInv @k @g @y @a (dual (swap @k @y @a) . linDist @k @g @a @y f)++linDistS+  :: forall {k} (a :: k) (b :: k) c. (Dialogue k, Ob c) => '[a, b] ~> '[Dual c] -> '[a] ~> '[Dual (b ** c)]+linDistS f@Str{} = singleton (linDist @k @a @b @c (unStr f))++linDistInvS+  :: forall {k} (a :: k) (b :: k) c. (Dialogue k, Ob b, Ob c) => '[a] ~> '[Dual (b ** c)] -> '[a, b] ~> '[Dual c]+linDistInvS f@Str{} = withObDual @k @c (Str (linDistInv @k @a @b @c (unStr f)) \\ obj1 @(Dual c))++-- | Par, the dual of the tensor of the duals.+type Par :: forall {k}. k -> k -> k+type Par a b = Dual (Dual a ** Dual b)++-- | Recovers @'Ob' ('Par' a b)@, and the objecthood of the duals it is made of, from the objecthood+-- of @a@ and @b@.+withObPar+  :: forall {k} (a :: k) b r. (Dialogue k, Ob a, Ob b) => ((Ob (Dual a), Ob (Dual b), Ob (Par a b)) => r) -> r+withObPar r = withObDual @k @a (withObDual @k @b (withOb2 @k @(Dual a) @(Dual b) (withObDual @k @(Dual a ** Dual b) r)))++-- | 'Par'\'s action on arrows.+par :: forall {k} (a :: k) b c d. (Dialogue k) => a ~> c -> b ~> d -> Par a b ~> Par c d+par f g = dual (dual f ** dual g)++-- | The symmetry of 'Par'.+parSwap :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => Par a b ~> Par b a+parSwap = withObPar @a @b (dual (swap @k @(Dual b) @(Dual a)))++-- | Linear distributivity: the tensor distributes into the left of a 'Par'. Given the dual of+-- @a '**' b@, the @a@ turns it into the dual of @b@, which the 'Par' answers with @c@.+weakDistL :: forall {k} (a :: k) b c. (Dialogue k, Ob a, Ob b, Ob c) => a ** Par b c ~> Par (a ** b) c+weakDistL =+  withObPar @b @c+    ( withOb2 @k @a @b+        ( withObDual @k @(a ** b)+            ( withOb2 @k @a @(Par b c)+                ( linDist @k @(a ** Par b c) @(Dual (a ** b)) @(Dual c)+                    ( linDistInv @k @(Par b c) @(Dual b) @(Dual c) id+                        . (obj @(Par b c) ** linDistInv @k @(Dual (a ** b)) @a @b id)+                        . (obj @(Par b c) ** swap @k @a @(Dual (a ** b)))+                        . associator @k @(Par b c) @a @(Dual (a ** b))+                        . (swap @k @a @(Par b c) ** obj @(Dual (a ** b)))+                    )+                )+            )+        )+    )++-- | Linear distributivity on the other side, from 'weakDistL' by symmetry.+weakDistR :: forall {k} (a :: k) b c. (Dialogue k, Ob a, Ob b, Ob c) => Par a b ** c ~> Par a (b ** c)+weakDistR =+  withObPar @b @a+    ( withOb2 @k @c @b+        ( par (obj @a) (swap @k @c @b)+            . parSwap @(c ** b) @a+            . weakDistL @c @b @a+            . swap @k @(Par b a) @c+            . (parSwap @a @b ** obj @c)+        )+    )++dualityUnitSA :: forall {k} (a :: k). (Dialogue k, Ob a) => Unit ~> Dual (Dual a ** a)+dualityUnitSA = linDist @k @_ @(Dual a) @a leftUnitor \\ dualObj @a++dualityCounitSA :: forall {k} (a :: k). (Dialogue k, Ob a) => Dual a ** a ~> Dual Unit+dualityCounitSA = linDistInv @k @(Dual a) @a @Unit (dual (rightUnitor @k @a)) \\ dualObj @a++instance Dialogue () where+  type Dual '() = '()+  withObDual r = r+  dual U.Unit = U.Unit+  linDist U.Unit = U.Unit+  linDistInv U.Unit = U.Unit+  doubleNegInv = U.Unit++instance Dialogue BOOL where+  type Dual (a :: BOOL) = Not a+  withObDual r = r+  dual Fls = Tru+  dual F2T = F2T+  dual Tru = Fls+  linDist @a @b f = case (obj @a, obj @b) of+    (Fls, Fls) -> F2T+    (Tru, Fls) -> Tru+    (_, Tru) -> f+  linDistInv @_ @b @c f = case (obj @b, obj @c) of+    (Fls, Fls) -> F2T+    (Fls, Tru) -> Fls+    (Tru, _) -> f+  doubleNegInv @a = case obj @a of Fls -> Fls; Tru -> Tru++instance (Dialogue j, Dialogue k) => Dialogue (j, k) where+  type Dual '(a, b) = '(Dual a, Dual b)+  withObDual @'(a, b) r = withObDual @j @a (withObDual @k @b r)+  dual (f :**: g) = dual f :**: dual g+  linDist @'(a1, a2) @'(b1, b2) @'(c1, c2) (f :**: g) = linDist @j @a1 @b1 @c1 f :**: linDist @k @a2 @b2 @c2 g+  linDistInv @'(a1, a2) @'(b1, b2) @'(c1, c2) (f :**: g) = linDistInv @j @a1 @b1 @c1 f :**: linDistInv @k @a2 @b2 @c2 g+  doubleNegInv @'(a, b) = doubleNegInv @j @a :**: doubleNegInv @k @b++data family DualF (a :: k) :: k+instance (IsFreeOb (a :: FREE cs p), Dialogue `Elem` cs) => IsFreeOb (DualF a) where+  type Lower f (DualF a) = Dual (Lower f a)+  lowerOb @k' @f r = fromAll @Dialogue @cs @k' (withLowerOb @f @a (withObDual @k' @(Lower f a) r))++-- | The structures the free category needs for 'Dialogue', and those its laws are stated for.+type DialogueStructures :: [Kind -> Constraint]+type DialogueStructures = '[Monoidal, SymMonoidal, Dialogue]++instance+  (DialogueStructures `Elems` cs)+  => HasStructure cs (p :: CAT k) Dialogue+  where+  data Struct Dialogue a b where+    Dual :: a ~> b -> Struct Dialogue (DualF b) (DualF a)+    LinDist :: (Ob a, Ob b, Ob c) => a **! b ~> DualF c -> Struct Dialogue a (DualF (b **! c))+    LinDistInv :: (Ob a, Ob b, Ob c) => a ~> DualF (b **! c) -> Struct Dialogue (a **! b) (DualF c)+  foldStructure go (Dual f) = dual (go f)+  foldStructure @f go (LinDist @a @b @c g) =+    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (linDist @_ @(Lower f a) @(Lower f b) @(Lower f c) (go g))))+  foldStructure @f go (LinDistInv @a @b @c g) =+    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (linDistInv @_ @(Lower f a) @(Lower f b) @(Lower f c) (go g))))+instance (WithShow a) => P.Show (Struct Dialogue a b) where+  showsPrec d (Dual f) = P.showParen (d P.> 10) P.$ P.showString "dual " . P.showsPrec 11 f+  showsPrec d (LinDist f) = P.showParen (d P.> 10) P.$ P.showString "linDist " . P.showsPrec 11 f+  showsPrec d (LinDistInv f) = P.showParen (d P.> 10) P.$ P.showString "linDistInv " . P.showsPrec 11 f++instance+  (DialogueStructures `Elems` cs)+  => Dialogue (FREE cs (p :: CAT k))+  where+  type Dual a = DualF a+  withObDual r = r+  dual f = St (Dual f) Nil \\ f+  linDist @a @b @c f = St (LinDist @a @b @c f) Nil \\ f+  linDistInv @a @b @c f = St (LinDistInv @a @b @c f) Nil \\ f++-- | 'dual' is a contravariant functor, 'linDist' is a natural bijection+-- @Hom(a ** b, Dual c) ≅ Hom(a, Dual (b ** c))@ with inverse 'linDistInv', and 'doubleNegInv' is+-- the one they give.+instance Laws DialogueStructures where+  laws =+    [ Law "dual identity" \ @a _ -> withObDual @_ @a (dual (obj @a) === id)+    , Law "dual composition" \ @a @b @c mor -> do+        f <- mor @a @b "f"+        g <- mor @b @c "g"+        dual (g . f) === dual f . dual g+    , Law "linDist naturality" \ @a @b @c @d @e mor ->+        withOb2 @_ @a @b $ withOb2 @_ @d @e $ withObDual @_ @c $ withObDual @_ @d do+          p <- mor @(a ** b) @(Dual c) "p"+          f <- mor @d @a "f"+          g <- mor @e @b "g"+          h <- mor @d @c "h"+          linDist @_ @d @e @d (dual h . p . (f ** g)) === dual (g ** h) . linDist @_ @a @b @c p . f+    ]+      P.++ bijection+        "linDist"+        ( \ @a @b @c mor ->+            withOb2 @_ @a @b $+              withOb2 @_ @b @c $+                withObDual @_ @c $+                  withObDual @_ @(b ** c) $+                    Bijection (mor @(a ** b) @(Dual c) "p") (mor @a @(Dual (b ** c)) "q") (linDist @_ @a @b @c) (linDistInv @_ @a @b @c)+        )+      P.++ [ Law "doubleNegInv definition" \ @a _ -> withObDual @_ @a $ withObDual @_ @(Dual a) (doubleNegInv @_ @a === doubleNegInvDefault @a)+           ]
+ src/Proarrow/Category/Monoidal/IsoMix.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Isomix categories: dialogue categories whose two units agree, @'Dual' 'Unit'@, the unit of+-- par, being isomorphic to 'Unit' ('dualUnit'). Then a dual and its object can be joined into the+-- unit of the tensor, not just into the unit of par. Every compact closed category is isomix, and+-- so is 'Proarrow.Category.Instance.Linear.LINEAR', where tensor and par still differ.+-- 'Proarrow.Category.Instance.Cps.CPS' @r@ is isomix exactly when the answer object @r@ is the+-- unit: with effects as the answer object, as @CPS (IO ())@, joining a consumer and a value into+-- the unit would discard the effect.+module Proarrow.Category.Monoidal.IsoMix where++import Data.Kind (Constraint)+import Prelude qualified as P++import Proarrow.Category.Instance.Free (Elems, FREE (..), Free (..), HasStructure (..))+import Proarrow.Category.Instance.Product ((:**:) (..))+import Proarrow.Category.Instance.Unit qualified as U+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal, UnitF, type (**))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), DualF, dualityCounitSA)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Promonad (..))+import Proarrow.Tools.Laws (Inverses (..), Law (..), Laws (..), inverses, (===))++class (Dialogue k) => IsoMix k where+  -- | The unit of par is isomorphic to the unit of the tensor.+  dualUnit :: Dual (Unit :: k) ~> Unit++  -- | The inverse of 'dualUnit'.+  dualUnitInv :: (Unit :: k) ~> Dual Unit++  -- | Join a dual and its object into the unit. 'dualityCounitDefault' gives it from the+  -- dialogue structure; a compact closed category has a counit of its own. (There is no+  -- default method: @a@ occurs only under type families, so GHC could not instantiate one.)+  dualityCounit :: (Ob (a :: k)) => Dual a ** a ~> Unit++-- | 'dualityCounit' from the dialogue structure: into the unit of par, then 'dualUnit'.+dualityCounitDefault :: forall {k} (a :: k). (IsoMix k, Ob a) => Dual a ** a ~> Unit+dualityCounitDefault = dualUnit . dualityCounitSA @a++instance IsoMix () where+  dualUnit = U.Unit+  dualUnitInv = U.Unit+  dualityCounit = U.Unit++instance (IsoMix j, IsoMix k) => IsoMix (j, k) where+  dualUnit = dualUnit :**: dualUnit+  dualUnitInv = dualUnitInv :**: dualUnitInv+  dualityCounit @'(a, a') = dualityCounit @j @a :**: dualityCounit @k @a'++-- | The structures the free category needs for 'IsoMix', and those its laws are stated for.+type IsoMixStructures :: [Kind -> Constraint]+type IsoMixStructures = '[Monoidal, SymMonoidal, Dialogue, IsoMix]++instance (IsoMixStructures `Elems` cs) => HasStructure cs (p :: CAT k) IsoMix where+  data Struct IsoMix a b where+    DualUnit :: Struct IsoMix (DualF UnitF) UnitF+    DualUnitInv :: Struct IsoMix UnitF (DualF UnitF)+  foldStructure _ DualUnit = dualUnit+  foldStructure _ DualUnitInv = dualUnitInv+instance P.Show (Struct IsoMix a b) where+  showsPrec _ DualUnit = P.showString "dualUnit"+  showsPrec _ DualUnitInv = P.showString "dualUnitInv"++instance (IsoMixStructures `Elems` cs) => IsoMix (FREE cs (p :: CAT k)) where+  dualUnit = St DualUnit Nil+  dualUnitInv = St DualUnitInv Nil+  dualityCounit @a = dualityCounitDefault @a++-- | 'dualUnit' and 'dualUnitInv' are inverses, and 'dualityCounit' is the one from the+-- dialogue structure.+instance Laws IsoMixStructures where+  laws =+    inverses "dualUnit" (Inverses dualUnit dualUnitInv)+      P.++ [Law "dualityCounit definition" \ @a _ -> withObDual @_ @a (dualityCounit @_ @a === dualityCounitDefault @a)]
src/Proarrow/Category/Monoidal/StarAutonomous.hs view
@@ -2,20 +2,20 @@ {-# LANGUAGE RequiredTypeArguments #-} {-# OPTIONS_GHC -Wno-unused-foralls #-} --- | Star-autonomous categories: symmetric closed categories with a dualizing functor 'Dual', where--- morphisms @a ** b ~> Dual c@ correspond to @a ~> Dual (b ** c)@ ('linDist'). This gives--- double-negation elimination ('doubleNeg') and an internal hom @'ExpSA' a b = 'Dual' (a ** Dual b)@--- Star-autonomous categories are the categorical semantics of multiplicative linear logic.+-- | Star-autonomous categories: dialogue categories ("Proarrow.Category.Monoidal.Dialogue") whose+-- dualizing functor 'Dual' is an involution, so that double negation @'Dual' ('Dual' a) ≅ a@+-- ('doubleNeg') and 'dual' is bijective on hom-sets ('dualInv'). They are closed, with an internal+-- hom @'ExpSA' a b = 'Dual' (a ** Dual b)@, and are the categorical semantics of multiplicative+-- linear logic. module Proarrow.Category.Monoidal.StarAutonomous where  import Data.Kind (Constraint) import Prelude (($)) import Prelude qualified as P -import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..), Not)+import Proarrow.Category.Instance.Bool (BOOL (..), Booleans (..)) import Proarrow.Category.Instance.Free-  ( Elem (..)-  , Elems+  ( Elems   , FREE (..)   , Free (..)   , HasStructure (..)@@ -26,90 +26,41 @@   ) import Proarrow.Category.Instance.Product ((:**:) (..)) import Proarrow.Category.Instance.Unit qualified as U-import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), swap, type (**!))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) import Proarrow.Category.Monoidal.Closed (Closed (..))-import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1, singleton)-import Proarrow.Core (CAT, CategoryOf (..), Kind, Obj, Profunctor (..), Promonad (..), obj)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), DualF, dualObj)+import Proarrow.Core (CAT, CategoryOf (..), Kind, Profunctor (..), Promonad (..), obj) import Proarrow.Optic (PIso, iso)-import Proarrow.Tools.Laws-  ( Bijection (..)-  , Inverses (..)-  , Law (..)-  , Laws (..)-  , bijection-  , inverses-  , (===)-  )+import Proarrow.Tools.Laws (Bijection (..), Inverses (..), Laws (..), bijection, inverses) --- | A *-autonomous category: a symmetric monoidal closed category with a dualizing object, so--- that 'Dual' is a contravariant involution and @Hom(a '**' b, 'Dual' c)@ is symmetric in its three--- arguments.+-- | A *-autonomous category: a dialogue category whose dual is an involution, so that+-- @Hom(a '**' b, 'Dual' c)@ is symmetric in its three arguments. ----- __Laws:__+-- __Laws:__ those of 'Dialogue', and ----- * 'dual' is a contravariant functor: @'dual' 'id' = 'id'@ and @'dual' (f . g) = 'dual' g . 'dual' f@ -- * 'dual' and 'dualInv' are mutually inverse bijections on hom-sets: --   @'dualInv' ('dual' f) = f@ and @'dual' ('dualInv' g) = g@--- * 'linDist' and 'linDistInv' are mutually inverse, giving---   @Hom(a '**' b, 'Dual' c) ≅ Hom(a, 'Dual' (b '**' c))@, natural in all three variables--- * 'doubleNeg' and 'doubleNegInv' are mutually inverse, so @'Dual' ('Dual' a) ≅ a@, and---   'doubleNegInv' is 'doubleNegInvDefault', the one the rest of the structure gives+-- * 'doubleNeg' and 'doubleNegInv' are mutually inverse, so @'Dual' ('Dual' a) ≅ a@ -- -- Stated as code by the 'Proarrow.Tools.Laws.Laws' instance for 'StarAutonomousStructures', and -- checked by @Proarrow.Testing.Laws.testStarAutonomous@.-class (SymMonoidal k, Closed k, Ob (Unit :: k)) => StarAutonomous k where-  -- | The dual of an object.-  type Dual (a :: k) :: k--  -- | Recovers @'Ob' ('Dual' a)@ from the objecthood of @a@.-  withObDual :: (Ob (a :: k)) => ((Ob (Dual a)) => r) -> r--  -- | 'Dual'\'s contravariant action on arrows.-  dual :: (a :: k) ~> b -> Dual b ~> Dual a-+class (Dialogue k, Closed k) => StarAutonomous k where   -- | Inverse to 'dual' on hom-sets: recovers the undualized arrow.   dualInv :: (Ob (a :: k), Ob b) => Dual a ~> Dual b -> b ~> a -  -- | Linear distribution: transposes a tensor factor across the dual.-  linDist :: (Ob (a :: k), Ob b, Ob c) => a ** b ~> Dual c -> a ~> Dual (b ** c)--  -- | Inverse to 'linDist'.-  linDistInv :: (Ob (a :: k), Ob b, Ob c) => a ~> Dual (b ** c) -> a ** b ~> Dual c-   -- | Double-negation elimination. Defaults to 'doubleNegDefault'; an instance whose double dual   -- is the object itself can say so directly.   doubleNeg :: (Ob (a :: k)) => Dual (Dual a) ~> a   doubleNeg @a = doubleNegDefault @a -  -- | Double-negation introduction, inverse to 'doubleNeg'. Defaults to 'doubleNegInvDefault'.-  doubleNegInv :: (Ob (a :: k)) => a ~> Dual (Dual a)-  doubleNegInv @a = doubleNegInvDefault @a--dualObj :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Obj (Dual a)-dualObj = dual (obj @a)- -- | 'doubleNeg' from the rest of the structure: 'dualInv' of 'doubleNegInv' at the dual. doubleNegDefault :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual (Dual a) ~> a doubleNegDefault = dualInv @k @a (doubleNegInv @k @(Dual a)) \\ dualObj @(Dual a) \\ dualObj @a --- | 'doubleNegInv' from the rest of the structure, through 'linDistInv' and the duality unit.-doubleNegInvDefault :: forall {k} (a :: k). (StarAutonomous k, Ob a) => a ~> Dual (Dual a)-doubleNegInvDefault =-  linDistInv @k @Unit @a @(Dual a) (dual (swap @k @a @(Dual a)) . dualityUnitSA @a) . leftUnitorInv @k @a-    \\ dualObj @a- doubleNegIso   :: forall {k} (a :: k) (a' :: k). (StarAutonomous k, Ob a, Ob a') => PIso a a' (Dual (Dual a)) (Dual (Dual a')) doubleNegIso = iso doubleNegInv doubleNeg -linDistS-  :: forall {k} (a :: k) (b :: k) c. (StarAutonomous k, Ob c) => '[a, b] ~> '[Dual c] -> '[a] ~> '[Dual (b ** c)]-linDistS f@Str{} = singleton (linDist @k @a @b @c (unStr f))--linDistInvS-  :: forall {k} (a :: k) (b :: k) c. (StarAutonomous k, Ob b, Ob c) => '[a] ~> '[Dual (b ** c)] -> '[a, b] ~> '[Dual c]-linDistInvS f@Str{} = withObDual @k @c (Str (linDistInv @k @a @b @c (unStr f)) \\ obj1 @(Dual c))- type ExpSA a b = Dual (a ** Dual b)  currySA :: forall {k} (a :: k) b c. (StarAutonomous k, Ob a, Ob b) => a ** b ~> c -> a ~> ExpSA b c@@ -123,132 +74,54 @@ expSA :: forall {k} (a :: k) b x y. (StarAutonomous k) => b ~> y -> x ~> a -> ExpSA a b ~> ExpSA x y expSA f g = dual (g ** dual f) -dualityUnitSA :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Unit ~> Dual (Dual a ** a)-dualityUnitSA = linDist @k @_ @(Dual a) @a leftUnitor \\ dualObj @a--dualityCounitSA :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual a ** a ~> Dual Unit-dualityCounitSA = linDistInv @k @(Dual a) @a @Unit (dual (rightUnitor @k @a)) \\ dualObj @a- instance StarAutonomous () where-  type Dual '() = '()-  withObDual r = r-  dual U.Unit = U.Unit   dualInv U.Unit = U.Unit-  linDist U.Unit = U.Unit-  linDistInv U.Unit = U.Unit   doubleNeg = U.Unit-  doubleNegInv = U.Unit  instance StarAutonomous BOOL where-  type Dual (a :: BOOL) = Not a-  withObDual r = r-  dual Fls = Tru-  dual F2T = F2T-  dual Tru = Fls   dualInv @a @b f = case (obj @a, obj @b, f) of     (Fls, Fls, Tru) -> Fls     (Tru, Fls, F2T) -> F2T     (Tru, Tru, Fls) -> Tru     (Fls, Tru, f') -> case f' of {}-  linDist @a @b f = case (obj @a, obj @b) of-    (Fls, Fls) -> F2T-    (Tru, Fls) -> Tru-    (_, Tru) -> f-  linDistInv @_ @b @c f = case (obj @b, obj @c) of-    (Fls, Fls) -> F2T-    (Fls, Tru) -> Fls-    (Tru, _) -> f   doubleNeg @a = case obj @a of Fls -> Fls; Tru -> Tru-  doubleNegInv @a = case obj @a of Fls -> Fls; Tru -> Tru  -- BOOL is not CompactClosed  instance (StarAutonomous j, StarAutonomous k) => StarAutonomous (j, k) where-  type Dual '(a, b) = '(Dual a, Dual b)-  withObDual @'(a, b) r = withObDual @j @a (withObDual @k @b r)-  dual (f :**: g) = dual f :**: dual g   dualInv (f :**: g) = dualInv f :**: dualInv g-  linDist @'(a1, a2) @'(b1, b2) @'(c1, c2) (f :**: g) = linDist @j @a1 @b1 @c1 f :**: linDist @k @a2 @b2 @c2 g-  linDistInv @'(a1, a2) @'(b1, b2) @'(c1, c2) (f :**: g) = linDistInv @j @a1 @b1 @c1 f :**: linDistInv @k @a2 @b2 @c2 g   doubleNeg @'(a, b) = doubleNeg @j @a :**: doubleNeg @k @b-  doubleNegInv @'(a, b) = doubleNegInv @j @a :**: doubleNegInv @k @b -data family DualF (a :: k) :: k-instance (IsFreeOb (a :: FREE cs p), StarAutonomous `Elem` cs) => IsFreeOb (DualF a) where-  type Lower f (DualF a) = Dual (Lower f a)-  lowerOb @k' @f r = fromAll @StarAutonomous @cs @k' (withLowerOb @f @a (withObDual @k' @(Lower f a) r))- -- | The structures the free category needs for 'StarAutonomous', and those its laws are stated for. type StarAutonomousStructures :: [Kind -> Constraint]-type StarAutonomousStructures = '[Monoidal, SymMonoidal, Closed, StarAutonomous]+type StarAutonomousStructures = '[Monoidal, SymMonoidal, Closed, Dialogue, StarAutonomous]  instance   (StarAutonomousStructures `Elems` cs)   => HasStructure cs (p :: CAT k) StarAutonomous   where   data Struct StarAutonomous a b where-    Dual :: a ~> b -> Struct StarAutonomous (DualF b) (DualF a)     DualInv :: (Ob a, Ob b) => DualF a ~> DualF b -> Struct StarAutonomous b a-    LinDist :: (Ob a, Ob b, Ob c) => a **! b ~> DualF c -> Struct StarAutonomous a (DualF (b **! c))-    LinDistInv :: (Ob a, Ob b, Ob c) => a ~> DualF (b **! c) -> Struct StarAutonomous (a **! b) (DualF c)-  foldStructure go (Dual f) = dual (go f)   foldStructure @f go (DualInv @a @b g) =     withLowerOb @f @a (withLowerOb @f @b (dualInv @_ @(Lower f a) @(Lower f b) (go g)))-  foldStructure @f go (LinDist @a @b @c g) =-    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (linDist @_ @(Lower f a) @(Lower f b) @(Lower f c) (go g))))-  foldStructure @f go (LinDistInv @a @b @c g) =-    withLowerOb @f @a (withLowerOb @f @b (withLowerOb @f @c (linDistInv @_ @(Lower f a) @(Lower f b) @(Lower f c) (go g)))) instance (WithShow a) => P.Show (Struct StarAutonomous a b) where-  showsPrec d (Dual f) = P.showParen (d P.> 10) P.$ P.showString "dual " . P.showsPrec 11 f   showsPrec d (DualInv f) = P.showParen (d P.> 10) P.$ P.showString "dualInv " . P.showsPrec 11 f-  showsPrec d (LinDist f) = P.showParen (d P.> 10) P.$ P.showString "linDist " . P.showsPrec 11 f-  showsPrec d (LinDistInv f) = P.showParen (d P.> 10) P.$ P.showString "linDistInv " . P.showsPrec 11 f  instance   (StarAutonomousStructures `Elems` cs)   => StarAutonomous (FREE cs (p :: CAT k))   where-  type Dual a = DualF a-  withObDual r = r-  dual f = St (Dual f) Nil \\ f   dualInv @a @b f = St (DualInv @a @b f) Nil \\ f-  linDist @a @b @c f = St (LinDist @a @b @c f) Nil \\ f-  linDistInv @a @b @c f = St (LinDistInv @a @b @c f) Nil \\ f --- | 'dual' is a contravariant functor, bijective on hom-sets with inverse 'dualInv'; 'doubleNeg'--- is an isomorphism; and 'linDist' is a natural bijection--- @Hom(a ** b, Dual c) ≅ Hom(a, Dual (b ** c))@ with inverse 'linDistInv'.+-- | 'dual' is bijective on hom-sets with inverse 'dualInv', and 'doubleNeg' is an isomorphism.+-- The rest is in the laws of 'Proarrow.Category.Monoidal.Dialogue.DialogueStructures'. instance Laws StarAutonomousStructures where   laws =-    [ Law "dual identity" \ @a _ -> withObDual @_ @a (dual (obj @a) === id)-    , Law "dual composition" \ @a @b @c mor -> do-        f <- mor @a @b "f"-        g <- mor @b @c "g"-        dual (g . f) === dual f . dual g-    , Law "linDist naturality" \ @a @b @c @d @e mor ->-        withOb2 @_ @a @b $ withOb2 @_ @d @e $ withObDual @_ @c $ withObDual @_ @d do-          p <- mor @(a ** b) @(Dual c) "p"-          f <- mor @d @a "f"-          g <- mor @e @b "g"-          h <- mor @d @c "h"-          linDist @_ @d @e @d (dual h . p . (f ** g)) === dual (g ** h) . linDist @_ @a @b @c p . f-    ]-      P.++ bijection-        "dual"-        ( \ @a @b mor ->-            withObDual @_ @a $-              withObDual @_ @b $-                Bijection (mor @a @b "f") (mor @(Dual b) @(Dual a) "g") dual (dualInv @_ @b @a)-        )-      P.++ bijection-        "linDist"-        ( \ @a @b @c mor ->-            withOb2 @_ @a @b $-              withOb2 @_ @b @c $-                withObDual @_ @c $-                  withObDual @_ @(b ** c) $-                    Bijection (mor @(a ** b) @(Dual c) "p") (mor @a @(Dual (b ** c)) "q") (linDist @_ @a @b @c) (linDistInv @_ @a @b @c)-        )-      P.++ [ Law "doubleNegInv definition" \ @a _ -> withObDual @_ @a $ withObDual @_ @(Dual a) (doubleNegInv @_ @a === doubleNegInvDefault @a)-           ]+    bijection+      "dual"+      ( \ @a @b mor ->+          withObDual @_ @a $+            withObDual @_ @b $+              Bijection (mor @a @b "f") (mor @(Dual b) @(Dual a) "g") dual (dualInv @_ @b @a)+      )       P.++ inverses "doubleNeg" \ @a -> Inverses (doubleNegInv @_ @a) (doubleNeg @_ @a)
src/Proarrow/Category/Monoidal/Strictified.hs view
@@ -96,7 +96,7 @@       h k =         listCase @cs           (k leftUnitor)-          (\ @c -> k $ listCase @bs rightUnitor (obj @c ** fbs) (obj @c ** fbs))+          (\ @c -> k $ listCase @bs rightUnitor (withObFold @(c ': bs) id) (withObFold @(c ': bs) id))           (\ @c @cs' -> h @cs' \cbs -> withOb2 @k @c @(Fold cs') $ k $ (obj @c ** cbs) . associator @_ @c @(Fold cs') @(Fold bs))           \\ fbs   in h @as id@@ -111,11 +111,33 @@       h k =         listCase @cs           (k leftUnitorInv)-          (\ @c -> k $ listCase @bs rightUnitorInv (obj @c ** fbs) (obj @c ** fbs))+          (\ @c -> k $ listCase @bs rightUnitorInv (withObFold @(c ': bs) id) (withObFold @(c ': bs) id))           (\ @c @cs' -> h @cs' \cbs -> withOb2 @k @c @(Fold cs') $ k $ associatorInv @_ @c @(Fold cs') @(Fold bs) . (obj @c ** cbs))           \\ fbs   in h @as id +-- | Whether @Fold (as ++ bs)@ already is @Fold as ** Fold bs@: when @as@ is one object and @bs@+-- is not empty.+foldAppendCase+  :: forall {k} (as :: [k]) (bs :: [k]) r+   . (Ob as, Ob bs, Monoidal k)+  => ((Fold (as ++ bs) ~ (Fold as ** Fold bs)) => r) -> r -> r+foldAppendCase yes no = listCase @as no (listCase @bs no yes yes) no++-- | Precompose 'splitFold', unless it is the identity.+splitThen+  :: forall {k} (as :: [k]) (bs :: [k]) x+   . (Ob as, Ob bs, Monoidal k)+  => (Fold as ** Fold bs ~> x) -> Fold (as ++ bs) ~> x+splitThen h = foldAppendCase @as @bs h (h . splitFold @as @bs)++-- | Postcompose 'concatFold', unless it is the identity.+thenConcat+  :: forall {k} (as :: [k]) (bs :: [k]) x+   . (Ob as, Ob bs, Monoidal k)+  => (x ~> Fold as ** Fold bs) -> x ~> Fold (as ++ bs)+thenConcat h = foldAppendCase @as @bs h (concatFold @as @bs . h)+ type Strictified :: CAT [k] data Strictified as bs where   Str :: (Ob as, Ob bs) => {unStr :: Fold as ~> Fold bs} -> Strictified as bs@@ -137,7 +159,7 @@   r \\ Str{} = r  instance (Monoidal k) => Promonad (Strictified :: CAT [k]) where-  id @as = Str (fold @as)+  id @as = withObFold @as (Str id)   Str f . Str g = Str (f . g)  -- | The strictified monoidal category, making the unitors and associators identities.@@ -150,7 +172,7 @@   Str @as @bs f ** Str @cs @ds g =     withOb2 @[k] @as @cs $       withOb2 @[k] @bs @ds $-        Str (concatFold @bs @ds . (f ** g) . splitFold @as @cs)+        Str (thenConcat @bs @ds (splitThen @as @cs (f ** g)))  -- | List concatenation as monoidal tensor. instance (Monoidal k) => Monoidal [k] where
src/Proarrow/Functor.hs view
@@ -14,7 +14,7 @@ import Prelude qualified as P  import Proarrow.Core (CategoryOf (..), Profunctor, Promonad (..), rmap, (\\), type (+->))-import Proarrow.Object (Ob', obj)+import Proarrow.Object (obj)  infixr 0 .~> @@ -26,7 +26,7 @@ -- written as type constructors like this; the rest are encoded as representable profunctors -- instead ('FunctorForRep', "Proarrow.Profunctor.Representable"). type Functor :: forall {k1} {k2}. (k1 -> k2) -> Constraint-class (CategoryOf k1, CategoryOf k2, forall a. (Ob a) => Ob' (f a)) => Functor (f :: k1 -> k2) where+class (CategoryOf k1, CategoryOf k2) => Functor (f :: k1 -> k2) where   map :: a ~> b -> f a ~> f b  -- | Makes a @base@-style 'P.Functor' (kind @Type -> Type@) a 'Functor', to use with @deriving via@@@ -78,8 +78,6 @@ withMappedOb r = r \\ fmap @f (obj @a)  -- | Recover @'Ob' (f a)@ from a 'Functor' @f@ and @'Ob' a@, the @map@-based analog of--- 'withMappedOb'. The @'Proarrow.Object.Ob'' (f a)@ superclass of 'Functor' is a quantified--- constraint, and GHC will not extract its own @'Ob' (f a)@ superclass on demand, so it is observed--- from the mapped identity morphism instead.+-- 'withMappedOb': it is observed from the mapped identity morphism. withObF :: forall {k1} {k2} (f :: k1 -> k2) a r. (Functor f, Ob a) => ((Ob (f a)) => r) -> r withObF r = r \\ map @f (obj @a)
src/Proarrow/Monoid.hs view
@@ -27,7 +27,6 @@   , type (**!)   ) import Proarrow.Category.Monoidal.Action (Act, ActionAt, CoprodAction, MonoidalAction (..), actHom)-import Proarrow.Category.Monoidal.Closed (Closed (..), Exp) import Proarrow.Category.Monoidal.Strength (Strong (..)) import Proarrow.Category.Monoidal.Strictified (Strictified (..), obj1) import Proarrow.Colimit.BinaryCoproduct@@ -226,57 +225,6 @@ instance (Monoidal k, HasCoproducts k, Monoid (m :: k)) => Strong CoprodAction (Rep (ActionAt Tensor m) :: k +-> k) where   act @(COPR a) (Rep @y p) =     p // withObCoprod @k @a @y (Rep ((obj @m ** lft @k @a @y) . memptyAct @Tensor @m @a ||| (obj @m ** rgt @k @a @y) . p))---- | The exponential by a comonoid, @m ~~> -@, is an applicative functor (the reader applicative):--- @pure@ discards the argument with the counit and @<*>@ duplicates it with the comultiplication.--- Rendered on @'Rep' ('Exp' m)@ (legs @a ~> (m ~~> b)@) this is a--- 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor', so a--- 'Proarrow.Optic.Grate.Grate' is a 'Proarrow.Optic.Kaleidoscope.Kaleidoscope'.-instance (Closed k, SymMonoidal k, Comonoid (m :: k)) => MonoidalProfunctor (Rep (Exp m) :: k +-> k) where-  one = Rep (curry @k @Unit @m (leftUnitor @k @Unit . (obj @Unit ** counit @m)))-  Rep @x2 @_ @x1 l ** Rep @y2 @_ @y1 r =-    l //-      r //-        withOb2 @k @x1 @y1-          ( withOb2 @k @x2 @y2-              ( withObExp @k @m @x2-                  ( withObExp @k @m @y2-                      ( Rep-                          ( curry @k @(x1 ** y1) @m-                              ( (apply @k @m @x2 ** apply @k @m @y2)-                                  . swapInner @(m ~~> x2) @(m ~~> y2) @m @m-                                  . ((l ** r) ** comult @m)-                              )-                          )-                      )-                  )-              )-          )--instance (Closed k, HasCoproducts k, Ob (m :: k)) => MonoidalProfunctor (Coprod (Rep (Exp m)) :: COPROD k +-> COPROD k) where-  one = withObExp @k @m @InitialObject (Coprod (Rep initiate))-  Coprod (Rep @x2 l) ** Coprod (Rep @y2 r) =-    withObCoprod @k @x2 @y2 (Coprod (Rep ((lft @k @x2 @y2 ^^^ obj @m) . l ||| (rgt @k @x2 @y2 ^^^ obj @m) . r)))-instance (Closed k, SymMonoidal k, Ob (m :: k)) => Strong Tensor (Rep (Exp m) :: k +-> k) where-  act @a (Rep @y @_ @x p) =-    p //-      withOb2 @k @a @x-        ( withOb2 @k @a @y-            ( withObExp @k @m @y-                (Rep (curry @k @(a ** x) @m ((obj @a ** apply @k @m @y) . associator @k @a @(m ~~> y) @m . ((obj @a ** p) ** obj @m))))-            )-        )-instance (Closed k, HasCoproducts k, Comonoid (m :: k)) => Strong CoprodAction (Rep (Exp m) :: k +-> k) where-  act @(COPR a) (Rep @y p) =-    p //-      withObCoprod @k @a @y-        ( withObExp @k @m @a-            ( withObExp @k @m @y-                ( Rep-                    ((lft @k @a @y ^^^ obj @m) . curry @k @a @m (rightUnitor @k @a . (obj @a ** counit @m)) ||| (rgt @k @a @y ^^^ obj @m) . p)-                )-            )-        )  -- | The free-category structure for @'Supplies' 'Monoid'@: every object gets formal 'mappend' -- ('Join') and 'mempty' ('Sprout') generators, interpreted by 'foldStructure' through the
src/Proarrow/Optic/Glass.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}  -- | The __glass__ (Clarke et al., /Profunctor optics: a categorical update/): the optic for the -- combined action of the product and the exponential,@@ -39,6 +40,7 @@ import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Identity (Id (..)) import Proarrow.Profunctor.Representable (Rep (..))+import Proarrow.Tools.SMC (SYN (..), lam, toSMC, (!))  -- | The glass flavor. Its one method is the collapsed leg; everything is stated in a cartesian -- closed category, where the residual can be copied and selectors can be internalised.@@ -136,6 +138,10 @@ type Glass (s :: k) (t :: k) a b = Optic (Prostrong GlassFl) s t a b type Glass' s a = Glass s s a a +-- | Evaluation at a point: @s@ goes to the functions out of it, applied to it.+evalAt :: forall {k} (s :: k) a. (Closed k, SymMonoidal k, Ob s, Ob a) => s ~> ((s ~~> a) ~~> a)+evalAt = toSMC @(F s) @((F s :-> F a) :-> F a) \s -> lam (! s)+ -- | Build a glass from its single leg. The residuals are the whole source and the "logarithm" -- @s ~~> a@, so the witness is the lens witness at @s@ composed with the grate witness at @s ~~> a@. glass@@ -145,10 +151,9 @@ glass f =   withObSel @s @a @a $     withObExp @k @(s ~~> a) @b $-      let ev = curry @k @s @(s ~~> a) (apply @k @s @a . swap @k @s @(s ~~> a))-      in legs2prof @GlassFl-           (Rep @(Mod s a a) @(Product s) (id P.&&& ev) :.: Rep @a @(Exp (s ~~> a)) (obj @(Mod s a a)))-           (Corep @b @(Exp (s ~~> a)) (obj @(Mod s a b)) :.: Corep @(Mod s a b) @(Product s) f)+      legs2prof @GlassFl+        (Rep @(Mod s a a) @(Product s) (id P.&&& evalAt @s @a) :.: Rep @a @(Exp (s ~~> a)) (obj @(Mod s a a)))+        (Corep @b @(Exp (s ~~> a)) (obj @(Mod s a b)) :.: Corep @(Mod s a b) @(Product s) f)  -- | Eliminate any glass-flavored optic (a lens, a grate, or a composite of both, in either -- encoding) to its single leg.
src/Proarrow/Optic/Grate.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}  -- | The __grate__: the closed-category optic whose residual sits under an exponential, --@@ -14,7 +15,7 @@  import Prelude (($)) -import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..), first, second, swap, type (**))+import Proarrow.Category.Monoidal (SymMonoidal (..)) import Proarrow.Category.Monoidal.Closed (Closed (..), Exp) import Proarrow.Colimit.BinaryCoproduct (HasCoproducts) import Proarrow.Core (CategoryOf (..), Promonad (..), obj, type (+->))@@ -28,12 +29,13 @@   , legs2prof   , withLegs   )-import Proarrow.Optic.Glass (GlassFl, Mod)+import Proarrow.Optic.Glass (GlassFl, Mod, evalAt) import Proarrow.Optic.Kaleidoscope (KaleidoFl) import Proarrow.Profunctor.Corepresentable (Corep (..)) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Identity (Id (..)) import Proarrow.Profunctor.Representable (Rep (..))+import Proarrow.Tools.SMC (SYN (..), lam, toSMC, (!))  -- | A grate is a "residual lens" whose residual @m@ sits under an exponential instead of a -- tensor: @s ~> (m ~~> a)@ and @(m ~~> b) ~> t@. Unlike a 'Proarrow.Optic.Traversal.Traversal',@@ -53,19 +55,7 @@   :: forall {k} (x :: k) m a    . (Closed k, SymMonoidal k, Ob x, Ob m, Ob a)   => (x ~~> (m ~~> a)) ~> (m ~~> (x ~~> a))-flipExp =-  withObExp @k @m @a $-    withObExp @k @x @(m ~~> a) $-      withOb2 @k @(x ~~> (m ~~> a)) @m $-        curry @k @(x ~~> (m ~~> a)) @m-          ( curry @k @((x ~~> (m ~~> a)) ** m) @x-              ( apply @k @m @a-                  . first @m (apply @k @x @(m ~~> a))-                  . associatorInv @k @(x ~~> (m ~~> a)) @x @m-                  . second @(x ~~> (m ~~> a)) (swap @k @m @x)-                  . associator @k @(x ~~> (m ~~> a)) @m @x-              )-          )+flipExp = toSMC @(F x :-> F m :-> F a) @(F m :-> F x :-> F a) \f -> lam \m -> lam \x -> f ! x ! m  instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid m) => GrateFl (Rep (Exp m) :: k +-> k) (Corep (Exp m) :: k +-> k) where   zipWithP @_ @a (Rep sm) (Corep mbt) @x kk = mbt . (kk ^^^ obj @m) . flipExp @x @m @a . (sm ^^^ obj @x)@@ -95,5 +85,4 @@   => (Mod s a b ~> t) -> Grate s t a b grate f@Objs =   withObExp @k @s @a $-    let sa = curry @k @s @(s ~~> a) (apply @k @s @a . swap @k @s @(s ~~> a))-    in legs2prof @GrateFl (Rep @a @(Exp (s ~~> a)) sa) (Corep @b @(Exp (s ~~> a)) f)+    legs2prof @GrateFl (Rep @a @(Exp (s ~~> a)) (evalAt @s @a)) (Corep @b @(Exp (s ~~> a)) f)
src/Proarrow/Optic/Kaleidoscope.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# OPTIONS_GHC -Wno-orphans #-}  -- | The __cotraversal__ and the __kaleidoscope__: two flavors with the same witnesses (the -- representable 'StrongDistributiveProfunctor's, i.e. applicative functors rendered as profunctors,@@ -52,14 +55,17 @@ import Data.Kind (Constraint, Type) import Prelude qualified as P -import Proarrow.Category.Monoidal (MonoidalProfunctor (..), SymMonoidal, Tensor)-import Proarrow.Category.Monoidal.Action (ActionAt)-import Proarrow.Category.Monoidal.Closed (Closed, Exp)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction)+import Proarrow.Category.Monoidal.Closed (Closed (..), Exp) import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), StrongDistributiveProfunctor, Traversable)-import Proarrow.Colimit.BinaryCoproduct (HasCoproducts)-import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (//), (\\), type (+->))+import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (//), (\\), type (+->)) import Proarrow.Functor (Prelude (..))-import Proarrow.Monoid (Comonoid, Monoid)+import Proarrow.Monoid (Comonoid (..), Monoid)+import Proarrow.Object (pattern Objs) import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), legs2prof, withLegs) import Proarrow.Optic.Setter (SetterFl (..)) import Proarrow.Profunctor.Corepresentable (Corep (..))@@ -67,6 +73,8 @@ import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar) import Proarrow.Profunctor.Instance.Identity (Id (..)) import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..), repUniv)+import Proarrow.Tools.SMC (SYN (..), drop, dup, lam, lift, toSMC, (!))+import Proarrow.Tools.SMC qualified as SMC  -- * Carriers @@ -154,6 +162,46 @@   => KaleidoFl (Rep (ActionAt Tensor m) :: k +-> k) (Corep (ActionAt Tensor m))   where   kaleidoP (Rep h) (Corep i) rab = dimap h i (kaleidoAct @_ @(Rep (ActionAt Tensor m)) rab)++-- | The exponential by a comonoid, @m ~~> -@, is an applicative functor (the reader applicative):+-- @pure@ discards the argument with the counit and @<*>@ duplicates it with the comultiplication.+-- Rendered on @'Rep' ('Exp' m)@ (legs @a ~> (m ~~> b)@) this is a+-- 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor', so a+-- 'Proarrow.Optic.Grate.Grate' is a 'Proarrow.Optic.Kaleidoscope.Kaleidoscope'.+instance (Closed k, SymMonoidal k, Comonoid (m :: k)) => MonoidalProfunctor (Rep (Exp m) :: k +-> k) where+  one = Rep (toSMC @I @(F m :-> I) \u -> lam \i -> SMC.do () <- drop i; u)+  Rep @x2 @_ @x1 l@Objs ** Rep @y2 @_ @y1 r@Objs =+    withOb2 @k @x2 @y2 (Rep both)+    where+      both = toSMC @(F x1 :** F y1) @(F m :-> F x2 :** F y2) \p -> SMC.do+        let l' = lift @(F x1) @(F m :-> F x2) l+            r' = lift @(F y1) @(F m :-> F y2) r+        (x, y) <- p+        lam \i -> SMC.do+          (i1, i2) <- dup i+          l' x ! i1 SMC.** r' y ! i2++instance (Closed k, HasCoproducts k, Ob (m :: k)) => MonoidalProfunctor (Coprod (Rep (Exp m)) :: COPROD k +-> COPROD k) where+  one = withObExp @k @m @InitialObject (Coprod (Rep initiate))+  Coprod (Rep @x2 l) ** Coprod (Rep @y2 r) =+    withObCoprod @k @x2 @y2 (Coprod (Rep ((lft @k @x2 @y2 ^^^ obj @m) . l ||| (rgt @k @x2 @y2 ^^^ obj @m) . r)))+instance (Closed k, SymMonoidal k, Ob (m :: k)) => Strong Tensor (Rep (Exp m) :: k +-> k) where+  act @a (Rep @y @_ @x p@Objs) =+    withOb2 @k @a @y (Rep strong)+    where+      strong = toSMC @(F a :** F x) @(F m :-> F a :** F y) \(a, x) ->+        lam \i -> a SMC.** lift @(F x) @(F m :-> F y) p x ! i+instance (Closed k, HasCoproducts k, Comonoid (m :: k)) => Strong CoprodAction (Rep (Exp m) :: k +-> k) where+  act @(COPR a) (Rep @y p) =+    p //+      withObCoprod @k @a @y+        ( withObExp @k @m @a+            ( withObExp @k @m @y+                ( Rep+                    ((lft @k @a @y ^^^ obj @m) . curry @k @a @m (rightUnitor @k @a . (obj @a ** counit @m)) ||| (rgt @k @a @y ^^^ obj @m) . p)+                )+            )+        )  -- | The exponential pair for a comonoid exponent: @m ~~> -@ is the reader applicative. So every -- 'Proarrow.Optic.Grate.Grate' is a kaleidoscope.
src/Proarrow/Profunctor/Free.hs view
@@ -21,7 +21,8 @@ import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), swap) import Proarrow.Category.Monoidal.Applicative (Applicative (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))-import Proarrow.Category.Monoidal.StarAutonomous (Dual, dualObj)+import Proarrow.Category.Monoidal.Dialogue (Dual, dualObj)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.Strength (TracedMonoidal) import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), (==)) import Proarrow.Core
src/Proarrow/Profunctor/Instance/Costar.hs view
@@ -67,11 +67,12 @@   Costar @a f ** Costar @b g = withOb2 @j @a @b (Costar (f . map (fst @j @a @b) &&& g . map (snd @j @a @b)))  instance (Functor t, Traversable (Star t)) => Cotraversable (Costar t) where-  cotraverse (p :.: Costar f) = p // Costar id :.: case traverse (Star id :.: p) of p' :.: Star g -> rmap (f . g) p'+  cotraverse @_ @a (p :.: Costar f) =+    p // withObF @t @a (Costar id :.: case traverse (Star id :.: p) of p' :.: Star g -> rmap (f . g) p')  instance (Functor f, Thin j) => ThinProfunctor (Costar f :: j +-> k) where   type HasArrow (Costar f :: j +-> k) a b = HasArrow (Hom j) (f a) b-  arr = Costar arr+  arr @a = withObF @f @a (Costar arr)   withArr (Costar f) r = withArr f r  instance (Functor f, DecidableProfunctor (Hom j)) => DecidableProfunctor (Costar f :: j +-> k) where
src/Proarrow/Profunctor/Instance/Fold.hs view
@@ -14,7 +14,7 @@ import Proarrow.Category.Monoidal.Strength (Costrong (..), Strong (..)) import Proarrow.Colimit.BinaryCoproduct (COPROD (..), HasBinaryCoproducts (..), right) import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, type (+->))-import Proarrow.Functor (map)+import Proarrow.Functor (map, withObF) import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), PROD (..)) import Proarrow.Monoid (Monoid (..)) import Proarrow.Profunctor.Corepresentable (Corepresentable (..))@@ -49,8 +49,8 @@ instance (Cartesian k) => Costrong ProdAction (Fold :: k +-> k) where   coact @(PR a) @_ @y (Fold f g m z) = Fold (snd @k @a @y . f) (g . leftUnitorInvWith (fst @k @a @y . f . z)) m z -trav :: (Applicative f) => Fold a b -> Fold (f a) (f b)-trav (Fold @m k h m z) = Fold (map k) (map h) (liftA2 @_ @m @m m) (pure z)+trav :: forall {k} (f :: k -> k) (a :: k) (b :: k). (Applicative f) => Fold a b -> Fold (f a) (f b)+trav (Fold @m k h m z) = withObF @f @m (Fold (map k) (map h) (liftA2 @_ @m @m m) (pure z))  instance Corepresentable (Fold :: Type +-> Type) where   type Fold %% a = [a]
src/Proarrow/Profunctor/Instance/Star.hs view
@@ -19,7 +19,7 @@ import Proarrow.Category.Monoidal.Distributive (Distributive, Traversable (..), baseTraverse) import Proarrow.Category.Monoidal.Strength (Strong (..)) import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts, (++))-import Proarrow.Colimit.Initial (initiate)+import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), lmap, obj, (:~>), type (+->)) import Proarrow.Functor (Functor (..), Prelude (..), withObF) import Proarrow.Profunctor.Instance.Composition ((:.:) (..))@@ -64,7 +64,7 @@   Star @a f ** Star @b g = withOb2 @_ @a @b (Star (liftA2 @f @a @b id . (f ** g)))  instance (Functor f, HasCoproducts j, HasCoproducts k) => MonoidalProfunctor (Coprod (Star (f :: j -> k))) where-  one = Coprod (Star initiate)+  one = withObF @f @(InitialObject :: j) (Coprod (Star initiate))   Coprod (Star @a f) ** Coprod (Star @b g) = withObCoprod @_ @a @b (Coprod (Star (map (lft @_ @a @b) . f ||| map (rgt @_ @a @b) . g)))  -- Hmm, another wrapper required...@@ -132,7 +132,7 @@  instance (Functor f, Thin k) => ThinProfunctor (Star f :: j +-> k) where   type HasArrow (Star f :: j +-> k) a b = HasArrow (Hom k) a (f b)-  arr = Star arr+  arr @_ @b = withObF @f @b (Star arr)   withArr (Star f) r = withArr f r  instance (Functor f, DecidableProfunctor (Hom k)) => DecidableProfunctor (Star f :: j +-> k) where
src/Proarrow/Promonad/Cont.hs view
@@ -8,6 +8,7 @@ import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..)) import Proarrow.Category.Monoidal (MonoidalProfunctor (..), Tensor) import Proarrow.Category.Monoidal.Closed (Closed (..), curry, uncurry)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Strong (..)) import Proarrow.Colimit.BinaryCoproduct (Coprod (..), HasBinaryCoproducts (..), HasCoproducts)@@ -52,13 +53,17 @@       withObCoprod @k @bf @bg $         Coprod (Cont (\k -> f (k . lft @_ @bf @bg) ||| g (k . rgt @_ @bf @bg))) -instance StarAutonomous (KLEISLI (Cont (r :: Type))) where+instance Dialogue (KLEISLI (Cont (r :: Type))) where   type Dual @(KLEISLI (Cont r)) (KL a) = KL (a ~~> r)   withObDual r = r   dual (Kleisli (Cont f)) = Kleisli (Cont \k br -> k (f br))-  dualInv (Kleisli (Cont f)) = Kleisli (Cont \k b -> f (\g -> g b) k)   linDist (Kleisli (Cont f)) = Kleisli (Cont \k a -> k (\(b, c) -> f (\g -> g c) (a, b)))   linDistInv (Kleisli (Cont f)) = Kleisli (Cont \k (a, b) -> k (\c -> f (\g -> g (b, c)) a))+  doubleNegInv = Kleisli (Cont \k a -> k (\g -> g a))++instance StarAutonomous (KLEISLI (Cont (r :: Type))) where+  dualInv (Kleisli (Cont f)) = Kleisli (Cont \k b -> f (\g -> g b) k)+  doubleNeg = Kleisli (Cont \k nn -> nn k) instance Closed (KLEISLI (Cont (r :: Type))) where   type a ~~> b = ExpSA a b   withObExp r = r
src/Proarrow/Promonad/Writer.hs view
@@ -21,7 +21,9 @@   , unitObj   ) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), combineDual)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Distributive (Traversable (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), expSA) import Proarrow.Category.Monoidal.Strength (Strong (..)) import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), lmap, obj, rmap, tgt, (//), (:~>), type (+->))
src/Proarrow/Tools/Diagrams/Dot.hs view
@@ -18,6 +18,7 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Hypergraph   ( ExpHG   , Frobenius@@ -30,6 +31,7 @@   , linDistHG   , linDistInvHG   )+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Category.Monoidal.Strictified (IsList (..), SList (..), type (++))@@ -261,21 +263,26 @@   curry @a @b = curryHG @a @b   apply @b @c = applyHG @b @c -instance StarAutonomous DOT where+instance Dialogue DOT where   type Dual a = a   withObDual r = r   dual = dualHG-  dualInv = dualHG   linDist @a @b @c = linDistHG @a @b @c   linDistInv @a @b @c = linDistInvHG @a @b @c-  doubleNeg = id   doubleNegInv = id +instance StarAutonomous DOT where+  dualInv = dualHG+  doubleNeg = id++instance IsoMix DOT where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a+ instance CompactClosed DOT where   distribDual @a @b = withOb2 @DOT @a @b id-  dualUnit = id   dualityUnit @a = cup @a-  dualityCounit @a = cap @a instance Costrong Tensor Dot where   coact @(D as) @(D xs) @(D ys) (Dot f) = Dot \n ->     case f n of
src/Proarrow/Tools/Diagrams/Svg.hs view
@@ -37,7 +37,9 @@ import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Category.Monoidal.Strictified@@ -354,7 +356,7 @@  -- | The dual of a wire is its 'Co' wire. Duals come from 'dualCup' and 'dualCap', which mean a cup -- or cap and are drawn as a bend, so a dual wire is drawn hollow wherever it runs.-instance StarAutonomous SVG where+instance Dialogue SVG where   type Dual a = S (DualList (UN S a))   withObDual @a r = withIsListDual @(UN S a) r   dual @a @b f =@@ -366,13 +368,6 @@               M.== dualCapS @b ** obj1     )       \\ f-  dualInv @a @b g =-    withObDual @SVG @a $-      withObDual @SVG @b $-        unStr @'[b] @'[a] $-          dualCupS @a ** obj1-            M.== obj1 ** singleton g ** obj1-            M.== obj1 ** dualCapS @b   linDist @a @b @c f =     withObDual @SVG @b $       withObDual @SVG @c $@@ -397,9 +392,18 @@                   Str @'[a] @[Dual b, Dual c] (relabel @(Dual (b ** c)) @(Dual b ** Dual c) . g) ** obj1                     M.== obj1 ** swap2                     M.== dualCapS @b ** obj1-  doubleNeg @a = withObDual @SVG @a $ withObDual @SVG @(Dual a) $ withDualDual @(UN S a) $ relabel @(Dual (Dual a)) @a   doubleNegInv @a = withObDual @SVG @a $ withObDual @SVG @(Dual a) $ withDualDual @(UN S a) $ relabel @a @(Dual (Dual a)) +instance StarAutonomous SVG where+  dualInv @a @b g =+    withObDual @SVG @a $+      withObDual @SVG @b $+        unStr @'[b] @'[a] $+          dualCupS @a ** obj1+            M.== obj1 ** singleton g ** obj1+            M.== obj1 ** dualCapS @b+  doubleNeg @a = withObDual @SVG @a $ withObDual @SVG @(Dual a) $ withDualDual @(UN S a) $ relabel @(Dual (Dual a)) @a+ -- | A wire bent upwards, @a@ on the left and its dual on the right. It means 'cup', and is drawn -- as one bend that turns into the dual at its apex. dualCup :: forall (a :: SVG). (Ob a) => Unit ~> a ** Dual a@@ -429,6 +433,11 @@ dualCapS :: forall (a :: SVG). (Ob a) => [Dual a, a] ~> '[] dualCapS = withObDual @SVG @a $ Str (dualCap @a) +instance IsoMix SVG where+  dualUnit = relabel+  dualUnitInv = relabel+  dualityCounit @a = dualCap @a+ instance CompactClosed SVG where   distribDual @a @b =     withOb2 @SVG @a @b $@@ -438,9 +447,7 @@             withOb2 @SVG @(Dual a) @(Dual b) $               withDualAppend @(UN S a) @(UN S b) $                 relabel @(Dual (a ** b)) @(Dual a ** Dual b)-  dualUnit = relabel   dualityUnit @a = dualCup @a-  dualityCounit @a = dualCap @a  -- | The traced wires loop round the side of the diagram they are nearest to. instance Costrong Tensor Svg where
+ src/Proarrow/Tools/SMC.hs view
@@ -0,0 +1,1429 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecursiveDo #-}++-- | A HOAS front end for building morphisms in any symmetric monoidal category, the linear+-- counterpart of "Proarrow.Tools.CCC", which grows with the structure of the target: traces,+-- duals, additives, and the polarised System L reading of inputs and outputs in a dialogue+-- category. Each variable is used exactly once: the functions on terms+-- are linear, so GHC's linear types check that every variable is used once, and a 'Term' is+-- indexed by its context, which is exactly the variables it uses. So a variable is the identity+-- on its own type, and no copying or discarding is ever generated. Terms with disjoint contexts+-- combine by merging the contexts, which only reorders wires. Functions on terms need+-- @LinearTypes@ and linear arrows, e.g. @'Term' d g a %1 -> 'Term' d g b@.+--+-- Types are 'SYN' expressions, interpreted in the target category by 'Interp'. Their tensor is a+-- constructor, so a pattern can take a term's type apart, which the target's own @**@, a type+-- family, would not allow.+--+-- Every variable has an id, the number of binders around it, and a context lists its variables+-- by descending id. Merging compares ids, so it only reduces where the depths are known, which is+-- the case for terms built directly inside 'toSMC'. A reusable piece that binds variables of its+-- own is compiled on its own: with 'closed' when it has no inputs, and used through 'call'+-- otherwise.+--+-- The module also provides @do@ notation, for use with @QualifiedDo@, and with @RecursiveDo@ a+-- @rec@ block traces, which needs a traced monoidal category. Composition in the Int construction+-- ("Proarrow.Category.Instance.IntConstruction") uses both: the two morphisms run side by side,+-- and the wires each needs from the other are fed back.+--+-- > import Proarrow.Tools.SMC (SYN (..), lift, toSMC, (**))+-- > import Proarrow.Tools.SMC qualified as SMC+-- >+-- > Int @bp @bm @cp @cm f . Int @ap @am g =+-- >   Int $ toSMC @(F ap :** F cm) \x -> SMC.do+-- >     let g' = lift @(F ap :** F bm) @(F am :** F bp) g+-- >         f' = lift @(F bp :** F cm) @(F bm :** F cp) f+-- >     (ap, cm) <- x+-- >     rec ((am, bp), (bm, cp)) <- g' (ap ** bm) ** f' (bp ** cm)+-- >     am ** cp+--+-- A bind takes its right hand side apart with a pattern, see /Patterns/ below. In a @rec@ block,+-- the variables that are used before they are bound, @bm@ and @bp@ above, are fed back, and the others are passed on to the rest of+-- the block. GHC's translation of @rec@ passes every variable of the block to its end again,+-- including the ones a later statement of the block already used, so only such blocks work where+-- no statement uses a variable bound by an earlier one. A block of a single statement always+-- qualifies, and a nested pattern lets one statement bind everything, as above. 'loop' traces+-- without GHC's translation, so it has neither restriction, but the type of the fed back variable+-- has to be given.+--+-- The module is inspired by Bernardy and Spiwack,+-- [Evaluating Linear Functions to Symmetric Monoidal Categories](https://arxiv.org/abs/2103.06195), whose+-- @P k r a@ ports correspond to 'Term', @encode@ to 'lift', @decode@ to 'toSMC', @(!:)@ to+-- '(**)' and @split@ to 'split'. Unlike their implementation, it keeps the context thinned instead+-- of computing in the cartesian structure and arguing afterwards that the result is monoidal.+module Proarrow.Tools.SMC+  ( -- * Types+    SYN (..)+  , Interp+  , KnownObj (..)+  , synOb++    -- * Patterns+    -- $patterns++    -- * Terms++    -- ** Symmetric monoidal categories+  , Term (..)+  , toSMC+  , lift+  , call+  , closed+  , unit+  , (**)+  , split+  , Tuple (..)+  , TupleCtx+  , TupleDepth+  , recast++    -- ** Closed categories+  , lam+  , (!)++    -- ** CopyDiscard / Comonoids+  , dup+  , drop++    -- ** Traced monoidal categories+  , loop++    -- * Inputs and outputs+    -- $inout++    -- ** Dialogue categories+  , Up+  , Consumer+  , Command+  , type (:##)+  , cont+  , cut+  , (|>)+  , ret+  , thunk+  , force++    -- ** Isomix categories+  , annihilate++    -- ** *-autonomous categories+  , classical++    -- ** Compact closed categories+  , produce++    -- * Additives+    -- $additives+  , with+  , exl+  , exr+  , absorb+  , inl+  , inr+  , caseOf+  , absurd++    -- * Contexts+  , Ctx+  , Mul+  , KnownCtx+  , ctxOb+  , withCtxOb+  , Union+  , Merge (..)+  , snoc+  , push2++    -- * Do notation+  , (>>=)+  , return+  , mfix+  , fail+  , Bind+  , BindPat+  , Binds+  , Pat+  , Ret+  , Rec+  , RecVars++    -- * Examples+  , swapT+  , rotT+  , applyT+  , curryT+  , traceT+  , loopT+  , loopCC+  , snakeT+  , snakeDualT+  , combineDualT+  , dniT+  , dneT+  , bindT+  , contraT+  , parSwapT+  , weakDistT+  , bothWaysT+  , distT+  , swapEitherT+  ) where++import Data.Kind (Constraint, Type)+import GHC.Exts (Multiplicity (..))+import GHC.TypeLits (ErrorMessage (..), TypeError)+import GHC.TypeNats (CmpNat, Nat, type (+))+import Prelude (Ordering (..), type (~))+import Prelude qualified as P++import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , SymMonoidal (..)+  , Tensor+  , associator'+  , associatorInv'+  )+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), Par, bindDual, dualityCounitSA)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal, trace)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Object (Obj)++infixl 7 **+infixl 1 |>+infixl 8 !+infixl 7 :**+infixl 7 :##+infixl 6 :&&+infixl 6 :||+infixr 5 :->++-- | Type expressions over the objects of @k@: an object of @k@, the unit, the tensor, the+-- internal hom and the negation, and the additives: the product and its unit 'Top', and the+-- coproduct and its unit 'Zero'.+--+-- The negation gives the types a polarity: a type is negative when it is a 'Not', and positive+-- otherwise. A term of a positive type is a value, and a term of a negative type is a consumer+-- of what it negates. 'Up' shifts a positive type to a negative one, and 'Dn' a negative type to+-- a positive one, standing for the same object: a term of @'Dn' n@ is a stored term of @n@.+type data SYN k+  = F k+  | I+  | SYN k :** SYN k+  | SYN k :-> SYN k+  | Not (SYN k)+  | Dn (SYN k)+  | SYN k :&& SYN k+  | Top+  | SYN k :|| SYN k+  | Zero++-- | The object of @k@ a type expression stands for.+type Interp :: forall {k}. SYN k -> k+type family Interp s where+  Interp (F a) = a+  Interp I = Unit+  Interp (a :** b) = Interp a ** Interp b+  Interp (a :-> b) = Interp a ~~> Interp b+  Interp (Not a) = Dual (Interp a)+  Interp (Dn a) = Interp a+  Interp (a :&& b) = Interp a && Interp b+  Interp Top = TerminalObject+  Interp (a :|| b) = Interp a || Interp b+  Interp Zero = InitialObject++-- | Type expressions whose 'Interp' is an object, given that their leaves are.+type KnownObj :: forall {k}. SYN k -> Constraint+class (CategoryOf k) => KnownObj (s :: SYN k) where+  withSynOb :: ((Ob (Interp s)) => r) -> r++instance (CategoryOf k, Ob (a :: k)) => KnownObj (F a) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++instance (Monoidal k) => KnownObj (I :: SYN k) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++instance (Monoidal k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :** b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withOb2 @k @(Interp a) @(Interp b) r))++instance (Closed k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :-> b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withObExp @k @(Interp a) @(Interp b) r))++instance (KnownObj (a :: SYN k)) => KnownObj (Dn a) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a r++instance (Dialogue k, KnownObj (a :: SYN k)) => KnownObj (Not a) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withObDual @k @(Interp a) r)++instance (HasBinaryProducts k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :&& b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withObProd @k @(Interp a) @(Interp b) r))++instance (HasTerminalObject k) => KnownObj (Top :: SYN k) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++instance (HasBinaryCoproducts k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :|| b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withObCoprod @k @(Interp a) @(Interp b) r))++instance (HasInitialObject k) => KnownObj (Zero :: SYN k) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++-- | The identity on the object a type expression stands for.+{-# INLINE synOb #-}+synOb :: forall {k} (s :: SYN k). (KnownObj s) => Obj (Interp s)+synOb = withSynOb @s (obj @(Interp s))++-- | A context: the variables a term uses, each with its id and type, by descending id.+type Ctx :: Type -> Type+type Ctx k = [(Nat, SYN k)]++-- | The type standing in for a context: the tensor of its variables' types, with the most+-- recently bound variable on the right. A single variable is just its type, so a variable is the+-- identity. The cost is that @Mul ('(n, a) ': g)@ only reduces once @g@ is known to be empty or+-- not, which 'ctxCase' tells.+type Mul :: forall {k}. Ctx k -> SYN k+type family Mul g where+  Mul '[] = I+  Mul '[ '(n, a)] = a+  Mul ('(n, a) ': g) = Mul g :** a++-- | A term at binding depth @d@ with context @g@ and type @a@: a morphism from the tensor of+-- the context to @a@.+type Term :: forall {k}. Nat -> Ctx k -> SYN k -> Type+data Term d g a where+  MkTerm :: (Interp (Mul g) ~> Interp a) -> Term d g a++-- | A context that is known to be empty or not, all the way down.+type KnownCtx :: forall {k}. Ctx k -> Constraint+class KnownCtx (g :: Ctx k) where+  -- | Case analysis on the context, which is what lets @'Mul' ('(n, a) ': g)@ reduce.+  ctxCase :: ((g ~ '[]) => r) -> (forall n a g'. (g ~ ('(n, a) ': g'), KnownObj a, KnownCtx g') => r) -> r++  -- | The tensor of a context is an object. A method rather than a function over 'ctxCase', so that+  -- at a known context it is not recursive and can be inlined.+  withCtxOb :: (Monoidal k) => ((Ob (Interp (Mul g))) => r) -> r++instance KnownCtx ('[] :: Ctx k) where+  {-# INLINE ctxCase #-}+  {-# INLINE withCtxOb #-}+  ctxCase e _ = e+  withCtxOb r = r++instance (KnownObj a, KnownCtx g) => KnownCtx ('(n, a) ': g) where+  {-# INLINE ctxCase #-}+  {-# INLINE withCtxOb #-}+  ctxCase _ c = c+  withCtxOb r = ctxCase @g (withSynOb @a r) (withCtxOb @g (withSynOb @a (withOb2 @_ @(Interp (Mul g)) @(Interp a) r)))++-- | The identity on the tensor of a context.+{-# INLINE ctxOb #-}+ctxOb :: forall {k} (g :: Ctx k). (Monoidal k, KnownCtx g) => Obj (Interp (Mul g))+ctxOb = withCtxOb @g (obj @(Interp (Mul g)))++-- | A new variable on the right of a context: a unitor if the context was empty, and nothing+-- otherwise.+{-# INLINE snoc #-}+snoc+  :: forall {k} n (a :: SYN k) g+   . (Monoidal k, KnownObj a, KnownCtx g) => Interp (Mul g) ** Interp a ~> Interp (Mul ('(n, a) ': g))+snoc = ctxCase @g (withSynOb @a leftUnitor) (ctxOb @('(n, a) ': g))++-- | The context of two terms used side by side.+type Union :: forall {k}. Ctx k -> Ctx k -> Ctx k+type family Union g1 g2 where+  Union '[] g2 = g2+  Union g1 '[] = g1+  Union ('(n, a) ': g1) ('(m, b) ': g2) = UnionBy (CmpNat n m) ('(n, a) ': g1) ('(m, b) ': g2)++type UnionBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Ctx k+type family UnionBy o g1 g2 where+  UnionBy GT (x ': g1) g2 = x ': Union g1 g2+  UnionBy LT g1 (y ': g2) = y ': Union g1 g2+  UnionBy EQ _ _ = TypeError (Text "Proarrow.Tools.SMC: a variable is used more than once")++-- | Split the tensor of a merged context into the tensors of the two contexts it came from, and+-- back. This is where the wires are reordered, and the only place 'swap' is used.+type Merge :: forall {k}. Ctx k -> Ctx k -> Constraint+class (KnownCtx g1, KnownCtx g2) => Merge (g1 :: Ctx k) g2 where+  merge :: Interp (Mul (Union g1 g2)) ~> Interp (Mul g1) ** Interp (Mul g2)+  unmerge :: Interp (Mul g1) ** Interp (Mul g2) ~> Interp (Mul (Union g1 g2))++instance (Monoidal k, KnownCtx g2) => Merge ('[] :: Ctx k) g2 where+  {-# INLINE merge #-}+  {-# INLINE unmerge #-}+  merge = withCtxOb @g2 leftUnitorInv+  unmerge = withCtxOb @g2 leftUnitor++instance (Monoidal k, KnownCtx ('(n, a) ': g1)) => Merge ('(n, a) ': g1 :: Ctx k) '[] where+  {-# INLINE merge #-}+  {-# INLINE unmerge #-}+  merge = withCtxOb @('(n, a) ': g1) rightUnitorInv+  unmerge = withCtxOb @('(n, a) ': g1) rightUnitor++instance+  ( Monoidal k+  , KnownObj a+  , KnownObj b+  , KnownCtx g1+  , KnownCtx g2+  , MergeBy (CmpNat n m) ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)+  )+  => Merge ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)+  where+  {-# INLINE merge #-}+  {-# INLINE unmerge #-}+  merge = mergeBy @(CmpNat n m) @('(n, a) ': g1) @('(m, b) ': g2)+  unmerge = unmergeBy @(CmpNat n m) @('(n, a) ': g1) @('(m, b) ': g2)++-- | 'merge' and 'unmerge' for two non-empty contexts, by which of the two has the larger head id.+type MergeBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Constraint+class (KnownCtx g1, KnownCtx g2) => MergeBy o (g1 :: Ctx k) g2 where+  mergeBy :: Interp (Mul (UnionBy o g1 g2)) ~> Interp (Mul g1) ** Interp (Mul g2)+  unmergeBy :: Interp (Mul g1) ** Interp (Mul g2) ~> Interp (Mul (UnionBy o g1 g2))++-- The union of two non-empty contexts is not empty, so its tensor splits off the newest variable+-- as is, which the equality says for GHC. If the newest variable is alone on its side, merging is+-- one swap or nothing.+instance+  ( SymMonoidal k+  , Merge g1 ('(m, b) ': g2)+  , KnownObj (a :: SYN k)+  , KnownObj b+  , Mul ('(n, a) ': Union g1 ('(m, b) ': g2)) ~ (Mul (Union g1 ('(m, b) ': g2)) :** a)+  )+  => MergeBy GT ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE mergeBy #-}+  {-# INLINE unmergeBy #-}+  mergeBy =+    withCtxOb @('(m, b) ': g2)+      ( withSynOb @a+          ( ctxCase @g1+              (swap @k @(Interp (Mul ('(m, b) ': g2))) @(Interp a))+              ( associatorInv' (ctxOb @g1) (synOb @a) (ctxOb @('(m, b) ': g2))+                  . (ctxOb @g1 M.** swap @k @(Interp (Mul ('(m, b) ': g2))) @(Interp a))+                  . associator' (ctxOb @g1) (ctxOb @('(m, b) ': g2)) (synOb @a)+                  . (merge @g1 @('(m, b) ': g2) M.** synOb @a)+              )+          )+      )+  unmergeBy =+    withCtxOb @('(m, b) ': g2)+      ( withSynOb @a+          ( ctxCase @g1+              (swap @k @(Interp a) @(Interp (Mul ('(m, b) ': g2))))+              ( (unmerge @g1 @('(m, b) ': g2) M.** synOb @a)+                  . associatorInv' (ctxOb @g1) (ctxOb @('(m, b) ': g2)) (synOb @a)+                  . (ctxOb @g1 M.** swap @k @(Interp a) @(Interp (Mul ('(m, b) ': g2))))+                  . associator' (ctxOb @g1) (synOb @a) (ctxOb @('(m, b) ': g2))+              )+          )+      )++instance+  ( Monoidal k+  , Merge ('(n, a) ': g1) g2+  , KnownObj a+  , KnownObj (b :: SYN k)+  , Mul ('(m, b) ': Union ('(n, a) ': g1) g2) ~ (Mul (Union ('(n, a) ': g1) g2) :** b)+  )+  => MergeBy LT ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE mergeBy #-}+  {-# INLINE unmergeBy #-}+  mergeBy =+    ctxCase @g2+      (ctxOb @('(m, b) ': '(n, a) ': g1))+      ( associator' (ctxOb @('(n, a) ': g1)) (ctxOb @g2) (synOb @b)+          . (merge @('(n, a) ': g1) @g2 M.** synOb @b)+      )+  unmergeBy =+    ctxCase @g2+      (ctxOb @('(m, b) ': '(n, a) ': g1))+      ( (unmerge @('(n, a) ': g1) @g2 M.** synOb @b)+          . associatorInv' (ctxOb @('(n, a) ': g1)) (ctxOb @g2) (synOb @b)+      )++-- | The variable with id @n@: the identity on its type.+{-# INLINE var #-}+var :: forall {k} n (a :: SYN k) d. (CategoryOf k, KnownObj a) => Term d '[ '(n, a)] a+var = withSynOb @a (MkTerm (obj @(Interp a)))++-- $patterns+-- Wherever a function on terms receives an input, that is the function given to 'toSMC', 'lam',+-- 'loop' and 'cont', the alternatives of 'with' and 'caseOf', and the left of a bind in @do@+-- notation, the input arrives through a pattern: a variable, @()@, or a tuple of patterns. A+-- variable stands for the whole input, whatever its type, and must be used exactly once. @()@+-- matches the unit 'I'. A pair matches a tensor @a ':**' b@ and binds its two sides, and a triple+-- or quadruple is pairs nested to the left, as @a ':**' b ':**' c@ is. At a computation,+-- @'Up' (a ':**' b)@ or @'Up' 'I'@, a pair or @()@ pattern runs the computation and matches its+-- value, so the rest of the block must be of a negative type; a variable at a computation only+-- names it.+--+-- Tuples build terms as well, the mirror image of taking them apart: 'tuple', and 'ret' of a+-- tuple, make a pair at a tensor into '(**)' of its parts and a pair at a computation into the+-- computation of the pair.++-- | Compile a function on terms to a morphism. The function receives the input through a pattern+-- (see /Patterns/), so @()@ compiles a term without inputs and a tuple takes a tensor apart.+{-# INLINE toSMC #-}+toSMC+  :: forall {k} (a :: SYN k) b t cont+   . (Monoidal k, Binds t 0 a cont '[] b)+  => (t %1 -> cont)+  -> Interp a ~> Interp b+toSMC k = case bound @0 @'[] @a @b k of MkTerm f -> f++-- | Copy a term whose type is a comonoid, in "Proarrow.Tools.SMC": @(x1, x2) <- dup x@.+{-# INLINE dup #-}+dup :: forall {k} (s :: SYN k) d g. (Comonoid (Interp s)) => Term d g s %1 -> Term d g (s :** s)+dup = lift @s @(s :** s) comult++-- | Discard a term whose type is a comonoid, in "Proarrow.Tools.SMC": @() <- drop x@.+{-# INLINE drop #-}+drop :: forall {k} (s :: SYN k) d g. (Comonoid (Interp s)) => Term d g s %1 -> Term d g I+drop = lift @s @I counit++-- | Lift a morphism of the target category to a function on terms.+{-# INLINE lift #-}+lift :: forall {k} (a :: SYN k) b d g. (CategoryOf k) => (Interp a ~> Interp b) -> Term d g a %1 -> Term d g b+lift f (MkTerm t) = MkTerm (f . t)++-- | A term without variables, written at depth 0, for use at any depth. A reusable piece that+-- has no inputs but binds variables of its own is defined with it.+{-# INLINE closed #-}+closed :: forall {k} (a :: SYN k) d. Term 0 '[] a -> Term d '[] a+closed t = recast t++-- | Use a function on terms inside another term, compiled on its own with 'toSMC', so that its+-- argument is a pattern too. This is how a reusable piece that binds variables of its own is used,+-- and unlike 'lift' of the compiled morphism it needs no type annotations.+{-# INLINE call #-}+call+  :: forall {k} (a :: SYN k) b d g t cont+   . (Monoidal k, Binds t 0 a cont '[] b)+  => (t %1 -> cont)+  -> Term d g a+  %1 -> Term d g b+call f = lift @a @b (toSMC @a @b f)++-- | Two terms side by side. Their contexts must be disjoint.+{-# INLINE (**) #-}+(**)+  :: forall {k} d g1 g2 (a :: SYN k) b+   . (Monoidal k, Merge g1 g2)+  => Term d g1 a %1 -> Term d g2 b %1 -> Term d (Union g1 g2) (a :** b)+MkTerm f ** MkTerm g = MkTerm ((f M.** g) . merge @g1 @g2)++-- | Two new variables @(n, a)@ and @(m, b)@ on the right of the context @r@, for 'split'. When @r@+-- is empty the pair is the whole context.+{-# INLINE push2 #-}+push2+  :: forall {k} r n (a :: SYN k) m b g+   . (Monoidal k, KnownObj a, KnownObj b, Merge r g)+  => (Interp (Mul g) ~> Interp a ** Interp b)+  -> Interp (Mul (Union r g)) ~> Interp (Mul ('(m, b) ': '(n, a) ': r))+push2 p =+  ctxCase @r+    p+    (associatorInv' (ctxOb @r) (synOb @a) (synOb @b) . (ctxOb @r M.** p) . merge @r @g)++-- | Take a tensor apart: the continuation gets a variable for each side and must use both.+{-# INLINE split #-}+split+  :: forall {k} d g r (a :: SYN k) b c da db+   . (Monoidal k, KnownObj a, KnownObj b, Merge r g)+  => Term d g (a :** b)+  %1 -> ( Term da '[ '(d, a)] a+          %1 -> Term db '[ '(d + 1, b)] b+          %1 -> Term (d + 2) ('(d + 1, b) ': '(d, a) ': r) c+        )+  %1 -> Term d (Union r g) c+split (MkTerm p) k = case k (var @d @a) (var @(d + 1) @b) of+  MkTerm body -> MkTerm (body . push2 @r @d @a @(d + 1) @b @g p)++-- | The unit, which uses no variables.+{-# INLINE unit #-}+unit :: forall {k} d. (Monoidal k) => Term d ('[] :: Ctx k) I+unit = MkTerm id++-- | A function: the body receives the argument through a pattern (see /Patterns/). This needs the+-- category to be closed.+{-# INLINE lam #-}+lam+  :: forall {k} d r (a :: SYN k) b t cont+   . (Closed k, Binds t d a cont r b)+  => (t %1 -> cont)+  %1 -> Term d r (a :-> b)+lam k = case bound @d @r @a @b k of+  MkTerm body -> withCtxOb @r (withSynOb @a (MkTerm (curry @k @(Interp (Mul r)) @(Interp a) (body . snoc @d @a @r))))++-- | The body of a binder, with the pattern taking apart its new variable: what 'toSMC', 'lam',+-- 'loop' and 'cont' share, and the binds of a computation through 'runUp'.+{-# INLINE bound #-}+bound+  :: forall {k} d r (a :: SYN k) b t cont+   . (Binds t d a cont r b)+  => (t %1 -> cont)+  %1 -> Term (d + 1) ('(d, a) ': r) b+bound k = bindPat (var @d @a @(d + 1)) k++-- | Trace: the body receives the value fed back through a pattern (see /Patterns/), and returns+-- it again next to the result. This needs the category to be traced.+{-# INLINE loop #-}+loop+  :: forall {k} (u :: SYN k) b d r t cont+   . (TracedMonoidal k, KnownObj b, Binds t d u cont r (b :** u))+  => (t %1 -> cont)+  %1 -> Term d r b+loop k = case bound @d @r @u @(b :** u) k of+  MkTerm body ->+    withCtxOb @r+      (withSynOb @u (withSynOb @b (MkTerm (trace @(~>) @(Interp u) @(Interp (Mul r)) @(Interp b) (body . snoc @d @u @r)))))++-- | A new pair of wires, a variable and its dual, from nothing: the unit of the duality. This+-- needs the category to be compact closed.+{-# INLINE produce #-}+produce :: forall {k} (a :: SYN k) d. (CompactClosed k, KnownObj a) => Term d '[] (a :** Not a)+produce = withSynOb @a (MkTerm (dualityUnit @k @(Interp a)))++-- | Join a dual and its wire into nothing: the counit of the duality, which an isomix category+-- has.+{-# INLINE annihilate #-}+annihilate+  :: forall {k} (a :: SYN k) d g1 g2+   . (IsoMix k, KnownObj a, Merge g1 g2)+  => Consumer d g1 a %1 -> Term d g2 a %1 -> Term d (Union g1 g2) I+annihilate x y = lift @(Not a :** a) @I (withSynOb @a (dualityCounit @k @(Interp a))) (x ** y)++-- $inout+-- In a dialogue category, one with a tensorial negation 'Dual', a term of @'Not' a@ consumes an+-- @a@: an output, seen as an input. Terms then read as in System L, the μμ̃-calculus, which treats+-- the two alike. A 'Term' of @a@ produces an @a@ and a 'Consumer' of @a@, a term of @'Not' a@,+-- consumes one; 'cut', or @t '|>' k@, is the two meeting, a 'Command', a term of @'Not' 'I'@; and+-- 'cont' is the one binder, which receives an @a@ and runs a command with it, whether that @a@ is+-- an input or the consumer of an output.+--+-- The types have a polarity: @'Not' a@ is negative, everything else positive. A term of a negative+-- type is given its consumer, so binding an output of a positive type @a@ with 'cont' gives+-- @'Up' a = 'Not' ('Not' a)@, a computation that will produce an @a@, and 'ret' makes a value into+-- the computation that produces it. In @do@ notation, binding a computation runs it, with the rest+-- of the block, which must be negative, as what happens next; this is where terms get an+-- evaluation order, which a symmetric monoidal category does not have by itself. 'Dn' is the+-- shift the other way, the same object at positive polarity: 'thunk' and 'force' are identities+-- on the morphism, and a bind names a @'Dn' ('Up' a)@ instead of running it. Patterns and tuples+-- at a computation are described under /Patterns/.+--+-- More structure in the category adds to this. In an isomix category a consumer and its value+-- join into the unit itself rather than into @'Not' 'I'@ ('annihilate'). In a *-autonomous+-- category the negation is an involution, so a computation is its value again ('classical') and+-- the polarities collapse. In a compact closed category a value and its consumer can also be+-- created from nothing ('produce'), which gives traces and bends wires back on themselves.++-- | The shift of a positive type to a negative one: a computation that produces an @a@. A term of+-- it is a consumer of consumers of @a@, so in a category with @'Dual' a = a ~~> r@ it is the+-- continuation passing type @(a -> r) -> r@.+type Up :: forall {k}. SYN k -> SYN k+type Up a = Not (Not a)++-- | A consumer of @a@: a term of its negation.+type Consumer :: forall {k}. Nat -> Ctx k -> SYN k -> Type+type Consumer d g a = Term d g (Not a)++-- | A producer and a consumer meeting: a term of the unit of par.+type Command :: forall {k}. Nat -> Ctx k -> Type+type Command d g = Term d g (Not I)++-- | Par, the negation of the tensor of the negations, interpreted as 'Proarrow.Category.Monoidal.Dialogue.Par'.+type (:##) :: forall {k}. SYN k -> SYN k -> SYN k+type a :## b = Not (Not a :** Not b)++-- | A consumer meets a producer: @cut k t@ gives @t@ to @k@, like applying a continuation.+{-# INLINE cut #-}+cut+  :: forall {k} (a :: SYN k) d g1 g2+   . (Dialogue k, KnownObj a, Merge g1 g2)+  => Consumer d g1 a %1 -> Term d g2 a %1 -> Command d (Union g1 g2)+cut x y = lift @(Not a :** a) @(Not I) (withSynOb @a (dualityCounitSA @(Interp a))) (x ** y)++-- | 'cut' with the producer first, as System L writes @⟨t | k⟩@: @t |> k@ sends @t@ into @k@.+{-# INLINE (|>) #-}+(|>)+  :: forall {k} (a :: SYN k) d g1 g2+   . (Dialogue k, KnownObj a, Merge g2 g1)+  => Term d g1 a %1 -> Consumer d g2 a %1 -> Command d (Union g2 g1)+t |> k = cut k t++-- | The binder of System L. @cont \\x -> c@ is a term of @'Not' a@: it receives an @a@ through the+-- pattern @x@ (see /Patterns/) and runs the command @c@ with it.+--+-- What that @a@ is depends on how the result is used. As a 'Consumer' of @a@, the @a@ is an input+-- and @cont@ is μ̃: the seller in a shop receives the order, @cont \\(name, card, replyTo) -> …@. As+-- a term of the negative type @'Not' a@ in its own right, the @a@ is the consumer of an output and+-- @cont@ is μ, Haskell's @callCC@: a computation @'Up' b@ receives the consumer of its result,+-- @cont \\k -> … |> k@; a par @b ':##' c@ receives a consumer for each side, @cont \\(kb, kc) -> …@;+-- and a command, @'Not' 'I'@, receives nothing, @cont \\() -> …@. A consumer of a par is a+-- computation, which a nested pair pattern runs to get at the consumers of its sides.+{-# INLINE cont #-}+cont+  :: forall {k} d r (a :: SYN k) t cont+   . (Dialogue k, Binds t d a cont r (Not I))+  => (t %1 -> cont)+  %1 -> Term d r (Not a)+cont k = case bound @d @r @a @(Not I) k of+  MkTerm body ->+    withCtxOb @r+      ( withSynOb @a+          ( MkTerm+              ( dual (rightUnitorInv @k @(Interp a))+                  . linDist @k @(Interp (Mul r)) @(Interp a) @Unit (body . snoc @d @a @r)+              )+          )+      )++-- | Run a computation against the rest of a block. The body is what the rest does with the value,+-- given the context @r@; it becomes a consumer of the computation, whose context @g@ joins. What+-- the binds of a computation share, the counterpart of 'bound'.+{-# INLINE runUp #-}+runUp+  :: forall {k} d g r (a :: SYN k) y+   . (Dialogue k, KnownObj a, KnownObj y, Merge g r)+  => Term d g (Up a)+  %1 -> (Interp (Mul r) ** Interp a ~> Interp (Not y))+  -> Term d (Union g r) (Not y)+runUp (MkTerm m) body =+  withCtxOb @r+    ( withSynOb @a+        ( withSynOb @y+            ( MkTerm+                ( bindDual @(Interp (Mul r)) @(Interp a) @(Interp y) body+                    . (m M.** obj @(Interp (Mul r)))+                    . merge @g @r+                )+            )+        )+    )++-- | A value as the computation that produces it: double negation introduction, and the return of+-- a @do@ block in the continuation reading. It also reads as a producer of @a@ handed over as a+-- consumer of @'Not' a@. The value can be given as a 'Tuple' of terms, built by the type expected.+{-# INLINE ret #-}+ret+  :: forall {k} (a :: SYN k) t+   . (Dialogue k, KnownObj a, Tuple k t a)+  => t %1 -> Term (TupleDepth t) (TupleCtx k t) (Up a)+ret t = withSynOb @a (lift @a @(Up a) (doubleNegInv @k @(Interp a))) (tuple @k @t @a t)++-- | A term built from a tuple of terms, by the type it is expected to have: a term is itself, a+-- pair at a tensor is the tensor of its parts, and a pair at a computation @'Up' a@ is the+-- computation of the pair at @a@. A triple or quadruple stands for pairs nested to the left, as in+-- patterns. The parts must be at the same depth, and their contexts are merged.+type Tuple :: forall k -> Type -> SYN k -> Constraint+class Tuple k t a where+  tuple :: t %1 -> Term (TupleDepth t) (TupleCtx k t) a++-- | The context of a tuple of terms: the union of the contexts of its parts.+type TupleCtx :: forall k -> Type -> Ctx k+type family TupleCtx k t where+  TupleCtx k (x, y) = Union (TupleCtx k x) (TupleCtx k y)+  TupleCtx k (x, y, z) = TupleCtx k ((x, y), z)+  TupleCtx k (w, x, y, z) = TupleCtx k (((w, x), y), z)+  TupleCtx k t = CtxOf @k t++-- | The depth of a tuple of terms: that of its first part.+type TupleDepth :: Type -> Nat+type family TupleDepth t where+  TupleDepth (x, y) = TupleDepth x+  TupleDepth (x, y, z) = TupleDepth x+  TupleDepth (w, x, y, z) = TupleDepth w+  TupleDepth t = DepthOf t++-- The generic instances are incoherent, as for patterns: a term's type is often still unknown when+-- the instance is chosen, and a pair defaults to a tensor until its type is known to be an 'Up'.++-- | A term is itself.+instance {-# INCOHERENT #-} (t ~ Term d g a) => Tuple k t a where+  {-# INLINE tuple #-}+  tuple t = t++-- | A pair at a tensor is the tensor of its parts.+instance+  {-# INCOHERENT #-}+  ( Monoidal k+  , a ~ (a1 :** a2)+  , Tuple k x a1+  , Tuple k y a2+  , TupleDepth y ~ TupleDepth x+  , Merge (TupleCtx k x) (TupleCtx k y)+  )+  => Tuple k (x, y) (a :: SYN k)+  where+  {-# INLINE tuple #-}+  tuple (x, y) = tuple @k @x @a1 x ** tuple @k @y @a2 y++-- | A pair at a computation is the computation of the pair at the value.+instance (Dialogue k, KnownObj a, Tuple k (x, y) a) => Tuple k (x, y) (Not (Not a) :: SYN k) where+  {-# INLINE tuple #-}+  tuple p = ret @a p++instance (Tuple k ((x, y), z) a) => Tuple k (x, y, z) a where+  {-# INLINE tuple #-}+  tuple (x, y, z) = tuple @k @((x, y), z) @a ((x, y), z)++instance (Tuple k (((w, x), y), z) a) => Tuple k (w, x, y, z) a where+  {-# INLINE tuple #-}+  tuple (w, x, y, z) = tuple @k @(((w, x), y), z) @a (((w, x), y), z)++-- | The same morphism at another type expression for the same object, and at any depth: between+-- @'F' (a '**' b)@ and @'F' a ':**' 'F' b@, say, so that a pattern can take it apart, or between a+-- type and its 'Dn'. The polarity may change, the morphism does not.+{-# INLINE recast #-}+recast :: forall {k} (a :: SYN k) b d d' g. (Interp a ~ Interp b) => Term d g a %1 -> Term d' g b+recast (MkTerm f) = MkTerm f++-- | Store a term of a negative type as a value: the same morphism at the positive type @'Dn' n@,+-- which a bind names instead of running. This is call by push value's @thunk@, 'recast' to 'Dn'.+{-# INLINE thunk #-}+thunk :: forall {k} (n :: SYN k) d g. Term d g n %1 -> Term d g (Dn n)+thunk = recast++-- | A stored term at its negative type again, where a bind runs it. This is call by push value's+-- @force@, 'recast' from 'Dn'.+{-# INLINE force #-}+force :: forall {k} (n :: SYN k) d g. Term d g (Dn n) %1 -> Term d g n+force = recast++-- | A computation as its value again: double negation elimination, which only a *-autonomous+-- category has. There every type is equivalent to its shift, so the polarities collapse.+{-# INLINE classical #-}+classical :: forall {k} (a :: SYN k) d g. (StarAutonomous k, KnownObj a) => Term d g (Up a) %1 -> Term d g a+classical = withSynOb @a (lift @(Up a) @a (doubleNeg @k @(Interp a)))++-- $additives+-- The additives share their context between alternatives, of which only one is used. Terms that+-- share variables can't both be written in a linear function, so the alternatives are functions of+-- their own, compiled with 'toSMC' like the argument of 'call', and what they share is passed in as+-- one term.++-- | Both of two alternatives on the same input: the product. Each alternative receives the input+-- through a pattern (see /Patterns/). This needs products.+{-# INLINE with #-}+with+  :: forall {k} (s :: SYN k) a b d g t1 cont1 t2 cont2+   . (Monoidal k, HasBinaryProducts k, Binds t1 0 s cont1 '[] a, Binds t2 0 s cont2 '[] b)+  => (t1 %1 -> cont1)+  -> (t2 %1 -> cont2)+  -> Term d g s+  %1 -> Term d g (a :&& b)+with f h = lift @s @(a :&& b) (toSMC @s @a f &&& toSMC @s @b h)++-- | The first alternative of a product.+{-# INLINE exl #-}+exl+  :: forall {k} (a :: SYN k) b d g. (HasBinaryProducts k, KnownObj a, KnownObj b) => Term d g (a :&& b) %1 -> Term d g a+exl = lift @(a :&& b) @a (withSynOb @a (withSynOb @b (fst @k @(Interp a) @(Interp b))))++-- | The second alternative of a product.+{-# INLINE exr #-}+exr+  :: forall {k} (a :: SYN k) b d g. (HasBinaryProducts k, KnownObj a, KnownObj b) => Term d g (a :&& b) %1 -> Term d g b+exr = lift @(a :&& b) @b (withSynOb @a (withSynOb @b (snd @k @(Interp a) @(Interp b))))++-- | Use up a term into the unit of the product.+{-# INLINE absorb #-}+absorb :: forall {k} (s :: SYN k) d g. (HasTerminalObject k, KnownObj s) => Term d g s %1 -> Term d g Top+absorb = lift @s @Top (withSynOb @s (terminate @k @(Interp s)))++-- | The left injection into a coproduct.+{-# INLINE inl #-}+inl+  :: forall {k} (a :: SYN k) b d g+   . (HasBinaryCoproducts k, KnownObj a, KnownObj b)+  => Term d g a %1 -> Term d g (a :|| b)+inl = lift @a @(a :|| b) (withSynOb @a (withSynOb @b (lft @k @(Interp a) @(Interp b))))++-- | The right injection into a coproduct.+{-# INLINE inr #-}+inr+  :: forall {k} (a :: SYN k) b d g+   . (HasBinaryCoproducts k, KnownObj a, KnownObj b)+  => Term d g b %1 -> Term d g (a :|| b)+inr = lift @b @(a :|| b) (withSynOb @a (withSynOb @b (rgt @k @(Interp a) @(Interp b))))++-- | Case analysis on a coproduct, given first a term to share between the branches. Both branches+-- receive the pair of the shared term and the contents of their alternative through a pattern+-- (see /Patterns/). This needs the tensor to distribute over the coproduct.+{-# INLINE caseOf #-}+caseOf+  :: forall {k} (s :: SYN k) a b c d g1 g2 t1 cont1 t2 cont2+   . ( Distributive k+     , KnownObj s+     , KnownObj a+     , KnownObj b+     , Merge g1 g2+     , Binds t1 0 (s :** a) cont1 '[] c+     , Binds t2 0 (s :** b) cont2 '[] c+     )+  => Term d g1 s+  %1 -> Term d g2 (a :|| b)+  %1 -> (t1 %1 -> cont1)+  -> (t2 %1 -> cont2)+  -> Term d (Union g1 g2) c+caseOf e x f h =+  lift @(s :** (a :|| b)) @c+    ( withSynOb @s+        ( withSynOb @a+            ( withSynOb @b+                ( (toSMC @(s :** a) @c f ||| toSMC @(s :** b) @c h)+                    . distL @k @(Interp s) @(Interp a) @(Interp b)+                )+            )+        )+    )+    (e ** x)++-- | There is no term of 'Zero', so from one, together with the rest of the context, anything+-- follows.+{-# INLINE absurd #-}+absurd+  :: forall {k} (s :: SYN k) c d g1 g2+   . (Distributive k, KnownObj s, KnownObj c, Merge g1 g2)+  => Term d g1 s %1 -> Term d g2 Zero %1 -> Term d (Union g1 g2) c+absurd e z = lift @(s :** Zero) @c (withSynOb @s (withSynOb @c (initiate @k @(Interp c) . absorbL @k @(Interp s)))) (e ** z)++-- | Function application. The function and its argument must have disjoint contexts.+{-# INLINE (!) #-}+(!)+  :: forall {k} d g1 g2 (a :: SYN k) b+   . (Closed k, KnownObj a, KnownObj b, Merge g1 g2)+  => Term d g1 (a :-> b) %1 -> Term d g2 a %1 -> Term d (Union g1 g2) b+MkTerm f ! MkTerm x =+  withSynOb @a (withSynOb @b (MkTerm (apply @k @(Interp a) @(Interp b) . (f M.** x) . merge @g1 @g2)))++-- Do notation++-- | The pattern @t@ of a binder: it takes apart the variable @(n, a)@, and the binder's body+-- @cont@ then gives a term at depth @n + 1@ with type @b@, whose context is that variable and @g@.+-- Both the variable's type and the rest of the context must be known.+type Binds :: forall k. Type -> Nat -> SYN k -> Type -> Ctx k -> SYN k -> Constraint+type Binds @k t n a cont g b =+  (KnownObj a, KnownCtx g, BindPat k (Term (n + 1) '[ '(n, a)] a) t cont (Term (n + 1) ('(n, a) ': g) b))++-- | A bind in a @do@ block: a term taken apart by a pattern, or the variables of a @rec@ block.+-- The multiplicity @p@ of the continuation depends only on the right hand side @m@, since GHC+-- needs it before it knows the rest.+type Bind :: Type -> Type -> Type -> Multiplicity -> Type -> Type -> Constraint+class Bind k m t p cont r | m -> k p where+  -- | Bind the right hand side to the pattern of the continuation.+  (>>=) :: m %1 -> (t %p -> cont) %1 -> r++-- | A term on the right hand side is taken apart by the pattern. Incoherent, so that it is chosen+-- as soon as the right hand side is known, unless the right hand side is a computation.+instance {-# INCOHERENT #-} (BindPat k (Term d g a) t cont r) => Bind k (Term d g (a :: SYN k)) t One cont r where+  {-# INLINE (>>=) #-}+  (>>=) = bindPat++-- | A computation on the right hand side runs first, and the rest of the block is negative.+instance+  ( Dialogue k+  , KnownObj y+  , Merge g r+  , TyOf @k cont ~ Not y+  , Binds t d a cont r (Not y)+  , r' ~ Term d (Union g r) (Not y)+  )+  => Bind k (Term d g (Not (Not a))) t One cont r'+  where+  {-# INLINE (>>=) #-}+  m >>= k = case bound @d @r @a @(Not y) k of+    MkTerm body -> runUp @d @g @r @a @y m (body . snoc @d @a @r)++-- | A term on the right hand side taken apart by the pattern of the continuation. The types of the+-- continuation and the result are matched with equalities, so that the instance is chosen as soon+-- as the right hand side is known.+type BindPat :: Type -> Type -> Type -> Type -> Type -> Constraint+class BindPat k m t cont r | m -> k where+  bindPat :: m %1 -> (t %1 -> cont) %1 -> r++instance+  ( cont ~ Term (d + PSize t) (CtxOf @k cont) (TyOf @k cont)+  , r ~ Term d (PCtx t d g a (CtxOf @k cont)) (TyOf @k cont)+  , Pat k t d g a (CtxOf @k cont) (TyOf @k cont)+  )+  => BindPat k (Term d g (a :: SYN k)) t cont r+  where+  {-# INLINE bindPat #-}+  bindPat = pat @k @t @d @g @a @(CtxOf @k cont) @(TyOf @k cont)++-- | The statement of a @rec@ block, whose continuation is its 'return'.+instance+  (Bind k (Term d g a) t One cont r', r ~ Ret tt r')+  => Bind k (Term d g (a :: SYN k)) t One (Ret tt cont) r+  where+  {-# INLINE (>>=) #-}+  x >>= k = Ret (x >>= \p -> unRet (k p))++-- | The body of a @rec@ block, tagged with the tuple of its variables. GHC's translation passes+-- that tuple to both 'return' and 'mfix', and this tag is what makes them the same.+type Ret :: Type -> Type -> Type+newtype Ret t x = Ret x++unRet :: Ret t x %1 -> x+unRet (Ret x) = x++-- | A pattern: a variable, @()@, or a pair of patterns. A triple or quadruple stands for pairs+-- nested to the left, as @a ':**' b ':**' c@ is: @(x, y, z)@ is @((x, y), z)@. Binding it at depth+-- @d@ to a term with context @g@ and type @a@, with a continuation with context @g'@ and type @c@.+-- A pair or @()@ at a computation, @'Up' a@, runs it and matches its value, so @c@ is then negative.+type Pat :: forall k -> Type -> Nat -> Ctx k -> SYN k -> Ctx k -> SYN k -> Constraint+class Pat k t d g a g' c where+  pat :: Term d g a %1 -> (t %1 -> Term (d + PSize t) g' c) %1 -> Term d (PCtx t d g a g') c++-- | The number of variables a pattern binds on the way, and so the depth it adds.+type PSize :: Type -> Nat+type family PSize t where+  PSize (x, y) = 2 + PSize x + PSize y+  PSize (x, y, z) = PSize ((x, y), z)+  PSize (w, x, y, z) = PSize (((w, x), y), z)+  PSize t = 0++-- | The context of a pattern match, from the context of the right hand side and of the+-- continuation.+type PCtx :: forall {k}. Type -> Nat -> Ctx k -> SYN k -> Ctx k -> Ctx k+type family PCtx t d g a g' where+  PCtx (x, y) d g (Not (Not a)) g' = Union g (Tail (PCtx (x, y) d '[ '(d, a)] a g'))+  PCtx (x, y) d g (a1 :** a2) g' = Union (Drop2 (PCtxPair x y d a1 a2 g')) g+  PCtx (x, y, z) d g a g' = PCtx ((x, y), z) d g a g'+  PCtx (w, x, y, z) d g a g' = PCtx (((w, x), y), z) d g a g'+  PCtx () d g a g' = Union g g'+  PCtx t d g a g' = g'++-- | The context of the body of the 'split' that a pair pattern starts with.+type PCtxPair :: forall {k}. Type -> Type -> Nat -> SYN k -> SYN k -> Ctx k -> Ctx k+type PCtxPair x y d a1 a2 g' =+  PCtx x (d + 2) '[ '(d, a1)] a1 (PCtx y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g')++-- The generic instances are incoherent: a variable pattern's type is often still unknown when the+-- instance is chosen, and a pair pattern's type is always a pair by then. The instances at a+-- computation are more specific, so they win once the type is known to be an 'Up'.++-- | The pattern @()@ at a computation of the unit runs it.+instance (Dialogue k, KnownObj y, c ~ Not y, Merge g g') => Pat k () d g (Not (Not I) :: SYN k) g' c where+  {-# INLINE pat #-}+  pat u k = case k () of+    MkTerm t -> runUp @d @g @g' @I @y u (withCtxOb @g' (t . rightUnitor @k @(Interp (Mul g'))))++-- | A pair pattern at a computation runs it and takes its value apart. The value needs no variable+-- of its own: the pattern's variables take the ids it would have taken.+instance+  ( Dialogue k+  , KnownObj a+  , KnownObj y+  , c ~ Not y+  , Pat k (x, y') d '[ '(d, a)] a g' c+  , PCtx (x, y') d '[ '(d, a)] a g' ~ ('(d, a) ': r)+  , Merge g r+  )+  => Pat k (x, y') d g (Not (Not a) :: SYN k) g' c+  where+  {-# INLINE pat #-}+  pat m k = case pat @k @(x, y') @d @'[ '(d, a)] @a @g' @c (var @d @a @d) k of+    MkTerm body -> runUp @d @g @r @a @y m (body . snoc @d @a @r)++-- | The pattern @()@ uses up a term of the unit type.+instance {-# INCOHERENT #-} (Monoidal k, a ~ I, KnownObj c, Merge g g') => Pat k () d g (a :: SYN k) g' c where+  {-# INLINE pat #-}+  pat (MkTerm u) k = case k () of+    MkTerm t -> withSynOb @c (MkTerm (leftUnitor @k @(Interp c) . (u M.** t) . merge @g @g'))++instance {-# INCOHERENT #-} (t ~ Term (DepthOf t) g a) => Pat k t d g a g' c where+  {-# INLINE pat #-}+  pat x k = k (recast x)++instance+  {-# INCOHERENT #-}+  ( Monoidal k+  , a ~ (a1 :** a2)+  , KnownObj a1+  , KnownObj a2+  , Pat k x (d + 2) '[ '(d, a1)] a1 (PCtx y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g') c+  , Pat k y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g' c+  , d + 2 + PSize x + PSize y ~ d + PSize (x, y)+  , PCtxPair x y d a1 a2 g' ~ ('(d + 1, a2) ': '(d, a1) ': Drop2 (PCtxPair x y d a1 a2 g'))+  , Merge (Drop2 (PCtxPair x y d a1 a2 g')) g+  )+  => Pat k (x, y) d g (a :: SYN k) g' c+  where+  {-# INLINE pat #-}+  pat s k =+    split+      s+      ( \a b ->+          pat @k @x @(d + 2) @'[ '(d, a1)] @a1 @(PCtx y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g') @c+            a+            (\px -> pat @k @y @(d + 2 + PSize x) @'[ '(d + 1, a2)] @a2 @g' @c b (\py -> k (px, py)))+      )++instance {-# INCOHERENT #-} (Pat k ((x, y), z) d g a g' c) => Pat k (x, y, z) d g a g' c where+  {-# INLINE pat #-}+  pat s k = pat @k @((x, y), z) @d @g @a @g' @c s (\((px, py), pz) -> k (px, py, pz))++instance {-# INCOHERENT #-} (Pat k (((w, x), y), z) d g a g' c) => Pat k (w, x, y, z) d g a g' c where+  {-# INLINE pat #-}+  pat s k = pat @k @(((w, x), y), z) @d @g @a @g' @c s (\(((pw, px), py), pz) -> k (pw, px, py, pz))++-- | The variables of a @rec@ block, as GHC tuples them up.+type RecVars :: Type -> Type -> Constraint+class RecVars k t | t -> k where+  type Vars k t :: Ctx k+  recVars :: t+  consume :: t %1 -> r %1 -> r++instance (Monoidal k, KnownObj (a :: SYN k)) => RecVars k (Term d '[ '(n, a)] a) where+  {-# INLINE recVars #-}+  {-# INLINE consume #-}+  type Vars k (Term d '[ '(n, a)] a) = '[ '(n, a)]+  recVars = var @n @a+  consume (MkTerm _) r = r++instance (RecVars k x, RecVars k y) => RecVars k (x, y) where+  {-# INLINE recVars #-}+  {-# INLINE consume #-}+  type Vars k (x, y) = Union (Vars k x) (Vars k y)+  recVars = (recVars, recVars)+  consume (x, y) r = consume x (consume y r)++instance (RecVars k x, RecVars k y, RecVars k z) => RecVars k (x, y, z) where+  {-# INLINE recVars #-}+  {-# INLINE consume #-}+  type Vars k (x, y, z) = Union (Vars k x) (Vars k (y, z))+  recVars = (recVars, recVars, recVars)+  consume (x, y, z) r = consume x (consume (y, z) r)++instance (RecVars k x, RecVars k y, RecVars k z, RecVars k w) => RecVars k (x, y, z, w) where+  {-# INLINE recVars #-}+  {-# INLINE consume #-}+  type Vars k (x, y, z, w) = Union (Vars k x) (Vars k (y, z, w))+  recVars = (recVars, recVars, recVars, recVars)+  consume (x, y, z, w) r = consume x (consume (y, z, w) r)++instance (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v) => RecVars k (x, y, z, w, v) where+  {-# INLINE recVars #-}+  {-# INLINE consume #-}+  type Vars k (x, y, z, w, v) = Union (Vars k x) (Vars k (y, z, w, v))+  recVars = (recVars, recVars, recVars, recVars, recVars)+  consume (x, y, z, w, v) r = consume x (consume (y, z, w, v) r)++instance+  (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v, RecVars k u)+  => RecVars k (x, y, z, w, v, u)+  where+  {-# INLINE recVars #-}+  {-# INLINE consume #-}+  type Vars k (x, y, z, w, v, u) = Union (Vars k x) (Vars k (y, z, w, v, u))+  recVars = (recVars, recVars, recVars, recVars, recVars, recVars)+  consume (x, y, z, w, v, u) r = consume x (consume (y, z, w, v, u) r)++-- | The end of a @rec@ block: all its variables, as the tensor of their context.+{-# INLINE return #-}+return+  :: forall k t d. (Monoidal k, RecVars k t, KnownCtx (Vars k t)) => t %1 -> Ret t (Term d (Vars k t) (Mul (Vars k t)))+return t = Ret (consume t (MkTerm (ctxOb @(Vars k t))))++-- | A @rec@ block after tracing, from its context without the fed back variables to the variables+-- it passes on.+type Rec :: forall {k}. Nat -> Type -> Ctx k -> Ctx k -> Type+data Rec d t g0 outs where+  Rec :: (Interp (Mul g0) ~> Interp (Mul outs)) -> Rec d t g0 outs++-- | Trace a @rec@ block: the variables it uses before binding them are fed back.+{-# INLINE mfix #-}+mfix+  :: forall {k} t d (g :: Ctx k)+   . ( TracedMonoidal k+     , RecVars k t+     , Merge (Inter g (Vars k t)) (Minus g (Vars k t))+     , Merge (Inter g (Vars k t)) (Minus (Vars k t) g)+     , Union (Inter g (Vars k t)) (Minus g (Vars k t)) ~ g+     , Union (Inter g (Vars k t)) (Minus (Vars k t) g) ~ Vars k t+     )+  => (t -> Ret t (Term d g (Mul (Vars k t)))) %1 -> Rec d t (Minus g (Vars k t)) (Minus (Vars k t) g)+mfix f = case unRet (f recVars) of+  MkTerm body ->+    withCtxOb @(Inter g (Vars k t))+      ( withCtxOb @(Minus g (Vars k t))+          ( withCtxOb @(Minus (Vars k t) g)+              ( Rec+                  ( coact+                      @Tensor+                      @(~>)+                      @(Interp (Mul (Inter g (Vars k t))))+                      @(Interp (Mul (Minus g (Vars k t))))+                      @(Interp (Mul (Minus (Vars k t) g)))+                      ( merge @(Inter g (Vars k t)) @(Minus (Vars k t) g)+                          . body+                          . unmerge @(Inter g (Vars k t)) @(Minus g (Vars k t))+                      )+                  )+              )+          )+      )++-- | The rest of the @do@ block after a @rec@ block. GHC binds the variables of the block here+-- without linearity, so the context checks see to it that the ones passed on are used once and+-- the fed back ones not at all.+instance+  ( SymMonoidal k+  , RecVars k t+  , t' ~ t+  , cont ~ Term (HeadId (Vars k t) + 1) (CtxOf @k cont) (TyOf @k cont)+  , r ~ Term d (Union (Minus (CtxOf @k cont) outs) g0) (TyOf @k cont)+  , AllIn outs (CtxOf @k cont)+  , NoneIn (Minus (CtxOf @k cont) outs) (Vars k t)+  , Merge (Minus (CtxOf @k cont) outs) g0+  , Merge (Minus (CtxOf @k cont) outs) outs+  , CtxOf @k cont ~ Union (Minus (CtxOf @k cont) outs) outs+  )+  => Bind k (Rec d t (g0 :: Ctx k) outs) t' Many cont r+  where+  {-# INLINE (>>=) #-}+  Rec h >>= k = case k recVars of+    MkTerm body ->+      MkTerm+        ( body+            . unmerge @(Minus (CtxOf @k cont) outs) @outs+            . (ctxOb @(Minus (CtxOf @k cont) outs) M.** h)+            . merge @(Minus (CtxOf @k cont) outs) @g0+        )++-- | GHC's translation of @rec@ refers to @fail@, but pairs of variables always match.+fail :: a+fail = P.error "Proarrow.Tools.SMC.fail: a pattern did not match"++type DepthOf :: Type -> Nat+type family DepthOf t where+  DepthOf (Term d g a) = d++type CtxOf :: forall k. Type -> Ctx k+type family CtxOf t where+  CtxOf (Term d g a) = g++type TyOf :: forall k. Type -> SYN k+type family TyOf t where+  TyOf (Term d g a) = a++type Drop2 :: forall {k}. Ctx k -> Ctx k+type Drop2 g = Tail (Tail g)++type Tail :: forall {k}. Ctx k -> Ctx k+type family Tail g where+  Tail (x ': g) = g++type HeadId :: forall {k}. Ctx k -> Nat+type family HeadId g where+  HeadId ('(n, a) ': g) = n++-- | Every variable of the first context is in the second.+type AllIn :: forall {k}. Ctx k -> Ctx k -> Constraint+type AllIn g h = IsEmpty (Text "Proarrow.Tools.SMC: a variable bound in a rec block is not used") (Minus g h)++-- | No variable of the first context is in the second.+type NoneIn :: forall {k}. Ctx k -> Ctx k -> Constraint+type NoneIn g h =+  IsEmpty (Text "Proarrow.Tools.SMC: a variable fed back in a rec block is also used after it") (Inter g h)++type IsEmpty :: forall {k}. ErrorMessage -> Ctx k -> Constraint+type family IsEmpty msg g where+  IsEmpty msg '[] = ()+  IsEmpty msg g = TypeError msg++-- | The variables of @g@ whose ids are not in @h@.+type Minus :: forall {k}. Ctx k -> Ctx k -> Ctx k+type family Minus g h where+  Minus '[] h = '[]+  Minus g '[] = g+  Minus ('(n, a) ': g) ('(m, b) ': h) = MinusBy (CmpNat n m) ('(n, a) ': g) ('(m, b) ': h)++type MinusBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Ctx k+type family MinusBy o g h where+  MinusBy GT (x ': g) h = x ': Minus g h+  MinusBy EQ (x ': g) (y ': h) = Minus g h+  MinusBy LT g (y ': h) = Minus g h++-- | The variables of @g@ whose ids are in @h@.+type Inter :: forall {k}. Ctx k -> Ctx k -> Ctx k+type Inter g h = Minus g (Minus g h)++-- $+-- The examples below are compiled at @k = 'Data.Kind.Type'@, where the result can be run.++-- | Swap a tensor.+--+-- >>> import Prelude (Bool (..))+-- >>> swapT @Bool @Bool (True, False)+-- (False,True)+swapT :: forall {k} (a :: k) b. (SymMonoidal k, Ob a, Ob b) => a ** b ~> b ** a+swapT = toSMC @(F a :** F b) \(a, b) -> b ** a++-- | Apply a function to an argument, both in a tensor.+--+-- >>> import Prelude (Bool (..), not)+-- >>> applyT @Bool @Bool (not, True)+-- False+applyT :: forall {k} (a :: k) b. (Closed k, SymMonoidal k, Ob a, Ob b) => (a ~~> b) ** a ~> b+applyT = toSMC @((F a :-> F b) :** F a) (\p -> split p (\f x -> f ! x))++-- | Curry the tensor.+--+-- >>> import Prelude (Bool (..))+-- >>> curryT @Bool @Bool True False+-- (True,False)+curryT :: forall {k} (a :: k) b. (Closed k, SymMonoidal k, Ob a, Ob b) => a ~> b ~~> a ** b+curryT = toSMC @(F a) @(F b :-> F a :** F b) (\x -> lam (\y -> x ** y))++-- | Rotate a triple, with a triple pattern.+--+-- >>> import Prelude (Bool (..), Int)+-- >>> rotT @Int @Bool @Int ((1, True), 2)+-- ((True,2),1)+rotT :: forall {k} (a :: k) b c. (SymMonoidal k, Ob a, Ob b, Ob c) => a ** b ** c ~> b ** c ** a+rotT = toSMC @(F a :** F b :** F c) \(a, b, c) -> b ** c ** a++-- | Trace out @u@ with a @rec@ block. In 'Data.Kind.Type' the trace is a lazy fixed point.+--+-- >>> import Prelude (Int, take)+-- >>> traceT @Int @[Int] @[Int] (\(a, u) -> (take 3 u, a : u)) 1+-- [1,1,1]+traceT :: forall {k} (a :: k) b u. (TracedMonoidal k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b+traceT h = toSMC @(F a) \a -> Proarrow.Tools.SMC.do+  rec (b, u) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)+  b++-- | Trace out @u@ with 'loop'.+--+-- >>> import Prelude (Int, take)+-- >>> loopT @Int @[Int] @[Int] (\(a, u) -> (take 3 u, a : u)) 1+-- [1,1,1]+loopT :: forall {k} (a :: k) b u. (TracedMonoidal k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b+loopT h = toSMC @(F a) \a -> loop @(F u) \u -> lift @(F a :** F u) @(F b :** F u) h (a ** u)++-- | A trace from the duality alone, so for any compact closed category: feed @u@ in along one+-- end of a new pair and join its new value with the other end.+loopCC :: forall {k} (a :: k) b u. (CompactClosed k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b+loopCC h = toSMC @(F a) \a -> Proarrow.Tools.SMC.do+  (u, u') <- produce+  (b, v) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)+  () <- annihilate u' v+  b++-- | A snake: create a pair, join its dual with the input, and continue with the other end. By the+-- zigzag law it is the identity. The input is older than the pair, so it sits to the left of it,+-- and the join needs a swap.+snakeT :: forall {k} (a :: k). (CompactClosed k, Ob a) => a ~> a+snakeT = toSMC @(F a) \x -> Proarrow.Tools.SMC.do+  (a, a') <- produce+  () <- annihilate a' x+  a++-- | The inverse of 'distribDual': make a pair for @a ** b@, and annihilate the two halves of its+-- plain end with the given duals.+combineDualT :: forall {k} (a :: k) b. (CompactClosed k, Ob a, Ob b) => Dual a ** Dual b ~> Dual (a ** b)+combineDualT = toSMC @(Not (F a) :** Not (F b)) @(Not (F a :** F b)) \(da, db) -> Proarrow.Tools.SMC.do+  (ab, ab') <- produce+  (a, b) <- ab+  () <- annihilate da a+  () <- annihilate db b+  ab'++-- | The tensor distributes over the coproduct: the shared @a@ goes to whichever branch is taken.+--+-- >>> import Prelude (Bool (..), Char, Either (..), Int)+-- >>> distT @Int @Bool @Char (1, Left True)+-- Left (1,True)+distT+  :: forall {k} (a :: k) b c. (Distributive k, SymMonoidal k, Ob a, Ob b, Ob c) => a ** (b || c) ~> (a ** b) || (a ** c)+distT = toSMC @(F a :** (F b :|| F c)) \(a, bc) ->+  caseOf a bc (\(a', b) -> inl (a' ** b)) (\(a', c) -> inr (a' ** c))++-- | Swap a coproduct, with nothing to share.+--+-- >>> import Prelude (Bool (..), Either (..), Int)+-- >>> swapEitherT @Int @Bool (Left 1)+-- Right 1+swapEitherT :: forall {k} (a :: k) b. (Distributive k, SymMonoidal k, Ob a, Ob b) => a || b ~> b || a+swapEitherT = toSMC @(F a :|| F b) \x ->+  caseOf unit x (\((), a) -> inr a) (\((), b) -> inl b)++-- | A pair both as it is and swapped: each alternative takes the same pair apart in its own way.+--+-- >>> import Prelude (Bool (..), Int)+-- >>> bothWaysT @Int @Bool (1, True)+-- ((1,True),(True,1))+bothWaysT+  :: forall {k} (a :: k) b. (SymMonoidal k, HasBinaryProducts k, Ob a, Ob b) => a ** b ~> (a ** b) && (b ** a)+bothWaysT = toSMC @(F a :** F b) \p -> with (\q -> q) (\(x, y) -> y ** x) p++-- | Double negation introduction: a consumer of a consumer of @a@ hands it the @a@. This is+-- 'ret', written out.+dniT :: forall {k} (a :: k). (Dialogue k, Ob a) => a ~> Dual (Dual a)+dniT = toSMC @(F a) @(Up (F a)) \x -> cont (x |>)++-- | Double negation elimination, the classical direction: a computation is its value. Binding its+-- consumer with 'cont' and cutting would only give the computation back.+dneT :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual (Dual a) ~> a+dneT = toSMC @(Up (F a)) @(F a) \nn -> classical nn++-- | Sequencing: run the input computation, and continue with @f@ on its value. In a category with+-- @'Dual' a = a ~~> r@ this is the bind of the continuation monad.+bindT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => (a ~> Dual (Dual b)) -> Dual (Dual a) ~> Dual (Dual b)+bindT f = toSMC @(Up (F a)) @(Up (F b)) \m -> Proarrow.Tools.SMC.do+  x <- m+  lift @(F a) @(Up (F b)) f x++-- | Contraposition: a consumer of @b@ consumes @a@ through @f@.+contraT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => (a ~> b) -> Dual b ~> Dual a+contraT f = toSMC @(Not (F b)) @(Not (F a)) \nb -> cont \x -> cut nb (lift @(F a) @(F b) f x)++-- | Par is symmetric: bind both outputs and hand them to the input the other way round. This is+-- 'Proarrow.Category.Monoidal.Dialogue.parSwap'.+parSwapT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => Par a b ~> Par b a+parSwapT = toSMC @(F a :## F b) @(F b :## F a) \p -> cont \(kb, ka) -> ka ** kb |> p++-- | Linear (weak) distributivity, @a ⊗ (b ⅋ c) ⊸ (a ⊗ b) ⅋ c@: the @b@ the input emits is paired+-- with @a@ and sent to the first output, and its @c@ goes to the second. This is+-- 'Proarrow.Category.Monoidal.Dialogue.weakDistL'.+weakDistT+  :: forall {k} (a :: k) b c+   . (Dialogue k, Ob a, Ob b, Ob c)+  => a ** Par b c ~> Par (a ** b) c+weakDistT = toSMC @(F a :** (F b :## F c)) @((F a :** F b) :## F c) \(a, bc) ->+  cont \(kab, kc) -> cont (\b -> a ** b |> kab) ** kc |> bc++-- | The snake on the dual: join the input with the first end of a new pair, and continue with the+-- second. Here the wires meet in the order they come, so no swap is needed.+snakeDualT :: forall {k} (a :: k). (CompactClosed k, Ob a) => Dual a ~> Dual a+snakeDualT = toSMC @(Not (F a)) \x -> Proarrow.Tools.SMC.do+  (a, a') <- produce+  () <- annihilate x a+  a'
+ test/Examples/Cbpv.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}++-- | Call by push value in "Proarrow.Tools.SMC": values are pure, and effects live in computations,+-- terms of 'Up', which run when they are bound. The target is 'CPS' @(m ())@ for a monad @m@. Its+-- morphisms are plain functions, and a computation of an @a@ is @(a -> m ()) -> m ()@: an action+-- of @m@ that passes its result on. With @m@ 'IO' the programs below read, print and return; the+-- tests run them in a writer monad, so that the order of the effects can be checked.+module Examples.Cbpv (test) where++import Data.Kind (Type)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding ((**))++import Proarrow.Category.Instance.Cps (CPS (..), Cps (..))+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Core (CategoryOf (..))+import Proarrow.Testing (check)+import Proarrow.Tools.SMC (SYN (F, I, (:**)), Up, dup, force, lam, lift, ret, thunk, toSMC, unit, (!), (**))+import Proarrow.Tools.SMC qualified as SMC++-- | The category: functions, with the actions @m ()@ as the answer object.+type K m = CPS (m () :: Type)++-- | A value type.+type V m a = F (C a :: K m)++-- | A computation that produces an @a@: a term of it is @(a -> m ()) -> m ()@.+type Comp m a = Up (V m a)++-- | A computation for its effect alone.+type Eff m = Up (I :: SYN (K m))++-- | An action as a computation. The action runs when the computation is bound.+act :: forall m a d. (Monad m) => m a -> SMC.Term d '[] (Comp m a)+act m = lift @I @(Comp m a) (Cps \() k -> m >>= k) unit++-- | An action for its effect alone.+act_ :: forall m d. (Monad m) => m () -> SMC.Term d '[] (Eff m)+act_ m = lift @I @(Eff m) (Cps \() k -> m >>= k) unit++-- | A function from a value to an action, as a function from the value to its effect.+effect :: forall m a d g. (Monad m) => (a -> m ()) -> SMC.Term d g (V m a) %1 -> SMC.Term d g (Eff m)+effect f = lift @(V m a) @(Eff m) (Cps \a k -> f a >>= k)++-- | A constant.+val :: forall m a d. a -> SMC.Term d '[] (V m a)+val a = lift @I @(V m a) (Cps (const a)) unit++-- | Run a closed computation: give its result to a final continuation.+run :: (Unit ~> Dual (Dual (C a :: K m))) -> (a -> m ()) -> m ()+run (Cps p) k = p () k++-- * Programs++-- | Read two numbers, tell their sum, and return it. The reads happen in the order of the binds,+-- and the sum is a value, copied with 'dup' to be both told and returned.+addT :: forall m. (Monad m) => m Int -> m Int -> (String -> m ()) -> Unit ~> Dual (Dual (C Int :: K m))+addT readX readY say = toSMC @I @(Comp m Int) \() -> SMC.do+  x <- act readX+  y <- act readY+  (s, s') <- dup (plus (x ** y))+  () <- effect (say . ("sum " ++) . show) s+  ret s'++plus :: forall m d g. SMC.Term d g (V m Int :** V m Int) %1 -> SMC.Term d g (V m Int)+plus = lift @(V m Int :** V m Int) @(V m Int) (Cps (uncurry (+)))++-- | Two computations made in one order and run in the other. A computation is a value until it is+-- bound, so the effects happen in the order of the binds, not in the order the actions were+-- written.+reversedT :: forall m. (Monad m) => m () -> m () -> Unit ~> Dual (Dual (C () :: K m))+reversedT a b = toSMC @I @(Eff m) \() -> SMC.do+  (first, second) <- act_ a ** act_ b+  () <- second+  () <- first+  ret unit++-- | A computation that is made and dropped. Its effect never happens: dropping it is dropping a+-- value, which needs nothing but a comonoid.+droppedT :: forall m. (Monad m) => m () -> Unit ~> Dual (Dual (C () :: K m))+droppedT a = toSMC @I @(Eff m) \() -> SMC.do+  () <- SMC.drop (act_ a)+  ret unit++-- | A computation stored with 'thunk', so that binding it does not run it, copied as the value it+-- then is, and run twice with 'force'.+storedT :: forall m. (Monad m) => m () -> Unit ~> Dual (Dual (C () :: K m))+storedT a = toSMC @I @(Eff m) \() -> SMC.do+  t <- thunk (act_ a)+  (t1, t2) <- dup t+  () <- force t1+  () <- force t2+  ret unit++-- | A function from a value to a computation, made once and applied twice. Its effect happens at+-- each application, not when the function is made.+twiceT :: forall m. (Monad m) => (Int -> m ()) -> Unit ~> Dual (Dual (C () :: K m))+twiceT say = toSMC @I @(Eff m) \() -> SMC.do+  (f, f') <- dup (lam (effect say))+  () <- f ! val 1+  () <- f' ! val 2+  ret unit++-- * Tests++-- | The writer monad the tests run in.+type W = (,) [String]++tell :: String -> W ()+tell s = ([s], ())++-- | The effects of a program, with its result told last.+logOf :: (Unit ~> Dual (Dual (C a :: K W))) -> (a -> String) -> [String]+logOf p result = fst (run p (tell . result))++test :: TestTree+test =+  testGroup+    "Call by push value (Proarrow.Tools.SMC)"+    [ testProperty "actions run in the order of the binds, and the result comes last" $+        check+          "wrong effects"+          ( logOf (addT (tell "read x" >> pure 1) (tell "read y" >> pure 2) tell) (("return " ++) . show)+              == ["read x", "read y", "sum 3", "return 3"]+          )+    , testProperty "computations are values: made in one order, run in the other" $+        check "wrong effects" (logOf (reversedT (tell "a") (tell "b")) (const "done") == ["b", "a", "done"])+    , testProperty "a stored computation is bound without running, and runs at each force" $+        check "wrong effects" (logOf (storedT (tell "a")) (const "done") == ["a", "a", "done"])+    , testProperty "a dropped computation has no effect" $+        check "wrong effects" (logOf (droppedT (tell "never")) (const "done") == ["done"])+    , testProperty "a function's effect happens at each application" $+        check "wrong effects" (logOf (twiceT (tell . ("say " ++) . show)) (const "done") == ["say 1", "say 2", "done"])+    ]
test/Examples/Database.hs view
@@ -21,7 +21,6 @@ -- category's laws rather than migration. module Examples.Database (test) where -import Control.Monad (unless) import Data.Type.Equality ((:~:) (..)) import Test.Falsify (testFailed) import Test.Tasty (TestTree, testGroup)@@ -39,6 +38,7 @@ import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Ran (Ran (..), runRan, type (|>)) import Proarrow.Profunctor.Representable (Rep (..), Representable (repUniv))+import Proarrow.Testing (check)  -- * The detailed schema @A@ @@ -407,25 +407,25 @@   testGroup     "Database"     [ testProperty "the left pushforward unions the two seat tables" $-        unless+        check+          "the merged table should hold all four seats, tagged by where they came from"           (map seatName mergedSeats == ["economy E1", "economy E2", "first class F1", "first class F2"])-          (testFailed "the merged table should hold all four seats, tagged by where they came from")     , testProperty "restriction copies a merged seat into both tables" $ do-        unless (readRow economyRow == "economy E1") (testFailed "E1 should appear as an economy row")-        unless (readRow firstClassRow == "economy E1") (testFailed "E1 should appear as a first class row too")+        check "E1 should appear as an economy row" (readRow economyRow == "economy E1")+        check "E1 should appear as a first class row too" (readRow firstClassRow == "economy E1")     , testProperty "the right pushforward joins the two tables" $ case theJoin of         [p] -> do-          unless (fromPi @Economy p == E1) (testFailed "the economy half should be E1")-          unless (fromPi @FirstClass p == F2) (testFailed "the first class half should be F2")-          unless (atPi @DollarsA (emb PriceB) p == P 300) (testFailed "the shared price should be 300")-          unless (atPi @StringA (emb PosB) p == Pos "12A") (testFailed "the shared position should be 12A")+          check "the economy half should be E1" (fromPi @Economy p == E1)+          check "the first class half should be F2" (fromPi @FirstClass p == F2)+          check "the shared price should be 300" (atPi @DollarsA (emb PriceB) p == P 300)+          check "the shared position should be 12A" (atPi @StringA (emb PosB) p == Pos "12A")         ps -> testFailed ("exactly one pair of seats agrees, found " ++ show (length ps))     , testProperty "restriction turns the machine into the book's graph" $ do-        unless+        check+          "the source column should be the identity"           (map (fromDelta . sourceOf . asArrow) states == states)-          (testFailed "the source column should be the identity")-        unless+        check+          "the target column should be one step of the machine"           (map (fromDelta . targetOf . asArrow) states == [St4, St4, St5, St5, St5, St7, St6])-          (testFailed "the target column should be one step of the machine")-        unless (pathLength twoSteps == 2) (testFailed "the loop schema should have a two-step arrow")+        check "the loop schema should have a two-step arrow" (pathLength twoSteps == 2)     ]
+ test/Examples/IntComposition.hs view
@@ -0,0 +1,32 @@+-- | Composition in the Int construction, drawn. Over "Proarrow.Tools.Diagrams.Svg", which is traced,+-- two Int morphisms with boxes @g@ and @f@ compose to a diagram whose traced wires are the middle+-- object's two halves. The composition is the @rec@ block in+-- "Proarrow.Category.Instance.IntConstruction".+module Examples.IntComposition (test, compositionPicture) where++import Data.List (isInfixOf)+import Test.Tasty (TestTree)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (.))++import Proarrow.Category.Instance.IntConstruction (INT (..), IntConstruction (..))+import Proarrow.Core (Promonad (..))+import Proarrow.Testing (check)+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)++type W1 s = S '[Wire s]++gInt :: IntConstruction (I (W1 "a⁺") (W1 "a⁻")) (I (W1 "b⁺") (W1 "b⁻"))+gInt = Int (node @'[Wire "a⁺", Wire "b⁻"] @'[Wire "a⁻", Wire "b⁺"] "g")++fInt :: IntConstruction (I (W1 "b⁺") (W1 "b⁻")) (I (W1 "c⁺") (W1 "c⁻"))+fInt = Int (node @'[Wire "b⁺", Wire "c⁻"] @'[Wire "b⁻", Wire "c⁺"] "f")++-- | @f . g@ in the Int construction, as the underlying traced diagram.+compositionPicture :: String+compositionPicture = case fInt . gInt of Int h -> render h++test :: TestTree+test =+  testProperty "Int composition draws" $+    check "not an SVG document" ("<svg" `isInfixOf` compositionPicture)
+ test/Examples/LinearLogic.hs view
@@ -0,0 +1,312 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}++-- | The linear logic connectives of "Proarrow.Tools.SMC", each tested where it lives.+--+-- * Duals over 'FinRel', which is compact closed and also traced: the snake equations,+--   'combineDual', and the trace built from the duality agreeing with 'FinRel''s own.+-- * Classical reasoning in the Kleisli category of the continuation monad, which is+--   *-autonomous but not compact closed: its dual is @a -> r@, so terms can be run on values and+--   continuations. And 'annihilate' in 'LINEAR', which is isomix but not compact closed.+-- * The additives over 'FinRel', which is distributive: case analysis agrees with the+--   distributor, and 'with' with the pairing.+-- * Par, written with 'cont' and consumed with 'ret' of a pair of consumers, run in 'LINEAR' on+--   values and checked against its own par functions, and over 'FinRel', where par is the tensor.+module Examples.LinearLogic (test, snakePicture) where++import Data.List (isInfixOf)+import Data.Type.Nat (Nat (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (fst, id, snd, (**), (.))++import Proarrow.Category.Instance.FinRel (FINREL (..))+import Proarrow.Category.Instance.IntConstruction (INT (..), IntConstruction (..))+import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..))+import Proarrow.Category.Instance.Linear (LINEAR (..), unLinear)+import Proarrow.Category.Instance.Linear qualified as Lin+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), type (**))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), combineDual)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), Par, doubleNegInvDefault, par, parSwap, weakDistL, weakDistR)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.IsoMix (IsoMix)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..), doubleNegDefault)+import Proarrow.Category.Monoidal.Strength (trace)+import Proarrow.Core (CategoryOf (..), Promonad (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Promonad.Cont (Cont (..))+import Proarrow.Testing (check, genNamed)+import Proarrow.Tools.Diagrams.Svg qualified as Svg+import Proarrow.Tools.SMC+  ( SYN (F, Not, (:**))+  , annihilate+  , bothWaysT+  , combineDualT+  , cont+  , contraT+  , distT+  , dneT+  , dniT+  , loopCC+  , parSwapT+  , ret+  , rotT+  , snakeDualT+  , snakeT+  , swapEitherT+  , toSMC+  , weakDistT+  , (|>)+  , type (:##)+  )+import Proarrow.Tools.SMC qualified as SMC+import Props.FinRel ()++test :: TestTree+test = testGroup "Linear logic (Proarrow.Tools.SMC)" [duality, classical, additives, parTests]++type F1 = FR (S Z)+type F2 = FR (S (S Z))+type F3 = FR (S (S (S Z)))++-- * Duals++-- | The snake on the dual as a string diagram: a cup and a cap.+snakePicture :: String+snakePicture = Svg.render (snakeDualT @(Svg.S '[Svg.Wire "a"]))++duality :: TestTree+duality =+  testGroup+    "Duality"+    [ testProperty "snake is the identity (FinRel 2)" $ check "differs from id" (snakeT @F2 == id)+    , testProperty "snake is the identity (FinRel 3)" $ check "differs from id" (snakeT @F3 == id)+    , testProperty "the snake on the dual is the identity (FinRel 2)" $ check "differs from id" (snakeDualT @F2 == id)+    , testProperty "the snake draws" $ check "not an SVG document" ("<svg" `isInfixOf` snakePicture)+    , testProperty "a triple pattern is the left-nested pairs (FinRel 2, 1, 3)" $+        check+          "differs"+          ( toSMC @(F F2 :** F F1 :** F F3) (\(x, y, z) -> z SMC.** x SMC.** y)+              == toSMC @(F F2 :** F F1 :** F F3) (\((x, y), z) -> z SMC.** x SMC.** y)+          )+    , testProperty "a quadruple pattern is the left-nested pairs (FinRel 2, 1, 3, 2)" $+        check+          "differs"+          ( toSMC @(F F2 :** F F1 :** F F3 :** F F2) (\(w, x, y, z) -> z SMC.** x SMC.** w SMC.** y)+              == toSMC @(F F2 :** F F1 :** F F3 :** F F2) (\(((w, x), y), z) -> z SMC.** x SMC.** w SMC.** y)+          )+    , testProperty "combineDual (FinRel 2, 3)" $+        check "differs from combineDual" (combineDualT @F2 @F3 == combineDual @F2 @F3)+    , -- the Int construction's duals swap the two halves; bigger objects than these get expensive+      testProperty "combineDual (Int construction over FinRel)" $+        check "differs from combineDual" $+          case (combineDualT @(I F1 F2) @(I F1 F1), combineDual @(I F1 F2) @(I F1 F1)) of+            (Int f, Int g) -> f == g+    , testProperty "combineDual inverts distribDual (FinRel 3, 2)" $+        check "not inverses" (combineDualT @F3 @F2 . distribDual @_ @F3 @F2 == id)+    , testProperty "the trace from the duality is FinRel's trace" $ do+        h <- genNamed @(F2 ** F2 ~> F3 ** F2) "h"+        check "differs from trace" (loopCC @F2 @F3 @F2 h == trace @(~>) @F2 @F2 @F3 h)+    , testProperty "the trace from the duality is FinRel's trace (other sizes)" $ do+        h <- genNamed @(F3 ** F1 ~> F2 ** F1) "h"+        check "differs from trace" (loopCC @F3 @F2 @F1 h == trace @(~>) @F1 @F3 @F2 h)+    ]++-- * Classical reasoning++type K = KLEISLI (Cont Int)++-- | Run a morphism of @K@ on a value and a continuation.+run :: (KL a :: K) ~> KL b -> a -> (b -> Int) -> Int+run (Kleisli (Cont m)) a k = m k a++incr :: (KL Int :: K) ~> KL Int+incr = Kleisli (Cont \k a -> k (a + 1) * 2)++-- Values, continuations, and elements and continuations of the dual and double dual of @Int@.+xs :: [Int]+xs = [0, 3, 7]++ks :: [Int -> Int]+ks = [(* 2), (+ 1)]++nns :: [(Int -> Int) -> Int]+nns = [\c -> c 3 + c 4, ($ 5)]++nnks :: [((Int -> Int) -> Int) -> Int]+nnks = [\nn -> nn (* 3), \nn -> nn id + 1]++nbs :: [Int -> Int]+nbs = [(* 5), subtract 1]++nks :: [(Int -> Int) -> Int]+nks = [($ 2), \g -> g 0 + g 9]++-- | Give an @a@ to its consumer and keep the @b@: needs only isomix.+annihilateT :: forall {k} (a :: k) b. (IsoMix k, SymMonoidal k, Ob a, Ob b) => Dual a ** a ** b ~> b+annihilateT = toSMC @(Not (F a) :** F a :** F b) \(na, a, b) -> SMC.do+  () <- annihilate na a+  b++classical :: TestTree+classical =+  testGroup+    "Classical"+    [ testProperty "double negation elimination after introduction is the identity" $+        check "differs" (and [run (dneT @(KL Int) . dniT) x k == k x | x <- xs, k <- ks])+    , testProperty "double negation introduction is doubleNegInv" $+        check "differs" (and [run (dniT @(KL Int)) x k == run (doubleNegInv @K @(KL Int)) x k | x <- xs, k <- nnks])+    , testProperty "double negation elimination is doubleNeg" $+        check "differs" (and [run (dneT @(KL Int)) nn k == run (doubleNeg @K @(KL Int)) nn k | nn <- nns, k <- ks])+    , testProperty "the continuation category's doubleNeg is doubleNegDefault" $+        check+          "differs"+          (and [run (doubleNeg @K @(KL Int)) nn k == run (doubleNegDefault @(KL Int :: K)) nn k | nn <- nns, k <- ks])+    , testProperty "the continuation category's doubleNegInv is doubleNegInvDefault" $+        check+          "differs"+          (and [run (doubleNegInv @K @(KL Int)) x k == run (doubleNegInvDefault @(KL Int :: K)) x k | x <- xs, k <- nnks])+    , -- each call of LINEAR's doubleNeg needs its own reference; a shared one returns stale values+      testProperty "double negation in LINEAR gives back every value" $+        check "differs" ([unLinear (doubleNeg @LINEAR @(L Int) . doubleNegInv) x | x <- [1 .. 1000]] == [1 .. 1000])+    , testProperty "double negation elimination after introduction in LINEAR, nested" $+        check "differs" ([unLinear (dneT @(L Int) . dneT . dniT . dniT) x | x <- [1 .. 100]] == [1 .. 100])+    , testProperty "annihilate in LINEAR" $+        check "differs" (and [unLinear (annihilateT @(L ()) @(L Bool)) ((\() -> (), ()), b) == b | b <- [False, True]])+    , testProperty "contraposition is dual" $+        check "differs" (and [run (contraT incr) nb k == run (dual incr) nb k | nb <- nbs, k <- nks])+    ]++-- * Additives++additives :: TestTree+additives =+  testGroup+    "Additives"+    [ testProperty "case analysis is the distributor (FinRel 2, 1, 3)" $+        check "differs from distL" (distT @F2 @F1 @F3 == distL @_ @F2 @F1 @F3)+    , testProperty "swapping a coproduct twice is the identity (FinRel 2, 3)" $+        check "differs from id" (swapEitherT @F3 @F2 . swapEitherT @F2 @F3 == id)+    , testProperty "the projections of a pair both ways are id and swap (FinRel 2, 3)" $ do+        check "fst differs from id" (fst @_ @(F2 ** F3) @(F3 ** F2) . bothWaysT @F2 @F3 == id)+        check "snd differs from swap" (snd @_ @(F2 ** F3) @(F3 ** F2) . bothWaysT @F2 @F3 == swap @_ @F2 @F3)+    ]++-- * Par++-- In 'LINEAR' a par is @'Lin.Not' ('Lin.Not' a, 'Lin.Not' b)@, and a component is read off by+-- giving the other side a consumer ('Lin.parAppL', 'Lin.parAppR'), which goes through LINEAR's+-- double negation.+type P a b = Lin.Not (Lin.Not a, Lin.Not b)++discard :: Bool %1 -> ()+discard = unLinear counit++discard2 :: (Bool, Bool) %1 -> ()+discard2 (a, b) = case discard a of () -> discard b++observe :: P a b -> Lin.Not a -> Lin.Not b -> (a, b)+observe q na nb = (Lin.parAppR (Lin.Par q) nb, Lin.parAppL (Lin.Par q) na)++-- | Read off pars of booleans, of a pair of booleans and a boolean, and the other way round.+observe2 :: P Bool Bool -> (Bool, Bool)+observe2 q = observe q discard discard++observeL :: P (Bool, Bool) Bool -> ((Bool, Bool), Bool)+observeL q = observe q discard2 discard++observeR :: P Bool (Bool, Bool) -> (Bool, (Bool, Bool))+observeR q = observe q discard discard2++unPar :: Lin.Par a b -> P a b+unPar (Lin.Par q) = q++-- Pars of two booleans, with what they hold, using the consumers in either order.+pars :: [(P Bool Bool, (Bool, Bool))]+pars = [(q, (x, y)) | x <- [False, True], y <- [False, True], q <- both' x y]+  where+    both' :: Bool -> Bool -> [P Bool Bool]+    both' x y = [\(na, nb) -> case na x of () -> nb y, \(na, nb) -> case nb y of () -> na x]++-- | A three way par rotated, with its three outputs bound by one pattern and handed back as one+-- tuple. The consumer of the inner par is a computation, which the nested pattern runs and the+-- nested tuple builds.+parRotT+  :: forall {k} (a :: k) b c+   . (Dialogue k, Ob a, Ob b, Ob c)+  => (a `Par` b `Par` c) ~> (b `Par` c `Par` a)+parRotT = toSMC @(F a :## F b :## F c) @(F b :## F c :## F a) \p -> cont \(kb, kc, ka) -> p |> ret (ka, kb, kc)++-- | A command passed on through 'cont' with the pattern @()@.+unitContT :: forall k. (Dialogue k) => Dual (Unit :: k) ~> Dual Unit+unitContT = toSMC @(Not (SMC.I :: SYN k)) @(Not SMC.I) \c -> cont \() -> c++-- | 'parSwapT' with the par consumed by a consumer built with 'ret'.+parSwapRetT+  :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => Par a b ~> Par b a+parSwapRetT = toSMC @(F a :## F b) @(F b :## F a) \p -> cont \(kb, ka) -> p |> ret (ka, kb)++type B = L Bool++parTests :: TestTree+parTests =+  testGroup+    "Par"+    [ testProperty "par swap hands the input both outputs the other way round, as parSwap does" $+        check+          "differs"+          ( and+              [ observe2 (unLinear (parSwapT @B @B) q) == (y, x) && observe2 (unLinear (parSwap @B @B) q) == (y, x)+              | (q, (x, y)) <- pars+              ]+          )+    , testProperty "par swap twice is the identity" $+        check "differs" (and [observe2 (unLinear (parSwapT @B @B . parSwapT) q) == xy | (q, xy) <- pars])+    , testProperty "consuming the par with a consumer built with ret is the same" $+        check "differs" (and [observe2 (unLinear (parSwapRetT @B @B) q) == (y, x) | (q, (x, y)) <- pars])+    , testProperty "weak distributivity pairs the emitted b with a, as weakDistL and pairFst do" $+        check+          "differs"+          ( and+              [ all @[]+                  (== ((a, x), y))+                  [ observeL (unLinear (weakDistT @B @B @B) (a, q))+                  , observeL (unLinear (weakDistL @B @B @B) (a, q))+                  , observeL (unPar (Lin.pairFst (a, Lin.Par q)))+                  ]+              | a <- [False, True]+              , (q, (x, y)) <- pars+              ]+          )+    , testProperty "weakDistR pairs c with the emitted b, as pairSnd does" $+        check+          "differs"+          ( and+              [ all @[]+                  (== (x, (y, c)))+                  [observeR (unLinear (weakDistR @B @B @B) (q, c)), observeR (unPar (Lin.pairSnd (Lin.Par q, c)))]+              | c <- [False, True]+              , (q, (x, y)) <- pars+              ]+          )+    , testProperty "cont with a triple pattern rotates a three way par (FinRel 2, 1, 3)" $+        check "differs from rotT" (parRotT @F2 @F1 @F3 == rotT @F2 @F1 @F3)+    , testProperty "cont with the pattern () passes a command on (continuations)" $+        check+          "differs from id"+          (and [run (unitContT @K) c k == k c | c <- [const 3, const 7], k <- [($ ()), \g -> g () * 2]])+    , testProperty "par swap is parSwap and swap (FinRel 2, 3)" $ do+        check "differs from parSwap" (parSwapT @F2 @F3 == parSwap @F2 @F3)+        check "differs from swap" (parSwapT @F2 @F3 == swap @_ @F2 @F3)+    , testProperty "weak distributivity is weakDistL and the associator (FinRel 2, 1, 3)" $ do+        check "differs from weakDistL" (weakDistT @F2 @F1 @F3 == weakDistL @F2 @F1 @F3)+        check "differs from associatorInv" (weakDistT @F2 @F1 @F3 == associatorInv @_ @F2 @F1 @F3)+    , testProperty "weakDistR is the associator (FinRel 2, 1, 3)" $+        check "differs from associator" (weakDistR @F2 @F1 @F3 == associator @_ @F2 @F1 @F3)+    , testProperty "par on arrows is the tensor (FinRel)" $ do+        f <- genNamed @(F2 ~> F3) "f"+        g <- genNamed @(F1 ~> F2) "g"+        check "differs from f ** g" (par f g == f ** g)+    ]
+ test/Examples/Sessions.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}++-- | The internet commerce example of Wadler's /Propositions as Sessions/ (JFP version), with+-- "Proarrow.Tools.SMC" as the process calculus, run in 'LINEAR', and extended with a broker.+--+-- A session type of CP is a 'SYN' type, and its dual is 'Not'. A process with channels+-- @x : A, r : R@ is a term from @r@'s dual to @A@, so the buyer below takes the consumer of its+-- receipt and produces its side of the session, and the seller, which only has the session, is a+-- consumer of the buyer's side. Composing two processes on a channel, @νx.(P | Q)@, is a 'cut'.+-- The processes stay in the dialogue fragment, so a closed process with one channel left, the+-- receipt, is a computation, 'Up', that produces it; 'run' reaches the receipt through 'LINEAR'\'s+-- double negation.+--+-- CP ends every session in a unit, @1@ or @⊥@, so that after the last message the channel is+-- closed rather than left as the channel of the message. Here messages are values, so the units+-- are left out: @Name ⊗ Credit ⊗ Receipt⊥@ instead of @Name ⊗ (Credit ⊗ (Receipt⊥ ⅋ ⊥))@.+module Examples.Sessions (test) where++import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (*), (**), (.))++import Proarrow.Category.Instance.Linear (LINEAR (..), Linear (..), Ur (..), counitUr, unLinear)+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..))+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), dualityCounitSA)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Testing (check)+import Proarrow.Tools.SMC+  ( KnownCtx+  , SYN (F, I, Not, (:**), (:||))+  , Up+  , caseOf+  , closed+  , cont+  , inl+  , inr+  , lift+  , ret+  , toSMC+  , unit+  , (**)+  , (|>)+  , type (:##)+  )+import Proarrow.Tools.SMC qualified as SMC++test :: TestTree+test =+  testGroup+    "Sessions (Propositions as Sessions)"+    [ testProperty "the buyer gets the receipt the seller computes" $+        check "wrong receipt" (run deal == "tea, paid with 1234")+    , testProperty "the shopper gets the price the quoter looks up" $+        check "wrong price" (run ask == 3)+    , testProperty "selecting buy from the choice is buying" $+        check "differs" (run selectBuy == run deal)+    , testProperty "selecting shop from the choice is asking the price" $+        check "differs" (run selectShop == run ask)+    , testProperty "the deal written with the structure of the category is the same" $+        check "differs" (run dealByHand == run deal)+    , testProperty "buying through the broker annotates the receipt" $+        check "wrong receipt" (run brokeredDeal == "tea, paid with 1234 (via broker)")+    ]++-- | Run a closed process to its result.+run :: forall a. (Unit ~> Dual (Dual (L (Ur a)))) -> a+run p = counitUr (unLinear (doubleNeg @LINEAR @(L (Ur a)) . p) ())++-- * Messages++type Name = L (Ur String)+type Credit = L (Ur Int)+type Receipt = L (Ur String)+type Price = L (Ur Int)++-- * Buying++-- | @Buy = Name ⊗ Credit ⊗ Receipt⊥@: send a name, a credit card number, and where the receipt+-- should go.+type Buy :: SYN LINEAR+type Buy = F Name :** F Credit :** Not (F Receipt)++-- | @Sell = Buy⊥@.+type Sell :: SYN LINEAR+type Sell = Not Buy++-- | @x[u].(put-name_u | x[v].(put-credit_v | x ↔ r))@: send the name on @u@ and the card on @v@,+-- and forward the rest of @x@, where the receipt arrives, to @r@.+buyer :: (KnownCtx g) => SMC.Term d g (Not (F Receipt)) %1 -> SMC.Term d g Buy+buyer r = put "tea" ** put 1234 ** r++-- | @x(u).x(v).compute_{u,v,x}@: receive the name and the card, and send the receipt where it+-- should go.+seller :: SMC.Term d '[] Sell+seller = closed $ cont \(name, credit, toBuyer) -> compute (name ** credit) |> toBuyer++-- | @νx.(buy | sell)@, with the buyer's receipt as the result.+deal :: Unit ~> Dual (Dual Receipt)+deal = toSMC @I @(Up (F Receipt)) \() -> cont \r -> buyer r |> seller++-- * Asking the price++-- | @Shop = Name ⊗ Price⊥@.+type Shop :: SYN LINEAR+type Shop = F Name :** Not (F Price)++-- | @Quote = Shop⊥@.+type Quote :: SYN LINEAR+type Quote = Not Shop++-- | @x[u].(put-name_u | x ↔ r)@.+shopper :: (KnownCtx g) => SMC.Term d g (Not (F Price)) %1 -> SMC.Term d g Shop+shopper r = put "tea" ** r++-- | @x(u).lookup_{u,x}@.+quoter :: SMC.Term d '[] Quote+quoter = closed $ cont \(name, toShopper) -> lookupPrice name |> toShopper++-- | @νx.(shop | quote)@.+ask :: Unit ~> Dual (Dual Price)+ask = toSMC @I @(Up (F Price)) \() -> cont \r -> shopper r |> quoter++-- * Choosing++-- | @Select = Buy ⊕ Shop@, offered by @Choice = Sell & Quote@. The choice is a consumer of @Select@+-- that cases on it: @x.case(sell, quote)@.+type Select :: SYN LINEAR+type Select = Buy :|| Shop++choice :: SMC.Term d '[] (Not Select)+choice = closed $ cont \x -> caseOf unit x (\((), b) -> b |> seller) (\((), s) -> s |> quoter)++-- | @νx.(x[inl].buy | choice)@.+selectBuy :: Unit ~> Dual (Dual Receipt)+selectBuy = toSMC @I @(Up (F Receipt)) \() -> cont \r -> inl (buyer r) |> choice++-- | @νx.(x[inr].shop | choice)@, which tells the price instead.+selectShop :: Unit ~> Dual (Dual Price)+selectShop = toSMC @I @(Up (F Price)) \() -> cont \r -> inr (shopper r) |> choice++-- * A broker++-- | A process with two channels, @⊢ x : Sell, y : Buy@, to the buyer and to the seller, and so a+-- par. The consumer of the buyer's channel is a computation that produces the order: binding it+-- reads the order, which is then placed with the seller, with the receipt passed back with a note.+broker :: SMC.Term d '[] (Not Buy :## Buy)+broker = closed $ cont \(fromBuyer, toSeller) -> SMC.do+  (name, credit, toBuyer) <- fromBuyer+  name ** credit ** cont (\receipt -> annotate receipt |> toBuyer) |> toSeller++-- | @νx.νy.(buy | broker | sell)@. The buyer's side is handed to the broker as a computation.+brokeredDeal :: Unit ~> Dual (Dual Receipt)+brokeredDeal = toSMC @I @(Up (F Receipt)) \() -> cont \r -> ret (buyer r) ** seller |> broker++-- * By hand++-- | 'deal' written with the structure of the category directly, which is what 'toSMC' generates+-- from it, give or take some unitors.+dealByHand :: Unit ~> Dual (Dual Receipt)+dealByHand =+  dual (rightUnitorInv @_ @(Dual Receipt))+    . linDist @_ @Unit @(Dual Receipt) @Unit (dualityCounitSA @BuyObj . (sellerByHand M.** buyerByHand))++-- | 'Buy' as an object of 'LINEAR'.+type BuyObj :: LINEAR+type BuyObj = Name ** Credit ** Dual Receipt++-- | The seller: a consumer of the order, given as the transpose of what it does with one.+sellerByHand :: Unit ~> Dual BuyObj+sellerByHand =+  dual (rightUnitorInv @_ @BuyObj)+    . linDist @_ @Unit @BuyObj @Unit+      ( dualityCounitSA @Receipt+          . swap @_ @Receipt @(Dual Receipt)+          . (computeByHand M.** obj @(Dual Receipt))+          . leftUnitor @_ @BuyObj+      )++-- | The buyer: from where the receipt should go to the order.+buyerByHand :: Dual Receipt ~> BuyObj+buyerByHand =+  ((tea M.** card) M.** obj @(Dual Receipt))+    . (leftUnitorInv @_ @Unit M.** obj @(Dual Receipt))+    . leftUnitorInv @_ @(Dual Receipt)++tea :: Unit ~> Name+tea = Linear \() -> Ur "tea"++card :: Unit ~> Credit+card = Linear \() -> Ur 1234++computeByHand :: Name ** Credit ~> Receipt+computeByHand = Linear \(Ur n, Ur c) -> Ur (n ++ ", paid with " ++ show c)++-- * Helpers++-- | A message, from nothing.+put :: forall a d. a -> SMC.Term d '[] (F (L (Ur a)))+put x = lift @I @(F (L (Ur a))) (Linear \() -> Ur x) unit++compute :: SMC.Term d g (F Name :** F Credit) %1 -> SMC.Term d g (F Receipt)+compute = lift @(F Name :** F Credit) @(F Receipt) (Linear \(Ur n, Ur c) -> Ur (n ++ ", paid with " ++ show c))++lookupPrice :: SMC.Term d g (F Name) %1 -> SMC.Term d g (F Price)+lookupPrice = lift @(F Name) @(F Price) (Linear \(Ur n) -> Ur (length n))++annotate :: SMC.Term d g (F Receipt) %1 -> SMC.Term d g (F Receipt)+annotate = lift @(F Receipt) @(F Receipt) (Linear \(Ur s) -> Ur (s ++ " (via broker)"))
test/Examples/SimplyTypedLambdaCalculus.hs view
@@ -447,6 +447,7 @@  instance Testable TY where   type TestOb a = (ObId a, TyTestOb a)+  obFromTestOb r = r   showOb @a = showTy @a   genSome = genSomeDef @TyPalette @@ -461,6 +462,7 @@  instance Testable CON where   type TestOb g = (ConOb g, ConTestOb g)+  obFromTestOb r = r   showOb @g = showCon @g   genSome = genSomeDef @ConPalette
+ test/Examples/Toffoli.hs view
@@ -0,0 +1,221 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE QualifiedDo #-}++-- | The Toffoli gate example from the @linear-smc@ library (the examples of /Evaluating Linear+-- Functions to Symmetric Monoidal Categories/), ported to "Proarrow.Tools.SMC": the Toffoli gate+-- as the usual circuit of Hadamard, T and controlled-not gates, written once and compiled to three+-- categories.+--+-- * In 'Mat', gates are complex matrices.+-- * In "Proarrow.Category.Instance.ZX", gates are spiders. They are not normalized, so the result+--   is compared with the Toffoli gate up to a scalar.+-- * In "Proarrow.Tools.Diagrams.Svg", gates are boxes, and the circuit is drawn.+--+-- The original's last controlled-not leaves its two control wires swapped, so its matrix is a+-- Toffoli gate followed by a swap of the controls. Here one more bind puts them back in order.+module Examples.Toffoli (test) where++import Data.Complex (Complex (..), cis, magnitude)+import Data.Foldable (toList)+import Data.Kind (Type)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Type.Nat (Nat1, Nat2)+import Data.Vec.Lazy (Vec (..))+import GHC.TypeNats qualified as TN+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, sum, (*), (**), (.))+import Prelude qualified as P++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.Mat (Mat (..), MatK (..))+import Proarrow.Category.Instance.ZX (Bitstring (..), ZX (..))+import Proarrow.Category.Instance.ZX qualified as ZX+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal (..))+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Colimit.BinaryCoproduct (HasBiproducts (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Testing (check)+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.SMC (Merge, SYN (..), Term, Union, lift, toSMC, (**))+import Proarrow.Tools.SMC qualified as SMC++-- * The circuit++-- | The gates the circuit is built from, for qubits @q@.+type Gates :: forall {k}. k -> Type+data Gates q = Gates+  { hadamardG :: q ~> q+  , tG :: q ~> q+  , tInvG :: q ~> q+  , cnotG :: q ** q ~> q ** q+  }++toffoliWith :: forall {k} (q :: k). (SymMonoidal k, Ob q) => Gates q -> q ** q ** q ~> q ** q ** q+toffoliWith gates = toSMC @(F q :** F q :** F q) \(a0, b0, x0) -> SMC.do+  (a1, x1) <- cnot a0 (h x0)+  (b1, x2) <- cnot b0 (t' x1)+  (a2, x3) <- cnot a1 (t x2)+  (b2, x4) <- cnot b1 (t' x3)+  (b3, a3) <- cnot b2 (t a2)+  (b4, a4) <- cnot (t b3) (t' a3)+  a4 ** b4 ** h (t x4)+  where+    h, t, t' :: Term d g (F q) %1 -> Term d g (F q)+    h = lift (hadamardG gates)+    t = lift (tG gates)+    t' = lift (tInvG gates)+    cnot :: (Merge g1 g2) => Term d g1 (F q) %1 -> Term d g2 (F q) %1 -> Term d (Union g1 g2) (F q :** F q)+    cnot c x = lift (cnotG gates) (c ** x)++-- | The same circuit written directly with the monoidal structure, for comparison. The wires are+-- @a ** b ** x@, and each two-qubit gate needs its two wires moved next to each other by hand.+toffoliManual :: forall {k} (q :: k). (SymMonoidal k, Ob q) => Gates q -> q ** q ** q ~> q ** q ** q+toffoliManual (Gates h t t' cnot) =+  onX (h . t)+    . onBA (cnot . (t M.** t'))+    . onBA (cnot . (i M.** t))+    . onBX (cnot . (i M.** t'))+    . onAX (cnot . (i M.** t))+    . onBX (cnot . (i M.** t'))+    . onAX (cnot . (i M.** h))+  where+    i = obj @q+    -- (a ** b) ** x to (a ** x) ** b, and back again, since all three wires are qubits+    shuffle :: q ** q ** q ~> q ** q ** q+    shuffle = associatorInv @k @q @q @q . (i M.** swap @k @q @q) . associator @k @q @q @q+    onAX, onBX, onBA :: q ** q ~> q ** q -> q ** q ** q ~> q ** q ** q+    onAX f = shuffle . (f M.** i) . shuffle+    onBX f = associatorInv @k @q @q @q . (i M.** f) . associator @k @q @q @q+    onBA f = (swap @k @q @q M.** i) . (f M.** i) . (swap @k @q @q M.** i)+    onX :: q ~> q -> q ** q ** q ~> q ** q ** q+    onX g = i M.** i M.** g++bools :: [Bool]+bools = [False, True]++-- * Matrices++type C = Complex Double++mat2 :: C -> C -> C -> C -> Mat (M Nat2 :: MatK C) (M Nat2)+mat2 a b c d = Mat ((a ::: b ::: VNil) ::: (c ::: d ::: VNil) ::: VNil)++-- | The gate @u@ controlled by a qubit: the identity when the control is off, @u@ when it is on.+ctrlMat :: forall (a :: MatK C). (Ob a) => Mat a a -> Mat (M Nat2 ** a) (M Nat2 ** a)+ctrlMat u = sum (mat2 1 0 0 0 M.** obj @a) (mat2 0 0 0 1 M.** u)++matGates :: Gates (M Nat2 :: MatK C)+matGates =+  Gates+    { hadamardG = mat2 s s s (-s)+    , tG = mat2 1 0 0 (cis (pi / 4))+    , tInvG = mat2 1 0 0 (cis (-(pi / 4)))+    , cnotG = ctrlMat (mat2 0 1 1 0)+    }+  where+    s = 1 / sqrt 2++toffoliMat :: Mat (M Nat2 ** M Nat2 ** M Nat2 :: MatK C) (M Nat2 ** M Nat2 ** M Nat2)+toffoliMat = toffoliWith matGates++ket :: Bool -> Mat (M Nat1 :: MatK C) (M Nat2)+ket b = Mat (((if b then 0 else 1) ::: VNil) ::: ((if b then 1 else 0) ::: VNil) ::: VNil)++-- | Equal up to rounding: the T gates are only approximately undone.+close :: Mat (a :: MatK C) b -> Mat a b -> Bool+close (Mat x) (Mat y) = and [magnitude (u - v) < 1e-9 | (u, v) <- zip (entries x) (entries y)]+  where+    entries = concatMap toList++-- * ZX++zxGates :: Gates (1 :: TN.Nat)+zxGates =+  Gates+    { hadamardG = ZX.hadamard+    , tG = ZX.zSpider (pi / 4)+    , tInvG = ZX.zSpider (-(pi / 4))+    , cnotG = ZX.cnot+    }++toffoliZX :: ZX 3 3+toffoliZX = toffoliWith zxGates++ketZ :: Bool -> ZX 0 1+ketZ b = ZX (Map.singleton (BS (fromEnum b), BS 0) 1)++ket3 :: Bool -> Bool -> Bool -> ZX 0 3+ket3 c1 c2 x = ketZ c1 M.** ketZ c2 M.** ketZ x++-- | The Toffoli gate, from its action on the basis states.+toffoliZXSpec :: ZX 3 3+toffoliZXSpec =+  foldr1+    addZX+    [ket3 c1 c2 (x /= (c1 && c2)) . dagger (ket3 c1 c2 x) | c1 <- bools, c2 <- bools, x <- bools]+  where+    addZX (ZX a) (ZX b) = ZX (Map.unionWith (+) a b)++-- | Equal up to a nonzero scalar, and up to rounding.+proportional :: ZX i o -> ZX i o -> Bool+proportional (ZX a) (ZX b) = case [(magnitude v, k) | (k, v) <- Map.toList b] of+  [] -> Map.null a+  entries ->+    let k0 = snd (maximum entries)+        c = at a k0 / at b k0+    in magnitude c > 1e-9 && and [magnitude (at a k - c P.* at b k) < 1e-9 | k <- Map.keys (Map.union a b)]+  where+    at m k = Map.findWithDefault 0 k m++-- * Pictures++-- | A qubit, as a wire of a string diagram.+type SQ = S '[Wire "q"]++-- | Gates as boxes. The controlled-not is drawn the way circuits draw it: a copy point on the+-- control joined to a box on the target.+svgGates :: Gates SQ+svgGates =+  Gates+    { hadamardG = node "H"+    , tG = node "T"+    , tInvG = node "T†"+    , cnotG = (obj @SQ M.** node @'[Wire "q", Wire "q"] @'[Wire "q"] "⊕") . (comult @SQ M.** obj @SQ)+    }++-- | The circuit, drawn.+toffoliPicture :: String+toffoliPicture = render (toffoliWith svgGates)++test :: TestTree+test =+  testGroup+    "Toffoli (Proarrow.Tools.SMC)"+    [ testProperty "controlled-not on the basis states (Mat)" $+        sequence_+          [ check (show (c, x)) (close (cnotG matGates . (ket c M.** ket x)) (ket c M.** ket (x /= c)))+          | c <- bools+          , x <- bools+          ]+    , testProperty "Toffoli on the basis states (Mat)" $+        sequence_+          [ check+              (show (c1, c2, x))+              (close (toffoliMat . (ket c1 M.** ket c2 M.** ket x)) (ket c1 M.** ket c2 M.** ket (x /= (c1 && c2))))+          | c1 <- bools+          , c2 <- bools+          , x <- bools+          ]+    , testProperty "written by hand, the same circuit (Mat)" $+        check "differs from toffoliWith" (close (toffoliManual matGates) toffoliMat)+    , testProperty "written by hand, the same circuit (ZX), up to a scalar" $+        check (show (toffoliManual zxGates)) (proportional (toffoliManual zxGates) toffoliZXSpec)+    , testProperty "Toffoli circuit (ZX), up to a scalar" $+        check (show toffoliZX) (proportional toffoliZX toffoliZXSpec)+    , testProperty "the circuit draws" $+        check "not an SVG document" ("<svg" `isInfixOf` toffoliPicture)+    ]
test/Main.hs view
@@ -5,16 +5,22 @@ import Test.Tasty (defaultMain, testGroup) import Prelude +import Examples.Cbpv qualified as Cbpv import Examples.CustomLaws qualified as CustomLaws import Examples.Database qualified as Database import Examples.Free qualified as FreeExample import Examples.Graph qualified as Graph+import Examples.IntComposition qualified as IntComposition+import Examples.LinearLogic qualified as LinearLogic+import Examples.Sessions qualified as Sessions import Examples.SimplyTypedLambdaCalculus qualified as STLC+import Examples.Toffoli qualified as Toffoli import Examples.UntypedLambdaCalculus qualified as ULC import Examples.Vitrea qualified as Vitrea import Props.Bool qualified as Bool import Props.Cospan qualified as Cospan import Props.Cost qualified as Cost+import Props.Cps qualified as Cps import Props.DPO qualified as DPO import Props.Discrete qualified as Discrete import Props.Dot qualified as Dot@@ -25,6 +31,7 @@ import Props.Finitary.Graph qualified as FinitaryGraph import Props.Free qualified as Free import Props.Hask qualified as Hask+import Props.IntConstruction qualified as IntConstruction import Props.Kleisli qualified as Kleisli import Props.Mat qualified as Mat import Props.Optic.FinRel qualified as OpticFinRel@@ -56,12 +63,14 @@           , Dot.test           , FinHask.test           , FinRel.test+          , IntConstruction.test           , FinSet.test           , Finitary.test           , FinitaryGraph.test           , Free.test           , Hask.test           , Kleisli.test+          , Cps.test           , Mat.test           , Optic.test           , OpticLinear.test@@ -85,6 +94,11 @@           , Graph.test           , STLC.test           , ULC.test+          , IntComposition.test+          , LinearLogic.test+          , Sessions.test+          , Cbpv.test+          , Toffoli.test           , Vitrea.test           ]       ]
test/Props/Bool.hs view
@@ -56,6 +56,7 @@     , testMonoidal_ @BOOL     , testSymMonoidal_ @BOOL     , testCopyDiscard_ @BOOL+    , testDialogue_ @BOOL     , testStarAutonomous_ @BOOL     , testBinaryCoproducts_ @BOOL     , testDistributive_ @BOOL
test/Props/Cospan.hs view
@@ -35,7 +35,9 @@     , testMonoidal_ @(COSPAN FINSET)     , testSymMonoidal_ @(COSPAN FINSET)     , testClosed_ @(COSPAN FINSET)+    , testDialogue_ @(COSPAN FINSET)     , testStarAutonomous_ @(COSPAN FINSET)+    , testIsoMix_ @(COSPAN FINSET)     , testCompactClosed_ @(COSPAN FINSET)     , testCopyDiscard_ @(COSPAN FINSET)     , testHypergraph_ @(COSPAN FINSET)
test/Props/Cost.hs view
@@ -11,13 +11,11 @@ -- associativity and commutativity of @+@, and @distL@ \/ @distR@, which rely on monotonicity of @+@. module Props.Cost where -import Control.Monad (unless) import Data.Proxy (Proxy (..)) import Data.Type.Equality ((:~:) (Refl)) import Data.Type.Ord (OrderingI (..)) import GHC.TypeNats (cmpNat, natVal) import Numeric.Natural (Natural)-import Test.Falsify (testFailed) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty) import Prelude@@ -36,6 +34,7 @@   , TestableProfunctor   , TestableType (..)   , TestingEqShow (..)+  , check   , genSomeDef   , oneElem   )@@ -48,14 +47,14 @@     [ testCategory @COST     , testProperty "GTE decidable" $ propDecidable @GTE     , testProperty "shortest paths computed at the value level" $ do-        unless (distance @(D P) @(D R) == Just 7) (testFailed "P -> R should be 7")-        unless (distance @(D Q) @(D P) == Just 11) (testFailed "Q -> P should be 11")-        unless (distance @(D P) @(D P) == Just 0) (testFailed "P -> P should be 0")-        unless (distance @(D P) @(D Y) == Nothing) (testFailed "P -> Y should be unreachable")+        check "P -> R should be 7" (distance @(D P) @(D R) == Just 7)+        check "Q -> P should be 11" (distance @(D Q) @(D P) == Just 11)+        check "P -> P should be 0" (distance @(D P) @(D P) == Just 0)+        check "P -> Y should be unreachable" (distance @(D P) @(D Y) == Nothing)     , testProperty "shortest paths as witnesses" $ do-        unless (steps (shortest @COST @N @G @(D P) @(D R)) == 2) (testFailed "P -> R should take the detour via Q")-        unless (steps (shortest @COST @N @G @(D Q) @(D P)) == 3) (testFailed "Q -> P should go around the cycle")-        unless (steps (shortest @COST @N @G @(D P) @(D P)) == 0) (testFailed "P -> P should stay put")+        check "P -> R should take the detour via Q" (steps (shortest @COST @N @G @(D P) @(D R)) == 2)+        check "Q -> P should go around the cycle" (steps (shortest @COST @N @G @(D Q) @(D P)) == 3)+        check "P -> P should stay put" (steps (shortest @COST @N @G @(D P) @(D P)) == 0)     , testTerminalObject @COST     , testInitialObject @COST     , testBinaryProducts_ @COST
+ test/Props/Cps.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Cps where++import Data.Kind (Type)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (id, (.))++import Proarrow.Category.Instance.Cps (CPS (..), Cps (..))+import Proarrow.Core (CAT, CategoryOf (..), UN)+import Proarrow.Testing+  ( SomeProfunctorElt (..)+  , Testable (..)+  , TestableProfunctor (..)+  , TestableType (..)+  , TestingEqShow (..)+  , genSomeDef+  , invmap+  )+import Proarrow.Testing.Laws+import Props.Hask ()++-- | The dialogue category of 'Type' with answer object 'Bool', whose dual is @a -> Bool@, and the+-- isomix one with answer object @()@, whose dual @a -> ()@ is a point.+test :: TestTree+test =+  testGroup+    "CPS"+    [ testGroup+        "answer Bool"+        [ testCategory @(CPS Bool)+        , testMonoidal @(CPS Bool) (\r -> r)+        , testSymMonoidal @(CPS Bool) (\r -> r)+        , testClosed @(CPS Bool) (\r -> r) (\r -> r)+        , testDialogue @(CPS Bool) (\r -> r) (\r -> r)+        ]+    , -- the dialogue laws are the same instance as at Bool; only the isomix structure is new+      testGroup "answer ()" [testIsoMix @(CPS ()) (\r -> r) (\r -> r)]+    ]++instance (TestOb a, TestOb b) => TestableType (Cps (C a :: CPS (r :: Type)) (C b)) where+  gen = invmap Cps unCps (gen @(a -> b))+instance (TestOb a, TestOb b) => TestingEqShow (Cps (C a :: CPS (r :: Type)) (C b)) where+  eqP (Cps l) (Cps r) = eqP l r+  showP (Cps f) = "Cps (" ++ showP f ++ ")"+instance TestableProfunctor (Cps :: CAT (CPS (r :: Type))) where+  genProfunctorElt nm = do+    SomeP f <- genProfunctorElt @(->) nm+    pure (SomeP (Cps f))++instance Testable (CPS (r :: Type)) where+  type TestOb a = (Ob a, TestOb (UN C a))+  obFromTestOb r = r+  showOb @(C a) = "C " ++ showOb @_ @a+  genSome = genSomeDef @'[C Bool, C (), C (Maybe Bool)]
test/Props/Dot.hs view
@@ -66,7 +66,9 @@     , testComonoid_ @(D '["A", "B"])     , testHypergraph @DOT (\ @a @b r -> withOb2 @DOT @a @b r)     , testClosed_ @DOT+    , testDialogue_ @DOT     , testStarAutonomous_ @DOT+    , testIsoMix_ @DOT     , testCompactClosed_ @DOT     , testTraced_ @DOT     ]@@ -117,7 +119,7 @@   if stacked     then do       Some @m <- genSome @k-      (.) <$> labelled @m @b <*> labelled @a @m+      obFromTestOb @_ @m $ (.) <$> labelled @m @b <*> labelled @a @m     else labelled @a @b   where     labelled :: forall (x :: k) (y :: k). (Ob x, Ob y) => Gen (x ~> y)
test/Props/FinHask.hs view
@@ -110,6 +110,7 @@  instance Testable FINHASK where   type TestOb a = (Ob a, Typeable (UN FH a), TestableType (UN FH a))+  obFromTestOb r = r   showOb @(FH a) = P.show (typeRep @a)   genSome = genSomeDef @'[FH Void, FH (), FH P.Bool, FH (Fin 3)]
test/Props/FinRel.hs view
@@ -48,7 +48,9 @@     , testSymMonoidal_ @FINREL     , testDistributive_ @FINREL     , testClosed_ @FINREL+    , testDialogue_ @FINREL     , testStarAutonomous_ @FINREL+    , testIsoMix_ @FINREL     , testCompactClosed_ @FINREL     , testTraced_ @FINREL     , -- the tensor-hom (currying) adjunction @(FR Nat2 '**' -) ⊣ (FR Nat2 '~~>' -)@
test/Props/Free.hs view
@@ -4,12 +4,10 @@ module Props.Free where  import Control.Applicative (Alternative (..))-import Control.Monad (unless) import Data.Foldable (for_) import Data.Kind (Type) import Data.Type.Equality ((:~:) (..)) import Data.Type.Nat (Nat2)-import Test.Falsify (testFailed) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty) import Prelude hiding (Monoid, curry, fst, id, mempty, snd, (**), (.))@@ -23,8 +21,10 @@ import Proarrow.Category.Monoidal.Cartesian (Cartesian, prodToTensor, tensorToProd, termToUnit, unitToTerm) import Proarrow.Category.Monoidal.Closed (Closed, apply, curry, withObExp, type (-->)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed)+import Proarrow.Category.Monoidal.Dialogue (Dialogue, DualF) import Proarrow.Category.Monoidal.Distributive (Distributive)-import Proarrow.Category.Monoidal.StarAutonomous (DualF, StarAutonomous)+import Proarrow.Category.Monoidal.IsoMix (IsoMix)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous) import Proarrow.Category.Sheaf (Cover (..), Leg (..), Sheaf (..), Summands, Sums, legArrow) import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), type (+)) import Proarrow.Colimit.Initial (HasInitialObject (..), InitF)@@ -45,6 +45,7 @@   , TestableProfunctor   , TestableType (..)   , TestingEqShow (..)+  , check   , expect   , genNamed   , genSomeDef@@ -63,7 +64,9 @@    , SymMonoidal    , Closed    , Distributive+   , Dialogue    , StarAutonomous+   , IsoMix    , CompactClosed    , Supplies Monoid    , Supplies Comonoid@@ -111,16 +114,17 @@         (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)         (\ @a @b r -> withObExp @FINREL @(LowerT a) @(LowerT b) r)         (\r -> r)+    , testIsoMix @FREEKIND (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r) (\r -> r)     , testHypergraph @FREEKIND (\ @a @b r -> withOb2 @FINREL @(LowerT a) @(LowerT b) r)     , sheafTests     , testProperty "cartesian coercions interpret to identities" P.$ do         let roundTrip = retract @CARTCS @(Rep InterpT) (tensorToProd @(EMB '()) @(EMB '()) . prodToTensor @(EMB '()) @(EMB '()))             unitTrip = retract @CARTCS @(Rep InterpT) (unitToTerm . termToUnit)-        unless (roundTrip (True, False) P.== (True, False) P.&& unitTrip () P.== ()) (testFailed "cartesian coercions")+        check "cartesian coercions" (roundTrip (True, False) P.== (True, False) P.&& unitTrip () P.== ())     , testProperty "retract . widen = retract" P.$ do         let l = retract @NARROWCS @(Rep Interp) narrowTerm             r = retract @FREECS @(Rep Interp) (widen @FREECS narrowTerm)-        unless (l P.== r) (testFailed (P.show l P.++ " /= " P.++ P.show r))+        expect "retract . widen" r l     ]  -- * The cartesian coercions@@ -305,6 +309,7 @@ -- instance override (like 'CategoryOf FINREL'\'s own 'Ob' equation) does. instance Testable FREEKIND where   type TestOb a = (KnownFree a, Ob (LowerT a))+  obFromTestOb r = r   showOb @a = showSFree (theFree @a)   genSome = genSomeDef @Palette
test/Props/Hask.hs view
@@ -19,7 +19,6 @@ import Type.Reflection (Typeable, typeRep) import Prelude hiding (elem, (.)) -import Control.Monad (unless) import Proarrow.Core (Promonad (..), type (+->)) import Proarrow.Monoid qualified as Monoid import Proarrow.Testing@@ -29,6 +28,7 @@   , TestableProfunctor   , TestableType (..)   , TestingEqShow (..)+  , check   , genSomeDef   , invmap   , oneElem@@ -36,7 +36,6 @@   , pattern GenNonEmpty   ) import Proarrow.Testing.Laws-import Test.Falsify (testFailed) import Test.Tasty.Falsify (testProperty)  test :: TestTree@@ -56,9 +55,9 @@     , testClosed @Type (\r -> r) (\r -> r)     , testFrobenius @() (\r -> r)     , testProperty "list monoid is not Frobenius: copy-comonoid breaks speciality" $-        unless+        check+          "speciality unexpectedly held for [()]"           ((Monoid.mappend . Monoid.comult @[()]) [()] /= [()])-          (testFailed "speciality unexpectedly held for [()]")     , testProfunctor @(Rep (ExpRep :: (OPPOSITE Type, Type) +-> Type))     , testProfunctor @(Star (Prelude Maybe) :: Type +-> Type)     , testPromonad @(Star (Prelude Maybe) :: Type +-> Type)@@ -69,6 +68,7 @@  instance Testable Type where   type TestOb a = (TestableType a, Typeable a, Function a)+  obFromTestOb r = r   showOb @a = show (typeRep @a)   genSome = genSomeDef @'[Bool, (Bool, Bool), Maybe Bool, Void]
+ test/Props/IntConstruction.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | The Int construction over 'FinRel', whose trace is a finite existential, so composing+-- generated morphisms always terminates (unlike in Hask, where the trace is a lazy fixed point).+module Props.IntConstruction where++import Data.Type.Nat (Nat (..))+import Test.Tasty (TestTree, testGroup)+import Prelude (($), (++))++import Proarrow.Category.Instance.FinRel (FINREL (..), FinRel)+import Proarrow.Category.Instance.IntConstruction (INT (..), IntConstruction (..), IntMinus, IntPlus)+import Proarrow.Category.Monoidal (Monoidal (..), type (**))+import Proarrow.Core (CAT, CategoryOf (..), (\\))++import Proarrow.Testing (Testable (..), TestableProfunctor, TestableType (..), TestingEqShow (..), genSomeDef, invmap)+import Proarrow.Testing.Laws+import Props.FinRel ()++test :: TestTree+test =+  testGroup+    "IntConstruction"+    [ testCategory @(INT FINREL)+    , testMonoidal_ @(INT FINREL)+    , testSymMonoidal_ @(INT FINREL)+    , testClosed_ @(INT FINREL)+    , testDialogue_ @(INT FINREL)+    , testStarAutonomous_ @(INT FINREL)+    , testIsoMix_ @(INT FINREL)+    , testCompactClosed_ @(INT FINREL)+    ]++type F0 = FR Z+type F1 = FR (S Z)+type F2 = FR (S (S Z))++instance Testable (INT FINREL) where+  showOb @(I p m) = "I " ++ showOb @FINREL @p ++ " " ++ showOb @FINREL @m+  genSome = genSomeDef @'[I F1 F0, I F0 F1, I F1 F1, I F2 F1]+  genSomeSmall = genSomeDef @'[I F1 F0, I F0 F1, I F1 F1]++-- | The underlying morphism of the base category.+unInt :: IntConstruction a b -> IntPlus a ** IntMinus b ~> IntMinus a ** IntPlus b+unInt (Int f) = f++instance (Ob a, Ob b) => TestableType (IntConstruction (a :: INT FINREL) b) where+  gen =+    withOb2 @FINREL @(IntPlus a) @(IntMinus b) $+      withOb2 @FINREL @(IntMinus a) @(IntPlus b) $+        invmap Int unInt (gen @(FinRel (IntPlus a ** IntMinus b) (IntMinus a ** IntPlus b)))+instance (Ob a, Ob b) => TestingEqShow (IntConstruction (a :: INT FINREL) b) where+  eqP (Int l) (Int r) = eqP l r \\ l+  showP (Int f) = showP f \\ f+instance TestableProfunctor (IntConstruction :: CAT (INT FINREL))
test/Props/Kleisli.hs view
@@ -90,6 +90,7 @@  instance (TestableProfunctor p, TestableTypeP p, Promonad p) => Testable (KLEISLI (p :: Type +-> Type)) where   type TestOb a = (Ob a, TestOb (UN KL a))+  obFromTestOb r = r   showOb @(KL a) = "KL " ++ showOb @_ @a   genSome = genSomeDef @'[KL Bool, KL (), KL (Maybe Bool)]
test/Props/Mat.hs view
@@ -50,7 +50,9 @@     , testSymMonoidal_ @(MatK Int)     , testDistributive_ @(MatK Int)     , testClosed_ @(MatK Int)+    , testDialogue_ @(MatK Int)     , testStarAutonomous_ @(MatK Int)+    , testIsoMix_ @(MatK Int)     , testCompactClosed_ @(MatK Int)     , testTraced_ @(MatK Int)     , testCopyDiscard_ @(MatK Int)
test/Props/Optic/Hask.hs view
@@ -10,12 +10,11 @@ -- like the optic it came from. module Props.Optic.Hask where -import Control.Monad (unless) import Data.Bifunctor (bimap, first, second) import Data.Maybe (maybeToList) import Data.Tuple (swap) import Data.Type.Nat (Nat2, Nat3)-import Test.Falsify (Property, genWith, testFailed)+import Test.Falsify (Property, genWith) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty) import Prelude@@ -66,7 +65,7 @@ import Proarrow.Promonad.Reader (Reader (..)) import Proarrow.Promonad.Writer (Writer) -import Proarrow.Testing (GenTotal (..), TestableType (..), pattern GenNonEmpty)+import Proarrow.Testing (GenTotal (..), TestableType (..), expect, pattern GenNonEmpty) import Props.Hask ()  -- * The subtyping lattice@@ -293,7 +292,7 @@     assertEq (f a) (g a)  assertEq :: (Show b, Eq b) => b -> b -> Property ()-assertEq l r = unless (l == r) (testFailed (show l ++ " /= " ++ show r))+assertEq got want = expect "wrong value" want got  test :: TestTree test =
test/Props/Paths.hs view
@@ -9,9 +9,7 @@ -- properties check the separate obligation that the data satisfies the equations. module Props.Paths (test) where -import Control.Monad (unless) import Data.Type.Equality ((:~:) (..))-import Test.Falsify (testFailed) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty) import Prelude hiding (id, (.))@@ -28,6 +26,7 @@   , TestableProfunctor   , TestableType (..)   , TestingEqShow (..)+  , check   , genSomeFinite   , oneOfTotal   , optGen@@ -203,22 +202,22 @@   testGroup     "Paths"     [ testProperty "the schema's equations hold in the schema, by construction" $ do-        unless+        check+          "a secretary followed by where they work should be the identity"           (pathLength (emb WorksIn . emb Secr :: Department ~> Department) == 0)-          (testFailed "a secretary followed by where they work should be the identity")-        unless+        check+          "a manager followed by where they work should be just where they work"           (pathLength (emb WorksIn . emb Mngr :: Employee ~> Department) == 1)-          (testFailed "a manager followed by where they work should be just where they work")     , -- Normalisation makes the equations hold of the /schema/ whatever the data says, so this is       -- not implied by the test above: it is the separate, unchecked obligation that the instance       -- satisfies the constraints, and that is the property the approach is sold on.       testProperty "and the instance satisfies them, which is a separate matter" $ do-        unless+        check+          "every department's secretary must work in that department"           (all (\d -> staffStep WorksIn (staffStep Secr d) == d) allDepartments)-          (testFailed "every department's secretary must work in that department")-        unless+        check+          "every employee's manager must work in the same department"           (all (\e -> staffStep WorksIn (staffStep Mngr e) == staffStep WorksIn e) allEmployees)-          (testFailed "every employee's manager must work in the same department")     , testCategory @HR     , testGroup "Staff is a profunctor" [testProfunctor @Staff]     ]
test/Props/PointedHask.hs view
@@ -51,6 +51,7 @@  instance Testable POINTED where   type TestOb a = (Ob a, TestOb (UN P a))+  obFromTestOb r = r   showOb @(P a) = showOb @_ @a   genSome = genSomeDef @'[P Bool, P (Bool, Bool), P (Maybe Bool)]
test/Props/Sheaf/Collage.hs view
@@ -145,6 +145,7 @@  instance Testable (Presheaf (BOOL, BOOL)) where   type TestOb p = Finitary p+  obFromTestOb r = r   showOb @p = show (sizes @p)   genSome = genSomeList "Presheaf (BOOL, BOOL)" [Some @Pair, Some @(TerminalProfunctor :: Presheaf (BOOL, BOOL))] @@ -152,6 +153,7 @@  instance Testable (Presheaf Patches) where   type TestOb p = Finitary p+  obFromTestOb r = r   showOb @p = show (sizes @p)   genSome =     genSomeList "Presheaf Patches" [Some @AtApex, Some @(TerminalProfunctor :: Presheaf Patches)]@@ -166,6 +168,7 @@  instance Testable (Copresheaf (BOOL, BOOL)) where   type TestOb p = Finitary p+  obFromTestOb r = r   showOb @p = show (sizes @p)   genSome =     genSomeList@@ -179,6 +182,7 @@  instance Testable (Copresheaf Patches) where   type TestOb p = Finitary p+  obFromTestOb r = r   showOb @p = show (sizes @p)   genSome =     genSomeList
test/Props/Span.hs view
@@ -35,7 +35,9 @@     , testMonoidal_ @(SPAN FINSET)     , testSymMonoidal_ @(SPAN FINSET)     , testClosed_ @(SPAN FINSET)+    , testDialogue_ @(SPAN FINSET)     , testStarAutonomous_ @(SPAN FINSET)+    , testIsoMix_ @(SPAN FINSET)     , testCompactClosed_ @(SPAN FINSET)     , testCopyDiscard_ @(SPAN FINSET)     , testHypergraph_ @(SPAN FINSET)
test/Props/Svg.hs view
@@ -6,9 +6,8 @@ -- with every option switched. module Props.Svg where -import Control.Monad (forM_, replicateM, when)+import Control.Monad (forM_, replicateM) import Data.List qualified as List-import Test.Falsify (testFailed) import Test.Falsify.Generator (elem) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty)@@ -18,6 +17,7 @@ import Proarrow.Category.Monoidal.Closed (ClosedStructures) import Proarrow.Category.Monoidal.CompactClosed (CompactClosedStructures) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscardStructures)+import Proarrow.Category.Monoidal.Dialogue (DialogueStructures) import Proarrow.Category.Monoidal.Hypergraph (FrobeniusStructures) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomousStructures) import Proarrow.Category.Monoidal.Strength (TracedStructures)@@ -43,6 +43,7 @@   , TestableProfunctor   , TestableType (..)   , TestingEqShow (..)+  , check   , pattern GenNonEmpty   ) import Proarrow.Testing.Laws@@ -61,7 +62,9 @@     , testComonoid_ @(S '[Wire "A", I, Co "B"])     , testHypergraph @SVG (\ @a @b r -> withOb2 @SVG @a @b r)     , testClosed_ @SVG+    , testDialogue_ @SVG     , testStarAutonomous_ @SVG+    , testIsoMix_ @SVG     , testCompactClosed_ @SVG     , testTraced_ @SVG     , testProperty "every law draws as an equation" $ do@@ -75,6 +78,7 @@                   , lawSvgsWith @'[Monoidal] o                   , lawSvgsWith @SymMonoidalStructures o                   , lawSvgsWith @ClosedStructures o+                  , lawSvgsWith @DialogueStructures o                   , lawSvgsWith @StarAutonomousStructures o                   , lawSvgsWith @CompactClosedStructures o                   , lawSvgsWith @'[Monoidal, Supplies Monoid] o@@ -87,10 +91,10 @@                   ]               ]         forM_ structures \drawn -> do-          when (null drawn) (testFailed "a structure drew no laws")+          check "a structure drew no laws" (not (null drawn))           -- reads every character of the drawing, so its layout is computed in full           forM_ drawn \(name, d) ->-            when (count '<' d == 0 || count '<' d /= count '>' d) (testFailed (name ++ " drew malformed markup"))+            check (name ++ " drew malformed markup") (count '<' d > 0 && count '<' d == count '>' d)     ]  -- | A wire of the palette objects are drawn from.
test/Props/ZX.hs view
@@ -31,8 +31,10 @@     , testHypergraph_ @Nat     , testSymMonoidal_ @Nat     , testClosed_ @Nat+    , testIsoMix_ @Nat     , testCompactClosed_ @Nat     , testTraced_ @Nat+    , testDialogue_ @Nat     , testStarAutonomous_ @Nat     , testCopyDiscard_ @Nat     , testCommutativeMonoid_ @0
testing/Proarrow/Testing.hs view
@@ -15,7 +15,7 @@   , TestingEqShow (..)   , TestObIsOb   , TestOb'-  , obFromTestOb+  , testObFromOb      -- * Objecthood witnesses   , WithTestOb@@ -26,6 +26,11 @@   , WithTestObDual   , WithTestObRep   , WithTestObCorep+  , withTestOb2Def+  , withTestObProdDef+  , withTestObCoprodDef+  , withTestObExpDef+  , withTestObDualDef      -- * Objects   , Some (..)@@ -74,6 +79,7 @@   , applyFunP      -- * Assertions+  , check   , expect   , testEq   , eqHask@@ -110,7 +116,7 @@ import Proarrow.Category.Instance.Unit (Unit (..)) import Proarrow.Category.Monoidal qualified as M import Proarrow.Category.Monoidal.Closed qualified as Exponential-import Proarrow.Category.Monoidal.StarAutonomous qualified as SA+import Proarrow.Category.Monoidal.Dialogue qualified as SA import Proarrow.Category.Sheaf (HasFiniteCovers) import Proarrow.Colimit.BinaryCoproduct qualified as BinaryCoproduct import Proarrow.Core (CAT, CategoryOf (..), Hom, Is, OB, Profunctor (..), Promonad (..), UN, type (+->))@@ -118,7 +124,6 @@ import Proarrow.Functor qualified as Rep import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..)) import Proarrow.Limit.BinaryProduct qualified as BinaryProduct-import Proarrow.Object (Ob') import Proarrow.Profunctor.Corepresentable (type (%%)) import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..)) import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)@@ -234,10 +239,14 @@   GenFun f g -> f . applyFunP <$> genWithNamed nm (Just . show) g   GenEmpty _ -> discard --- | Check a measured value against the expected one, showing both. For the assertions a worked--- example makes, which no generic law-checking property covers.+-- | Fail with the message unless the condition holds. For the assertions a worked example makes,+-- which no generic law-checking property covers.+check :: String -> Bool -> Property ()+check msg ok = unless ok (testFailed msg)++-- | Check a measured value against the expected one, showing both. expect :: (Eq a, Show a) => String -> a -> a -> Property ()-expect what want got = unless (got == want) (testFailed (what ++ ", found " ++ show got ++ ", expected " ++ show want))+expect what want got = check (what ++ ", found " ++ show got ++ ", expected " ++ show want) (got == want)  -- | Check that two values are semantically equal, naming both sides so a failure says which law -- broke and what the two sides came out as.@@ -306,7 +315,7 @@   SomeP :: (TestOb a, TestOb b) => p a b -> SomeProfunctorElt p  someP :: forall {k} {j} (p :: k +-> j) a b. (Profunctor p, TestObIsOb j, TestObIsOb k) => p a b -> SomeProfunctorElt p-someP p = SomeP p \\ p+someP p = testObFromOb @a (testObFromOb @b (SomeP p)) \\ p  instance   (forall a b. (TestOb (a :: k), TestOb (b :: j)) => TestingEqShow (p a b), Testable k, Testable j)@@ -328,17 +337,20 @@   genProfunctorElt :: String -> Property (SomeProfunctorElt p)   default genProfunctorElt :: (TestableTypeP p) => String -> Property (SomeProfunctorElt p)   genProfunctorElt nm = do-    Some @a <- genOb-    Some @b <- genObSuchThat \(Some @b') -> isGenNonEmpty @(p a b')+    Some @a <- genOb @k+    Some @b <- genObSuchThat @j \(Some @b') -> isGenNonEmpty @(p a b')     p <- genNamed @(p a b) nm     pure $ SomeP p  -- | A kind whose objects can be enumerated and displayed.-class (forall (a :: k). (TestOb a) => Ob' a, TestableProfunctor (Hom k), TestableTypeP (Hom k), CategoryOf k) => Testable k where+class (TestableProfunctor (Hom k), TestableTypeP (Hom k), CategoryOf k) => Testable k where   type TestOb (a :: k) :: GHC.Constraint   type TestOb a = Ob a   showOb :: forall (a :: k). (TestOb a) => String   genSome :: Gen (Some k)+  obFromTestOb :: forall (a :: k) r. (TestOb a) => ((Ob a) => r) -> r+  default obFromTestOb :: forall (a :: k) r. (TestOb a ~ Ob a, TestOb a) => ((Ob a) => r) -> r+  obFromTestOb r = r    -- | The palette for properties whose cost grows steeply with object size: in practice those   -- that enumerate an internal hom, which is brute force over tables and doubly exponential (an@@ -366,6 +378,7 @@     pure $ SomeP (Op p) instance (Testable k) => Testable (OPPOSITE k) where   type TestOb a = (Is OP a, TestOb (UN OP a))+  obFromTestOb @(OP a) r = obFromTestOb @_ @a r   showOb @(OP a) = "OP (" ++ showOb @k @a ++ ")"   genSome = mapSome OP <$> genSome   genSomeSmall = mapSome OP <$> genSomeSmall@@ -378,6 +391,7 @@  instance (Testable k) => Testable (PROD k) where   type TestOb a = (Is PR a, TestOb (UN PR a))+  obFromTestOb @(PR a) r = obFromTestOb @_ @a r   showOb @(PR a) = "PR (" ++ showOb @k @a ++ ")"   genSome = mapSome PR <$> genSome   genSomeSmall = mapSome PR <$> genSomeSmall@@ -391,36 +405,30 @@   genProfunctorElt nm = do     SomeP p <- genProfunctorElt @p (nm ++ "_0")     SomeP q <- genProfunctorElt @q (nm ++ "_1")-    pure $ SomeP (p :**: q)+    pure (SomeP (p :**: q) \\ p \\ q) instance (Testable j, Testable k) => Testable (j, k) where   type TestOb a = (a ~ '(Fst @ a, Snd @ a), TestOb (Fst @ a), TestOb (Snd @ a))+  obFromTestOb @'(a, b) r = obFromTestOb @_ @a $ obFromTestOb @_ @b r   showOb @'(a, b) = "(" ++ showOb @j @a ++ ", " ++ showOb @k @b ++ ")"   genSome = do     Some @a <- genSome @j     Some @b <- genSome @k-    pure $ Some @'(a, b)+    pure $ obFromTestOb @_ @a $ obFromTestOb @_ @b $ Some @'(a, b)   genSomeSmall = do     Some @a <- genSomeSmall @j     Some @b <- genSomeSmall @k-    pure $ Some @'(a, b)+    pure $ obFromTestOb @_ @a $ obFromTestOb @_ @b $ Some @'(a, b)  class (TestOb a) => TestOb' a instance (TestOb a) => TestOb' a -class (forall (a :: k). (Ob a) => TestOb' a) => TestObIsOb k-instance (forall (a :: k). (Ob a) => TestOb' a) => TestObIsOb k+class (Testable k, forall (a :: k). (Ob a) => TestOb' a) => TestObIsOb k+instance (Testable k, forall (a :: k). (Ob a) => TestOb' a) => TestObIsOb k --- | Recover @'Ob' a@ from @'TestOb' a@ (the 'Testable' superclass entailment), packaged as a--- function so that call sites with other quantified givens in scope (e.g. the comonoid supply of a--- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' category, whose head has @Ob@ as a--- superclass) don't have to rely on GHC expanding superclasses of quantified-constraint heads.--- With such a given in scope, @\\r -> r@ at this type fails with "Could not deduce Ob a", while--- the same lambda compiles without it (cf. 'Proarrow.Testing.Laws.testSymMonoidal_' versus--- 'Proarrow.Testing.Laws.testCopyDiscard_').-obFromTestOb :: forall {k} (a :: k) r. (Testable k, TestOb a) => ((Ob a) => r) -> r--- Seen on GHC 9.10.3, likely a solver limitation. Worth retrying without this helper after a--- GHC upgrade.-obFromTestOb r = r+-- | Recover @'TestOb' a@ from @'Ob' a@ where 'TestObIsOb' provides it: the converse of+-- 'obFromTestOb @_', a function for the same reason.+testObFromOb :: forall {k} (a :: k) r. (TestObIsOb k, Ob a) => ((TestOb a) => r) -> r+testObFromOb r = r  -- * Objecthood witnesses @@ -435,18 +443,33 @@ -- | @'TestOb'@ is closed under the tensor. type WithTestOb2 k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a M.** b)) => r) -> r +withTestOb2Def :: forall {k}. (TestObIsOb k, M.Monoidal k) => WithTestOb2 k+withTestOb2Def @a @b r = obFromTestOb @_ @a $ obFromTestOb @_ @b $ M.withOb2 @_ @a @b r+ -- | @'TestOb'@ is closed under the binary product. type WithTestObProd k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a BinaryProduct.&& b)) => r) -> r +withTestObProdDef :: forall {k}. (TestObIsOb k, BinaryProduct.HasBinaryProducts k) => WithTestObProd k+withTestObProdDef @a @b r = obFromTestOb @_ @a $ obFromTestOb @_ @b $ BinaryProduct.withObProd @_ @a @b r+ -- | @'TestOb'@ is closed under the binary coproduct. type WithTestObCoprod k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a BinaryCoproduct.|| b)) => r) -> r +withTestObCoprodDef :: forall {k}. (TestObIsOb k, BinaryCoproduct.HasBinaryCoproducts k) => WithTestObCoprod k+withTestObCoprodDef @a @b r = obFromTestOb @_ @a $ obFromTestOb @_ @b $ BinaryCoproduct.withObCoprod @_ @a @b r+ -- | @'TestOb'@ is closed under the internal hom. type WithTestObExp k = forall (a :: k) b r. (TestOb a, TestOb b) => ((TestOb (a Exponential.~~> b)) => r) -> r +withTestObExpDef :: forall {k}. (TestObIsOb k, Exponential.Closed k) => WithTestObExp k+withTestObExpDef @a @b r = obFromTestOb @_ @a $ obFromTestOb @_ @b $ Exponential.withObExp @_ @a @b r+ -- | @'TestOb'@ is closed under dualization. type WithTestObDual k = forall (a :: k) r. (TestOb a) => ((TestOb (SA.Dual a)) => r) -> r +withTestObDualDef :: forall {k}. (TestObIsOb k, SA.Dialogue k) => WithTestObDual k+withTestObDualDef @a r = obFromTestOb @_ @a $ SA.withObDual @_ @a r+ -- | @'TestOb'@ is closed under a representable profunctor. type WithTestObRep k p = forall (a :: k) r. (TestOb a) => ((TestOb (p % a)) => r) -> r @@ -627,7 +650,7 @@   )   => TestableType (Tabulated t lm rm a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Tabulated t lm rm)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(Tabulated t lm rm)))  instance   ( Testable j@@ -645,7 +668,7 @@   showP _ = "TerminalProfunctor"  instance (Testable j, Testable k, TestOb (a :: k), TestOb (b :: j)) => TestableType (TerminalProfunctor a b) where-  gen = obFromTestOb @a (obFromTestOb @b (oneElem TerminalProfunctor))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (oneElem TerminalProfunctor))  instance (Testable j, Testable k) => TestableProfunctor (TerminalProfunctor :: j +-> k) @@ -684,7 +707,7 @@   (Testable j, Testable k, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))   => TestableType (Sieve a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Sieve :: j +-> k)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(Sieve :: j +-> k)))  instance (Testable j, Testable k, FiniteCat j, FiniteCat k) => TestableProfunctor (Sieve :: j +-> k) @@ -703,7 +726,7 @@   (Testable j, Testable k, Finitary p, Finitary q, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))   => TestableType ((p :~>: q) a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(p :~>: q)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(p :~>: q)))  instance   (Testable j, Testable k, Finitary p, Finitary q, FiniteCat j, FiniteCat k)@@ -734,7 +757,7 @@   (Testable j, Testable k, Finitary w, Finitary p, FiniteCat i, FiniteCat j, TestOb (a :: k), TestOb (b :: j))   => TestableType (Rift (OP (w :: k +-> i)) p a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Rift (OP w) p)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(Rift (OP w) p)))  instance   (Testable j, Testable k, Finitary w, Finitary p, FiniteCat i, FiniteCat j)@@ -751,7 +774,7 @@   (Testable j, Testable k, Finitary v, Finitary p, FiniteCat i, FiniteCat k, TestOb (a :: k), TestOb (b :: j))   => TestableType (Ran (OP (v :: i +-> j)) p a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Ran (OP v) p)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(Ran (OP v) p)))  instance   (Testable j, Testable k, Finitary v, Finitary p, FiniteCat i, FiniteCat k)@@ -774,7 +797,7 @@   )   => TestableType (ClosedSieve t a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(ClosedSieve t :: j +-> k)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(ClosedSieve t :: j +-> k)))  instance   (Testable j, Testable k, HasFiniteCovers t k, FiniteCat j, FiniteCat k)@@ -793,7 +816,7 @@   (Testable j, Testable k, HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k, TestOb (a :: k), TestOb (b :: j))   => TestableType (Plus t p a b)   where-  gen = obFromTestOb @a (obFromTestOb @b (genElements @(Plus t p :: j +-> k)))+  gen = obFromTestOb @_ @a (obFromTestOb @_ @b (genElements @(Plus t p :: j +-> k)))  instance   (Testable j, Testable k, HasFiniteCovers t k, Finitary p, FiniteCat j, FiniteCat k)
testing/Proarrow/Testing/Laws.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ImpredicativeTypes #-}  {- HLINT ignore "Redundant id" -} @@ -17,12 +18,12 @@ -- every object is a 'TestOb', typically those that leave 'TestOb' at its @'Ob'@ default. module Proarrow.Testing.Laws where -import Control.Monad (unless, when)+import Control.Monad (when) import Data.Default (def) import Data.Foldable (for_) import Data.List (genericLength, sort) import Numeric.Natural (Natural)-import Test.Falsify (Property, testFailed)+import Test.Falsify (Property) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (TestOptions, testProperty) import Prelude hiding (elem, fst, id, snd, (.), (>>))@@ -42,8 +43,10 @@ import Proarrow.Category.Monoidal.Closed qualified as Exponential import Proarrow.Category.Monoidal.CompactClosed qualified as CC import Proarrow.Category.Monoidal.CopyDiscard qualified as CopyDiscard+import Proarrow.Category.Monoidal.Dialogue qualified as SA import Proarrow.Category.Monoidal.Distributive qualified as Distributive import Proarrow.Category.Monoidal.Hypergraph qualified as Hypergraph+import Proarrow.Category.Monoidal.IsoMix qualified as IsoMix import Proarrow.Category.Monoidal.StarAutonomous qualified as SA import Proarrow.Category.Monoidal.Strength qualified as Strength import Proarrow.Category.Sheaf qualified as Sheaf@@ -73,40 +76,15 @@ import Proarrow.Object (pattern Objs) import Proarrow.Optic (ExOptic, Flip, Optic) import Proarrow.Optic.Getter (GetterFl, review, view)-import Proarrow.Profunctor.Corepresentable (Corepresentable, coindex, withObCorep)+import Proarrow.Profunctor.Corepresentable (Corepresentable, coindex, withObCorep, type (%%)) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Ran (Ran (..)) import Proarrow.Profunctor.Instance.Rift (Rift (..)) import Proarrow.Profunctor.Instance.Sieve (Sieve (..)) import Proarrow.Profunctor.Instance.Yoneda (Yo (..))-import Proarrow.Profunctor.Representable (Representable, withObRep)+import Proarrow.Profunctor.Representable (Representable, withObRep, type (%)) import Proarrow.Promonad qualified as Promonad import Proarrow.Testing-  ( Some (..)-  , SomeProfunctorElt (..)-  , TestOb'-  , TestObIsOb-  , Testable (..)-  , TestableProfunctor (..)-  , TestableTypeP-  , TestingEqShow (..)-  , WithTestOb-  , WithTestOb2-  , WithTestObCoprod-  , WithTestObCorep-  , WithTestObDual-  , WithTestObExp-  , WithTestObProd-  , WithTestObRep-  , expect-  , genNamed-  , genOb-  , genObSmall-  , genObSuchThat-  , isGenNonEmpty-  , obFromTestOb-  , testEq-  ) import Proarrow.Testing.Laws.Run   ( CorepresentedBy   , RepresentedBy@@ -124,7 +102,7 @@  -- | Two arrows are mutually inverse: @f . g = id@ and @g . f = id@. propIso :: forall {k} (a :: k) b. (Testable k, TestOb a, TestOb b) => a ~> b -> b ~> a -> Property ()-propIso f g = do+propIso f g = obFromTestOb @_ @a $ obFromTestOb @_ @b $ do   testEq "right inverse" "f . g" (f . g) "id" id   testEq "left inverse" "g . f" (g . f) "id" id @@ -211,14 +189,14 @@ propDecidable = do   Some @a <- genOb @k   Some @b <- genOb @j-  obFromTestOb @a $-    obFromTestOb @b $+  obFromTestOb @_ @a $+    obFromTestOb @_ @b $       case Thin.decide @p @a @b of         Thin.Yes x -> do-          unless (isGenNonEmpty @(p a b)) $ testFailed "decide: TRU, but no element can be generated"+          check "decide: TRU, but no element can be generated" (isGenNonEmpty @(p a b))           y <- genNamed @(p a b) "y"           testEq "decide" "decide" x "y" y-        Thin.No -> when (isGenNonEmpty @(p a b)) $ testFailed "decide: FLS, but an element can be generated"+        Thin.No -> check "decide: FLS, but an element can be generated" (not (isGenNonEmpty @(p a b)))  -- | A transformation @n :: p ':~>' q@ is natural: @n ('dimap' f g p) = 'dimap' f g (n p)@. propNaturalTransformation@@ -259,18 +237,22 @@ propNumbering = do   Some @a <- genOb @k   Some @b <- genOb @j-  let n = Finitary.size @p @a @b-      es = Finitary.elements @p @a @b-  unless (genericLength es == n) $-    testFailed ("size is " ++ show n ++ " but elements has " ++ show (genericLength es :: Natural) ++ " entries")-  unless (map (Finitary.toIndex @p @a @b) es == Finitary.indices n) $-    testFailed ("elements should be numbered in order, found " ++ show (map (Finitary.toIndex @p @a @b) es))-  x <- genNamed @(p a b) "x"-  -- The numbering claims every index is below 'Finitary.size', which a @Fin@-typed index would-  -- have given for free. Without this check an undersized 'Finitary.size' goes unnoticed, since-  -- the other laws only ever look at the elements it admits.-  unless (Finitary.toIndex x < n) $-    testFailed ("toIndex " ++ showP x ++ " is " ++ show (Finitary.toIndex x) ++ ", not below size " ++ show n)+  obFromTestOb @_ @a $ obFromTestOb @_ @b $ do+    let n = Finitary.size @p @a @b+        es = Finitary.elements @p @a @b+    check+      ("size is " ++ show n ++ " but elements has " ++ show (genericLength es :: Natural) ++ " entries")+      (genericLength es == n)+    check+      ("elements should be numbered in order, found " ++ show (map (Finitary.toIndex @p @a @b) es))+      (map (Finitary.toIndex @p @a @b) es == Finitary.indices n)+    x <- genNamed @(p a b) "x"+    -- The numbering claims every index is below 'Finitary.size', which a @Fin@-typed index would+    -- have given for free. Without this check an undersized 'Finitary.size' goes unnoticed, since+    -- the other laws only ever look at the elements it admits.+    check+      ("toIndex " ++ showP x ++ " is " ++ show (Finitary.toIndex x) ++ ", not below size " ++ show n)+      (Finitary.toIndex x < n)  -- * Functors, representability and adjunctions @@ -292,17 +274,18 @@   g <- genNamed @(b ~> c) "g"   withTestObF @a $     withTestObF @c $-      -- 'Functor.withObF' recovers @Ob (f a)@\/@Ob (f c)@ from the functor (GHC will not extract-      -- them from the quantified @Ob' (f a)@ superclass on its own)-      Functor.withObF @f @a $-        Functor.withObF @f @c $ do-          testEq "identity" "map id" (Functor.map @f (obj @a)) "id" (obj @(f a))-          testEq-            "composition"-            "map (g . f)"-            (Functor.map @f (g . f))-            "map g . map f"-            (Functor.map @f g . Functor.map @f f)+      obFromTestOb @_ @a $+        obFromTestOb @_ @c $+          -- 'Functor.withObF' recovers @Ob (f a)@\/@Ob (f c)@ from the functor+          Functor.withObF @f @a $+            Functor.withObF @f @c $ do+              testEq "identity" "map id" (Functor.map @f (obj @a)) "id" (obj @(f a))+              testEq+                "composition"+                "map (g . f)"+                (Functor.map @f (g . f))+                "map g . map f"+                (Functor.map @f g . Functor.map @f f)  -- | The functor laws of @f@ ('propFunctor') as a ready-made test. testFunctor@@ -354,7 +337,7 @@  testMonStrong_   :: forall {k} (p :: k +-> k). (Strength.Strong M.Tensor p, M.Monoidal k, TestableProfunctor p, TestObIsOb k) => TestTree-testMonStrong_ = testMonStrong @p (\ @a @b r -> M.withOb2 @k @a @b r)+testMonStrong_ = testMonStrong @p (\ @a @b -> withTestOb2Def @a @b)  -- | The laws of costrength of @p@ for the tensor acting on its own category, stated as code -- ('Laws.ProLaws' @('Strength.Costrong' 'M.Tensor')@). The witness says how 'TestOb' is closed@@ -378,7 +361,7 @@  testMonCostrong_   :: forall {k} (p :: k +-> k). (Strength.Costrong M.Tensor p, M.Monoidal k, TestableProfunctor p, TestObIsOb k) => TestTree-testMonCostrong_ = testMonCostrong @p (\ @a @b r -> M.withOb2 @k @a @b r)+testMonCostrong_ = testMonCostrong @p (\ @a @b -> withTestOb2Def @a @b)  -- | The 'Representable' laws of @p@ stated as code ('Laws.ProLaws' 'Representable'): 'index' and -- 'tabulate' are inverse and natural. The witness lifts 'TestOb' along @p '%' -@.@@ -396,7 +379,7 @@     (CategoryW :& RepresentedW (CategoryW :& WNil) (\ @b r -> withTestObRep @b r) :& WNil)  testRepresentable_ :: forall {j} {k} (p :: j +-> k). (Representable p, TestableProfunctor p, TestObIsOb k) => TestTree-testRepresentable_ = testRepresentable @p (\ @b r -> withObRep @p @b r)+testRepresentable_ = testRepresentable @p (\ @b r -> obFromTestOb @_ @b (withObRep @p @b r))  -- | The 'Corepresentable' laws of @p@ stated as code ('Laws.ProLaws' 'Corepresentable'): 'coindex' -- and 'cotabulate' are inverse and natural. The witness lifts 'TestOb' along @p '%%' -@.@@ -417,7 +400,7 @@   :: forall {j} {k} (p :: j +-> k)    . (Corepresentable p, TestableProfunctor p, TestObIsOb j)   => TestTree-testCorepresentable_ = testCorepresentable @p (\ @a r -> withObCorep @p @a r)+testCorepresentable_ = testCorepresentable @p (\ @a r -> obFromTestOb @_ @a (withObCorep @p @a r))  -- | The 'Promonad' laws of @p@ stated as code: 'id' is a unit for composition, which is -- associative, and both are natural.@@ -469,7 +452,10 @@   :: forall {j} {k} (p :: j +-> k)    . (Adjunction p, TestableProfunctor p, TestObIsOb j, TestObIsOb k)   => TestTree-testAdjunction_ = testAdjunction @p (\ @a r -> withObCorep @p @a r) (\ @b r -> withObRep @p @b r)+testAdjunction_ =+  testAdjunction @p+    (\ @a r -> obFromTestOb @_ @a (withObCorep @p @a (testObFromOb @(p %% a) r)))+    (\ @b r -> obFromTestOb @_ @b (withObRep @p @b (testObFromOb @(p % b) r)))  -- * Limits and colimits @@ -495,7 +481,7 @@   testLaws @'[BinaryProduct.HasBinaryProducts] "Binary products" (ProductsW (\ @a @b r -> withTestObProd @a @b r) :& WNil)  testBinaryProducts_ :: forall k. (Testable k, BinaryProduct.HasBinaryProducts k, TestObIsOb k) => TestTree-testBinaryProducts_ = testBinaryProducts @k (\ @a @b r -> BinaryProduct.withObProd @k @a @b r)+testBinaryProducts_ = testBinaryProducts @k (\ @a @b -> withTestObProdDef @a @b)  -- | The universal property of the binary coproduct, dual to 'testBinaryProducts', from -- @'Proarrow.Tools.Laws.Laws' '['BinaryCoproduct.HasBinaryCoproducts']@.@@ -506,7 +492,7 @@     (CoproductsW (\ @a @b r -> withTestObCoprod @a @b r) :& WNil)  testBinaryCoproducts_ :: forall k. (Testable k, BinaryCoproduct.HasBinaryCoproducts k, TestObIsOb k) => TestTree-testBinaryCoproducts_ = testBinaryCoproducts @k (\ @a @b r -> BinaryCoproduct.withObCoprod @k @a @b r)+testBinaryCoproducts_ = testBinaryCoproducts @k (\ @a @b -> withTestObCoprodDef @a @b)  -- | Check that composing with an arrow /reflects/ equality: the composites agree exactly when the -- two arrows already did. @eqComposed@ is the caller\'s comparison of the composites (a@@ -518,9 +504,9 @@ propReflectsEq :: (TestingEqShow x) => String -> String -> Bool -> x -> x -> Property () propReflectsEq label desc eqComposed k1 k2 = do   eqDirect <- eqP k1 k2-  unless (eqComposed == eqDirect) $-    testFailed $-      "Failed " ++ label ++ ": (" ++ desc ++ ") = " ++ show eqComposed ++ " but (k1 == k2) = " ++ show eqDirect+  check+    ("Failed " ++ label ++ ": (" ++ desc ++ ") = " ++ show eqComposed ++ " but (k1 == k2) = " ++ show eqDirect)+    (eqComposed == eqDirect)  -- | Checks the equalizer laws: the equalizer arrow @e@ equalizes @f@ and @g@; any @h@ that factors -- through @e@ (generated as @e . p@) is recovered by 'Equalizer.factorEqualizer'; and @e@ is mono.@@ -697,7 +683,7 @@ testMonoidal withTestOb2 = testLaws @'[M.Monoidal] "Monoidal" (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& WNil)  testMonoidal_ :: forall k. (Testable k, M.Monoidal k, TestObIsOb k) => TestTree-testMonoidal_ = testMonoidal @k (\ @a @b r -> M.withOb2 @k @a @b r)+testMonoidal_ = testMonoidal @k (\ @a @b -> withTestOb2Def @a @b)  -- | The laws of a symmetric monoidal category, from -- @'Proarrow.Tools.Laws.Laws' 'M.SymMonoidalStructures'@: 'M.swap' is a natural@@ -709,7 +695,7 @@     (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& SymMonoidalW :& WNil)  testSymMonoidal_ :: forall k. (Testable k, M.SymMonoidal k, TestObIsOb k) => TestTree-testSymMonoidal_ = testSymMonoidal @k (\ @a @b r -> M.withOb2 @k @a @b r)+testSymMonoidal_ = testSymMonoidal @k (\ @a @b -> withTestOb2Def @a @b)  -- | The laws of a copy-discard category: every object is a cocommutative comonoid (the laws of its -- supply, in "Proarrow.Monoid"), and 'CopyDiscard.copy' and 'CopyDiscard.discard' are that comonoid@@ -719,8 +705,10 @@ testCopyDiscard withTestOb2 =   testGroup     "CopyDiscard"-    [ testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Comonoid] "Comonoids" (monoidal :& ComonoidSupplyW :& WNil)-    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CocommutativeComonoid]+    [ testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Comonoid] @k+        "Comonoids"+        (monoidal :& ComonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CocommutativeComonoid] @k         "Cocommutative comonoids"         (monoidal :& SymMonoidalW :& CocommutativeComonoidSupplyW :& WNil)     , testLaws @CopyDiscard.CopyDiscardStructures "Copy and discard" (monoidal :& SymMonoidalW :& CopyDiscardW :& WNil)@@ -728,10 +716,9 @@   where     monoidal = MonoidalW (\ @a @b r -> withTestOb2 @a @b r) --- | 'testCopyDiscard' where 'TestOb' is 'Ob'. 'Ob' goes through 'obFromTestOb', because with the--- comonoid supply in scope GHC does not find the @TestOb a => Ob' a => Ob a@ route on its own.+-- | 'testCopyDiscard' where 'TestOb' is 'Ob'. testCopyDiscard_ :: forall k. (Testable k, CopyDiscard.CopyDiscard k, TestObIsOb k) => TestTree-testCopyDiscard_ = testCopyDiscard @k (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (M.withOb2 @k @a @b r)))+testCopyDiscard_ = testCopyDiscard @k (\ @a @b -> withTestOb2Def @a @b)  -- | The coherence law tying 'Cartesian.Cartesian' to its 'CopyDiscard.CopyDiscard' superclass -- (Fox's theorem): the comonoid supplied on every object is the natural one, @copy = id &&& id@@@ -765,7 +752,7 @@  testCartesian_ :: forall k. (Testable k, Cartesian.Cartesian k, TestObIsOb k, TestOb (M.Unit @k)) => TestTree testCartesian_ =-  testCartesian @k (\ @a r -> obFromTestOb @a r) (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (M.withOb2 @k @a @b r)))+  testCartesian @k (\ @a r -> obFromTestOb @_ @a r) (\ @a @b -> withTestOb2Def @a @b)  -- | The tensor distributes over coproducts and is absorbed by the initial object, from -- @'Proarrow.Tools.Laws.Laws' 'Distributive.DistributiveStructures'@: 'Distributive.distL',@@ -790,8 +777,8 @@ testDistributive_ :: forall k. (Testable k, Distributive.Distributive k, TestObIsOb k) => TestTree testDistributive_ =   testDistributive @k-    (\ @a @b r -> M.withOb2 @k @a @b r)-    (\ @a @b r -> BinaryCoproduct.withObCoprod @k @a @b r)+    (\ @a @b -> withTestOb2Def @a @b)+    (\ @a @b -> withTestObCoprodDef @a @b)  -- | The laws of a closed monoidal category, from -- @'Proarrow.Tools.Laws.Laws' 'Exponential.ClosedStructures'@: 'Exponential.apply' undoes@@ -813,16 +800,36 @@ testClosed_ :: forall k. (Testable k, Exponential.Closed k, TestObIsOb k) => TestTree testClosed_ =   testClosed @k-    (\ @a @b r -> M.withOb2 @k @a @b r)-    (\ @a @b r -> Exponential.withObExp @k @a @b r)+    (\ @a @b -> withTestOb2Def @a @b)+    (\ @a @b -> withTestObExpDef @a @b) +-- | Laws of a dialogue category, from @'Proarrow.Tools.Laws.Laws' 'SA.DialogueStructures'@:+-- 'SA.dual' is a contravariant functor, 'SA.linDist' is a natural bijection+-- @Hom(a ** b, Dual c) ≅ Hom(a, Dual (b ** c))@ with inverse 'SA.linDistInv', and+-- 'SA.doubleNegInv' is the one they give.+testDialogue+  :: forall k+   . (Testable k, SA.Dialogue k, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> WithTestObDual k+  -> TestTree+testDialogue withTestOb2 withTestObDual =+  testLaws @SA.DialogueStructures+    "Dialogue"+    ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)+        :& SymMonoidalW+        :& DialogueW (\ @a r -> withTestObDual @a r)+        :& WNil+    )++testDialogue_ :: forall k. (Testable k, SA.Dialogue k, TestObIsOb k) => TestTree+testDialogue_ = testDialogue @k (\ @a @b -> withTestOb2Def @a @b) (\ @a -> withTestObDualDef @a)+ -- | Laws of a *-autonomous category, from--- @'Proarrow.Tools.Laws.Laws' 'SA.StarAutonomousStructures'@:--- 'SA.dual' is a contravariant functor, bijective on hom-sets with inverse 'SA.dualInv';--- 'SA.doubleNeg' is an isomorphism; and 'SA.linDist' is a natural bijection--- @Hom(a ** b, Dual c) ≅ Hom(a, Dual (b ** c))@ with inverse 'SA.linDistInv'. The exponential--- witness is needed because 'Exponential.Closed' is a superclass, although no law builds an--- exponential.+-- @'Proarrow.Tools.Laws.Laws' 'SA.StarAutonomousStructures'@: 'SA.dual' is bijective on hom-sets+-- with inverse 'SA.dualInv', and 'SA.doubleNeg' is an isomorphism. The rest is 'testDialogue'.+-- The exponential witness is needed because 'Exponential.Closed' is a superclass, although no+-- law builds an exponential. testStarAutonomous   :: forall k    . (Testable k, SA.StarAutonomous k, TestOb (M.Unit @k))@@ -836,20 +843,43 @@     ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)         :& SymMonoidalW         :& ClosedW (\ @a @b r -> withTestObExp @a @b r)-        :& StarAutonomousW (\ @a r -> withTestObDual @a r)+        :& DialogueW (\ @a r -> withTestObDual @a r)+        :& StarAutonomousW         :& WNil     )  testStarAutonomous_ :: forall k. (Testable k, SA.StarAutonomous k, TestObIsOb k) => TestTree testStarAutonomous_ =   testStarAutonomous @k-    (\ @a @b r -> M.withOb2 @k @a @b r)-    (\ @a @b r -> Exponential.withObExp @k @a @b r)-    (\ @a r -> r \\ SA.dualObj @a)+    (\ @a @b -> withTestOb2Def @a @b)+    (\ @a @b -> withTestObExpDef @a @b)+    (\ @a -> withTestObDualDef @a) +-- | Laws of an isomix category, from @'Proarrow.Tools.Laws.Laws' 'IsoMix.IsoMixStructures'@:+-- 'IsoMix.dualUnit' and 'IsoMix.dualUnitInv' are inverses, and 'IsoMix.dualityCounit' is the+-- one the dialogue structure gives.+testIsoMix+  :: forall k+   . (Testable k, IsoMix.IsoMix k, TestOb (M.Unit @k))+  => WithTestOb2 k+  -> WithTestObDual k+  -> TestTree+testIsoMix withTestOb2 withTestObDual =+  testLaws @IsoMix.IsoMixStructures+    "Isomix"+    ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)+        :& SymMonoidalW+        :& DialogueW (\ @a r -> withTestObDual @a r)+        :& IsoMixW+        :& WNil+    )++testIsoMix_ :: forall k. (Testable k, IsoMix.IsoMix k, TestObIsOb k) => TestTree+testIsoMix_ = testIsoMix @k (\ @a @b -> withTestOb2Def @a @b) (\ @a -> withTestObDualDef @a)+ -- | Laws of a compact closed category, from -- @'Proarrow.Tools.Laws.Laws' 'CC.CompactClosedStructures'@:--- 'CC.distribDual' and 'CC.dualUnit' are isomorphisms (so 'SA.Dual' is strong monoidal), and+-- 'CC.distribDual' and 'IsoMix.dualUnit' are isomorphisms (so 'SA.Dual' is strong monoidal), and -- 'CC.dualityUnit' and 'CC.dualityCounit' satisfy the zigzag identities. See -- 'testStarAutonomous' for the exponential witness. testCompactClosed@@ -865,7 +895,9 @@     ( MonoidalW (\ @a @b r -> withTestOb2 @a @b r)         :& SymMonoidalW         :& ClosedW (\ @a @b r -> withTestObExp @a @b r)-        :& StarAutonomousW (\ @a r -> withTestObDual @a r)+        :& DialogueW (\ @a r -> withTestObDual @a r)+        :& StarAutonomousW+        :& IsoMixW         :& CompactClosedW         :& WNil     )@@ -873,9 +905,9 @@ testCompactClosed_ :: forall k. (Testable k, CC.CompactClosed k, TestObIsOb k) => TestTree testCompactClosed_ =   testCompactClosed @k-    (\ @a @b r -> M.withOb2 @k @a @b r)-    (\ @a @b r -> Exponential.withObExp @k @a @b r)-    (\ @a r -> r \\ SA.dualObj @a)+    (\ @a @b -> withTestOb2Def @a @b)+    (\ @a @b -> withTestObExpDef @a @b)+    (\ @a -> withTestObDualDef @a)  -- | The laws of a category that supplies special commutative Frobenius algebras, stated for -- every object: the monoid and comonoid laws of its points, their commutativity, and the Frobenius laws of@@ -893,15 +925,19 @@ testHypergraph withTestOb2 =   testGroup     "Hypergraph (Frobenius supply)"-    [ testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Monoid] "Monoids" (monoidal :& MonoidSupplyW :& WNil)-    , testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Comonoid] "Comonoids" (monoidal :& ComonoidSupplyW :& WNil)-    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CommutativeMonoid]+    [ testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Monoid] @k+        "Monoids"+        (monoidal :& MonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, Monoid.Supplies Monoid.Comonoid] @k+        "Comonoids"+        (monoidal :& ComonoidSupplyW :& WNil)+    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CommutativeMonoid] @k         "Commutative monoids"         (monoidal :& SymMonoidalW :& CommutativeMonoidSupplyW :& WNil)-    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CocommutativeComonoid]+    , testLaws @'[M.Monoidal, M.SymMonoidal, Monoid.Supplies Monoid.CocommutativeComonoid] @k         "Cocommutative comonoids"         (monoidal :& SymMonoidalW :& CocommutativeComonoidSupplyW :& WNil)-    , testLaws @Hypergraph.FrobeniusStructures+    , testLaws @Hypergraph.FrobeniusStructures @k         "Frobenius"         (monoidal :& SymMonoidalW :& MonoidSupplyW :& ComonoidSupplyW :& WNil)     ]@@ -917,7 +953,7 @@      , Monoid.Supplies Monoid.CocommutativeComonoid k      )   => TestTree-testHypergraph_ = testHypergraph @k (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (M.withOb2 @k @a @b r)))+testHypergraph_ = testHypergraph @k (\ @a @b -> withTestOb2Def @a @b)  -- * Traced monoidal categories @@ -933,7 +969,7 @@     (MonoidalW (\ @a @b r -> withTestOb2 @a @b r) :& SymMonoidalW :& TracedW :& WNil)  testTraced_ :: forall k. (Testable k, Strength.TracedMonoidal k, TestObIsOb k) => TestTree-testTraced_ = testTraced @k (\ @a @b r -> M.withOb2 @k @a @b r)+testTraced_ = testTraced @k (\ @a @b -> withTestOb2Def @a @b)  -- * Monoids and comonoids @@ -1043,7 +1079,7 @@ testMonoid f = testProperty ("Monoid " ++ showOb @k @m) (propMonoid @m \ @a @b -> f @a @b)  testMonoid_ :: forall {k} m. (Testable k, Monoid.Monoid (m :: k), TestObIsOb k) => TestTree-testMonoid_ = testMonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)+testMonoid_ = testMonoid @m (\ @a @b -> withTestOb2Def @a @b)  -- | The comonoid laws of @m@, as the monoid laws of @m@ in the opposite category. testComonoid@@ -1054,7 +1090,7 @@ testComonoid f = testProperty ("Comonoid " ++ showOb @k @m) (propMonoid @(OP m) \ @(OP a) @(OP b) r -> f @a @b r)  testComonoid_ :: forall {k} m. (Testable k, Monoid.Comonoid (m :: k), TestObIsOb k) => TestTree-testComonoid_ = testComonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)+testComonoid_ = testComonoid @m (\ @a @b -> withTestOb2Def @a @b)  -- | The laws of a commutative monoid ('propCommutativeMonoid') as a ready-made test. testCommutativeMonoid@@ -1065,7 +1101,7 @@ testCommutativeMonoid f = testProperty ("CommutativeMonoid " ++ showOb @k @m) (propCommutativeMonoid @m \ @a @b -> f @a @b)  testCommutativeMonoid_ :: forall {k} m. (Testable k, Monoid.CommutativeMonoid (m :: k), TestObIsOb k) => TestTree-testCommutativeMonoid_ = testCommutativeMonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)+testCommutativeMonoid_ = testCommutativeMonoid @m (\ @a @b -> withTestOb2Def @a @b)  -- | The laws of a cocommutative comonoid ('propCocommutativeComonoid') as a ready-made test. testCocommutativeComonoid@@ -1079,7 +1115,7 @@   :: forall {k} m    . (Testable k, Monoid.CocommutativeComonoid (m :: k), TestObIsOb k)   => TestTree-testCocommutativeComonoid_ = testCocommutativeComonoid @m (\ @a @b r -> M.withOb2 @k @a @b r)+testCocommutativeComonoid_ = testCocommutativeComonoid @m (\ @a @b -> withTestOb2Def @a @b)  -- | The laws of a special commutative Frobenius algebra ('propFrobenius') as a ready-made test. testFrobenius@@ -1102,7 +1138,7 @@      , TestObIsOb k      )   => TestTree-testFrobenius_ = testFrobenius @m (\ @a @b r -> M.withOb2 @k @a @b r)+testFrobenius_ = testFrobenius @m (\ @a @b -> withTestOb2Def @a @b)  -- * Toposes @@ -1138,7 +1174,7 @@   Some @b <- genOb @k   Some @z <- genOb @k   f <- genNamed @(a ~> b) "f"-  x <- genNamed @(z ~> a) "x"+  x@Objs <- genNamed @(z ~> a) "x"   y <- genNamed @(z ~> b) "y"   inGraph <- eqP (f . x) y   classified <-@@ -1183,7 +1219,7 @@      )   => TestTree testSubobjectClassifier_ =-  testSubobjectClassifier @k (\ @a @b r -> BinaryProduct.withObProd @k @a @b r)+  testSubobjectClassifier @k (\ @a @b -> withTestObProdDef @a @b)  -- | Negation is implication into false: -- @'Topos.not' = 'Topos.implies' . (id '&&&' 'Terminal.const' 'Topos.false')@. A theorem of@@ -1262,7 +1298,7 @@   => (Topos.Omega :: k) ~> Topos.Omega   -> TestTree testLawvereTierney_ =-  testLawvereTierney @k (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (BinaryProduct.withObProd @k @a @b r)))+  testLawvereTierney @k (\ @a @b -> withTestObProdDef @a @b)  testLawvereTierneyFamily_   :: forall k@@ -1276,7 +1312,7 @@   -> ((Terminal.TerminalObject :: k) ~> Topos.Omega -> (Topos.Omega :: k) ~> Topos.Omega)   -> TestTree testLawvereTierneyFamily_ name =-  testLawvereTierneyFamily @k name (\ @a @b r -> obFromTestOb @a (obFromTestOb @b (BinaryProduct.withObProd @k @a @b r)))+  testLawvereTierneyFamily @k name (\ @a @b -> withTestObProdDef @a @b)  -- * Sites and sheaves @@ -1510,11 +1546,11 @@    . (Sheaf.HasFiniteCovers t k, Sheaf.Sheaf t p, TestableProfunctor p, TestableTypeP p, TestObIsOb k)   => TestTree testGluesBack = testProperty "glues back" do-  Some @a <- genObSuchThat @k \(Some @a) -> not (null (Sheaf.covers @t @k @a))+  Some @a <- genObSuchThat @k \(Some @a) -> obFromTestOb @_ @a (not (null (Sheaf.covers @t @k @a)))   Some @b <- genOb @j   x <- genNamed @(p a b) "x"-  obFromTestOb @a $-    obFromTestOb @b $+  obFromTestOb @_ @a $+    obFromTestOb @_ @b $       for_ (Sheaf.covers @t @k @a) \(Sheaf.SomeCover c) -> propGluesBack @t c x  -- | 'propGluesBack' at one named cover, for a site whose covers cannot be listed. The label names@@ -1528,7 +1564,7 @@ testGluesBackAt lbl c = testProperty ("glues back at " ++ lbl) do   Some @b <- genOb @j   x <- genNamed @(p a b) "x"-  obFromTestOb @a $ obFromTestOb @b $ propGluesBack @t c x+  obFromTestOb @_ @a $ obFromTestOb @_ @b $ propGluesBack @t c x  -- | An equalizer of sheaves is a sheaf, for every coverage: the 'Sheaf.Sheaf' instance for -- 'FinTopos.Reindex' presupposes that the table cuts out a /subsheaf/, and this decides it, by
testing/Proarrow/Testing/Laws/Run.hs view
@@ -78,7 +78,9 @@ import Proarrow.Category.Monoidal.Closed qualified as Exponential import Proarrow.Category.Monoidal.CompactClosed qualified as CC import Proarrow.Category.Monoidal.CopyDiscard qualified as CopyDiscard+import Proarrow.Category.Monoidal.Dialogue qualified as SA import Proarrow.Category.Monoidal.Distributive qualified as Distributive+import Proarrow.Category.Monoidal.IsoMix qualified as IsoMix import Proarrow.Category.Monoidal.StarAutonomous qualified as SA import Proarrow.Category.Monoidal.Strength qualified as Strength import Proarrow.Colimit.BinaryCoproduct qualified as BinaryCoproduct@@ -110,6 +112,7 @@   , isGenNonEmpty   , obFromTestOb   , testEq+  , testObFromOb   ) import Proarrow.Tools.Laws qualified as Laws @@ -234,7 +237,9 @@ data instance Witness Initial.HasInitialObject k = InitialW data instance Witness Distributive.Distributive k = DistributiveW newtype instance Witness Exponential.Closed k = ClosedW (WithTestObExp k)-newtype instance Witness SA.StarAutonomous k = StarAutonomousW (WithTestObDual k)+newtype instance Witness SA.Dialogue k = DialogueW (WithTestObDual k)+data instance Witness SA.StarAutonomous k = StarAutonomousW+data instance Witness IsoMix.IsoMix k = IsoMixW data instance Witness CC.CompactClosed k = CompactClosedW data instance Witness Strength.TracedMonoidal k = TracedW data instance Witness CopyDiscard.CopyDiscard k = CopyDiscardW@@ -280,7 +285,7 @@  instance (Testable k, TestOb (a :: k)) => Tested (TLeaf a :: TESTED cs k) where   type Untest (TLeaf a) = a-  untestOb r = obFromTestOb @a r+  untestOb r = obFromTestOb @_ @a r   untestTestOb _ r = r instance (Testable k, M.Monoidal k, TestOb (M.Unit :: k)) => Tested (M.UnitF :: TESTED cs k) where   type Untest M.UnitF = M.Unit@@ -333,10 +338,10 @@   untestTestOb ws r =     untestTestOb2 @a @b ws (case witness @Exponential.Closed ws of ClosedW f -> f @(Untest a) @(Untest b) r) -instance (HasWitness SA.StarAutonomous cs, SA.StarAutonomous k, Tested (a :: TESTED cs k)) => Tested (SA.DualF a) where+instance (HasWitness SA.Dialogue cs, SA.Dialogue k, Tested (a :: TESTED cs k)) => Tested (SA.DualF a) where   type Untest (SA.DualF a) = SA.Dual (Untest a)   untestOb r = untestOb @a (SA.withObDual @k @(Untest a) r)-  untestTestOb ws r = untestTestOb @a ws (case witness @SA.StarAutonomous ws of StarAutonomousW f -> f @(Untest a) r)+  untestTestOb ws r = untestTestOb @a ws (case witness @SA.Dialogue ws of DialogueW f -> f @(Untest a) r)  -- | 'untestOb' of two objects at once. untestOb2 :: forall {cs} {k} (a :: TESTED cs k) b r. (Tested a, Tested b) => ((Ob (Untest a), Ob (Untest b)) => r) -> r@@ -483,39 +488,60 @@  instance   ( HasWitness M.Monoidal cs-  , HasWitness Exponential.Closed cs-  , HasWitness SA.StarAutonomous cs+  , HasWitness SA.Dialogue cs   , Testable k-  , SA.StarAutonomous k+  , SA.Dialogue k   , TestOb (M.Unit :: k)   )-  => SA.StarAutonomous (TESTED cs k)+  => SA.Dialogue (TESTED cs k)   where   type Dual a = SA.DualF a   withObDual r = r   dual (TestedArr df f) = TestedArr (app "dual" df) (SA.dual f)-  dualInv @a @b (TestedArr df f) = untestOb2 @a @b (TestedArr (app "dualInv" df) (SA.dualInv @k @(Untest a) @(Untest b) f))   linDist @a @b @c (TestedArr df f) =     untestOb3 @a @b @c (TestedArr (app "linDist" df) (SA.linDist @k @(Untest a) @(Untest b) @(Untest c) f))   linDistInv @a @b @c (TestedArr df f) =     untestOb3 @a @b @c (TestedArr (app "linDistInv" df) (SA.linDistInv @k @(Untest a) @(Untest b) @(Untest c) f))-  doubleNeg @a = untestOb @a (prim "doubleNeg" (SA.doubleNeg @k @(Untest a)))   doubleNegInv @a = untestOb @a (prim "doubleNegInv" (SA.doubleNegInv @k @(Untest a)))  instance   ( HasWitness M.Monoidal cs   , HasWitness Exponential.Closed cs-  , HasWitness SA.StarAutonomous cs+  , HasWitness SA.Dialogue cs   , Testable k+  , SA.StarAutonomous k+  , TestOb (M.Unit :: k)+  )+  => SA.StarAutonomous (TESTED cs k)+  where+  dualInv @a @b (TestedArr df f) = untestOb2 @a @b (TestedArr (app "dualInv" df) (SA.dualInv @k @(Untest a) @(Untest b) f))+  doubleNeg @a = untestOb @a (prim "doubleNeg" (SA.doubleNeg @k @(Untest a)))++instance+  ( HasWitness M.Monoidal cs+  , HasWitness SA.Dialogue cs+  , Testable k+  , IsoMix.IsoMix k+  , TestOb (M.Unit :: k)+  )+  => IsoMix.IsoMix (TESTED cs k)+  where+  dualUnit = prim "dualUnit" IsoMix.dualUnit+  dualUnitInv = prim "dualUnitInv" IsoMix.dualUnitInv+  dualityCounit @a = untestOb @a (prim "dualityCounit" (IsoMix.dualityCounit @k @(Untest a)))++instance+  ( HasWitness M.Monoidal cs+  , HasWitness Exponential.Closed cs+  , HasWitness SA.Dialogue cs+  , Testable k   , CC.CompactClosed k   , TestOb (M.Unit :: k)   )   => CC.CompactClosed (TESTED cs k)   where   distribDual @a @b = untestOb2 @a @b (prim "distribDual" (CC.distribDual @k @(Untest a) @(Untest b)))-  dualUnit = prim "dualUnit" CC.dualUnit   dualityUnit @a = untestOb @a (prim "dualityUnit" (CC.dualityUnit @k @(Untest a)))-  dualityCounit @a = untestOb @a (prim "dualityCounit" (CC.dualityCounit @k @(Untest a)))  -- | Every object is a monoid when the category supplies them, with the monoid of the object it -- stands for.@@ -680,7 +706,7 @@   => Adj.Proadjunction (TestedP p :: TESTED csj j +-> TESTED csk k) (TestedP q :: TESTED csk k +-> TESTED csj j)   where   unit @a = untestOb @a case Adj.unit @p @q @(Untest a) of-    (:.:) @m l r -> (:.:) @(TLeaf m :: TESTED csk k) (TestedP (atom "unitQ") l) (TestedP (atom "unitP") r) \\ l+    (:.:) @m l r -> testObFromOb @m ((:.:) @(TLeaf m :: TESTED csk k) (TestedP (atom "unitQ") l) (TestedP (atom "unitP") r)) \\ l   counit (TestedP dp x :.: TestedP dq y) = TestedArr (app "counit" (infixlDoc 9 " :.: " dp dq)) (Adj.counit (x :.: y))  -- | The procomonad the objects stand for. The middle object of 'Promonad.produplicate' is only