diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
--- a/README.md
+++ b/README.md
@@ -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
 
diff --git a/proarrow.cabal b/proarrow.cabal
--- a/proarrow.cabal
+++ b/proarrow.cabal
@@ -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
diff --git a/src/Proarrow/Category/Instance/Bool.hs b/src/Proarrow/Category/Instance/Bool.hs
--- a/src/Proarrow/Category/Instance/Bool.hs
+++ b/src/Proarrow/Category/Instance/Bool.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/Cospan.hs b/src/Proarrow/Category/Instance/Cospan.hs
--- a/src/Proarrow/Category/Instance/Cospan.hs
+++ b/src/Proarrow/Category/Instance/Cospan.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/Cps.hs b/src/Proarrow/Category/Instance/Cps.hs
new file mode 100644
--- /dev/null
+++ b/src/Proarrow/Category/Instance/Cps.hs
@@ -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)
diff --git a/src/Proarrow/Category/Instance/FinRel.hs b/src/Proarrow/Category/Instance/FinRel.hs
--- a/src/Proarrow/Category/Instance/FinRel.hs
+++ b/src/Proarrow/Category/Instance/FinRel.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/IntConstruction.hs b/src/Proarrow/Category/Instance/IntConstruction.hs
--- a/src/Proarrow/Category/Instance/IntConstruction.hs
+++ b/src/Proarrow/Category/Instance/IntConstruction.hs
@@ -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))
diff --git a/src/Proarrow/Category/Instance/Linear.hs b/src/Proarrow/Category/Instance/Linear.hs
--- a/src/Proarrow/Category/Instance/Linear.hs
+++ b/src/Proarrow/Category/Instance/Linear.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/Mat.hs b/src/Proarrow/Category/Instance/Mat.hs
--- a/src/Proarrow/Category/Instance/Mat.hs
+++ b/src/Proarrow/Category/Instance/Mat.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/Monoid.hs b/src/Proarrow/Category/Instance/Monoid.hs
--- a/src/Proarrow/Category/Instance/Monoid.hs
+++ b/src/Proarrow/Category/Instance/Monoid.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/Product.hs b/src/Proarrow/Category/Instance/Product.hs
--- a/src/Proarrow/Category/Instance/Product.hs
+++ b/src/Proarrow/Category/Instance/Product.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/Span.hs b/src/Proarrow/Category/Instance/Span.hs
--- a/src/Proarrow/Category/Instance/Span.hs
+++ b/src/Proarrow/Category/Instance/Span.hs
@@ -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
diff --git a/src/Proarrow/Category/Instance/ZX.hs b/src/Proarrow/Category/Instance/ZX.hs
--- a/src/Proarrow/Category/Instance/ZX.hs
+++ b/src/Proarrow/Category/Instance/ZX.hs
@@ -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
diff --git a/src/Proarrow/Category/Monoidal.hs b/src/Proarrow/Category/Monoidal.hs
--- a/src/Proarrow/Category/Monoidal.hs
+++ b/src/Proarrow/Category/Monoidal.hs
@@ -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
diff --git a/src/Proarrow/Category/Monoidal/Applicative.hs b/src/Proarrow/Category/Monoidal/Applicative.hs
--- a/src/Proarrow/Category/Monoidal/Applicative.hs
+++ b/src/Proarrow/Category/Monoidal/Applicative.hs
@@ -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
diff --git a/src/Proarrow/Category/Monoidal/Closed.hs b/src/Proarrow/Category/Monoidal/Closed.hs
--- a/src/Proarrow/Category/Monoidal/Closed.hs
+++ b/src/Proarrow/Category/Monoidal/Closed.hs
@@ -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)
diff --git a/src/Proarrow/Category/Monoidal/CompactClosed.hs b/src/Proarrow/Category/Monoidal/CompactClosed.hs
--- a/src/Proarrow/Category/Monoidal/CompactClosed.hs
+++ b/src/Proarrow/Category/Monoidal/CompactClosed.hs
@@ -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 _ ->
diff --git a/src/Proarrow/Category/Monoidal/Dialogue.hs b/src/Proarrow/Category/Monoidal/Dialogue.hs
new file mode 100644
--- /dev/null
+++ b/src/Proarrow/Category/Monoidal/Dialogue.hs
@@ -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)
+           ]
diff --git a/src/Proarrow/Category/Monoidal/IsoMix.hs b/src/Proarrow/Category/Monoidal/IsoMix.hs
new file mode 100644
--- /dev/null
+++ b/src/Proarrow/Category/Monoidal/IsoMix.hs
@@ -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)]
diff --git a/src/Proarrow/Category/Monoidal/StarAutonomous.hs b/src/Proarrow/Category/Monoidal/StarAutonomous.hs
--- a/src/Proarrow/Category/Monoidal/StarAutonomous.hs
+++ b/src/Proarrow/Category/Monoidal/StarAutonomous.hs
@@ -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)
diff --git a/src/Proarrow/Category/Monoidal/Strictified.hs b/src/Proarrow/Category/Monoidal/Strictified.hs
--- a/src/Proarrow/Category/Monoidal/Strictified.hs
+++ b/src/Proarrow/Category/Monoidal/Strictified.hs
@@ -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
diff --git a/src/Proarrow/Functor.hs b/src/Proarrow/Functor.hs
--- a/src/Proarrow/Functor.hs
+++ b/src/Proarrow/Functor.hs
@@ -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)
diff --git a/src/Proarrow/Monoid.hs b/src/Proarrow/Monoid.hs
--- a/src/Proarrow/Monoid.hs
+++ b/src/Proarrow/Monoid.hs
@@ -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
diff --git a/src/Proarrow/Optic/Glass.hs b/src/Proarrow/Optic/Glass.hs
--- a/src/Proarrow/Optic/Glass.hs
+++ b/src/Proarrow/Optic/Glass.hs
@@ -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.
diff --git a/src/Proarrow/Optic/Grate.hs b/src/Proarrow/Optic/Grate.hs
--- a/src/Proarrow/Optic/Grate.hs
+++ b/src/Proarrow/Optic/Grate.hs
@@ -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)
diff --git a/src/Proarrow/Optic/Kaleidoscope.hs b/src/Proarrow/Optic/Kaleidoscope.hs
--- a/src/Proarrow/Optic/Kaleidoscope.hs
+++ b/src/Proarrow/Optic/Kaleidoscope.hs
@@ -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.
diff --git a/src/Proarrow/Profunctor/Free.hs b/src/Proarrow/Profunctor/Free.hs
--- a/src/Proarrow/Profunctor/Free.hs
+++ b/src/Proarrow/Profunctor/Free.hs
@@ -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
diff --git a/src/Proarrow/Profunctor/Instance/Costar.hs b/src/Proarrow/Profunctor/Instance/Costar.hs
--- a/src/Proarrow/Profunctor/Instance/Costar.hs
+++ b/src/Proarrow/Profunctor/Instance/Costar.hs
@@ -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
diff --git a/src/Proarrow/Profunctor/Instance/Fold.hs b/src/Proarrow/Profunctor/Instance/Fold.hs
--- a/src/Proarrow/Profunctor/Instance/Fold.hs
+++ b/src/Proarrow/Profunctor/Instance/Fold.hs
@@ -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]
diff --git a/src/Proarrow/Profunctor/Instance/Star.hs b/src/Proarrow/Profunctor/Instance/Star.hs
--- a/src/Proarrow/Profunctor/Instance/Star.hs
+++ b/src/Proarrow/Profunctor/Instance/Star.hs
@@ -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
diff --git a/src/Proarrow/Promonad/Cont.hs b/src/Proarrow/Promonad/Cont.hs
--- a/src/Proarrow/Promonad/Cont.hs
+++ b/src/Proarrow/Promonad/Cont.hs
@@ -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
diff --git a/src/Proarrow/Promonad/Writer.hs b/src/Proarrow/Promonad/Writer.hs
--- a/src/Proarrow/Promonad/Writer.hs
+++ b/src/Proarrow/Promonad/Writer.hs
@@ -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 (+->))
diff --git a/src/Proarrow/Tools/Diagrams/Dot.hs b/src/Proarrow/Tools/Diagrams/Dot.hs
--- a/src/Proarrow/Tools/Diagrams/Dot.hs
+++ b/src/Proarrow/Tools/Diagrams/Dot.hs
@@ -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
diff --git a/src/Proarrow/Tools/Diagrams/Svg.hs b/src/Proarrow/Tools/Diagrams/Svg.hs
--- a/src/Proarrow/Tools/Diagrams/Svg.hs
+++ b/src/Proarrow/Tools/Diagrams/Svg.hs
@@ -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
diff --git a/src/Proarrow/Tools/SMC.hs b/src/Proarrow/Tools/SMC.hs
new file mode 100644
--- /dev/null
+++ b/src/Proarrow/Tools/SMC.hs
@@ -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'
diff --git a/test/Examples/Cbpv.hs b/test/Examples/Cbpv.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Cbpv.hs
@@ -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"])
+    ]
diff --git a/test/Examples/Database.hs b/test/Examples/Database.hs
--- a/test/Examples/Database.hs
+++ b/test/Examples/Database.hs
@@ -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)
     ]
diff --git a/test/Examples/IntComposition.hs b/test/Examples/IntComposition.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/IntComposition.hs
@@ -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)
diff --git a/test/Examples/LinearLogic.hs b/test/Examples/LinearLogic.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/LinearLogic.hs
@@ -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)
+    ]
diff --git a/test/Examples/Sessions.hs b/test/Examples/Sessions.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Sessions.hs
@@ -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)"))
diff --git a/test/Examples/SimplyTypedLambdaCalculus.hs b/test/Examples/SimplyTypedLambdaCalculus.hs
--- a/test/Examples/SimplyTypedLambdaCalculus.hs
+++ b/test/Examples/SimplyTypedLambdaCalculus.hs
@@ -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
 
diff --git a/test/Examples/Toffoli.hs b/test/Examples/Toffoli.hs
new file mode 100644
--- /dev/null
+++ b/test/Examples/Toffoli.hs
@@ -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)
+    ]
diff --git a/test/Main.hs b/test/Main.hs
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -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
           ]
       ]
diff --git a/test/Props/Bool.hs b/test/Props/Bool.hs
--- a/test/Props/Bool.hs
+++ b/test/Props/Bool.hs
@@ -56,6 +56,7 @@
     , testMonoidal_ @BOOL
     , testSymMonoidal_ @BOOL
     , testCopyDiscard_ @BOOL
+    , testDialogue_ @BOOL
     , testStarAutonomous_ @BOOL
     , testBinaryCoproducts_ @BOOL
     , testDistributive_ @BOOL
diff --git a/test/Props/Cospan.hs b/test/Props/Cospan.hs
--- a/test/Props/Cospan.hs
+++ b/test/Props/Cospan.hs
@@ -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)
diff --git a/test/Props/Cost.hs b/test/Props/Cost.hs
--- a/test/Props/Cost.hs
+++ b/test/Props/Cost.hs
@@ -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
diff --git a/test/Props/Cps.hs b/test/Props/Cps.hs
new file mode 100644
--- /dev/null
+++ b/test/Props/Cps.hs
@@ -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)]
diff --git a/test/Props/Dot.hs b/test/Props/Dot.hs
--- a/test/Props/Dot.hs
+++ b/test/Props/Dot.hs
@@ -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)
diff --git a/test/Props/FinHask.hs b/test/Props/FinHask.hs
--- a/test/Props/FinHask.hs
+++ b/test/Props/FinHask.hs
@@ -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)]
 
diff --git a/test/Props/FinRel.hs b/test/Props/FinRel.hs
--- a/test/Props/FinRel.hs
+++ b/test/Props/FinRel.hs
@@ -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 '~~>' -)@
diff --git a/test/Props/Free.hs b/test/Props/Free.hs
--- a/test/Props/Free.hs
+++ b/test/Props/Free.hs
@@ -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
 
diff --git a/test/Props/Hask.hs b/test/Props/Hask.hs
--- a/test/Props/Hask.hs
+++ b/test/Props/Hask.hs
@@ -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]
 
diff --git a/test/Props/IntConstruction.hs b/test/Props/IntConstruction.hs
new file mode 100644
--- /dev/null
+++ b/test/Props/IntConstruction.hs
@@ -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))
diff --git a/test/Props/Kleisli.hs b/test/Props/Kleisli.hs
--- a/test/Props/Kleisli.hs
+++ b/test/Props/Kleisli.hs
@@ -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)]
 
diff --git a/test/Props/Mat.hs b/test/Props/Mat.hs
--- a/test/Props/Mat.hs
+++ b/test/Props/Mat.hs
@@ -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)
diff --git a/test/Props/Optic/Hask.hs b/test/Props/Optic/Hask.hs
--- a/test/Props/Optic/Hask.hs
+++ b/test/Props/Optic/Hask.hs
@@ -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 =
diff --git a/test/Props/Paths.hs b/test/Props/Paths.hs
--- a/test/Props/Paths.hs
+++ b/test/Props/Paths.hs
@@ -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]
     ]
diff --git a/test/Props/PointedHask.hs b/test/Props/PointedHask.hs
--- a/test/Props/PointedHask.hs
+++ b/test/Props/PointedHask.hs
@@ -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)]
 
diff --git a/test/Props/Sheaf/Collage.hs b/test/Props/Sheaf/Collage.hs
--- a/test/Props/Sheaf/Collage.hs
+++ b/test/Props/Sheaf/Collage.hs
@@ -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
diff --git a/test/Props/Span.hs b/test/Props/Span.hs
--- a/test/Props/Span.hs
+++ b/test/Props/Span.hs
@@ -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)
diff --git a/test/Props/Svg.hs b/test/Props/Svg.hs
--- a/test/Props/Svg.hs
+++ b/test/Props/Svg.hs
@@ -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.
diff --git a/test/Props/ZX.hs b/test/Props/ZX.hs
--- a/test/Props/ZX.hs
+++ b/test/Props/ZX.hs
@@ -31,8 +31,10 @@
     , testHypergraph_ @Nat
     , testSymMonoidal_ @Nat
     , testClosed_ @Nat
+    , testIsoMix_ @Nat
     , testCompactClosed_ @Nat
     , testTraced_ @Nat
+    , testDialogue_ @Nat
     , testStarAutonomous_ @Nat
     , testCopyDiscard_ @Nat
     , testCommutativeMonoid_ @0
diff --git a/testing/Proarrow/Testing.hs b/testing/Proarrow/Testing.hs
--- a/testing/Proarrow/Testing.hs
+++ b/testing/Proarrow/Testing.hs
@@ -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)
diff --git a/testing/Proarrow/Testing/Laws.hs b/testing/Proarrow/Testing/Laws.hs
--- a/testing/Proarrow/Testing/Laws.hs
+++ b/testing/Proarrow/Testing/Laws.hs
@@ -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
diff --git a/testing/Proarrow/Testing/Laws/Run.hs b/testing/Proarrow/Testing/Laws/Run.hs
--- a/testing/Proarrow/Testing/Laws/Run.hs
+++ b/testing/Proarrow/Testing/Laws/Run.hs
@@ -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