monoidal-functors 0.2.3.0 → 0.3.0.0

raw patch · 39 files changed

+6890/−656 lines, 39 filesdep +hedgehogdep +hedgehog-classesdep +kind-genericsdep ~basedep ~bifunctorsdep ~contravariantPVP ok

version bump matches the API change (PVP)

Dependencies added: hedgehog, hedgehog-classes, kind-generics, kind-generics-th, kindly-functors

Dependency ranges changed: base, bifunctors, contravariant, distributive, profunctors, semialign, tagged, these, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +26/−5
• examples/co-log/Main.hs +15/−15
• laws/Control/Category/Cartesian/Laws.hs +163/−0
• laws/Control/Category/Laws/Internal.hs +45/−0
• laws/Control/Category/Tensor/Laws.hs +213/−0
• laws/Data/Bifunctor/Monoidal/Laws.hs +418/−0
• laws/Data/Functor/Monoidal/Laws.hs +543/−0
• monoidal-functors.cabal +86/−17
• src/Control/Category/Cartesian.hs +40/−14
• src/Control/Category/Tensor.hs +51/−23
• src/Control/Category/Tensor/Expr.hs +13/−5
• src/Data/Bifunctor/BiInvariant.hs +37/−25
• src/Data/Bifunctor/Module.hs +150/−144
• src/Data/Bifunctor/Monoidal.hs +408/−87
• src/Data/Bifunctor/Monoidal/Specialized.hs +281/−26
• src/Data/Bifunctor/Rank2/Monoidal.hs +350/−0
• src/Data/Bifunctor/Rank2/Traversable.hs +109/−0
• src/Data/Functor/Invariant.hs +19/−5
• src/Data/Functor/Module.hs +45/−43
• src/Data/Functor/Monoidal.hs +225/−224
• src/Data/Functor/Monoidal/Generic.hs +253/−0
• src/Data/Functor/Monoidal/Specialized.hs +278/−0
• src/Data/Functor/Rank2/Monoidal.hs +414/−0
• src/Data/Functor/Rank2/Traversable.hs +60/−0
• src/Data/Trifunctor/Module.hs +5/−5
• src/Data/Trifunctor/Monoidal.hs +188/−18
• src/Data/Trifunctor/Rank2/Traversable.hs +143/−0
• test/Control/Category/CartesianSpec.hs +53/−0
• test/Control/Category/LawsSupport.hs +84/−0
• test/Control/Category/TensorSpec.hs +162/−0
• test/Data/Bifunctor/Monoidal/LawsSpec.hs +277/−0
• test/Data/Bifunctor/Rank2/MonoidalSpec.hs +351/−0
• test/Data/Bifunctor/Rank2/TraversableSpec.hs +141/−0
• test/Data/Functor/Monoidal/GenericSpec.hs +400/−0
• test/Data/Functor/Monoidal/LawsSpec.hs +182/−0
• test/Data/Functor/Rank2/MonoidalSpec.hs +329/−0
• test/Data/Functor/Rank2/TraversableSpec.hs +165/−0
• test/Data/Trifunctor/Rank2/TraversableSpec.hs +132/−0
• test/Main.hs +36/−0

@@ -2,6 +2,27 @@  ## Upcoming +## 0.3.0.0 -- 2026-11-08+* Renames the tensor and unit type parameters of the `Semigroupal` / `Unital` / `Monoidal` and `*.Module` classes to match the Haddock math. Domain tensors and units are `tC` / `iC` (numbered `tC1`, `tC2`, `tC3` per argument for bifunctors and trifunctors), and codomain ones are `tD` / `iD`. This replaces the mix of `t1` / `t0` / `to` / `o`. The parameter order is the same, so visible type applications do not change.+* Makes the `Semigroupal` / `Unital` / `Monoidal` instances for `Data.Bifunctor.Product` componentwise. Each instance delegates to the components' own instances at every tensor and unit, and replaces the `FromBiapplicative` instance that needed `Biapplicative` components. `Product` is now `Monoidal` at profunctor components (e.g. `Product (->) (Star Maybe)`) and at the `Either` and `These` tensors.+* Adds `Data.Bifunctor.Rank2.Monoidal`, the bifunctor-interpreted counterpart to `Data.Functor.Rank2.Monoidal`. A rank-2 bifunctor is a functor from the bifunctor category to `Hask`, so the record's fields have the shape `p a b` as in `Data.Bifunctor.Rank2.Traversable`. Unlike `Data.Bifunctor.Monoidal` the classes take a single domain tensor. A bifunctor's domain is a product category and so needs a pair of tensors, but the bifunctor category is one category. Ships `GHC.Generics` derivations at three instantiations, over `Data.Bifunctor.Product` and `Data.Bifunctor.Sum`: the covariant product (field-wise `Pair`, as the empty-instance default), the coproduct (`gcombineSum`, injecting a whole record all-`L2` or all-`R2`), and the oplax product split (`gsplitProduct`). The tensor units are `Joker Proxy` and `Joker V1`, since `bifunctors` ships no unit or empty bifunctor of its own. There is no `These` instantiation, as the ecosystem has no bifunctor analogue of `These1`.+* Adds rank-2 `Traversable` classes for higher-kinded data: `Data.Functor.Rank2.Traversable`, `Data.Bifunctor.Rank2.Traversable`, and `Data.Trifunctor.Rank2.Traversable`. Their `sequence` distributes the interpretation functor out of a record over any functor / profunctor / trifunctor that is `Monoidal` with respect to tupling. Each ships a `GHC.Generics` default covering records of `f a` / `p a b` / `p a b c` fields, and each is polymorphic over the variance of every interpretation position, generalizing `barbies`' `TraversableB`. The functor version is the `Applicative` collect at a covariant interpretation and the `Divisible` fold at a contravariant one. The bifunctor version splits each field into its `First` and `Second` projections, giving a profunctor traversal at variance `(Op, (->))` and the `Biapplicative` unzip at `((->), (->))`. The trifunctor version splits into `First`, `Second`, and `Third` across its three positions.+* Reworks the `Semigroupal` / `Unital` / `Monoidal` instances for `Product`, `f :*: g`, the transparent newtype wrappers (`Rec1`, `M1`, `Alt`, `Reverse`, `Backwards`), and the phantom functors (`Proxy`, `U1`, `Const`, `Constant`) into single variance-agnostic instances that hold at every tensor and both variances at once, removing the previous covariant/contravariant instance overlaps. `Product` and `:*:` combine componentwise by delegating to their components' own instances; the wrappers inherit their component's instance by coercion; and the phantom functors combine via their underlying `Semigroup` (`Const` / `Constant`) or the trivial value (`Proxy` / `U1`). As a result `Product`/`:*:`/wrappers are now usable with contravariant components (e.g. `Product Predicate Comparison`), which previously did not typecheck.+* Adds `Data.Functor.Monoidal.Generic` for deriving `Semigroupal`, `Unital`, and `Monoidal` instances via `kind-generics`. `FromGeneric` covers both covariant (Applicative/Alternative) and contravariant (Divisible/Decidable) functors across the `(,)`, `Either`, and `These` tensors; `FromRepresentable` additionally derives the coherent `Op` split for representable functors.+* Adds a `monoidal-functors:laws` public sublibrary exporting `hedgehog-classes` `Laws` for the monoidal-functor classes, so consumers can law-test their own instances. Covers covariant functors (`semigroupalLaws` / `unitalLaws` / `monoidalLaws`, compared with `Eq`), contravariant functors (`contravariantSemigroupalLaws` / `contravariantUnitalLaws` / `contravariantMonoidalLaws`, checked extensionally through an observation), and the `Op` comonoidal split (`opSemigroupalLaws`, plus `representableSplitLaws` for split/combine coherence). Requires `cabal-version: 3.0`.+* Adds `Control.Category.Tensor.Laws` and `Control.Category.Cartesian.Laws` to the `monoidal-functors:laws` sublibrary — reusable `hedgehog-classes` `Laws` for the categorical structure classes (`gbifunctorLaws`, `isoLaws`, `associativeLaws`, `tensorLaws`, `symmetricLaws`, `semicartesianLaws`, `semicocartesianLaws`, `cartesianLaws`, `cocartesianLaws`) so consumers can law-test their own instances. Each law is checked extensionally through a caller-supplied observer, so it holds at any category (`(->)`, `Op`, `Star` / `Kleisli`, …).+* Adds `Data.Bifunctor.Monoidal.Laws` to the `monoidal-functors:laws` sublibrary — `semigroupalLaws` / `unitalLaws` / `monoidalLaws` for covariant bifunctor `Monoidal` instances (compared with `Eq`), and `profunctorSemigroupalLaws` / `profunctorUnitalLaws` / `profunctorMonoidalLaws` for profunctor instances (`(->)`, `Star`, `Kleisli`, …, observed extensionally). The bifunctor analog of `Data.Functor.Monoidal.Laws`.+* Adds `Bifunctor.Monoidal` instances for `Biapplicative`.+* Adds infix operators for `Semigroupal`.+* Adds `Data.Functor.Monoidal.Specialized` combinators module.+* Adds `Biapplicative` operations to `Data.Bifunctor.Monoidal.Specialized`.+* Adds `Unalign` `Semigroupal` instances.+* Expands GHC support through 9.12; bumps nixpkgs, Cabal, and CI tooling.+* Adds support for `semialign` 1.4 (retaining 1.3 compatibility via CPP).+* Replaces the `doctest-parallel` test-suite with the canonical `cabal repl --with-compiler=doctest` invocation, exposed as `just doctest` and as its own CI job. The old suite reached the library through a shared GHC environment file, which `cabal test all` could rewrite while the suite was running, so any pending rebuild failed the doctests with missing dependencies. Driving `doctest` as the compiler also passes the library's real `ghc-options` and CPP macros, which retires the hand-rolled `MIN_VERSION_semialign` reconstruction and picks up examples the old suite was skipping.+* Replaces the `Makefile` with a `justfile` for local development.+* Adds release commands to `justfile`.+ ## 0.2.3.0 -- 2023-08-03 * Add support for GHC 9.6 @@ -16,14 +37,14 @@ ## 0.2.1.0 -- 2023-01-29  * Rewrite `Semigroupal`, `Unital`, and `Monoidal` `Functor` instances-  to use deriving via+  to use deriving via.  ## 0.2.0.0 -- 2023-01-29 -* Adds Tensored Type-* Rewrites haddocks-* Adds `Control.Category.Cartesian` module-* Adds a number of specialized combinators to `Data.Bifunctor.Monoidal.Specialized`+* Adds Tensored Type.+* Rewrites haddocks.+* Adds `Control.Category.Cartesian` module.+* Adds a number of specialized combinators to `Data.Bifunctor.Monoidal.Specialized`.  ## 0.1.1.0 -- 2021-12-13 

@@ -45,12 +45,12 @@ carL =   carToTuple     >$< (constL "Logging make..." *< showL >* constL "Finished logging make...")-      >*< (constL "Logging model.." *< showL >* constL "Finished logging model...")-      >*< ( engineToEither-              >$< constL "Logging pistons..."-              *< intL-              >|< constL "Logging rocket..."-          )+    >*< (constL "Logging model.." *< showL >* constL "Finished logging model...")+    >*< ( engineToEither+            >$< constL "Logging pistons..."+            *< intL+            >|< constL "Logging rocket..."+        )  runCarExample :: IO () runCarExample = usingLoggerT carL $ logMsg $ Car "Toyota" "Corolla" (Pistons 4)@@ -63,24 +63,24 @@   contramap :: (a -> b) -> LogAction m b -> LogAction m a   contramap f (LogAction act) = LogAction $ \a -> act (f a) -instance Applicative m => Semigroupal (->) (,) (,) (LogAction m) where+instance (Applicative m) => Semigroupal (->) (,) (,) (LogAction m) where   combine :: (LogAction m a, LogAction m b) -> LogAction m (a, b)   combine (act1, act2) = LogAction $ \(a, b) ->     unLogAction act1 a       *> unLogAction act2 b       *> pure () -instance Applicative m => Unital (->) () () (LogAction m) where+instance (Applicative m) => Unital (->) () () (LogAction m) where   introduce :: () -> LogAction m ()   introduce () = LogAction $ \_ -> pure () -instance Applicative m => Semigroupal (->) Either (,) (LogAction m) where+instance (Applicative m) => Semigroupal (->) Either (,) (LogAction m) where   combine :: (LogAction m a, LogAction m b) -> LogAction m (Either a b)   combine (act1, act2) = LogAction $ \case     Left a -> coerce act1 a     Right b -> coerce act2 b -instance Applicative m => Unital (->) Void () (LogAction m) where+instance (Applicative m) => Unital (->) Void () (LogAction m) where   introduce :: () -> LogAction m Void   introduce () = LogAction $ \_ -> pure () @@ -118,12 +118,12 @@  infixr 4 >*< -(>*<) :: Semigroupal (->) (,) (,) f => f a -> f b -> f (a, b)+(>*<) :: (Semigroupal (->) (,) (,) f) => f a -> f b -> f (a, b) (>*<) = (|?|)  infixr 3 >|< -(>|<) :: Semigroupal (->) Either (,) f => f a -> f b -> f (Either a b)+(>|<) :: (Semigroupal (->) Either (,) f) => f a -> f b -> f (Either a b) (>|<) = (|?|)  infixr 4 >*@@ -149,7 +149,7 @@ logStringStdout = LogAction putStrLn  -- Combinator that allows to log any showable value-showL :: Show a => LogAction IO a+showL :: (Show a) => LogAction IO a showL = contramap show logStringStdout  -- Returns a log action that logs a given string ignoring its input.@@ -177,12 +177,12 @@   LogAction logger <- asks getLogAction   logger msg -usingLoggerT :: Monad m => LogAction m msg -> LoggerT msg m a -> m a+usingLoggerT :: (Monad m) => LogAction m msg -> LoggerT msg m a -> m a usingLoggerT action = flip runReaderT (liftLogAction action) . runLoggerT  newtype LoggerT msg m a = LoggerT {runLoggerT :: ReaderT (LogAction (LoggerT msg m) msg) m a}   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader (LogAction (LoggerT msg m) msg))  instance MonadTrans (LoggerT msg) where-  lift :: Monad m => m a -> LoggerT msg m a+  lift :: (Monad m) => m a -> LoggerT msg m a   lift = LoggerT . lift

@@ -0,0 +1,163 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Reusable @hedgehog-classes@ 'Laws' for the classes in+-- "Control.Category.Cartesian". These cover 'Semicartesian', 'Semicocartesian',+-- 'Cartesian', and 'Cocartesian'. A consumer can law-test their own+-- instances the same way they test 'Monoid' or 'Applicative'.+--+-- > import Control.Category.Cartesian.Laws (cartesianLaws)+-- > import Hedgehog.Classes (lawsCheck)+-- >+-- > main :: IO Bool+-- > main = lawsCheck (cartesianLaws @(->) @(,) @() (\f -> Identity . f))+--+-- As in "Control.Category.Tensor.Laws", morphisms here have no 'Eq' \/ 'Show'.+-- Every law is checked /extensionally/ through a caller-supplied observer+-- @run@. The observer's shape follows the law.+--+--   * The diagonal \/ codiagonal coassociativity laws ('Semicartesian' \/+--     'Semicocartesian') relate morphisms whose domain and codomain /differ/. They+--     take a general @forall x y. cat x y -> x -> obs y@ observer, usable+--     for @('->')@, @'Star' m@, and @'Kleisli' m@, but not 'Op'.+--   * The projection \/ inclusion unit laws ('Cartesian' \/ 'Cocartesian') relate+--     /endomorphisms/ against 'id'. They take a+--     @forall z. cat z z -> z -> obs z@ observer, which additionally covers 'Op'.+module Control.Category.Cartesian.Laws+  ( -- * Semicartesian+    semicartesianLaws,++    -- * Semicocartesian+    semicocartesianLaws,++    -- * Cartesian+    cartesianLaws,++    -- * Cocartesian+    cocartesianLaws,+  )+where++--------------------------------------------------------------------------------++import Control.Category (id, (>>>))+import Control.Category.Cartesian+  ( Cartesian (kill),+    Cocartesian (spawn),+    Semicartesian (split),+    Semicocartesian (merge),+  )+import Control.Category.Laws.Internal (agree, genInt)+import Control.Category.Tensor+  ( Associative (assoc),+    Iso (bwd, fwd),+    Tensor (unitl, unitr),+    glmap,+    grmap,+  )+import Hedgehog (Gen)+import Hedgehog.Classes (Laws (..))+import Prelude hiding (id)++--------------------------------------------------------------------------------+-- Semicartesian++-- | The 'Semicartesian' laws. The diagonal 'split' is coassociative.+--+-- @+-- 'Control.Category.Tensor.grmap' 'split' '>>>' … ≡ 'split' '>>>' 'Control.Category.Tensor.glmap' 'split' '>>>' 'bwd' 'assoc'+-- @+semicartesianLaws ::+  forall cat t obs.+  ( Semicartesian cat t,+    Eq (obs (t Int (t Int Int))),+    Show (obs (t Int (t Int Int))),+    Eq (obs (t (t Int Int) Int)),+    Show (obs (t (t Int Int) Int))+  ) =>+  (forall x y. cat x y -> x -> obs y) ->+  Laws+semicartesianLaws run =+  Laws+    "Semicartesian"+    [ ("split coassociativity (right)", agree run (s >>> grmap s) (s >>> glmap s >>> bwd assoc) genInt),+      ("split coassociativity (left)", agree run (s >>> glmap s) (s >>> grmap s >>> fwd assoc) genInt)+    ]+  where+    s :: cat Int (t Int Int)+    s = split++--------------------------------------------------------------------------------+-- Semicocartesian++-- | The 'Semicocartesian' laws. The codiagonal 'merge' is coassociative. @genT@+-- builds a tensor from generators for its factors, supplying the nested inputs.+semicocartesianLaws ::+  forall cat t obs.+  ( Semicocartesian cat t,+    Show (t Int (t Int Int)),+    Show (t (t Int Int) Int),+    Eq (obs Int),+    Show (obs Int)+  ) =>+  (forall x y. cat x y -> x -> obs y) ->+  (forall x y. Gen x -> Gen y -> Gen (t x y)) ->+  Laws+semicocartesianLaws run genT =+  Laws+    "Semicocartesian"+    [ ("merge coassociativity (right)", agree run (grmap m >>> m) (fwd assoc >>> glmap m >>> m) (genT genInt (genT genInt genInt))),+      ("merge coassociativity (left)", agree run (glmap m >>> m) (bwd assoc >>> grmap m >>> m) (genT (genT genInt genInt) genInt))+    ]+  where+    m :: cat (t Int Int) Int+    m = merge++--------------------------------------------------------------------------------+-- Cartesian++-- | The 'Cartesian' laws. 'kill' is a counit for 'split', so projecting after+-- duplicating is the identity.+--+-- @+-- 'fwd' 'unitl' '.' 'Control.Category.Tensor.glmap' 'kill' '.' 'split' ≡ 'id'+-- 'fwd' 'unitr' '.' 'Control.Category.Tensor.grmap' 'kill' '.' 'split' ≡ 'id'+-- @+cartesianLaws ::+  forall cat t i obs.+  ( Cartesian cat t i,+    Eq (obs Int),+    Show (obs Int)+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  Laws+cartesianLaws run =+  Laws+    "Cartesian"+    [ ("left projection", agree run (split @cat @t >>> glmap (kill @cat @t @i) >>> fwd (unitl @cat @t @i)) id genInt),+      ("right projection", agree run (split @cat @t >>> grmap (kill @cat @t @i) >>> fwd (unitr @cat @t @i)) id genInt)+    ]++--------------------------------------------------------------------------------+-- Cocartesian++-- | The 'Cocartesian' laws. 'spawn' is a unit for 'merge', so merging after+-- including is the identity.+--+-- @+-- 'merge' '.' 'Control.Category.Tensor.glmap' 'spawn' '.' 'bwd' 'unitl' ≡ 'id'+-- 'merge' '.' 'Control.Category.Tensor.grmap' 'spawn' '.' 'bwd' 'unitr' ≡ 'id'+-- @+cocartesianLaws ::+  forall cat t i obs.+  ( Cocartesian cat t i,+    Eq (obs Int),+    Show (obs Int)+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  Laws+cocartesianLaws run =+  Laws+    "Cocartesian"+    [ ("left inclusion", agree run (bwd (unitl @cat @t @i) >>> glmap (spawn @cat @t @i) >>> merge @cat @t) id genInt),+      ("right inclusion", agree run (bwd (unitr @cat @t @i) >>> grmap (spawn @cat @t @i) >>> merge @cat @t) id genInt)+    ]

@@ -0,0 +1,45 @@+-- | Internal shared machinery for the @Control.Category.*.Laws@ modules.+--+-- Morphisms in the categories these law modules target ('(->)', @'Star' m@,+-- @'Kleisli' m@, 'Op') have no 'Eq' \/ 'Show', so every law is checked+-- /extensionally/. Build both sides, run them on a generated input through a+-- caller-supplied observer, and compare the observed results. 'agree' is that+-- primitive. 'genInt' \/ 'genBool' are the witness element types the+-- coherence squares are checked at.+module Control.Category.Laws.Internal+  ( genInt,+    genBool,+    agree,+  )+where++--------------------------------------------------------------------------------++import Hedgehog (Gen, Property, forAll, property, (===))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Prelude++--------------------------------------------------------------------------------++-- | The witness element types the coherence squares are checked at.+genInt :: Gen Int+genInt = Gen.int (Range.linear (-100) 100)++genBool :: Gen Bool+genBool = Gen.bool++-- | Observe that two parallel morphisms agree on a generated input. @run@ is the+-- caller's extensional observer for the category. For example,+-- @('Data.Functor.Identity.Identity' '.') . ($)@ for @('->')@, @runStar@ \/+-- @runKleisli@ for the Kleisli-style categories.+agree ::+  (Eq (obs y), Show (obs y), Show x) =>+  (cat x y -> x -> obs y) ->+  cat x y ->+  cat x y ->+  Gen x ->+  Property+agree run f g gen = property $ do+  x <- forAll gen+  run f x === run g x

@@ -0,0 +1,213 @@+-- | Reusable @hedgehog-classes@ 'Laws' for the structures in+-- "Control.Category.Tensor" ('GBifunctor', 'Iso', 'Associative', 'Tensor', and+-- 'Symmetric'). A consumer can law-test their own instances the same way they+-- test 'Monoid' or 'Applicative'.+--+-- > import Control.Category.Tensor.Laws (associativeLaws)+-- > import Hedgehog.Classes (lawsCheck)+-- >+-- > main :: IO Bool+-- > main = lawsCheck (associativeLaws runKleisli genTheseTensor)+--+-- Each law is checked extensionally through a caller-supplied observer (see+-- 'Control.Category.Laws.Internal.agree'). Every law here reduces to \"an+-- endomorphism agrees with 'id'\". This covers the round-trips of an 'Iso', the+-- iso-ness of @assoc@ \/ @unitl@ \/ @unitr@, the involution of @swap@, and the+-- functoriality of @gbimap@. The observer only runs /endomorphisms/ @cat z z@,+-- and a single @forall z. cat z z -> z -> obs z@ serves every category+-- (including 'Op', which a forward observer could not).+module Control.Category.Tensor.Laws+  ( -- * GBifunctor+    gbifunctorLaws,++    -- * Iso+    isoLaws,++    -- * Associative+    associativeLaws,++    -- * Tensor+    tensorLaws,++    -- * Symmetric+    symmetricLaws,+  )+where++--------------------------------------------------------------------------------++import Control.Category (Category, id, (>>>))+import Control.Category.Laws.Internal (agree, genBool, genInt)+import Control.Category.Tensor+  ( Associative (assoc),+    GBifunctor (gbimap),+    Iso (..),+    Symmetric (swap),+    Tensor (unitl, unitr),+    glmap,+    grmap,+  )+import Hedgehog (Gen, Property)+import Hedgehog.Classes (Laws (..))+import Prelude hiding (id)++--------------------------------------------------------------------------------++-- | The two isomorphism laws for an 'Iso' are @fwd . bwd ≡ id@ and+-- @bwd . fwd ≡ id@. Shared by 'isoLaws', 'associativeLaws', and 'tensorLaws'.+isoProperties ::+  forall cat obs a b.+  ( Category cat,+    Show a,+    Show b,+    Eq (obs a),+    Show (obs a),+    Eq (obs b),+    Show (obs b)+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  Iso cat a b ->+  Gen a ->+  Gen b ->+  [(String, Property)]+isoProperties run iso genA genB =+  [ ("fwd . bwd = id", agree run (bwd iso >>> fwd iso) id genB),+    ("bwd . fwd = id", agree run (fwd iso >>> bwd iso) id genA)+  ]++--------------------------------------------------------------------------------+-- GBifunctor++-- | The 'GBifunctor' laws for @gbimap@ in category @cat@ at tensor @t@.+--+-- @+-- 'gbimap' 'id' 'id'                    ≡ 'id'+-- 'gbimap' (f '>>>' f') (g '>>>' g')        ≡ 'gbimap' f g '>>>' 'gbimap' f' g'+-- 'gbimap' f g                      ≡ 'grmap' g '>>>' 'glmap' f+-- @+--+-- The two arrow pairs are endomorphisms on each tensor factor: @(f, f')@ on the+-- left factor @a@ and @(g, g')@ on the right factor @c@.+gbifunctorLaws ::+  forall cat t obs a c.+  ( GBifunctor cat cat cat t,+    Show (t a c),+    Eq (obs (t a c)),+    Show (obs (t a c))+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  (cat a a, cat a a) ->+  (cat c c, cat c c) ->+  Gen (t a c) ->+  Laws+gbifunctorLaws run (f, f') (g, g') gen =+  Laws+    "GBifunctor"+    [ ("Identity", agree run (gbimap id id) id gen),+      ("Composition", agree run (gbimap (f >>> f') (g >>> g')) (gbimap f g >>> gbimap f' g') gen),+      ("Decomposition", agree run (gbimap f g) (grmap g >>> glmap f) gen)+    ]++--------------------------------------------------------------------------------+-- Iso++-- | The isomorphism laws for a given 'Iso' value. @fwd@ and @bwd@ are mutually+-- inverse, checked on generated inhabitants of both endpoints.+isoLaws ::+  forall cat obs a b.+  ( Category cat,+    Show a,+    Show b,+    Eq (obs a),+    Show (obs a),+    Eq (obs b),+    Show (obs b)+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  Iso cat a b ->+  Gen a ->+  Gen b ->+  Laws+isoLaws run iso genA genB = Laws "Iso" (isoProperties run iso genA genB)++--------------------------------------------------------------------------------+-- Associative++-- | The 'Associative' laws. @assoc@ is an isomorphism between the two+-- re-nestings of @t@. @genT@ builds a tensor from generators for its factors+-- (e.g. @\\gx gy -> (,) '<$>' gx '<*>' gy@ for @(,)@), from which the nested+-- witnesses are assembled.+associativeLaws ::+  forall cat t obs.+  ( Associative cat t,+    Show (t Int (t Int Int)),+    Show (t (t Int Int) Int),+    Eq (obs (t Int (t Int Int))),+    Show (obs (t Int (t Int Int))),+    Eq (obs (t (t Int Int) Int)),+    Show (obs (t (t Int Int) Int))+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  (forall x y. Gen x -> Gen y -> Gen (t x y)) ->+  Laws+associativeLaws run genT =+  Laws+    "Associative"+    ( isoProperties+        run+        (assoc @cat @t)+        (genT genInt (genT genInt genInt))+        (genT (genT genInt genInt) genInt)+    )++--------------------------------------------------------------------------------+-- Tensor++-- | The 'Tensor' laws. The left and right unitors @unitl@ \/ @unitr@ are+-- isomorphisms. The caller supplies generators for @i \`t\` a@ and @a \`t\` i@+-- (with @a = 'Int'@), which also fixes the unit @i@. This is needed because some+-- units ('Data.Void.Void') are uninhabited and cannot be generated directly.+tensorLaws ::+  forall cat t i obs.+  ( Tensor cat t i,+    Show (t i Int),+    Show (t Int i),+    Eq (obs Int),+    Show (obs Int),+    Eq (obs (t i Int)),+    Show (obs (t i Int)),+    Eq (obs (t Int i)),+    Show (obs (t Int i))+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  Gen (t i Int) ->+  Gen (t Int i) ->+  Laws+tensorLaws run genIA genAI =+  Laws+    "Tensor"+    ( prefixed "unitl" (isoProperties run (unitl @cat @t) genIA genInt)+        ++ prefixed "unitr" (isoProperties run (unitr @cat @t) genAI genInt)+    )+  where+    prefixed p = map (\(n, pr) -> (p <> " " <> n, pr))++--------------------------------------------------------------------------------+-- Symmetric++-- | The 'Symmetric' law. @swap@ is its own inverse, @swap ≡ swap⁻¹@, checked at+-- distinct factor types (@Int@, @Bool@) so a non-swapping @swap@ cannot pass.+symmetricLaws ::+  forall cat t obs.+  ( Symmetric cat t,+    Show (t Int Bool),+    Eq (obs (t Int Bool)),+    Show (obs (t Int Bool))+  ) =>+  (forall z. cat z z -> z -> obs z) ->+  (forall x y. Gen x -> Gen y -> Gen (t x y)) ->+  Laws+symmetricLaws run genT =+  Laws+    "Symmetric"+    [("swap . swap = id", agree run (swap @cat @t >>> swap @cat @t) id (genT genInt genBool))]

@@ -0,0 +1,418 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Reusable @hedgehog-classes@ 'Laws' for the /covariant/ bifunctor+-- 'Semigroupal' \/ 'Unital' \/ 'Monoidal' classes of+-- "Data.Bifunctor.Monoidal". A consumer can law-test their own instances the+-- same way they test 'Monoid' or 'Applicative'.+--+-- > import Data.Bifunctor.Monoidal.Laws (monoidalLaws)+-- > import Hedgehog.Classes (lawsCheck)+-- >+-- > main :: IO Bool+-- > main = lawsCheck (monoidalLaws @(,) @() @(,) @() genMyBifunctor)+--+-- Each law is stated at category @('->')@ over the /product/ codomain tensor+-- @(,)@, general in the two domain tensors @tC1@ \/ @tC2@ (and, for the unit+-- laws, their units @iC1@ \/ @iC2@). One function covers whichever pair of+-- tensors an instance uses. This is the bifunctor analog of the covariant half+-- of "Data.Functor.Monoidal.Laws". The coherence squares are compared with 'Eq'+-- and re-association happens with 'bimap' over both tensor positions.+--+-- The rank-2 generator @forall a b. 'Gen' a -> 'Gen' b -> 'Gen' (f a b)@ lets a+-- law instantiate @f@ at the several element types the coherence square needs.+module Data.Bifunctor.Monoidal.Laws+  ( -- * Covariant bifunctors+    semigroupalLaws,+    unitalLaws,+    monoidalLaws,++    -- * Profunctors+    profunctorSemigroupalLaws,+    profunctorUnitalLaws,+    profunctorMonoidalLaws,++    -- * Colax (Op) bifunctors+    opSemigroupalLaws,+  )+where++--------------------------------------------------------------------------------++import Control.Category.Tensor (Associative (assoc), Iso (bwd, fwd), Tensor (unitl, unitr), gbimap, glmap, grmap)+import Data.Bifunctor (Bifunctor (bimap))+import Data.Bifunctor.Monoidal (Monoidal, Semigroupal (combine), Unital (introduce))+import Data.Functor.Contravariant (Op (..))+import Data.Profunctor (Profunctor (dimap))+import Hedgehog (Gen, Property, forAll, forAllWith, property, (===))+import Hedgehog.Classes (Laws (..))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Prelude++--------------------------------------------------------------------------------++-- | The element type the coherence squares are witnessed at.+genInt :: Gen Int+genInt = Gen.int (Range.linear (-100) 100)++--------------------------------------------------------------------------------++-- | 'combine' laws. It commutes with the codomain tensors' associators+-- (associativity) and with maps into them (naturality of the laxator).+semigroupalLaws ::+  forall tC1 tC2 f.+  ( Semigroupal (->) tC1 tC2 (,) f,+    Associative (->) tC1,+    Associative (->) tC2,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Eq a, Eq b) => Eq (tC2 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Laws+semigroupalLaws genF =+  Laws+    "Semigroupal"+    [ ("Associativity", semigroupalAssoc @tC1 @tC2 genF),+      ("Naturality", semigroupalNaturality @tC1 @tC2 genF)+    ]++semigroupalAssoc ::+  forall tC1 tC2 f.+  ( Semigroupal (->) tC1 tC2 (,) f,+    Associative (->) tC1,+    Associative (->) tC2,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Eq a, Eq b) => Eq (tC2 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Property+semigroupalAssoc genF = property $ do+  x <- forAll (genF genInt genInt)+  y <- forAll (genF genInt genInt)+  z <- forAll (genF genInt genInt)+  bimap (bwd (assoc @(->) @tC1)) (bwd (assoc @(->) @tC2)) (combine @(->) @tC1 @tC2 @(,) (combine @(->) @tC1 @tC2 @(,) (x, y), z))+    === combine @(->) @tC1 @tC2 @(,) (x, combine @(->) @tC1 @tC2 @(,) (y, z))++semigroupalNaturality ::+  forall tC1 tC2 f.+  ( Semigroupal (->) tC1 tC2 (,) f,+    Associative (->) tC1,+    Associative (->) tC2,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Eq a, Eq b) => Eq (tC2 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Property+semigroupalNaturality genF = property $ do+  x <- forAll (genF genInt genInt)+  y <- forAll (genF genInt genInt)+  let g = (+ 1) :: Int -> Int+      h = (* 2) :: Int -> Int+  bimap (gbimap @(->) @(->) @(->) @tC1 g g) (gbimap @(->) @(->) @(->) @tC2 h h) (combine @(->) @tC1 @tC2 @(,) (x, y))+    === combine @(->) @tC1 @tC2 @(,) (bimap g h x, bimap g h y)++--------------------------------------------------------------------------------++-- | Left and right unit laws: 'introduce' is a unit for 'combine', up to the+-- codomain tensors' unitors.+unitalLaws ::+  forall tC1 iC1 tC2 iC2 f.+  ( Semigroupal (->) tC1 tC2 (,) f,+    Unital (->) iC1 iC2 () f,+    Tensor (->) tC1 iC1,+    Tensor (->) tC2 iC2,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Laws+unitalLaws genF =+  Laws+    "Unital"+    [ ("Left Unit", unitalLeft @tC1 @iC1 @tC2 @iC2 genF),+      ("Right Unit", unitalRight @tC1 @iC1 @tC2 @iC2 genF)+    ]++unitalLeft ::+  forall tC1 iC1 tC2 iC2 f.+  ( Semigroupal (->) tC1 tC2 (,) f,+    Unital (->) iC1 iC2 () f,+    Tensor (->) tC1 iC1,+    Tensor (->) tC2 iC2,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Property+unitalLeft genF = property $ do+  fab <- forAll (genF genInt genInt)+  bimap (fwd (unitl @(->) @tC1)) (fwd (unitl @(->) @tC2)) (combine @(->) @tC1 @tC2 @(,) (introduce @(->) @iC1 @iC2 @() (), fab))+    === fab++unitalRight ::+  forall tC1 iC1 tC2 iC2 f.+  ( Semigroupal (->) tC1 tC2 (,) f,+    Unital (->) iC1 iC2 () f,+    Tensor (->) tC1 iC1,+    Tensor (->) tC2 iC2,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Property+unitalRight genF = property $ do+  fab <- forAll (genF genInt genInt)+  bimap (fwd (unitr @(->) @tC1)) (fwd (unitr @(->) @tC2)) (combine @(->) @tC1 @tC2 @(,) (fab, introduce @(->) @iC1 @iC2 @() ()))+    === fab++--------------------------------------------------------------------------------++-- | Every 'semigroupalLaws' and 'unitalLaws' property together, for a full+-- covariant bifunctor 'Monoidal' instance.+monoidalLaws ::+  forall tC1 iC1 tC2 iC2 f.+  ( Monoidal (->) tC1 iC1 tC2 iC2 (,) () f,+    Bifunctor f,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Eq a, Eq b) => Eq (tC2 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  Laws+monoidalLaws genF =+  Laws+    "Monoidal"+    ( lawsProperties (semigroupalLaws @tC1 @tC2 genF)+        <> lawsProperties (unitalLaws @tC1 @iC1 @tC2 @iC2 genF)+    )++--------------------------------------------------------------------------------+-- Colax (Op) bifunctors++-- | 'combine' laws for the colax (@'Op'@) direction. The split+-- @f (tC1 x x') (tC2 y y') -> tD (f x y) (f x' y')@ is coassociative and natural,+-- general in all three tensors. Covariant bifunctors compared with 'Eq'.+opSemigroupalLaws ::+  forall tC1 tC2 tD f.+  ( Semigroupal Op tC1 tC2 tD f,+    Associative (->) tC1,+    Associative (->) tC2,+    Associative (->) tD,+    Bifunctor f,+    Bifunctor tC1,+    Bifunctor tC2,+    Bifunctor tD,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tD a b),+    forall a b. (Show a, Show b) => Show (tD a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC1 a b)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC2 a b)) ->+  Laws+opSemigroupalLaws genF genT1 genT2 =+  Laws+    "Semigroupal (Op)"+    [ ("Coassociativity", opCoassoc @tC1 @tC2 @tD genF genT1 genT2),+      ("Conaturality", opConaturality @tC1 @tC2 @tD genF genT1 genT2)+    ]++opCoassoc ::+  forall tC1 tC2 tD f.+  ( Semigroupal Op tC1 tC2 tD f,+    Associative (->) tC1,+    Associative (->) tC2,+    Associative (->) tD,+    Bifunctor f,+    Bifunctor tC1,+    Bifunctor tC2,+    Bifunctor tD,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tD a b),+    forall a b. (Show a, Show b) => Show (tD a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC1 a b)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC2 a b)) ->+  Property+opCoassoc genF genT1 genT2 = property $ do+  w <- forAll (genF (genT1 genInt (genT1 genInt genInt)) (genT2 genInt (genT2 genInt genInt)))+  let split :: forall x x' y y'. f (tC1 x x') (tC2 y y') -> tD (f x y) (f x' y')+      split = getOp (combine @Op @tC1 @tC2 @tD)+      lhs = grmap @(->) @(->) @(->) @tD split (split w)+      rhs =+        bwd (assoc @(->) @tD) $+          glmap @(->) @(->) @(->) @tD split (split (bimap (fwd (assoc @(->) @tC1)) (fwd (assoc @(->) @tC2)) w))+  lhs === rhs++opConaturality ::+  forall tC1 tC2 tD f.+  ( Semigroupal Op tC1 tC2 tD f,+    Associative (->) tC1,+    Associative (->) tC2,+    Associative (->) tD,+    Bifunctor f,+    Bifunctor tC1,+    Bifunctor tC2,+    Bifunctor tD,+    forall a b. (Eq a, Eq b) => Eq (f a b),+    forall a b. (Show a, Show b) => Show (f a b),+    forall a b. (Eq a, Eq b) => Eq (tD a b),+    forall a b. (Show a, Show b) => Show (tD a b),+    forall a b. (Show a, Show b) => Show (tC1 a b),+    forall a b. (Show a, Show b) => Show (tC2 a b)+  ) =>+  (forall a b. Gen a -> Gen b -> Gen (f a b)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC1 a b)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC2 a b)) ->+  Property+opConaturality genF genT1 genT2 = property $ do+  w <- forAll (genF (genT1 genInt genInt) (genT2 genInt genInt))+  let g = (+ 1) :: Int -> Int+      h = (* 2) :: Int -> Int+      split :: forall x x' y y'. f (tC1 x x') (tC2 y y') -> tD (f x y) (f x' y')+      split = getOp (combine @Op @tC1 @tC2 @tD)+  split (bimap (gbimap @(->) @(->) @(->) @tC1 g g) (gbimap @(->) @(->) @(->) @tC2 h h) w)+    === gbimap @(->) @(->) @(->) @tD (bimap g h) (bimap g h) (split w)++--------------------------------------------------------------------------------+-- Profunctors+--+-- The function-like instances ('(->)', @'Data.Profunctor.Star' f@,+-- @'Control.Arrow.Kleisli' f@, ...) are /profunctors/, not covariant bifunctors.+-- They are contravariant in the first argument, and have no 'Eq' \/ 'Show'. The laws+-- re-associate with 'dimap' (@fwd@ on the contravariant side, @bwd@ on the+-- covariant side) and are observed extensionally through a caller-supplied+-- @run@, as the contravariant-functor laws of+-- "Data.Functor.Monoidal.Laws" are. @genP@ generates (opaque) profunctor values+-- and @genT1@ builds the contravariant-side input tensor.++-- | 'combine' laws for a /profunctor/. Associativity and naturality of the+-- laxator, observed through @run@.+profunctorSemigroupalLaws ::+  forall tC1 tC2 p obs.+  ( Semigroupal (->) tC1 tC2 (,) p,+    Profunctor p,+    Associative (->) tC1,+    Associative (->) tC2,+    Eq (obs (tC2 Int (tC2 Int Int))),+    Show (obs (tC2 Int (tC2 Int Int))),+    Eq (obs (tC2 Int Int)),+    Show (obs (tC2 Int Int)),+    Show (tC1 Int (tC1 Int Int)),+    Show (tC1 Int Int)+  ) =>+  (forall a b. p a b -> a -> obs b) ->+  Gen (p Int Int) ->+  (forall x y. Gen x -> Gen y -> Gen (tC1 x y)) ->+  Laws+profunctorSemigroupalLaws run genP genT1 =+  Laws+    "Semigroupal"+    [ ( "Associativity",+        property $ do+          x <- forAllWith (const "<opaque>") genP+          y <- forAllWith (const "<opaque>") genP+          z <- forAllWith (const "<opaque>") genP+          inp <- forAll (genT1 genInt (genT1 genInt genInt))+          run (dimap (fwd (assoc @(->) @tC1)) (bwd (assoc @(->) @tC2)) (combine @(->) @tC1 @tC2 @(,) (combine @(->) @tC1 @tC2 @(,) (x, y), z))) inp+            === run (combine @(->) @tC1 @tC2 @(,) (x, combine @(->) @tC1 @tC2 @(,) (y, z))) inp+      ),+      ( "Naturality",+        property $ do+          x <- forAllWith (const "<opaque>") genP+          y <- forAllWith (const "<opaque>") genP+          inp <- forAll (genT1 genInt genInt)+          let g = (+ 1) :: Int -> Int+              h = (* 2) :: Int -> Int+          run (dimap (gbimap @(->) @(->) @(->) @tC1 g g) (gbimap @(->) @(->) @(->) @tC2 h h) (combine @(->) @tC1 @tC2 @(,) (x, y))) inp+            === run (combine @(->) @tC1 @tC2 @(,) (dimap g h x, dimap g h y)) inp+      )+    ]++-- | Left and right unit laws for a /profunctor/, observed through @run@ on a+-- generated element.+profunctorUnitalLaws ::+  forall tC1 iC1 tC2 iC2 p obs.+  ( Semigroupal (->) tC1 tC2 (,) p,+    Unital (->) iC1 iC2 () p,+    Profunctor p,+    Tensor (->) tC1 iC1,+    Tensor (->) tC2 iC2,+    Eq (obs Int),+    Show (obs Int)+  ) =>+  (forall a b. p a b -> a -> obs b) ->+  Gen (p Int Int) ->+  Laws+profunctorUnitalLaws run genP =+  Laws+    "Unital"+    [ ( "Left Unit",+        property $ do+          pab <- forAllWith (const "<opaque>") genP+          inp <- forAll genInt+          run (dimap (bwd (unitl @(->) @tC1)) (fwd (unitl @(->) @tC2)) (combine @(->) @tC1 @tC2 @(,) (introduce @(->) @iC1 @iC2 @() (), pab))) inp+            === run pab inp+      ),+      ( "Right Unit",+        property $ do+          pab <- forAllWith (const "<opaque>") genP+          inp <- forAll genInt+          run (dimap (bwd (unitr @(->) @tC1)) (fwd (unitr @(->) @tC2)) (combine @(->) @tC1 @tC2 @(,) (pab, introduce @(->) @iC1 @iC2 @() ()))) inp+            === run pab inp+      )+    ]++-- | Every 'profunctorSemigroupalLaws' and 'profunctorUnitalLaws' property+-- together, for a full profunctor 'Monoidal' instance.+profunctorMonoidalLaws ::+  forall tC1 iC1 tC2 iC2 p obs.+  ( Monoidal (->) tC1 iC1 tC2 iC2 (,) () p,+    Profunctor p,+    Eq (obs (tC2 Int (tC2 Int Int))),+    Show (obs (tC2 Int (tC2 Int Int))),+    Eq (obs (tC2 Int Int)),+    Show (obs (tC2 Int Int)),+    Eq (obs Int),+    Show (obs Int),+    Show (tC1 Int (tC1 Int Int)),+    Show (tC1 Int Int)+  ) =>+  (forall a b. p a b -> a -> obs b) ->+  Gen (p Int Int) ->+  (forall x y. Gen x -> Gen y -> Gen (tC1 x y)) ->+  Laws+profunctorMonoidalLaws run genP genT1 =+  Laws+    "Monoidal"+    ( lawsProperties (profunctorSemigroupalLaws @tC1 @tC2 run genP genT1)+        <> lawsProperties (profunctorUnitalLaws @tC1 @iC1 @tC2 @iC2 run genP)+    )

@@ -0,0 +1,543 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Reusable @hedgehog-classes@ 'Laws' for this library's monoidal-functor+-- classes, so a consumer can law-test their own 'Semigroupal' \/ 'Unital' \/+-- 'Monoidal' instances the same way they test 'Monoid' or 'Applicative':+--+-- > import Data.Functor.Monoidal.Laws (monoidalLaws)+-- > import Hedgehog.Classes (lawsCheck)+-- >+-- > main :: IO Bool+-- > main = lawsCheck (monoidalLaws @(,) @() genMyFunctor)+--+-- The 'Semigroupal' associativity and naturality laws are stated once, point-free+-- and parametric in the category @cat@ ('assocSquare', 'natSquare'). At+-- @cat = (->)@ they give the covariant laws, at @cat = 'Op'@ the colax (split)+-- laws. 'checkCov' and 'checkOp' run the two directions.+--+-- 'semigroupalLaws' \/ 'unitalLaws' \/ 'monoidalLaws' cover the covariant family,+-- general in the domain tensor @tC@ (and, for units, its unit @iC@). One+-- function handles @(,)@ (Applicative \/ Divisible), @Either@ (Alternative \/+-- Decidable), and @These@ (Semialign). 'opSemigroupalLaws' covers the @'Op'@+-- family, general in @tC@ and the split tensor @tD@. It handles the unzip+-- @f (a, b) -> (f a, f b)@ (@tD = (,)@), the @Unalign@ split+-- @f ('Data.These.These' a b) -> (f a, f b)@, and+-- @f ('Either' a b) -> 'Either' (f a) (f b)@ (@tD = 'Either'@).+--+-- The @contravariant*@ family covers contravariant functors (@Divisible@ \/+-- @Decidable@), which lack 'Eq' \/ 'Show'. Each is observed on a generated input+-- through a caller-supplied @obs :: forall a. f a -> a -> r@.+--+-- The rank-2 generator @forall x. 'Gen' x -> 'Gen' (f x)@ instantiates @f@ at the+-- element types each square needs.+module Data.Functor.Monoidal.Laws+  ( -- * Covariant functors+    semigroupalLaws,+    unitalLaws,+    monoidalLaws,++    -- * Contravariant functors+    contravariantSemigroupalLaws,+    contravariantUnitalLaws,+    contravariantMonoidalLaws,++    -- * The Op (comonoidal) laxator+    opSemigroupalLaws,+    representableSplitLaws,+  )+where++--------------------------------------------------------------------------------++import Control.Category ((.))+import Control.Category.Tensor (Associative (..), GBifunctor (gbimap), Iso (..), Tensor (..), glmap, grmap)+import Data.Functor.Contravariant (Contravariant (..), Op (..))+import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..))+import Hedgehog (Gen, Property, forAll, forAllWith, property, (===))+import Hedgehog.Classes (Laws (..))+import Hedgehog.Gen qualified as Gen+import Hedgehog.Range qualified as Range+import Prelude hiding ((.))++--------------------------------------------------------------------------------++-- | The element type the coherence squares are witnessed at.+genInt :: Gen Int+genInt = Gen.int (Range.linear (-100) 100)++genPair :: Gen a -> Gen b -> Gen (a, b)+genPair ga gb = (,) <$> ga <*> gb++--------------------------------------------------------------------------------+-- Cat-parametric coherence squares.+--+-- The associativity and naturality squares are stated once at an abstract+-- category @cat@. At @cat = (->)@ they are the covariant laws. At @cat = 'Op'@+-- they are the colax (split) laws, since @'bwd' ('assoc' \@'Op') = 'Op' ('fwd'+-- 'assoc')@. 'checkCov' and 'checkOp' run the two directions.++-- | The two parallel @cat@-morphisms a coherence law asserts equal.+data Square cat s t = Square (cat s t) (cat s t)++-- | Lift a @cat@-morphism through @f@. @'fmap'@ at @(->)@, @'fmap'@ under+-- arrow-reversal at @'Op'@.+class MapF cat f where+  mapF :: cat a b -> cat (f a) (f b)++instance (Functor f) => MapF (->) f where+  mapF = fmap++instance (Functor f) => MapF Op f where+  mapF (Op g) = Op (fmap g)++-- | Associativity of the laxator. @'combine'@ commutes with the domain and+-- codomain associators. This is the coherence square documented on 'Semigroupal'.+assocSquare ::+  forall cat tC tD f a b c.+  ( Semigroupal cat tC tD f,+    Associative cat tD,+    Associative cat tC,+    MapF cat f+  ) =>+  Square cat (tD (tD (f a) (f b)) (f c)) (f (tC a (tC b c)))+assocSquare =+  Square+    (combine @cat @tC @tD . grmap (combine @cat @tC @tD) . bwd (assoc @cat @tD))+    (mapF (bwd (assoc @cat @tC)) . combine @cat @tC @tD . glmap (combine @cat @tC @tD))++-- | Naturality of the laxator. @'combine'@ commutes with maps into either tensor.+natSquare ::+  forall cat tC tD f a a' b b'.+  ( Semigroupal cat tC tD f,+    Associative cat tD,+    Associative cat tC,+    MapF cat f+  ) =>+  cat a a' ->+  cat b b' ->+  Square cat (tD (f a) (f b)) (f (tC a' b'))+natSquare g h =+  Square+    (mapF (gbimap @cat @cat @cat @tC g h) . combine @cat @tC @tD)+    (combine @cat @tC @tD . gbimap @cat @cat @cat @tD (mapF g) (mapF h))++-- | Run a covariant square. Apply each side to a generated source, compare with+-- 'Eq'.+checkCov ::+  forall s t.+  (Eq t, Show s, Show t) =>+  Gen s ->+  Square (->) s t ->+  Property+checkCov gen (Square l r) = property $ do+  s <- forAll gen+  l s === r s++-- | Run an @'Op'@ square. Each side unwraps to a split @t -> s@. Generate the+-- input at @t@, compare the outputs at @s@.+checkOp ::+  forall s t.+  (Eq s, Show s, Show t) =>+  Gen t ->+  Square Op s t ->+  Property+checkOp gen (Square (Op l) (Op r)) = property $ do+  t <- forAll gen+  l t === r t++--------------------------------------------------------------------------------++-- | 'combine' laws. It commutes with the codomain tensor's associator+-- (associativity) and with maps into it (naturality of the laxator).+semigroupalLaws ::+  forall tC f.+  ( Semigroupal (->) tC (,) f,+    Associative (->) tC,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tC a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Laws+semigroupalLaws genF =+  Laws+    "Semigroupal"+    [ ("Associativity", semigroupalAssoc @tC genF),+      ("Naturality", semigroupalNaturality @tC genF)+    ]++semigroupalNaturality ::+  forall tC f.+  ( Semigroupal (->) tC (,) f,+    Associative (->) tC,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tC a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Property+semigroupalNaturality genF =+  checkCov+    (genPair (genF genInt) (genF genInt))+    (natSquare @(->) @tC @(,) ((+ 1) :: Int -> Int) ((* 2) :: Int -> Int))++semigroupalAssoc ::+  forall tC f.+  ( Semigroupal (->) tC (,) f,+    Associative (->) tC,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tC a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Property+semigroupalAssoc genF =+  checkCov+    (genPair (genPair (genF genInt) (genF genInt)) (genF genInt))+    (assocSquare @(->) @tC @(,))++--------------------------------------------------------------------------------++-- | Left and right unit laws. 'introduce' is a unit for 'combine', up to the+-- codomain tensor's unitors.+unitalLaws ::+  forall tC iC f.+  ( Semigroupal (->) tC (,) f,+    Unital (->) iC () f,+    Tensor (->) tC iC,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Laws+unitalLaws genF =+  Laws+    "Unital"+    [ ("Left Unit", unitalLeft @tC @iC genF),+      ("Right Unit", unitalRight @tC @iC genF)+    ]++unitalLeft ::+  forall tC iC f.+  ( Semigroupal (->) tC (,) f,+    Unital (->) iC () f,+    Tensor (->) tC iC,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Property+unitalLeft genF = property $ do+  fa <- forAll (genF genInt)+  fmap (fwd (unitl @(->) @tC)) (combine @(->) @tC @(,) (introduce @(->) @iC @() (), fa)) === fa++unitalRight ::+  forall tC iC f.+  ( Semigroupal (->) tC (,) f,+    Unital (->) iC () f,+    Tensor (->) tC iC,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Property+unitalRight genF = property $ do+  fa <- forAll (genF genInt)+  fmap (fwd (unitr @(->) @tC)) (combine @(->) @tC @(,) (fa, introduce @(->) @iC @() ())) === fa++--------------------------------------------------------------------------------++-- | Every 'semigroupalLaws' and 'unitalLaws' property together, for a full+-- 'Monoidal' instance.+monoidalLaws ::+  forall tC iC f.+  ( Monoidal (->) tC iC (,) () f,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tC a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Laws+monoidalLaws genF =+  Laws+    "Monoidal"+    ( lawsProperties (semigroupalLaws @tC genF)+        <> lawsProperties (unitalLaws @tC @iC genF)+    )++--------------------------------------------------------------------------------++-- | Laws for the /Op/ (comonoidal) laxator @'combine' \@'Op'@, the split+-- @f (a \`tC\` b) -> tD (f a) (f b)@. General in the domain tensor @tC@ and the+-- split tensor @tD@. It builds the same 'assocSquare' \/ 'natSquare' as+-- 'semigroupalLaws' and runs them through 'checkOp'. One function covers every+-- shipped @'Op'@ 'Semigroupal' instance. The unzip @f (a, b) -> (f a, f b)@+-- (@tD = (,)@), the @Unalign@ split @f ('Data.These.These' a b) -> (f a, f b)@,+-- and @f ('Either' a b) -> 'Either' (f a) (f b)@ (@tD = 'Either'@). @genT@ builds+-- the @tC@-shaped payloads the split consumes. Covariant functors only.+opSemigroupalLaws ::+  forall tC tD f.+  ( Semigroupal Op tC tD f,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tD a b),+    forall a b. (Show a, Show b) => Show (tD a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  Laws+opSemigroupalLaws genF genT =+  Laws+    "Semigroupal (Op)"+    [ ("Coassociativity", opCoassoc @tC @tD genF genT),+      ("Conaturality", opConaturality @tC @tD genF genT)+    ]++opCoassoc ::+  forall tC tD f.+  ( Semigroupal Op tC tD f,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tD a b),+    forall a b. (Show a, Show b) => Show (tD a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  Property+opCoassoc genF genT =+  checkOp+    (genF (genT genInt (genT genInt genInt)))+    (assocSquare @Op @tC @tD)++opConaturality ::+  forall tC tD f.+  ( Semigroupal Op tC tD f,+    Functor f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x),+    forall a b. (Eq a, Eq b) => Eq (tD a b),+    forall a b. (Show a, Show b) => Show (tD a b),+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  Property+opConaturality genF genT =+  checkOp+    (genF (genT genInt genInt))+    (natSquare @Op @tC @tD (Op ((+ 1) :: Int -> Int)) (Op ((* 2) :: Int -> Int)))++--------------------------------------------------------------------------------++-- | Coherence between the covariant @'combine'@ and the @'Op'@ split. They are+-- mutually inverse. This holds when the split inverts the product @combine@, for+-- representable functors (those deriving via @FromRepresentable@). It is /not/+-- satisfied by the standalone @FromGeneric@ unzip on a non-representable functor,+-- whose cartesian @combine@ the unzip does not invert.+representableSplitLaws ::+  forall f.+  ( Semigroupal (->) (,) (,) f,+    Semigroupal Op (,) (,) f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Laws+representableSplitLaws genF =+  Laws+    "Semigroupal (Op) coherence"+    [ ("split . combine", splitAfterCombine genF),+      ("combine . split", combineAfterSplit genF)+    ]++splitAfterCombine ::+  forall f.+  ( Semigroupal (->) (,) (,) f,+    Semigroupal Op (,) (,) f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Property+splitAfterCombine genF = property $ do+  x <- forAll (genF genInt)+  y <- forAll (genF genInt)+  getOp (combine @Op @(,) @(,)) (combine @(->) @(,) @(,) (x, y)) === (x, y)++combineAfterSplit ::+  forall f.+  ( Semigroupal (->) (,) (,) f,+    Semigroupal Op (,) (,) f,+    forall x. (Eq x) => Eq (f x),+    forall x. (Show x) => Show (f x)+  ) =>+  (forall x. Gen x -> Gen (f x)) ->+  Property+combineAfterSplit genF = property $ do+  xy <- forAll (genF (genPair genInt genInt))+  combine @(->) @(,) @(,) (getOp (combine @Op @(,) @(,)) xy) === xy++--------------------------------------------------------------------------------++-- | 'combine' laws for a /contravariant/ functor. Associativity and naturality+-- of the laxator. Since contravariant functors (@Divisible@, @Decidable@)+-- generally are not 'Eq' \/ 'Show', the two sides are observed through @obs@ on+-- a generated element of the codomain tensor. @genT@ is a tensor builder, such as+-- @\\ga gb -> (,) '<$>' ga '<*>' gb@ for @(,)@, or+-- @\\ga gb -> 'Gen.choice' [Left '<$>' ga, Right '<$>' gb]@ for @Either@. It+-- assembles the associativity and naturality observation points.+contravariantSemigroupalLaws ::+  forall tC f r.+  ( Semigroupal (->) tC (,) f,+    Contravariant f,+    Associative (->) tC,+    Eq r,+    Show r,+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  Gen (f Int) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  (forall a. f a -> a -> r) ->+  Laws+contravariantSemigroupalLaws genF genT obs =+  Laws+    "Semigroupal"+    [ ("Associativity", contravariantAssoc @tC genF genT obs),+      ("Naturality", contravariantNaturality @tC genF genT obs)+    ]++contravariantAssoc ::+  forall tC f r.+  ( Semigroupal (->) tC (,) f,+    Contravariant f,+    Associative (->) tC,+    Eq r,+    Show r,+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  Gen (f Int) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  (forall a. f a -> a -> r) ->+  Property+contravariantAssoc genF genT obs = property $ do+  x <- forAllWith (const "<opaque>") genF+  y <- forAllWith (const "<opaque>") genF+  z <- forAllWith (const "<opaque>") genF+  t <- forAll (genT genInt (genT genInt genInt))+  obs (contramap (fwd (assoc @(->) @tC)) (combine @(->) @tC @(,) (combine @(->) @tC @(,) (x, y), z))) t+    === obs (combine @(->) @tC @(,) (x, combine @(->) @tC @(,) (y, z))) t++contravariantNaturality ::+  forall tC f r.+  ( Semigroupal (->) tC (,) f,+    Contravariant f,+    Associative (->) tC,+    Eq r,+    Show r,+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  Gen (f Int) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  (forall a. f a -> a -> r) ->+  Property+contravariantNaturality genF genT obs = property $ do+  x <- forAllWith (const "<opaque>") genF+  y <- forAllWith (const "<opaque>") genF+  t <- forAll (genT genInt genInt)+  let g = (+ 1) :: Int -> Int+      h = (* 2) :: Int -> Int+  obs (contramap (gbimap @(->) @(->) @(->) @tC g h) (combine @(->) @tC @(,) (x, y))) t+    === obs (combine @(->) @tC @(,) (contramap g x, contramap h y)) t++-- | Left and right unit laws for a /contravariant/ functor, observed through+-- @obs@ at a generated element. The unit laws need no tensor-shaped input.+contravariantUnitalLaws ::+  forall tC iC f r.+  ( Semigroupal (->) tC (,) f,+    Unital (->) iC () f,+    Contravariant f,+    Tensor (->) tC iC,+    Eq r,+    Show r+  ) =>+  Gen (f Int) ->+  (forall a. f a -> a -> r) ->+  Laws+contravariantUnitalLaws genF obs =+  Laws+    "Unital"+    [ ("Left Unit", contravariantUnitL @tC @iC genF obs),+      ("Right Unit", contravariantUnitR @tC @iC genF obs)+    ]++contravariantUnitL ::+  forall tC iC f r.+  ( Semigroupal (->) tC (,) f,+    Unital (->) iC () f,+    Contravariant f,+    Tensor (->) tC iC,+    Eq r,+    Show r+  ) =>+  Gen (f Int) ->+  (forall a. f a -> a -> r) ->+  Property+contravariantUnitL genF obs = property $ do+  x <- forAllWith (const "<opaque>") genF+  a <- forAll genInt+  obs (contramap (bwd (unitl @(->) @tC)) (combine @(->) @tC @(,) (introduce @(->) @iC @() (), x))) a+    === obs x a++contravariantUnitR ::+  forall tC iC f r.+  ( Semigroupal (->) tC (,) f,+    Unital (->) iC () f,+    Contravariant f,+    Tensor (->) tC iC,+    Eq r,+    Show r+  ) =>+  Gen (f Int) ->+  (forall a. f a -> a -> r) ->+  Property+contravariantUnitR genF obs = property $ do+  x <- forAllWith (const "<opaque>") genF+  a <- forAll genInt+  obs (contramap (bwd (unitr @(->) @tC)) (combine @(->) @tC @(,) (x, introduce @(->) @iC @() ()))) a+    === obs x a++-- | Every 'contravariantSemigroupalLaws' and 'contravariantUnitalLaws' property+-- together, for a full contravariant 'Monoidal' instance.+contravariantMonoidalLaws ::+  forall tC iC f r.+  ( Monoidal (->) tC iC (,) () f,+    Contravariant f,+    Eq r,+    Show r,+    forall a b. (Show a, Show b) => Show (tC a b)+  ) =>+  Gen (f Int) ->+  (forall a b. Gen a -> Gen b -> Gen (tC a b)) ->+  (forall a. f a -> a -> r) ->+  Laws+contravariantMonoidalLaws genF genT obs =+  Laws+    "Monoidal"+    ( lawsProperties (contravariantSemigroupalLaws @tC genF genT obs)+        <> lawsProperties (contravariantUnitalLaws @tC @iC genF obs)+    )

@@ -1,7 +1,7 @@-cabal-version:       2.4+cabal-version:       3.0 name:                monoidal-functors category:            Control, Categories-version:             0.2.3.0+version:             0.3.0.0 license:             MIT license-file:        LICENSE author:              Solomon Bothwell & Asad Saeeduddin@@ -10,13 +10,15 @@ synopsis:            Monoidal Functors Library homepage:            http://github.com/solomon-b/monoidal-functors build-type:          Simple-extra-source-files:  CHANGELOG.md+extra-doc-files:     CHANGELOG.md description:         A typeclass hierarchy for monoidal functors.-tested-with:   GHC == 8.10.7-             , GHC == 9.0.2-             , GHC == 9.2.4-             , GHC == 9.4.5-             , GHC == 9.6.2+tested-with:+    GHC == 9.2.8,+    GHC == 9.4.8,+    GHC == 9.6.7,+    GHC == 9.8.4,+    GHC == 9.10.3,+    GHC == 9.12.4, source-repository head   type:     git   location: https://github.com/solomon-b/monoidal-functors@@ -54,16 +56,18 @@   build-depends:     base                          >= 4.12 && < 5,     bifunctors                    >= 5.6.1 && < 6,-    tagged                        >= 0.8.7 && < 0.9,+    kindly-functors               >= 0.2 && < 0.3,+    tagged                        >= 0.8.7 && < 0.10,     transformers                  >= 0.5.6 && < 0.7,     comonad                       >= 5.0.8 && < 6,     distributive                  >= 0.6.2 && < 0.7,     contravariant                 >= 1.5.5 && < 1.6,     profunctors                   >= 5.6.2 && < 5.7,-    semialign                     >= 1.3 && < 1.4,+    semialign                     >= 1.3 && < 1.5,     semigroupoids                 >= 6.0.0 && < 6.1,     these                         >= 1.2 && < 1.3,     mtl                           >= 2.2.2 && < 2.4,+    kind-generics                 >= 0.5 && < 0.6,    exposed-modules:     Control.Category.Tensor@@ -73,11 +77,18 @@     Data.Bifunctor.Module     Data.Bifunctor.Monoidal     Data.Bifunctor.Monoidal.Specialized+    Data.Bifunctor.Rank2.Monoidal+    Data.Bifunctor.Rank2.Traversable     Data.Functor.Invariant     Data.Functor.Module     Data.Functor.Monoidal+    Data.Functor.Monoidal.Generic+    Data.Functor.Monoidal.Specialized+    Data.Functor.Rank2.Monoidal+    Data.Functor.Rank2.Traversable     Data.Trifunctor.Module     Data.Trifunctor.Monoidal+    Data.Trifunctor.Rank2.Traversable    ghc-options:     -Wall@@ -92,17 +103,75 @@   hs-source-dirs: src    default-language: Haskell2010-  + -------------------------------------------------------------------------------- +library laws+  import:            common-extensions+  visibility:        public+  hs-source-dirs:    laws+  exposed-modules:   Control.Category.Cartesian.Laws+                     Control.Category.Tensor.Laws+                     Data.Bifunctor.Monoidal.Laws+                     Data.Functor.Monoidal.Laws+  other-modules:     Control.Category.Laws.Internal+  build-depends:+    base,+    monoidal-functors,+    hedgehog                      >= 1.5 && < 1.6,+    hedgehog-classes              >= 0.2 && < 0.3,+    profunctors,+  default-language:  Haskell2010++--------------------------------------------------------------------------------+ executable co-log   import: common-extensions   hs-source-dirs:    examples/co-log   main-is:           Main.hs-  build-depends:     base-                   , bifunctors-                   , contravariant-                   , distributive-                   , monoidal-functors-                   , mtl+  build-depends:+    base,+    bifunctors,+    contravariant,+    distributive,+    monoidal-functors,+    mtl,+  default-language: Haskell2010++--------------------------------------------------------------------------------++test-suite spec+  import:            common-extensions+  type:              exitcode-stdio-1.0+  hs-source-dirs:    test+  main-is:           Main.hs+  other-modules:     Control.Category.CartesianSpec+                     Control.Category.LawsSupport+                     Control.Category.TensorSpec+                     Data.Bifunctor.Monoidal.LawsSpec+                     Data.Bifunctor.Rank2.MonoidalSpec+                     Data.Bifunctor.Rank2.TraversableSpec+                     Data.Functor.Monoidal.GenericSpec+                     Data.Functor.Monoidal.LawsSpec+                     Data.Functor.Rank2.MonoidalSpec+                     Data.Functor.Rank2.TraversableSpec+                     Data.Trifunctor.Rank2.TraversableSpec+  build-depends:+    base,+    bifunctors,+    contravariant,+    distributive,+    hedgehog,+    hedgehog-classes,+    kind-generics,+    kind-generics-th,+    kindly-functors,+    monoidal-functors,+    monoidal-functors:laws,+    profunctors,+    tagged,+    these,+    transformers,+  ghc-options:+    -Wall   default-language: Haskell2010

@@ -25,6 +25,13 @@  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Void (Void)++--------------------------------------------------------------------------------+ -- | A 'Category' is 'Semicartesian' if it is equipped with a -- 'Symmetric' bifunctor @t@ and each object comes equipped with a -- <https://ncatlab.org/nlab/show/diagonal+morphism diagonal morphism>@@ -36,7 +43,7 @@ -- 'Control.Category.Tensor.grmap' 'split' '.' 'split' ≡ 'bwd' 'Control.Category.Tensor.assoc' '.' 'Control.Category.Tensor.glmap' 'split' '.' 'split' -- 'Control.Category.Tensor.glmap' 'split' '.' 'split' ≡ 'fwd' 'Control.Category.Tensor.assoc' '.' 'Control.Category.Tensor.grmap' 'split' '.' 'split' -- @-class Symmetric cat t => Semicartesian cat t where+class (Symmetric cat t) => Semicartesian cat t where   -- | The <https://ncatlab.org/nlab/show/diagonal+morphism diagonal morphism> of @a@ in @cat@. We can think of 'split'   -- as duplicating data.   --@@ -64,15 +71,15 @@ -- | Infix version of 'fork'. infixr 9 /\ -(/\) :: Semicartesian cat t => cat a x -> cat a y -> cat a (x `t` y)+(/\) :: (Semicartesian cat t) => cat a x -> cat a y -> cat a (x `t` y) (/\) = fork  instance Semicartesian (->) (,) where   split :: a -> (a, a)   split a = (a, a) -instance Semicocartesian (->) t => Semicartesian Op t where-  split :: Semicocartesian (->) t => Op a (t a a)+instance (Semicocartesian (->) t) => Semicartesian Op t where+  split :: (Semicocartesian (->) t) => Op a (t a a)   split = Op merge  --------------------------------------------------------------------------------@@ -87,7 +94,7 @@ -- 'merge' '.' 'Control.Category.Tensor.grmap' 'merge' ≡ 'merge' . 'Control.Category.Tensor.glmap' 'merge' '.' 'fwd' 'Control.Category.Tensor.assoc' -- 'merge' '.' 'Control.Category.Tensor.glmap' 'merge' ≡ 'merge' . 'Control.Category.Tensor.grmap' 'merge' '.' 'bwd' 'Control.Category.Tensor.assoc' -- @-class Symmetric cat t => Semicocartesian cat t where+class (Symmetric cat t) => Semicocartesian cat t where   -- | The <https://ncatlab.org/nlab/show/codiagonal co-diagonal morphism> of @a@ in @cat@.   --   -- ==== __Examples__@@ -103,6 +110,12 @@   -- universal map @cat (x \`t\` y) a@.   --   -- ==== __Examples__+  --+  -- >>> fuse @(->) @Either (show @Bool) (show @Int) (Left True)+  -- "True"+  --+  -- >>> fuse @(->) @Either (show @Bool) (show @Int) (Right 42)+  -- "42"   fuse :: cat x a -> cat y a -> cat (x `t` y) a   fuse f g = f # g >>> merge @@ -111,15 +124,15 @@ -- | Infix version of 'fuse'. infixr 9 \/ -(\/) :: Semicocartesian cat t => cat x a -> cat y a -> cat (x `t` y) a+(\/) :: (Semicocartesian cat t) => cat x a -> cat y a -> cat (x `t` y) a (\/) = fuse  instance Semicocartesian (->) Either where   merge :: Either a a -> a   merge = either id id -instance Semicartesian (->) t => Semicocartesian Op t where-  merge :: Semicartesian (->) t => Op (t a a) a+instance (Semicartesian (->) t) => Semicocartesian Op t where+  merge :: (Semicartesian (->) t) => Op (t a a) a   merge = Op split  --------------------------------------------------------------------------------@@ -164,6 +177,10 @@   -- | Given the universal map @cat a (x `t` y)@, construct morphisms @cat a x@ and @cat a y@.   --   -- ==== __Examples__+  --+  -- >>> let (f, g) = unfork @(->) @(,) (\b -> (b, not b))+  -- >>> (f True, g True)+  -- (True,False)   unfork :: cat a (x `t` y) -> (cat a x, cat a y)   unfork h = (h >>> projl, h >>> projr) @@ -173,8 +190,8 @@   kill :: a -> ()   kill = const () -instance Cocartesian (->) t i => Cartesian Op t i where-  kill :: Cocartesian (->) t i => Op a i+instance (Cocartesian (->) t i) => Cartesian Op t i where+  kill :: (Cocartesian (->) t i) => Op a i   kill = Op spawn  --------------------------------------------------------------------------------@@ -190,32 +207,41 @@ -- @ class (Semicocartesian cat t, Tensor cat t i) => Cocartesian cat t i | i -> t, t -> i where   -- | A morphism from the initial object @i@ in @cat@ to @a@.-  ---  -- ==== __Examples__   spawn :: cat i a    -- | The left inclusion for @t@.   --   -- ==== __Examples__+  --+  -- >>> incll @(->) @Either @Void True :: Either Bool ()+  -- Left True   incll :: cat x (x `t` y)   incll = bwd unitr >>> id # spawn    -- | The right inclusion for @t@.   --   -- ==== __Examples__+  --+  -- >>> inclr @(->) @Either @Void True :: Either () Bool+  -- Right True   inclr :: cat y (x `t` y)   inclr = bwd unitl >>> spawn # id    -- | Given the universal map @cat (x `t` y) a@, construct morphisms @cat x a@ and @cat y a@.   --   -- ==== __Examples__+  --+  -- >>> let h = either not not :: Either Bool Bool -> Bool+  -- >>> let (f, g) = unfuse @(->) @Either @Void h+  -- >>> (f True, g False)+  -- (False,True)   unfuse :: cat (x `t` y) a -> (cat x a, cat y a)   unfuse h = (incll >>> h, inclr >>> h)    {-# MINIMAL spawn #-} -instance Cartesian (->) t i => Cocartesian Op t i where-  spawn :: Cartesian (->) t i => Op i a+instance (Cartesian (->) t i) => Cocartesian Op t i where+  spawn :: (Cartesian (->) t i) => Op i a   spawn = Op kill  instance Cocartesian (->) Either Void where

@@ -31,10 +31,18 @@ import Data.Profunctor (Profunctor (..), Star (..)) import Data.These (These (..), these) import Data.Void (Void, absurd)-import Prelude hiding (id, (.))+import Prelude hiding (Applicative (..), id, (.))  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Void (Void)+-- >>> import Data.Functor.Contravariant (Op (..))++--------------------------------------------------------------------------------+ -- | An invertible mapping between 'a' and 'b' in category 'cat'. -- -- === Laws@@ -45,7 +53,7 @@ -- @ data Iso cat a b = Iso {fwd :: cat a b, bwd :: cat b a} -instance Category cat => Category (Iso cat) where+instance (Category cat) => Category (Iso cat) where   id :: Iso cat a a   id = Iso id id @@ -88,24 +96,39 @@   gbimap :: cat1 a b -> cat2 c d -> cat3 (a `t` c) (b `t` d)  -- | Infix operator for 'gbimap'.+--+-- ==== __Examples__+--+-- >>> (#) @(->) @(->) @(->) @(,) show not (123 :: Int, False)+-- ("123",True) infixr 9 # -(#) :: GBifunctor cat1 cat2 cat3 t => cat1 a b -> cat2 c d -> cat3 (a `t` c) (b `t` d)+(#) :: (GBifunctor cat1 cat2 cat3 t) => cat1 a b -> cat2 c d -> cat3 (a `t` c) (b `t` d) (#) = gbimap  -- | Covariantally map over the right variable.-grmap :: GBifunctor cat1 cat2 cat3 t => cat2 c d -> cat3 (a `t` c) (a `t` d)+--+-- ==== __Examples__+--+-- >>> grmap @(->) @(->) @(->) @(,) not (123 :: Int, False)+-- (123,True)+grmap :: (GBifunctor cat1 cat2 cat3 t) => cat2 c d -> cat3 (a `t` c) (a `t` d) grmap = (#) id  -- | Covariantally map over the left variable.-glmap :: GBifunctor cat1 cat2 cat3 t => cat1 a b -> cat3 (a `t` c) (b `t` c)+--+-- ==== __Examples__+--+-- >>> glmap @(->) @(->) @(->) @(,) show (123 :: Int, False)+-- ("123",False)+glmap :: (GBifunctor cat1 cat2 cat3 t) => cat1 a b -> cat3 (a `t` c) (b `t` c) glmap = flip (#) id -instance GBifunctor (->) (->) (->) t => GBifunctor Op Op Op t where+instance (GBifunctor (->) (->) (->) t) => GBifunctor Op Op Op t where   gbimap :: Op a b -> Op c d -> Op (t a c) (t b d)   gbimap (Op f) (Op g) = Op $ gbimap f g -instance Bifunctor t => GBifunctor (->) (->) (->) t where+instance (Bifunctor t) => GBifunctor (->) (->) (->) t where   gbimap = bimap  instance GBifunctor (Star Maybe) (Star Maybe) (Star Maybe) These where@@ -124,7 +147,7 @@       That c -> That <$> g c       These a c -> liftA2 These (f a) (g c) -instance GBifunctor cat cat cat t => GBifunctor (Iso cat) (Iso cat) (Iso cat) t where+instance (GBifunctor cat cat cat t) => GBifunctor (Iso cat) (Iso cat) (Iso cat) t where   gbimap :: Iso cat a b -> Iso cat c d -> Iso cat (t a c) (t b d)   gbimap iso1 iso2 = Iso (gbimap (fwd iso1) (fwd iso2)) (gbimap (bwd iso1) (bwd iso2)) @@ -148,14 +171,11 @@   --   -- ==== __Examples__   ---  -- >>> :t assoc @(->) @(,)-  -- assoc @(->) @(,) :: Iso (->) (a, (b, c)) ((a, b), c)-  --   -- >>> fwd (assoc @(->) @(,)) (1, ("hello", True))   -- ((1,"hello"),True)   assoc :: Iso cat (a `t` (b `t` c)) ((a `t` b) `t` c) -instance Associative (->) t => Associative Op t where+instance (Associative (->) t) => Associative Op t where   assoc :: Iso Op (a `t` (b `t` c)) ((a `t` b) `t` c)   assoc =     Iso@@ -181,11 +201,22 @@  instance Associative (->) These where   assoc :: Iso (->) (These a (These b c)) (These (These a b) c)-  assoc =-    Iso-      { fwd = these (This . This) (glmap That) (glmap . These),-        bwd = these (grmap This) (That . That) (flip $ grmap . flip These)-      }+  assoc = Iso fwdThese bwdThese+    where+      fwdThese (This a) = This (This a)+      fwdThese (That (This b)) = This (That b)+      fwdThese (That (That c)) = That c+      fwdThese (That (These b c)) = These (That b) c+      fwdThese (These a (This b)) = This (These a b)+      fwdThese (These a (That c)) = These (This a) c+      fwdThese (These a (These b c)) = These (These a b) c+      bwdThese (This (This a)) = This a+      bwdThese (This (That b)) = That (This b)+      bwdThese (This (These a b)) = These a (This b)+      bwdThese (That c) = That (That c)+      bwdThese (These (This a) c) = These a (That c)+      bwdThese (These (That b) c) = That (These b c)+      bwdThese (These (These a b) c) = These a (These b c)  instance (Monad m, Associative (->) t, GBifunctor (Star m) (Star m) (Star m) t) => Associative (Star m) t where   assoc :: Iso (Star m) (a `t` (b `t` c)) ((a `t` b) `t` c)@@ -222,7 +253,7 @@ -- 'fwd' 'unitl' (i ⊗ a) ≡ a -- 'bwd' 'unitl' a ≡ (i ⊗ a) -- @-class Associative cat t => Tensor cat t i | t -> i where+class (Associative cat t) => Tensor cat t i | t -> i where   -- | The <https://ncatlab.org/nlab/show/natural+isomorphism natural isomorphism> between @(i \`t\` a)@ and @a@.   --   -- ==== __Examples__@@ -358,14 +389,11 @@ -- @ -- 'swap' '.' 'swap' ≡ 'id' -- @-class Associative cat t => Symmetric cat t where+class (Associative cat t) => Symmetric cat t where   -- | @swap@ is a symmetry isomorphism for @t@   --   -- ==== __Examples__   ---  -- >>> :t swap @(->) @(,)-  -- swap @(->) @(,) :: (a, b) -> (b, a)-  --   -- >>> swap @(->) @(,) (True, "hello")   -- ("hello",True)   --@@ -376,7 +404,7 @@   -- Right True   swap :: cat (a `t` b) (b `t` a) -instance Symmetric (->) t => Symmetric Op t where+instance (Symmetric (->) t) => Symmetric Op t where   swap :: Op (a `t` b) (b `t` a)   swap = Op swap 

@@ -25,6 +25,14 @@  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -XDataKinds+-- >>> import Prelude+-- >>> import Data.Void (Void)+-- >>> import Data.These (These (..))++--------------------------------------------------------------------------------+ -- | -- -- __Examples:__@@ -50,11 +58,11 @@  newtype Tensored t i xs = Tensored {getTensored :: MConcat t i xs} -deriving newtype instance Show (MConcat t i xs) => Show (Tensored t i xs)+deriving newtype instance (Show (MConcat t i xs)) => Show (Tensored t i xs) -deriving newtype instance Eq (MConcat t i xs) => Eq (Tensored t i xs)+deriving newtype instance (Eq (MConcat t i xs)) => Eq (Tensored t i xs) -deriving newtype instance Ord (MConcat t i xs) => Ord (Tensored t i xs)+deriving newtype instance (Ord (MConcat t i xs)) => Ord (Tensored t i xs)  -------------------------------------------------------------------------------- @@ -64,10 +72,10 @@   (x ': xs) ++ ys = x ': (xs ++ ys)  class AppendTensored xs where-  appendTensored :: Tensor (->) t i => Tensored t i xs `t` Tensored t i ys -> Tensored t i (xs ++ ys)+  appendTensored :: (Tensor (->) t i) => Tensored t i xs `t` Tensored t i ys -> Tensored t i (xs ++ ys)  instance AppendTensored '[] where   appendTensored = fwd unitl . glmap getTensored -instance AppendTensored xs => AppendTensored (x ': xs) where+instance (AppendTensored xs) => AppendTensored (x ': xs) where   appendTensored = Tensored . grmap (getTensored . appendTensored @xs . glmap Tensored) . bwd assoc . glmap getTensored

@@ -44,6 +44,13 @@  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Control.Category.Tensor (Iso (..), fwd)++--------------------------------------------------------------------------------+ -- | A bifunctor is 'BiInvariant' if it is parametric in both its type -- parameters. --@@ -74,34 +81,39 @@   biinvmap :: (a' -> a) -> (a -> a') -> (b' -> b) -> (b -> b') -> p a b -> p a' b'  -- | BiInvariant witnesses an Isomorphism-biinvIso :: BiInvariant p => Iso (->) a a' -> Iso (->) b b' -> Iso (->) (p a b) (p a' b')+--+-- ==== __Examples__+--+-- >>> fwd (biinvIso @(,) (Iso (read @Int) show) (Iso (read @Bool) show)) ("10", "True")+-- (10,True)+biinvIso :: (BiInvariant p) => Iso (->) a a' -> Iso (->) b b' -> Iso (->) (p a b) (p a' b') biinvIso (Iso f f') (Iso g g') = Iso (biinvmap f' f g' g) (biinvmap f f' g g')  -- | Boilerplate newtype to derive 'BiInvariant' for any 'Profunctor'. newtype FromProfunctor p a b = FromProfunctor {runPro :: p a b} -instance Profunctor p => BiInvariant (FromProfunctor p) where+instance (Profunctor p) => BiInvariant (FromProfunctor p) where   biinvmap :: (a' -> a) -> (a -> a') -> (b' -> b) -> (b -> b') -> FromProfunctor p a b -> FromProfunctor p a' b'   biinvmap f _ _ g = FromProfunctor . dimap f g . runPro  -- | Boilerplate newtype to derive 'BiInvariant' for any 'Bifunctor'. newtype FromBifunctor p a b = FromBifunctor {runBi :: p a b} -instance Bifunctor p => BiInvariant (FromBifunctor p) where+instance (Bifunctor p) => BiInvariant (FromBifunctor p) where   biinvmap :: (a' -> a) -> (a -> a') -> (b' -> b) -> (b -> b') -> FromBifunctor p a b -> FromBifunctor p a' b'   biinvmap _ f _ g = FromBifunctor . bimap f g . runBi  -- | Boilerplate newtype to derive 'BiInvariant' for any 'Contravariant'. newtype FromContra f a = FromContra {runContra :: f a} -instance Contravariant f => Contravariant (FromContra f) where-  contramap :: Contravariant f => (a' -> a) -> FromContra f a -> FromContra f a'+instance (Contravariant f) => Contravariant (FromContra f) where+  contramap :: (Contravariant f) => (a' -> a) -> FromContra f a -> FromContra f a'   contramap f = FromContra . contramap f . runContra  newtype FromFunctor f a = FromFunctor (f a)   deriving (Functor) -type Coercible1 f = ((forall a b. Coercible a b => Coercible (f a) (f b)) :: Constraint)+type Coercible1 f = ((forall a b. (Coercible a b) => Coercible (f a) (f b)) :: Constraint)  type Coercible2 f = (forall a b c d. (Coercible a b, Coercible c d) => Coercible (f a c) (f b d) :: Constraint) @@ -111,23 +123,23 @@  deriving via (FromProfunctor (Cayley f q)) instance (Functor f, Profunctor q) => BiInvariant (Cayley f q) -deriving via (FromProfunctor (Closure p)) instance Profunctor p => BiInvariant (Closure p)+deriving via (FromProfunctor (Closure p)) instance (Profunctor p) => BiInvariant (Closure p) -deriving via (FromProfunctor (Clown f :: * -> * -> *)) instance Contravariant f => BiInvariant (Clown (FromContra f) :: * -> * -> *)+deriving via (FromProfunctor (Clown f :: * -> * -> *)) instance (Contravariant f) => BiInvariant (Clown (FromContra f) :: * -> * -> *) -deriving via (FromProfunctor (Codensity p)) instance Profunctor p => BiInvariant (Codensity p)+deriving via (FromProfunctor (Codensity p)) instance (Profunctor p) => BiInvariant (Codensity p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => BiInvariant (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => BiInvariant (CofreeMapping p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => BiInvariant (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => BiInvariant (CofreeTraversing p) -deriving via (FromProfunctor (Cokleisli w)) instance Functor w => BiInvariant (Cokleisli w)+deriving via (FromProfunctor (Cokleisli w)) instance (Functor w) => BiInvariant (Cokleisli w)  deriving via (FromProfunctor (Copastro p)) instance BiInvariant (Copastro p)  deriving via (FromProfunctor (CopastroSum p)) instance BiInvariant (CopastroSum p) -deriving via (FromProfunctor (Costar f)) instance Functor f => BiInvariant (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Functor f) => BiInvariant (Costar f)  deriving via (FromProfunctor (Cotambara p)) instance BiInvariant (Cotambara p) @@ -143,9 +155,9 @@  deriving via (FromProfunctor (FreeTraversing p)) instance BiInvariant (FreeTraversing p) -deriving via (FromProfunctor (Joker f :: * -> * -> *)) instance Functor f => BiInvariant (Joker (FromContra f) :: * -> * -> *)+deriving via (FromProfunctor (Joker f :: * -> * -> *)) instance (Functor f) => BiInvariant (Joker (FromContra f) :: * -> * -> *) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => BiInvariant (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => BiInvariant (Kleisli m)  deriving via (FromProfunctor (Pastro p)) instance BiInvariant (Pastro p) @@ -159,21 +171,21 @@  deriving via (FromProfunctor (Rift p q)) instance (Profunctor p, Profunctor q) => BiInvariant (Rift p q) -deriving via (FromProfunctor (Star f)) instance Functor f => BiInvariant (Star (FromFunctor f))+deriving via (FromProfunctor (Star f)) instance (Functor f) => BiInvariant (Star (FromFunctor f)) -deriving via (FromProfunctor (Star f)) instance Functor f => BiInvariant (Star (FromContra f))+deriving via (FromProfunctor (Star f)) instance (Functor f) => BiInvariant (Star (FromContra f))  deriving via (FromProfunctor (Sum p q)) instance (Profunctor p, Profunctor q) => BiInvariant (Sum (FromProfunctor p) (FromProfunctor q))  deriving via (FromProfunctor (Tagged :: * -> * -> *)) instance BiInvariant (Tagged :: * -> * -> *) -deriving via (FromProfunctor (Tambara p)) instance Profunctor p => BiInvariant (Tambara p)+deriving via (FromProfunctor (Tambara p)) instance (Profunctor p) => BiInvariant (Tambara p) -deriving via (FromProfunctor (TambaraSum p)) instance Profunctor p => BiInvariant (TambaraSum p)+deriving via (FromProfunctor (TambaraSum p)) instance (Profunctor p) => BiInvariant (TambaraSum p)  deriving via (FromProfunctor (Tannen f q)) instance (Functor f, Profunctor q) => BiInvariant (Tannen f q) -deriving via (FromProfunctor (WrappedArrow p)) instance Arrow p => BiInvariant (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (Arrow p) => BiInvariant (WrappedArrow p)  deriving via (FromProfunctor (Yoneda p)) instance BiInvariant (Yoneda p) @@ -191,19 +203,19 @@  deriving via (FromBifunctor Arg) instance BiInvariant Arg -deriving via (FromBifunctor (Biap bi)) instance Bifunctor bi => BiInvariant (Biap bi)+deriving via (FromBifunctor (Biap bi)) instance (Bifunctor bi) => BiInvariant (Biap bi)  deriving via (FromBifunctor (Biff p f g)) instance (Bifunctor p, Functor f, Functor g) => BiInvariant (Biff (FromBifunctor p) f g) -deriving via (FromBifunctor (Clown f :: * -> * -> *)) instance Functor f => BiInvariant (Clown (FromFunctor f) :: * -> * -> *)+deriving via (FromBifunctor (Clown f :: * -> * -> *)) instance (Functor f) => BiInvariant (Clown (FromFunctor f) :: * -> * -> *)  deriving via (FromBifunctor (Const :: * -> * -> *)) instance BiInvariant (Const :: * -> * -> *)  deriving via (FromBifunctor Either) instance BiInvariant Either -deriving via (FromBifunctor (Flip p)) instance Bifunctor p => BiInvariant (Flip p)+deriving via (FromBifunctor (Flip p)) instance (Bifunctor p) => BiInvariant (Flip p) -deriving via (FromBifunctor (Joker f :: * -> * -> *)) instance Functor f => BiInvariant (Joker (FromFunctor f) :: * -> * -> *)+deriving via (FromBifunctor (Joker f :: * -> * -> *)) instance (Functor f) => BiInvariant (Joker (FromFunctor f) :: * -> * -> *)  deriving via (FromBifunctor (K1 i :: * -> * -> *)) instance BiInvariant (K1 i :: * -> * -> *) @@ -215,4 +227,4 @@  deriving via (FromBifunctor These) instance BiInvariant These -deriving via (FromBifunctor (WrappedBifunctor p)) instance Bifunctor p => BiInvariant (WrappedBifunctor p)+deriving via (FromBifunctor (WrappedBifunctor p)) instance (Bifunctor p) => BiInvariant (WrappedBifunctor p)

@@ -57,6 +57,12 @@  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude++--------------------------------------------------------------------------------+ -- | Boilerplate newtype to derive modules for any 'Profunctor'. newtype FromProfunctor p a b = FromProfunctor (p a b)   deriving newtype (Functor, Profunctor, Strong, Choice, Costrong, Cochoice)@@ -67,7 +73,7 @@  -------------------------------------------------------------------------------- --- | A 'Profunctor' \(P : \mathcal{C}^{op} \times \mathcal{D} \to Set\)+-- | A 'Profunctor' \(P : \mathcal{C_1}^{op} \times \mathcal{C_2} \to Set\) -- is a Tambara 'LeftModule' if it is equipped with a morphism \(s_{a,b,m} : P(a, b) \to P(a \odot m, b \odot m)\), -- which we call 'lstrength'. --@@ -78,7 +84,7 @@ -- 'Data.Profunctor.Types.lmap' ('rstrength' @f@) 'Control.Category..' 'lstrength' ≡ 'Data.Profunctor.Types.rmap' ('rstrength' @f@) 'Control.Category..' 'lstrength' -- 'lstrength' 'Control.Category..' 'lstrength' ≡ 'Types.dimap' ('Control.Category.Tensor.bwd' 'Control.Category.Tensor.assoc') ('Control.Category.Tensor.fwd' 'Control.Category.Tensor.assoc') 'Control.Category..' 'lstrength' -- @-class LeftModule cat t1 t2 p where+class LeftModule cat tC1 tC2 p where   -- | ==== __Examples__   --   -- 'Data.Profiunctor.Strong.first'':@@ -90,57 +96,57 @@   --   -- >>> :t lstrength @(->) @Either @Either   -- lstrength @(->) @Either @Either :: LeftModule (->) Either Either p => p a b -> p (Either a x) (Either b x)-  lstrength :: cat (p a b) (p (t1 a x) (t2 b x))+  lstrength :: cat (p a b) (p (tC1 a x) (tC2 b x)) -instance Strong p => LeftModule (->) (,) (,) (FromProfunctor p) where+instance (Strong p) => LeftModule (->) (,) (,) (FromProfunctor p) where   lstrength :: FromProfunctor p a b -> FromProfunctor p (a, x) (b, x)   lstrength = first' -instance Choice p => LeftModule (->) Either Either (FromProfunctor p) where+instance (Choice p) => LeftModule (->) Either Either (FromProfunctor p) where   lstrength :: FromProfunctor p a b -> FromProfunctor p (Either a x) (Either b x)   lstrength = left' -instance Bifunctor p => LeftModule (->) Either Either (FromBifunctor p) where+instance (Bifunctor p) => LeftModule (->) Either Either (FromBifunctor p) where   lstrength :: FromBifunctor p a b -> FromBifunctor p (Either a x) (Either b x)   lstrength = gbimap Left Left -instance Bifunctor p => LeftModule (->) These These (FromBifunctor p) where+instance (Bifunctor p) => LeftModule (->) These These (FromBifunctor p) where   lstrength :: FromBifunctor p a b -> FromBifunctor p (These a x) (These b x)   lstrength = gbimap This This -instance Bifunctor p => LeftModule Op (,) (,) (FromBifunctor p) where+instance (Bifunctor p) => LeftModule Op (,) (,) (FromBifunctor p) where   lstrength :: Op (FromBifunctor p a b) (FromBifunctor p (a, x) (b, x))   lstrength = Op (gbimap fst fst) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => LeftModule (->) (,) (,) (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => LeftModule (->) (,) (,) (Kleisli m)  deriving via (FromProfunctor (Pastro p)) instance LeftModule (->) (,) (,) (Pastro p) -deriving via (FromProfunctor (Tambara p)) instance Profunctor p => LeftModule (->) (,) (,) (Tambara p)+deriving via (FromProfunctor (Tambara p)) instance (Profunctor p) => LeftModule (->) (,) (,) (Tambara p) -deriving via (FromProfunctor (Closure p)) instance Strong p => LeftModule (->) (,) (,) (Closure p)+deriving via (FromProfunctor (Closure p)) instance (Strong p) => LeftModule (->) (,) (,) (Closure p)  deriving via (FromProfunctor (FreeTraversing p)) instance LeftModule (->) (,) (,) (FreeTraversing p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => LeftModule (->) (,) (,) (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => LeftModule (->) (,) (,) (CofreeTraversing p)  deriving via (FromProfunctor (FreeMapping p)) instance LeftModule (->) (,) (,) (FreeMapping p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => LeftModule (->) (,) (,) (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => LeftModule (->) (,) (,) (CofreeMapping p) -deriving via (FromProfunctor (Coyoneda p)) instance Strong p => LeftModule (->) (,) (,) (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Strong p) => LeftModule (->) (,) (,) (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Strong p => LeftModule (->) (,) (,) (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Strong p) => LeftModule (->) (,) (,) (Yoneda p)  deriving via (FromProfunctor (->)) instance LeftModule (->) (,) (,) (->)  deriving via (FromProfunctor (Forget r)) instance LeftModule (->) (,) (,) (Forget r) -deriving via (FromProfunctor (Star m)) instance Functor m => LeftModule (->) (,) (,) (Star m)+deriving via (FromProfunctor (Star m)) instance (Functor m) => LeftModule (->) (,) (,) (Star m) -deriving via (FromProfunctor (Clown f)) instance Contravariant f => LeftModule (->) (,) (,) (Clown f)+deriving via (FromProfunctor (Clown f)) instance (Contravariant f) => LeftModule (->) (,) (,) (Clown f) -deriving via (FromProfunctor (WrappedArrow p)) instance Arrow p => LeftModule (->) (,) (,) (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (Arrow p) => LeftModule (->) (,) (,) (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Strong p, Strong q) => LeftModule (->) (,) (,) (Sum p q) @@ -152,7 +158,7 @@  deriving via (FromProfunctor (Cayley f q)) instance (Functor f, Strong q) => LeftModule (->) (,) (,) (Cayley f q) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => LeftModule (->) Either Either (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => LeftModule (->) Either Either (Kleisli m)  deriving via (FromProfunctor Tagged) instance LeftModule (->) Either Either Tagged @@ -160,31 +166,31 @@  deriving via (FromProfunctor (PastroSum p)) instance LeftModule (->) Either Either (PastroSum p) -deriving via (FromProfunctor (TambaraSum p)) instance Profunctor p => LeftModule (->) Either Either (TambaraSum p)+deriving via (FromProfunctor (TambaraSum p)) instance (Profunctor p) => LeftModule (->) Either Either (TambaraSum p)  deriving via (FromProfunctor (FreeTraversing p)) instance LeftModule (->) Either Either (FreeTraversing p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => LeftModule (->) Either Either (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => LeftModule (->) Either Either (CofreeTraversing p)  deriving via (FromProfunctor (FreeMapping p)) instance LeftModule (->) Either Either (FreeMapping p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => LeftModule (->) Either Either (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => LeftModule (->) Either Either (CofreeMapping p) -deriving via (FromProfunctor (Coyoneda p)) instance Choice p => LeftModule (->) Either Either (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Choice p) => LeftModule (->) Either Either (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Choice p => LeftModule (->) Either Either (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Choice p) => LeftModule (->) Either Either (Yoneda p)  deriving via (FromProfunctor (->)) instance LeftModule (->) Either Either (->) -deriving via (FromProfunctor (Cokleisli w)) instance Comonad w => LeftModule (->) Either Either (Cokleisli w)+deriving via (FromProfunctor (Cokleisli w)) instance (Comonad w) => LeftModule (->) Either Either (Cokleisli w) -deriving via (FromProfunctor (Forget r)) instance Monoid r => LeftModule (->) Either Either (Forget r)+deriving via (FromProfunctor (Forget r)) instance (Monoid r) => LeftModule (->) Either Either (Forget r) -deriving via (FromProfunctor (Star f)) instance Applicative f => LeftModule (->) Either Either (Star f)+deriving via (FromProfunctor (Star f)) instance (Applicative f) => LeftModule (->) Either Either (Star f) -deriving via (FromProfunctor (Joker f)) instance Functor f => LeftModule (->) Either Either (Joker f)+deriving via (FromProfunctor (Joker f)) instance (Functor f) => LeftModule (->) Either Either (Joker f) -deriving via (FromProfunctor (WrappedArrow p)) instance ArrowChoice p => LeftModule (->) Either Either (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (ArrowChoice p) => LeftModule (->) Either Either (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Choice p, Choice q) => LeftModule (->) Either Either (Sum p q) @@ -264,7 +270,7 @@  -------------------------------------------------------------------------------- --- | A 'Profunctor' \(P : \mathcal{C}^{op} \times \mathcal{D} \to Set\)+-- | A 'Profunctor' \(P : \mathcal{C_1}^{op} \times \mathcal{C_2} \to Set\) -- is a Tambara 'RightModule' if it is equipped with a morphism \(s_{a,b,m} : P(a, b) \to P(m \odot a, m \odot b)\), -- which we call 'rstrength'. --@@ -275,7 +281,7 @@ -- 'Data.Profunctor.Types.lmap' ('lstrength' @f@) 'Control.Category..' 'rstrength' ≡ 'Data.Profunctor.Types.rmap' ('lstrength' @f@) 'Control.Category..' 'rstrength' -- 'rstrength' 'Control.Category..' 'rstrength' ≡  'Data.Profunctor.Types.dimap' ('Control.Category.Tensor.fwd' 'Control.Category.Tensor.assoc') ('Control.Category.Tensor.bwd' 'Control.Category.Tensor.assoc') 'Control.Category..' 'rstrength' -- @-class RightModule cat t1 t2 f where+class RightModule cat tC1 tC2 f where   -- | ==== __Examples__   --   -- 'Data.Profunctor.Strong.second'':@@ -287,57 +293,57 @@   --   -- >>> :t rstrength @(->) @Either @Either   -- rstrength @(->) @Either @Either :: RightModule (->) Either Either f => f a b -> f (Either x a) (Either x b)-  rstrength :: cat (f a b) (f (x `t1` a) (x `t2` b))+  rstrength :: cat (f a b) (f (x `tC1` a) (x `tC2` b)) -instance Strong p => RightModule (->) (,) (,) (FromProfunctor p) where+instance (Strong p) => RightModule (->) (,) (,) (FromProfunctor p) where   rstrength :: FromProfunctor p a b -> FromProfunctor p (c, a) (c, b)   rstrength = second' -instance Choice p => RightModule (->) Either Either (FromProfunctor p) where+instance (Choice p) => RightModule (->) Either Either (FromProfunctor p) where   rstrength :: FromProfunctor p a b -> FromProfunctor p (Either c a) (Either c b)   rstrength = right' -instance Bifunctor p => RightModule (->) Either Either (FromBifunctor p) where+instance (Bifunctor p) => RightModule (->) Either Either (FromBifunctor p) where   rstrength :: FromBifunctor p a b -> FromBifunctor p (Either x a) (Either x b)   rstrength = gbimap Right Right -instance Bifunctor p => RightModule (->) These These (FromBifunctor p) where+instance (Bifunctor p) => RightModule (->) These These (FromBifunctor p) where   rstrength :: FromBifunctor p a b -> FromBifunctor p (These x a) (These x b)   rstrength = gbimap That That -instance Bifunctor p => RightModule Op (,) (,) (FromBifunctor p) where+instance (Bifunctor p) => RightModule Op (,) (,) (FromBifunctor p) where   rstrength :: Op (FromBifunctor p a b) (FromBifunctor p (x, a) (x, b))   rstrength = Op (gbimap snd snd) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => RightModule (->) (,) (,) (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => RightModule (->) (,) (,) (Kleisli m)  deriving via (FromProfunctor (Pastro p)) instance RightModule (->) (,) (,) (Pastro p) -deriving via (FromProfunctor (Tambara p)) instance Profunctor p => RightModule (->) (,) (,) (Tambara p)+deriving via (FromProfunctor (Tambara p)) instance (Profunctor p) => RightModule (->) (,) (,) (Tambara p) -deriving via (FromProfunctor (Closure p)) instance Strong p => RightModule (->) (,) (,) (Closure p)+deriving via (FromProfunctor (Closure p)) instance (Strong p) => RightModule (->) (,) (,) (Closure p)  deriving via (FromProfunctor (FreeTraversing p)) instance RightModule (->) (,) (,) (FreeTraversing p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => RightModule (->) (,) (,) (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => RightModule (->) (,) (,) (CofreeTraversing p)  deriving via (FromProfunctor (FreeMapping p)) instance RightModule (->) (,) (,) (FreeMapping p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => RightModule (->) (,) (,) (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => RightModule (->) (,) (,) (CofreeMapping p) -deriving via (FromProfunctor (Coyoneda p)) instance Strong p => RightModule (->) (,) (,) (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Strong p) => RightModule (->) (,) (,) (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Strong p => RightModule (->) (,) (,) (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Strong p) => RightModule (->) (,) (,) (Yoneda p)  deriving via (FromProfunctor (->)) instance RightModule (->) (,) (,) (->)  deriving via (FromProfunctor (Forget r)) instance RightModule (->) (,) (,) (Forget r) -deriving via (FromProfunctor (Star m)) instance Functor m => RightModule (->) (,) (,) (Star m)+deriving via (FromProfunctor (Star m)) instance (Functor m) => RightModule (->) (,) (,) (Star m) -deriving via (FromProfunctor (Clown f)) instance Contravariant f => RightModule (->) (,) (,) (Clown f)+deriving via (FromProfunctor (Clown f)) instance (Contravariant f) => RightModule (->) (,) (,) (Clown f) -deriving via (FromProfunctor (WrappedArrow p)) instance Arrow p => RightModule (->) (,) (,) (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (Arrow p) => RightModule (->) (,) (,) (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Strong p, Strong q) => RightModule (->) (,) (,) (Sum p q) @@ -349,7 +355,7 @@  deriving via (FromProfunctor (Cayley f q)) instance (Functor f, Strong q) => RightModule (->) (,) (,) (Cayley f q) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => RightModule (->) Either Either (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => RightModule (->) Either Either (Kleisli m)  deriving via (FromProfunctor Tagged) instance RightModule (->) Either Either Tagged @@ -357,31 +363,31 @@  deriving via (FromProfunctor (PastroSum p)) instance RightModule (->) Either Either (PastroSum p) -deriving via (FromProfunctor (TambaraSum p)) instance Profunctor p => RightModule (->) Either Either (TambaraSum p)+deriving via (FromProfunctor (TambaraSum p)) instance (Profunctor p) => RightModule (->) Either Either (TambaraSum p)  deriving via (FromProfunctor (FreeTraversing p)) instance RightModule (->) Either Either (FreeTraversing p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => RightModule (->) Either Either (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => RightModule (->) Either Either (CofreeTraversing p)  deriving via (FromProfunctor (FreeMapping p)) instance RightModule (->) Either Either (FreeMapping p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => RightModule (->) Either Either (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => RightModule (->) Either Either (CofreeMapping p) -deriving via (FromProfunctor (Coyoneda p)) instance Choice p => RightModule (->) Either Either (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Choice p) => RightModule (->) Either Either (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Choice p => RightModule (->) Either Either (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Choice p) => RightModule (->) Either Either (Yoneda p)  deriving via (FromProfunctor (->)) instance RightModule (->) Either Either (->) -deriving via (FromProfunctor (Cokleisli w)) instance Comonad w => RightModule (->) Either Either (Cokleisli w)+deriving via (FromProfunctor (Cokleisli w)) instance (Comonad w) => RightModule (->) Either Either (Cokleisli w) -deriving via (FromProfunctor (Forget r)) instance Monoid r => RightModule (->) Either Either (Forget r)+deriving via (FromProfunctor (Forget r)) instance (Monoid r) => RightModule (->) Either Either (Forget r) -deriving via (FromProfunctor (Star f)) instance Applicative f => RightModule (->) Either Either (Star f)+deriving via (FromProfunctor (Star f)) instance (Applicative f) => RightModule (->) Either Either (Star f) -deriving via (FromProfunctor (Joker f)) instance Functor f => RightModule (->) Either Either (Joker f)+deriving via (FromProfunctor (Joker f)) instance (Functor f) => RightModule (->) Either Either (Joker f) -deriving via (FromProfunctor (WrappedArrow p)) instance ArrowChoice p => RightModule (->) Either Either (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (ArrowChoice p) => RightModule (->) Either Either (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Choice p, Choice q) => RightModule (->) Either Either (Sum p q) @@ -470,47 +476,47 @@ -- 'rstrength' ≡ 'Data.Profunctor.Types.dimap' 'Control.Category.Tensor.swap' 'Control.Category.Tensor.swap' 'Control.Category..' 'lstrength' -- 'lstrength' ≡ 'Data.Profunctor.Types.dimap' 'Control.Category.Tensor.swap' 'Control.Category.Tensor.swap' 'Control.Category..' 'rstrength' -- @-class (LeftModule cat t1 t2 f, RightModule cat t1 t2 f) => Bimodule cat t1 t2 f+class (LeftModule cat tC1 tC2 f, RightModule cat tC1 tC2 f) => Bimodule cat tC1 tC2 f -instance Strong p => Bimodule (->) (,) (,) (FromProfunctor p)+instance (Strong p) => Bimodule (->) (,) (,) (FromProfunctor p) -instance Choice p => Bimodule (->) Either Either (FromProfunctor p)+instance (Choice p) => Bimodule (->) Either Either (FromProfunctor p) -instance Bifunctor p => Bimodule (->) Either Either (FromBifunctor p)+instance (Bifunctor p) => Bimodule (->) Either Either (FromBifunctor p) -instance Bifunctor p => Bimodule (->) These These (FromBifunctor p)+instance (Bifunctor p) => Bimodule (->) These These (FromBifunctor p) -instance Bifunctor p => Bimodule Op (,) (,) (FromBifunctor p)+instance (Bifunctor p) => Bimodule Op (,) (,) (FromBifunctor p) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => Bimodule (->) (,) (,) (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => Bimodule (->) (,) (,) (Kleisli m)  deriving via (FromProfunctor (Pastro p)) instance Bimodule (->) (,) (,) (Pastro p) -deriving via (FromProfunctor (Tambara p)) instance Profunctor p => Bimodule (->) (,) (,) (Tambara p)+deriving via (FromProfunctor (Tambara p)) instance (Profunctor p) => Bimodule (->) (,) (,) (Tambara p) -deriving via (FromProfunctor (Closure p)) instance Strong p => Bimodule (->) (,) (,) (Closure p)+deriving via (FromProfunctor (Closure p)) instance (Strong p) => Bimodule (->) (,) (,) (Closure p)  deriving via (FromProfunctor (FreeTraversing p)) instance Bimodule (->) (,) (,) (FreeTraversing p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => Bimodule (->) (,) (,) (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => Bimodule (->) (,) (,) (CofreeTraversing p)  deriving via (FromProfunctor (FreeMapping p)) instance Bimodule (->) (,) (,) (FreeMapping p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => Bimodule (->) (,) (,) (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => Bimodule (->) (,) (,) (CofreeMapping p) -deriving via (FromProfunctor (Coyoneda p)) instance Strong p => Bimodule (->) (,) (,) (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Strong p) => Bimodule (->) (,) (,) (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Strong p => Bimodule (->) (,) (,) (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Strong p) => Bimodule (->) (,) (,) (Yoneda p)  deriving via (FromProfunctor (->)) instance Bimodule (->) (,) (,) (->)  deriving via (FromProfunctor (Forget r)) instance Bimodule (->) (,) (,) (Forget r) -deriving via (FromProfunctor (Star m)) instance Functor m => Bimodule (->) (,) (,) (Star m)+deriving via (FromProfunctor (Star m)) instance (Functor m) => Bimodule (->) (,) (,) (Star m) -deriving via (FromProfunctor (Clown f)) instance Contravariant f => Bimodule (->) (,) (,) (Clown f)+deriving via (FromProfunctor (Clown f)) instance (Contravariant f) => Bimodule (->) (,) (,) (Clown f) -deriving via (FromProfunctor (WrappedArrow p)) instance Arrow p => Bimodule (->) (,) (,) (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (Arrow p) => Bimodule (->) (,) (,) (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Strong p, Strong q) => Bimodule (->) (,) (,) (Sum p q) @@ -522,7 +528,7 @@  deriving via (FromProfunctor (Cayley f q)) instance (Functor f, Strong q) => Bimodule (->) (,) (,) (Cayley f q) -deriving via (FromProfunctor (Kleisli m)) instance Monad m => Bimodule (->) Either Either (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (Monad m) => Bimodule (->) Either Either (Kleisli m)  deriving via (FromProfunctor Tagged) instance Bimodule (->) Either Either Tagged @@ -530,31 +536,31 @@  deriving via (FromProfunctor (PastroSum p)) instance Bimodule (->) Either Either (PastroSum p) -deriving via (FromProfunctor (TambaraSum p)) instance Profunctor p => Bimodule (->) Either Either (TambaraSum p)+deriving via (FromProfunctor (TambaraSum p)) instance (Profunctor p) => Bimodule (->) Either Either (TambaraSum p)  deriving via (FromProfunctor (FreeTraversing p)) instance Bimodule (->) Either Either (FreeTraversing p) -deriving via (FromProfunctor (CofreeTraversing p)) instance Profunctor p => Bimodule (->) Either Either (CofreeTraversing p)+deriving via (FromProfunctor (CofreeTraversing p)) instance (Profunctor p) => Bimodule (->) Either Either (CofreeTraversing p)  deriving via (FromProfunctor (FreeMapping p)) instance Bimodule (->) Either Either (FreeMapping p) -deriving via (FromProfunctor (CofreeMapping p)) instance Profunctor p => Bimodule (->) Either Either (CofreeMapping p)+deriving via (FromProfunctor (CofreeMapping p)) instance (Profunctor p) => Bimodule (->) Either Either (CofreeMapping p) -deriving via (FromProfunctor (Coyoneda p)) instance Choice p => Bimodule (->) Either Either (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Choice p) => Bimodule (->) Either Either (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Choice p => Bimodule (->) Either Either (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Choice p) => Bimodule (->) Either Either (Yoneda p)  deriving via (FromProfunctor (->)) instance Bimodule (->) Either Either (->) -deriving via (FromProfunctor (Cokleisli w)) instance Comonad w => Bimodule (->) Either Either (Cokleisli w)+deriving via (FromProfunctor (Cokleisli w)) instance (Comonad w) => Bimodule (->) Either Either (Cokleisli w) -deriving via (FromProfunctor (Forget r)) instance Monoid r => Bimodule (->) Either Either (Forget r)+deriving via (FromProfunctor (Forget r)) instance (Monoid r) => Bimodule (->) Either Either (Forget r) -deriving via (FromProfunctor (Star f)) instance Applicative f => Bimodule (->) Either Either (Star f)+deriving via (FromProfunctor (Star f)) instance (Applicative f) => Bimodule (->) Either Either (Star f) -deriving via (FromProfunctor (Joker f)) instance Functor f => Bimodule (->) Either Either (Joker f)+deriving via (FromProfunctor (Joker f)) instance (Functor f) => Bimodule (->) Either Either (Joker f) -deriving via (FromProfunctor (WrappedArrow p)) instance ArrowChoice p => Bimodule (->) Either Either (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (ArrowChoice p) => Bimodule (->) Either Either (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Choice p, Choice q) => Bimodule (->) Either Either (Sum p q) @@ -634,7 +640,7 @@  -------------------------------------------------------------------------------- --- | A 'Profunctor' \(P : \mathcal{C}^{op} \times \mathcal{D} \to Set\)+-- | A 'Profunctor' \(P : \mathcal{C_1}^{op} \times \mathcal{C_2} \to Set\) -- is a Tambara 'LeftCoModule' if it is equipped with a morphism \(s^{-1}_{a,b,m} : P(a \odot m, a \odot m) \to P(a, b) \), -- which we call 'lcostrength'. --@@ -645,7 +651,7 @@ -- 'lcostrength' 'Control.Category..' 'Data.Profunctor.Types.lmap' ('rstrength' f) ≡ 'lcostrength' 'Control.Category..' 'Data.Profunctor.Types.rmap' ('rstrength' f) -- 'lcostrength' 'Control.Category..' 'lcostrength' ≡  'lcostrength' 'Control.Category..' 'Data.Profunctor.Types.dimap' ('Control.Category.Tensor.fwd' 'Control.Category.Tensor.assoc') ('Control.Category.Tensor.bwd' 'Control.Category.Tensor.assoc') -- @-class LeftCoModule cat t1 t2 f where+class LeftCoModule cat tC1 tC2 f where   -- | ==== __Examples__   --   -- 'Data.Profunctor.Strong.unfirst':@@ -657,45 +663,45 @@   --   -- >>> :t lcostrength @(->) @Either @Either   -- lcostrength @(->) @Either @Either :: LeftCoModule (->) Either Either f => f (Either a x) (Either b x) -> f a b-  lcostrength :: cat (f (t1 a x) (t2 b x)) (f a b)+  lcostrength :: cat (f (tC1 a x) (tC2 b x)) (f a b) -instance Costrong p => LeftCoModule (->) (,) (,) (FromProfunctor p) where+instance (Costrong p) => LeftCoModule (->) (,) (,) (FromProfunctor p) where   lcostrength :: FromProfunctor p (a, x) (b, x) -> FromProfunctor p a b   lcostrength = unfirst -instance Cochoice p => LeftCoModule (->) Either Either (FromProfunctor p) where-  lcostrength :: Cochoice p => FromProfunctor p (Either a x) (Either b x) -> FromProfunctor p a b+instance (Cochoice p) => LeftCoModule (->) Either Either (FromProfunctor p) where+  lcostrength :: (Cochoice p) => FromProfunctor p (Either a x) (Either b x) -> FromProfunctor p a b   lcostrength = unleft -instance Bifunctor p => LeftCoModule (->) (,) (,) (FromBifunctor p) where-  lcostrength :: Bifunctor p => FromBifunctor p (a, x) (b, x) -> FromBifunctor p a b+instance (Bifunctor p) => LeftCoModule (->) (,) (,) (FromBifunctor p) where+  lcostrength :: (Bifunctor p) => FromBifunctor p (a, x) (b, x) -> FromBifunctor p a b   lcostrength = gbimap fst fst -instance Bifunctor p => LeftCoModule Op Either Either (FromBifunctor p) where-  lcostrength :: Bifunctor p => Op (FromBifunctor p (Either a x) (Either b x)) (FromBifunctor p a b)+instance (Bifunctor p) => LeftCoModule Op Either Either (FromBifunctor p) where+  lcostrength :: (Bifunctor p) => Op (FromBifunctor p (Either a x) (Either b x)) (FromBifunctor p a b)   lcostrength = Op (gbimap Left Left) -instance Bifunctor p => LeftCoModule Op These These (FromBifunctor p) where-  lcostrength :: Bifunctor p => Op (FromBifunctor p (These a x) (These b x)) (FromBifunctor p a b)+instance (Bifunctor p) => LeftCoModule Op These These (FromBifunctor p) where+  lcostrength :: (Bifunctor p) => Op (FromBifunctor p (These a x) (These b x)) (FromBifunctor p a b)   lcostrength = Op (gbimap This This) -deriving via (FromProfunctor (Kleisli m)) instance MonadFix m => LeftCoModule (->) (,) (,) (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (MonadFix m) => LeftCoModule (->) (,) (,) (Kleisli m)  deriving via (FromProfunctor Tagged) instance LeftCoModule (->) (,) (,) Tagged -deriving via (FromProfunctor (Coyoneda p)) instance Costrong p => LeftCoModule (->) (,) (,) (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Costrong p) => LeftCoModule (->) (,) (,) (Coyoneda p) -deriving via (FromProfunctor (Copastro p)) instance Cochoice p => LeftCoModule (->) (,) (,) (Copastro p)+deriving via (FromProfunctor (Copastro p)) instance (Cochoice p) => LeftCoModule (->) (,) (,) (Copastro p) -deriving via (FromProfunctor (Yoneda p)) instance Costrong p => LeftCoModule (->) (,) (,) (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Costrong p) => LeftCoModule (->) (,) (,) (Yoneda p)  deriving via (FromProfunctor (->)) instance LeftCoModule (->) (,) (,) (->) -deriving via (FromProfunctor (Cokleisli f)) instance Functor f => LeftCoModule (->) (,) (,) (Cokleisli f)+deriving via (FromProfunctor (Cokleisli f)) instance (Functor f) => LeftCoModule (->) (,) (,) (Cokleisli f) -deriving via (FromProfunctor (Costar f)) instance Functor f => LeftCoModule (->) (,) (,) (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Functor f) => LeftCoModule (->) (,) (,) (Costar f) -deriving via (FromProfunctor (WrappedArrow p)) instance ArrowLoop p => LeftCoModule (->) (,) (,) (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (ArrowLoop p) => LeftCoModule (->) (,) (,) (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Costrong p, Costrong q) => LeftCoModule (->) (,) (,) (Sum p q) @@ -711,17 +717,17 @@  deriving via (FromProfunctor (CotambaraSum p)) instance LeftCoModule (->) Either Either (CotambaraSum p) -deriving via (FromProfunctor (Coyoneda p)) instance Cochoice p => LeftCoModule (->) Either Either (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Cochoice p) => LeftCoModule (->) Either Either (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Cochoice p => LeftCoModule (->) Either Either (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Cochoice p) => LeftCoModule (->) Either Either (Yoneda p)  deriving via (FromProfunctor (->)) instance LeftCoModule (->) Either Either (->)  deriving via (FromProfunctor (Forget r)) instance LeftCoModule (->) Either Either (Forget r) -deriving via (FromProfunctor (Costar f)) instance Applicative f => LeftCoModule (->) Either Either (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Applicative f) => LeftCoModule (->) Either Either (Costar f) -deriving via (FromProfunctor (Star f)) instance Traversable f => LeftCoModule (->) Either Either (Star f)+deriving via (FromProfunctor (Star f)) instance (Traversable f) => LeftCoModule (->) Either Either (Star f)  deriving via (FromProfunctor (Sum p q)) instance (Cochoice p, Cochoice q) => LeftCoModule (->) Either Either (Sum p q) @@ -799,7 +805,7 @@  -------------------------------------------------------------------------------- --- | A 'Profunctor' \(P : \mathcal{C}^{op} \times \mathcal{D} \to Set\)+-- | A 'Profunctor' \(P : \mathcal{C_1}^{op} \times \mathcal{C_2} \to Set\) -- is a Tambara 'RightCoModule' if it is equipped with a morphism \(s^{-1}_{a,b,m} : P(m \odot a, m \odot a) \to P(a, b) \), -- which we call 'rcostrength'. --@@ -810,7 +816,7 @@ -- 'rcostrength' 'Control.Category..' 'Data.Profunctor.Types.lmap' ('lstrength' f) ≡ 'rcostrength' 'Control.Category..' 'Data.Profunctor.Types.rmap' ('lstrength' f) -- 'rcostrength' 'Control.Category..' 'rcostrength' ≡  'rcostrength' 'Control.Category..' 'Data.Profunctor.Types.dimap' ('Control.Category.Tensor.bwd' 'Control.Category.Tensor.assoc') ('Control.Category.Tensor.fwd' 'Control.Category.Tensor.assoc') -- @-class RightCoModule cat t1 t2 f where+class RightCoModule cat tC1 tC2 f where   -- | ==== __Examples__   --   -- 'Data.Profunctor.Strong.unsecond':@@ -822,45 +828,45 @@   --   -- >>> :t rcostrength @(->) @Either @Either   -- rcostrength @(->) @Either @Either :: RightCoModule (->) Either Either f => f (Either x a) (Either x b) -> f a b-  rcostrength :: cat (f (x `t1` a) (x `t2` b)) (f a b)+  rcostrength :: cat (f (x `tC1` a) (x `tC2` b)) (f a b) -instance Costrong p => RightCoModule (->) (,) (,) (FromProfunctor p) where+instance (Costrong p) => RightCoModule (->) (,) (,) (FromProfunctor p) where   rcostrength :: FromProfunctor p (x, a) (x, b) -> FromProfunctor p a b   rcostrength = unsecond -instance Cochoice p => RightCoModule (->) Either Either (FromProfunctor p) where+instance (Cochoice p) => RightCoModule (->) Either Either (FromProfunctor p) where   rcostrength :: FromProfunctor p (Either x a) (Either x b) -> FromProfunctor p a b   rcostrength = unright -instance Bifunctor p => RightCoModule (->) (,) (,) (FromBifunctor p) where+instance (Bifunctor p) => RightCoModule (->) (,) (,) (FromBifunctor p) where   rcostrength :: FromBifunctor p (x, a) (x, b) -> FromBifunctor p a b   rcostrength = gbimap snd snd -instance Bifunctor p => RightCoModule Op Either Either (FromBifunctor p) where+instance (Bifunctor p) => RightCoModule Op Either Either (FromBifunctor p) where   rcostrength :: Op (FromBifunctor p (Either x a) (Either x b)) (FromBifunctor p a b)   rcostrength = Op (gbimap Right Right) -instance Bifunctor p => RightCoModule Op These These (FromBifunctor p) where+instance (Bifunctor p) => RightCoModule Op These These (FromBifunctor p) where   rcostrength :: Op (FromBifunctor p (These x a) (These x b)) (FromBifunctor p a b)   rcostrength = Op (gbimap That That) -deriving via (FromProfunctor (Kleisli m)) instance MonadFix m => RightCoModule (->) (,) (,) (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (MonadFix m) => RightCoModule (->) (,) (,) (Kleisli m)  deriving via (FromProfunctor Tagged) instance RightCoModule (->) (,) (,) Tagged -deriving via (FromProfunctor (Coyoneda p)) instance Costrong p => RightCoModule (->) (,) (,) (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Costrong p) => RightCoModule (->) (,) (,) (Coyoneda p) -deriving via (FromProfunctor (Copastro p)) instance Cochoice p => RightCoModule (->) (,) (,) (Copastro p)+deriving via (FromProfunctor (Copastro p)) instance (Cochoice p) => RightCoModule (->) (,) (,) (Copastro p) -deriving via (FromProfunctor (Yoneda p)) instance Costrong p => RightCoModule (->) (,) (,) (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Costrong p) => RightCoModule (->) (,) (,) (Yoneda p)  deriving via (FromProfunctor (->)) instance RightCoModule (->) (,) (,) (->) -deriving via (FromProfunctor (Cokleisli f)) instance Functor f => RightCoModule (->) (,) (,) (Cokleisli f)+deriving via (FromProfunctor (Cokleisli f)) instance (Functor f) => RightCoModule (->) (,) (,) (Cokleisli f) -deriving via (FromProfunctor (Costar f)) instance Functor f => RightCoModule (->) (,) (,) (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Functor f) => RightCoModule (->) (,) (,) (Costar f) -deriving via (FromProfunctor (WrappedArrow p)) instance ArrowLoop p => RightCoModule (->) (,) (,) (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (ArrowLoop p) => RightCoModule (->) (,) (,) (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Costrong p, Costrong q) => RightCoModule (->) (,) (,) (Sum p q) @@ -876,17 +882,17 @@  deriving via (FromProfunctor (CotambaraSum p)) instance RightCoModule (->) Either Either (CotambaraSum p) -deriving via (FromProfunctor (Coyoneda p)) instance Cochoice p => RightCoModule (->) Either Either (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Cochoice p) => RightCoModule (->) Either Either (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Cochoice p => RightCoModule (->) Either Either (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Cochoice p) => RightCoModule (->) Either Either (Yoneda p)  deriving via (FromProfunctor (->)) instance RightCoModule (->) Either Either (->)  deriving via (FromProfunctor (Forget r)) instance RightCoModule (->) Either Either (Forget r) -deriving via (FromProfunctor (Costar f)) instance Applicative f => RightCoModule (->) Either Either (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Applicative f) => RightCoModule (->) Either Either (Costar f) -deriving via (FromProfunctor (Star f)) instance Traversable f => RightCoModule (->) Either Either (Star f)+deriving via (FromProfunctor (Star f)) instance (Traversable f) => RightCoModule (->) Either Either (Star f)  deriving via (FromProfunctor (Sum p q)) instance (Cochoice p, Cochoice q) => RightCoModule (->) Either Either (Sum p q) @@ -973,35 +979,35 @@ -- 'rcostrength' ≡ 'lcostrength' 'Control.Category..' 'Data.Profunctor.Types.dimap' 'Control.Category.Tensor.swap' 'Control.Category.Tensor.swap' -- 'lcostrength' ≡ 'rcostrength' 'Control.Category..' 'Data.Profunctor.Types.dimap' 'Control.Category.Tensor.swap' 'Control.Category.Tensor.swap' -- @-class (LeftCoModule cat t1 t2 f, RightCoModule cat t1 t2 f) => CoBimodule cat t1 t2 f+class (LeftCoModule cat tC1 tC2 f, RightCoModule cat tC1 tC2 f) => CoBimodule cat tC1 tC2 f -instance Costrong p => CoBimodule (->) (,) (,) (FromProfunctor p)+instance (Costrong p) => CoBimodule (->) (,) (,) (FromProfunctor p) -instance Cochoice p => CoBimodule (->) Either Either (FromProfunctor p)+instance (Cochoice p) => CoBimodule (->) Either Either (FromProfunctor p) -instance Bifunctor p => CoBimodule (->) (,) (,) (FromBifunctor p)+instance (Bifunctor p) => CoBimodule (->) (,) (,) (FromBifunctor p) -instance Bifunctor p => CoBimodule Op Either Either (FromBifunctor p)+instance (Bifunctor p) => CoBimodule Op Either Either (FromBifunctor p) -instance Bifunctor p => CoBimodule Op These These (FromBifunctor p)+instance (Bifunctor p) => CoBimodule Op These These (FromBifunctor p) -deriving via (FromProfunctor (Kleisli m)) instance MonadFix m => CoBimodule (->) (,) (,) (Kleisli m)+deriving via (FromProfunctor (Kleisli m)) instance (MonadFix m) => CoBimodule (->) (,) (,) (Kleisli m)  deriving via (FromProfunctor Tagged) instance CoBimodule (->) (,) (,) Tagged -deriving via (FromProfunctor (Coyoneda p)) instance Costrong p => CoBimodule (->) (,) (,) (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Costrong p) => CoBimodule (->) (,) (,) (Coyoneda p) -deriving via (FromProfunctor (Copastro p)) instance Cochoice p => CoBimodule (->) (,) (,) (Copastro p)+deriving via (FromProfunctor (Copastro p)) instance (Cochoice p) => CoBimodule (->) (,) (,) (Copastro p) -deriving via (FromProfunctor (Yoneda p)) instance Costrong p => CoBimodule (->) (,) (,) (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Costrong p) => CoBimodule (->) (,) (,) (Yoneda p)  deriving via (FromProfunctor (->)) instance CoBimodule (->) (,) (,) (->) -deriving via (FromProfunctor (Cokleisli f)) instance Functor f => CoBimodule (->) (,) (,) (Cokleisli f)+deriving via (FromProfunctor (Cokleisli f)) instance (Functor f) => CoBimodule (->) (,) (,) (Cokleisli f) -deriving via (FromProfunctor (Costar f)) instance Functor f => CoBimodule (->) (,) (,) (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Functor f) => CoBimodule (->) (,) (,) (Costar f) -deriving via (FromProfunctor (WrappedArrow p)) instance ArrowLoop p => CoBimodule (->) (,) (,) (WrappedArrow p)+deriving via (FromProfunctor (WrappedArrow p)) instance (ArrowLoop p) => CoBimodule (->) (,) (,) (WrappedArrow p)  deriving via (FromProfunctor (Sum p q)) instance (Costrong p, Costrong q) => CoBimodule (->) (,) (,) (Sum p q) @@ -1017,17 +1023,17 @@  deriving via (FromProfunctor (CotambaraSum p)) instance CoBimodule (->) Either Either (CotambaraSum p) -deriving via (FromProfunctor (Coyoneda p)) instance Cochoice p => CoBimodule (->) Either Either (Coyoneda p)+deriving via (FromProfunctor (Coyoneda p)) instance (Cochoice p) => CoBimodule (->) Either Either (Coyoneda p) -deriving via (FromProfunctor (Yoneda p)) instance Cochoice p => CoBimodule (->) Either Either (Yoneda p)+deriving via (FromProfunctor (Yoneda p)) instance (Cochoice p) => CoBimodule (->) Either Either (Yoneda p)  deriving via (FromProfunctor (->)) instance CoBimodule (->) Either Either (->)  deriving via (FromProfunctor (Forget r)) instance CoBimodule (->) Either Either (Forget r) -deriving via (FromProfunctor (Costar f)) instance Applicative f => CoBimodule (->) Either Either (Costar f)+deriving via (FromProfunctor (Costar f)) instance (Applicative f) => CoBimodule (->) Either Either (Costar f) -deriving via (FromProfunctor (Star f)) instance Traversable f => CoBimodule (->) Either Either (Star f)+deriving via (FromProfunctor (Star f)) instance (Traversable f) => CoBimodule (->) Either Either (Star f)  deriving via (FromProfunctor (Sum p q)) instance (Cochoice p, Cochoice q) => CoBimodule (->) Either Either (Sum p q) 

@@ -1,12 +1,26 @@ module Data.Bifunctor.Monoidal   ( -- * Semigroupal     Semigroupal (..),+    (|??|),+    (|**|),+    (|*+|),+    (|*&|),+    (|++|),+    (|+*|),+    (|+&|),+    (|&&|),+    (|&*|),+    (|&+|),      -- * Unital     Unital (..),      -- * Monoidal     Monoidal,++    -- * Newtypes for Deriving Via+    FromBiapplicative (..),+    StrongCategory (..),   ) where @@ -15,23 +29,41 @@ import Control.Applicative (Alternative (..), Applicative (..), pure, (<$>)) import Control.Arrow (Kleisli (..)) import Control.Category (Category (..))-import Control.Category.Cartesian (Cocartesian (..), Semicartesian (..))-import Control.Category.Tensor (Associative, Iso (..), Tensor (..))+import Control.Category.Cartesian (Cocartesian (..))+import Control.Category.Tensor (Associative, Iso (..), Tensor (..), gbimap) import Control.Monad (Functor (..), Monad) import Data.Biapplicative (Biapplicative (..), Bifunctor (..))-import Data.Bifunctor.Clown (Clown)+import Data.Bifunctor.Biap (Biap (..))+import Data.Bifunctor.Biff (Biff (..))+import Data.Bifunctor.Clown (Clown (..))+import Data.Bifunctor.Flip (Flip (..)) import Data.Bifunctor.Joker (Joker (..))+import Data.Bifunctor.Product (Product (..))+import Data.Bifunctor.Tannen (Tannen (..))+import Data.Bifunctor.Wrapped (WrappedBifunctor (..)) import Data.Either (Either, either) import Data.Function (const, ($))+import Data.Functor.Const (Const (..))+import Data.Functor.Contravariant (Op (..))+import Data.Functor.Monoidal qualified as F import Data.Profunctor (Forget (..), Profunctor (..), Star (..), Strong (..))+import Data.Semigroup (Arg (..)) import Data.Semigroupoid (Semigroupoid (..))+import Data.Tagged (Tagged (..)) import Data.These (These (..), these) import Data.Tuple (fst, snd, uncurry) import Data.Void (Void, absurd)-import Prelude (Either (..))+import Prelude (Either (..), Monoid, curry)  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Void (Void)++--------------------------------------------------------------------------------+ -- | Given monoidal categories \((\mathcal{C}, \otimes, I_{\mathcal{C}})\) and \((\mathcal{D}, \bullet, I_{\mathcal{D}})\). -- A bifunctor \(F : \mathcal{C_1} \times \mathcal{C_2} \to \mathcal{D}\) is 'Semigroupal' if it supports a -- natural transformation \(\phi_{AB,CD} : F\ A\ B \bullet F\ C\ D \to F\ (A \otimes C)\ (B \otimes D)\), which we call 'combine'.@@ -54,29 +86,215 @@ -- @ -- 'combine' 'Control.Category..' 'Control.Category.Tensor.grmap' 'combine' 'Control.Category..' 'bwd' 'Control.Category.Tensor.assoc' ≡ 'fmap' ('bwd' 'Control.Category.Tensor.assoc') 'Control.Category..' 'combine' 'Control.Category..' 'Control.Category.Tensor.glmap' 'combine' -- @-class (Associative cat t1, Associative cat t2, Associative cat to) => Semigroupal cat t1 t2 to f where+class (Associative cat tC1, Associative cat tC2, Associative cat tD) => Semigroupal cat tC1 tC2 tD f where   -- | A natural transformation \(\phi_{AB,CD} : F\ A\ B \bullet F\ C\ D \to F\ (A \otimes C)\ (B \otimes D)\).   --   -- ==== __Examples__   ---  -- >>> :t combine @(->) @(,) @(,) @(,) @(,)-  -- combine @(->) @(,) @(,) @(,) @(,) :: ((x, y), (x', y')) -> ((x, x'), (y, y'))-  --   -- >>> combine @(->) @(,) @(,) @(,) @(,) ((True, "Hello"), ((), "World"))   -- ((True,()),("Hello","World"))   --   -- >>> combine @(->) @(,) @(,) @(,) @(->) (show, (>10)) (True, 11)   -- ("True",True)-  combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y'))+  combine :: cat (tD (f x y) (f x' y')) (f (tC1 x x') (tC2 y y')) -instance Profunctor p => Semigroupal (->) (,) Either Either p where+newtype FromBiapplicative p a b = FromBiapplicative (p a b)+  deriving newtype (Functor, Bifunctor, Biapplicative)++instance (Biapplicative p) => Semigroupal (->) (,) (,) (,) (FromBiapplicative p) where+  combine :: (FromBiapplicative p x y, FromBiapplicative p x' y') -> FromBiapplicative p (x, x') (y, y')+  combine = uncurry $ biliftA2 (,) (,)++deriving via FromBiapplicative (,) instance Semigroupal (->) (,) (,) (,) (,)++-- Colax (Op) splits. The split @f (tC1 x x') (tC2 y y') -> tD (f x y) (f x' y')@,+-- dual to the covariant @combine@.++-- | The product transpose, inverse to the covariant @(,)@ combine.+instance Semigroupal Op (,) (,) (,) (,) where+  combine :: Op ((x, y), (x', y')) ((x, x'), (y, y'))+  combine = Op (\((x, x'), (y, y')) -> ((x, y), (x', y')))++-- | The coproduct rearrangement, inverse to the covariant @Either@ combine.+instance Semigroupal Op Either Either Either Either where+  combine :: Op (Either (Either x y) (Either x' y')) (Either (Either x x') (Either y y'))+  combine = Op $ \case+    Left (Left x) -> Left (Left x)+    Left (Right x') -> Right (Left x')+    Right (Left y) -> Left (Right y)+    Right (Right y') -> Right (Right y')++-- | Tuples transpose the parameter pairs and duplicate the leading @Monoid@ tags.+-- The split needs no @Monoid@ (it duplicates rather than combines).+instance Semigroupal Op (,) (,) (,) ((,,) x) where+  combine :: Op ((x, a, b), (x, a', b')) (x, (a, a'), (b, b'))+  combine = Op (\(x, (a, a'), (b, b')) -> ((x, a, b), (x, a', b')))++instance Semigroupal Op (,) (,) (,) ((,,,) x y) where+  combine :: Op ((x, y, a, b), (x, y, a', b')) (x, y, (a, a'), (b, b'))+  combine = Op (\(x, y, (a, a'), (b, b')) -> ((x, y, a, b), (x, y, a', b')))++instance Semigroupal Op (,) (,) (,) ((,,,,) x y z) where+  combine :: Op ((x, y, z, a, b), (x, y, z, a', b')) (x, y, z, (a, a'), (b, b'))+  combine = Op (\(x, y, z, (a, a'), (b, b')) -> ((x, y, z, a, b), (x, y, z, a', b')))++instance Semigroupal Op (,) (,) (,) ((,,,,,) x y z w) where+  combine :: Op ((x, y, z, w, a, b), (x, y, z, w, a', b')) (x, y, z, w, (a, a'), (b, b'))+  combine = Op (\(x, y, z, w, (a, a'), (b, b')) -> ((x, y, z, w, a, b), (x, y, z, w, a', b')))++instance Semigroupal Op (,) (,) (,) ((,,,,,,) x y z w v) where+  combine :: Op ((x, y, z, w, v, a, b), (x, y, z, w, v, a', b')) (x, y, z, w, v, (a, a'), (b, b'))+  combine = Op (\(x, y, z, w, v, (a, a'), (b, b')) -> ((x, y, z, w, v, a, b), (x, y, z, w, v, a', b')))++-- | 'Arg' is a pair with a key-only 'Eq'. Its split transposes like a tuple.+instance Semigroupal Op (,) (,) (,) Arg where+  combine :: Op (Arg a b, Arg a' b') (Arg (a, a') (b, b'))+  combine = Op (\(Arg (a, a') (b, b')) -> (Arg a b, Arg a' b'))++-- | Phantom in one parameter, so the split projects the other and discards the+-- phantom nesting. 'Const' carries its content in the first parameter, 'Tagged'+-- in the second.+instance Semigroupal Op (,) (,) (,) Const where+  combine :: Op (Const a b, Const a' b') (Const (a, a') (b, b'))+  combine = Op (\(Const (a, a')) -> (Const a, Const a'))++instance Semigroupal Op (,) (,) (,) Tagged where+  combine :: Op (Tagged a b, Tagged a' b') (Tagged (a, a') (b, b'))+  combine = Op (\(Tagged (b, b')) -> (Tagged b, Tagged b'))++-- | Componentwise, at the product split. Each component splits and the results+-- transpose into a pair of products. @Associative@ \/ @Bifunctor@ on the tensors+-- are the 'Semigroupal' superclasses, listed so GHC can use @combine@ here.+instance+  ( Semigroupal Op tC1 tC2 (,) f,+    Semigroupal Op tC1 tC2 (,) g,+    Associative (->) tC1,+    Associative (->) tC2,+    Bifunctor tC1,+    Bifunctor tC2+  ) =>+  Semigroupal Op tC1 tC2 (,) (Product f g)+  where+  combine :: Op (Product f g a b, Product f g a' b') (Product f g (tC1 a a') (tC2 b b'))+  combine = Op $ \(Pair fab gab) ->+    let (fa, fa') = getOp (combine @Op @tC1 @tC2 @(,)) fab+        (ga, ga') = getOp (combine @Op @tC1 @tC2 @(,)) gab+     in (Pair fa ga, Pair fa' ga')++-- | 'Joker' and 'Clown' carry a functor on one parameter and are phantom in the+-- other, so their split delegates to the functor colax split of+-- "Data.Functor.Monoidal". 'Joker' acts on the second parameter, 'Clown' on the+-- first.+instance (F.Semigroupal Op tC2 tD f, Associative (->) tC1, Bifunctor tD) => Semigroupal Op tC1 tC2 tD (Joker f) where+  combine :: Op (tD (Joker f a b) (Joker f a' b')) (Joker f (tC1 a a') (tC2 b b'))+  combine = Op $ \(Joker fbb') -> gbimap Joker Joker (getOp (F.combine @Op @tC2 @tD) fbb')++instance (F.Semigroupal Op tC1 tD f, Associative (->) tC2, Bifunctor tD) => Semigroupal Op tC1 tC2 tD (Clown f) where+  combine :: Op (tD (Clown f a b) (Clown f a' b')) (Clown f (tC1 a a') (tC2 b b'))+  combine = Op $ \(Clown faa') -> gbimap Clown Clown (getOp (F.combine @Op @tC1 @tD) faa')++-- | 'Forget' is a function out of its first parameter, phantom in the second.+-- The split is the co-pairing, inverse to the covariant @Forget@ @combine@+-- (@either@). The generic colax law cannot exercise it (the split consumes a+-- profunctor at structured contravariant-argument types, which the rank-2 @Gen@+-- interface cannot generate input-dependently), so it is covered by ad-hoc tests+-- at fixed 'Either' types in the test suite (both inverse laws, coassociativity,+-- and conaturality).+instance Semigroupal Op Either Either (,) (Forget (f r)) where+  combine :: Op (Forget (f r) x y, Forget (f r) x' y') (Forget (f r) (Either x x') (Either y y'))+  combine = Op (\(Forget h) -> (Forget (h . Left), Forget (h . Right)))++-- NOTE: The function-like bifunctors @('->')@, @'Star' f@, and @'Kleisli' f@ have+-- no lawful colax dual. Their split would have to turn one function out of a+-- combined input into two functions out of the parts, which needs projections or+-- base points that do not exist naturally. Only 'Forget' splits, because its+-- codomain @f r@ does not depend on the (contravariant) argument.++-- | Transparent newtype wrappers delegate to the wrapped bifunctor's split.+instance (Semigroupal Op tC1 tC2 tD p, Associative (->) tC1, Associative (->) tC2, Bifunctor tD) => Semigroupal Op tC1 tC2 tD (Biap p) where+  combine :: Op (tD (Biap p a b) (Biap p a' b')) (Biap p (tC1 a a') (tC2 b b'))+  combine = Op $ \(Biap pv) -> gbimap Biap Biap (getOp (combine @Op @tC1 @tC2 @tD) pv)++instance (Semigroupal Op tC1 tC2 tD p, Associative (->) tC1, Associative (->) tC2, Bifunctor tD) => Semigroupal Op tC1 tC2 tD (WrappedBifunctor p) where+  combine :: Op (tD (WrappedBifunctor p a b) (WrappedBifunctor p a' b')) (WrappedBifunctor p (tC1 a a') (tC2 b b'))+  combine = Op $ \(WrapBifunctor pv) -> gbimap WrapBifunctor WrapBifunctor (getOp (combine @Op @tC1 @tC2 @tD) pv)++-- | 'Flip' swaps the parameters, so its split is the wrapped bifunctor's split at+-- the swapped tensors.+instance (Semigroupal Op tC2 tC1 tD p, Associative (->) tC1, Associative (->) tC2, Bifunctor tD) => Semigroupal Op tC1 tC2 tD (Flip p) where+  combine :: Op (tD (Flip p a b) (Flip p a' b')) (Flip p (tC1 a a') (tC2 b b'))+  combine = Op $ \(Flip pv) -> gbimap Flip Flip (getOp (combine @Op @tC2 @tC1 @tD) pv)++-- | 'Tannen' wraps a bifunctor in a functor. Map the bifunctor split under the+-- functor, then use the functor colax split to pull the tensor out.+instance (F.Semigroupal Op tD tD f, Semigroupal Op tC1 tC2 tD p, Functor f, Associative (->) tC1, Associative (->) tC2, Bifunctor tD) => Semigroupal Op tC1 tC2 tD (Tannen f p) where+  combine :: Op (tD (Tannen f p a b) (Tannen f p a' b')) (Tannen f p (tC1 a a') (tC2 b b'))+  combine = Op $ \(Tannen fp) -> gbimap Tannen Tannen (getOp (F.combine @Op @tD @tD) (fmap (getOp (combine @Op @tC1 @tC2 @tD)) fp))++-- | 'Biff' applies a functor to each parameter before the bifunctor. Each+-- parameter's functor splits into the codomain tensor @tD@, then the bifunctor+-- splits at @Op tD tD tD@. Fixing the intermediate tensors to @tD@ keeps them+-- determined by the instance head.+instance+  ( F.Semigroupal Op tC1 tD f,+    F.Semigroupal Op tC2 tD g,+    Semigroupal Op tD tD tD p,+    Functor f,+    Functor g,+    Bifunctor p,+    Associative (->) tC1,+    Associative (->) tC2,+    Bifunctor tD+  ) =>+  Semigroupal Op tC1 tC2 tD (Biff p f g)+  where+  combine :: Op (tD (Biff p f g a b) (Biff p f g a' b')) (Biff p f g (tC1 a a') (tC2 b b'))+  combine = Op $ \(Biff pv) ->+    gbimap Biff Biff (getOp (combine @Op @tD @tD @tD) (bimap (getOp (F.combine @Op @tC1 @tD)) (getOp (F.combine @Op @tC2 @tD)) pv))++deriving via FromBiapplicative ((,,) x) instance (Monoid x) => Semigroupal (->) (,) (,) (,) ((,,) x)++deriving via FromBiapplicative ((,,,) x y) instance (Monoid x, Monoid y) => Semigroupal (->) (,) (,) (,) ((,,,) x y)++deriving via FromBiapplicative ((,,,,) x y z) instance (Monoid x, Monoid y, Monoid z) => Semigroupal (->) (,) (,) (,) ((,,,,) x y z)++deriving via FromBiapplicative ((,,,,,) x y z w) instance (Monoid x, Monoid y, Monoid z, Monoid w) => Semigroupal (->) (,) (,) (,) ((,,,,,) x y z w)++deriving via FromBiapplicative ((,,,,,,) x y z w v) instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Semigroupal (->) (,) (,) (,) ((,,,,,,) x y z w v)++deriving via FromBiapplicative Arg instance Semigroupal (->) (,) (,) (,) Arg++deriving via FromBiapplicative Const instance Semigroupal (->) (,) (,) (,) Const++deriving via FromBiapplicative (Biap p) instance (Biapplicative p) => Semigroupal (->) (,) (,) (,) (Biap p)++deriving via FromBiapplicative Tagged instance Semigroupal (->) (,) (,) (,) Tagged++deriving via FromBiapplicative (Clown f) instance (Applicative f) => Semigroupal (->) (,) (,) (,) (Clown f)++deriving via FromBiapplicative (Flip p) instance (Biapplicative p) => Semigroupal (->) (,) (,) (,) (Flip p)++deriving via FromBiapplicative (Joker g) instance (Applicative g) => Semigroupal (->) (,) (,) (,) (Joker g)++deriving via FromBiapplicative (WrappedBifunctor p) instance (Biapplicative p) => Semigroupal (->) (,) (,) (,) (WrappedBifunctor p)++-- | A single variance-agnostic 'Product' instance. @combine@ is componentwise,+-- delegating to each component's own 'Semigroupal'. It subsumes the former+-- @FromBiapplicative@ instance and covers profunctor components and the+-- 'Either' \/ 'These' tensors.+instance (Semigroupal (->) tC1 tC2 (,) f, Semigroupal (->) tC1 tC2 (,) g) => Semigroupal (->) tC1 tC2 (,) (Product f g) where+  combine :: (Product f g x y, Product f g x' y') -> Product f g (tC1 x x') (tC2 y y')+  combine (Pair fxy gxy, Pair fxy' gxy') =+    Pair (combine @(->) @tC1 @tC2 @(,) (fxy, fxy')) (combine @(->) @tC1 @tC2 @(,) (gxy, gxy'))++deriving via FromBiapplicative (Tannen f p) instance (Applicative f, Biapplicative p) => Semigroupal (->) (,) (,) (,) (Tannen f p)++deriving via FromBiapplicative (Biff p f g) instance (Applicative f, Applicative g, Biapplicative p) => Semigroupal (->) (,) (,) (,) (Biff p f g)++instance (Profunctor p) => Semigroupal (->) (,) Either Either p where   combine :: Either (p x y) (p x' y') -> p (x, x') (Either y y')   combine = either (dimap fst Left) (dimap snd Right) -instance Semigroupal (->) (,) (,) (,) (,) where-  combine :: ((x, y), (x', y')) -> ((x, x'), (y, y'))-  combine ((x, y), (x', y')) = ((x, x'), (y, y'))- -- NOTE: This version could be used for a more general abstraction -- of products in a category: -- combine =@@ -116,85 +334,77 @@   combine :: (x -> y, x' -> y') -> Either x x' -> Either y y'   combine fs = either (Left . fst fs) (Right . snd fs) -instance Applicative f => Semigroupal (->) (,) (,) (,) (Joker f) where-  combine :: (Joker f x y, Joker f x' y') -> Joker f (x, x') (y, y')-  combine = uncurry $ biliftA2 (,) (,)--instance Alternative f => Semigroupal (->) Either Either (,) (Joker f) where+instance (Alternative f) => Semigroupal (->) Either Either (,) (Joker f) where   combine :: (Joker f x y, Joker f x' y') -> Joker f (Either x x') (Either y y')   combine = uncurry $ biliftA2 (\_ x' -> Right x') (\_ y' -> Right y') -instance Functor f => Semigroupal (->) Either Either Either (Joker f) where+instance (Functor f) => Semigroupal (->) Either Either Either (Joker f) where   combine :: Either (Joker f x y) (Joker f x' y') -> Joker f (Either x x') (Either y y')   combine = either (Joker . fmap Left . runJoker) (Joker . fmap Right . runJoker) -instance Applicative f => Semigroupal (->) (,) (,) (,) (Clown f) where-  combine :: (Clown f x y, Clown f x' y') -> Clown f (x, x') (y, y')-  combine = uncurry $ biliftA2 (,) (,)--instance Alternative f => Semigroupal (->) Either Either (,) (Clown f) where+instance (Alternative f) => Semigroupal (->) Either Either (,) (Clown f) where   combine :: (Clown f x y, Clown f x' y') -> Clown f (Either x x') (Either y y')   combine = uncurry $ biliftA2 (\_ x' -> Right x') (\_ y' -> Right y') -instance Applicative f => Semigroupal (->) (,) (,) (,) (Star f) where+instance (Applicative f) => Semigroupal (->) (,) (,) (,) (Star f) where   combine :: (Star f x y, Star f x' y') -> Star f (x, x') (y, y')   combine (Star fxy, Star fxy') = Star $ \(x, x') -> liftA2 (,) (fxy x) (fxy' x') -instance Functor f => Semigroupal (->) Either Either (,) (Star f) where+instance (Functor f) => Semigroupal (->) Either Either (,) (Star f) where   combine :: (Star f x y, Star f x' y') -> Star f (Either x x') (Either y y')   combine (Star fxy, Star fxy') = Star $ either (fmap Left . fxy) (fmap Right . fxy') -instance Applicative f => Semigroupal (->) These These (,) (Star f) where+instance (Applicative f) => Semigroupal (->) These These (,) (Star f) where   combine :: (Star f x y, Star f x' y') -> Star f (These x x') (These y y')   combine (Star fxy, Star fxy') = Star $ these (fmap This . fxy) (fmap That . fxy') (\x x' -> liftA2 These (fxy x) (fxy' x')) -instance Alternative f => Semigroupal (->) These These These (Star f) where-  combine :: Applicative f => These (Star f x y) (Star f x' y') -> Star f (These x x') (These y y')+instance (Alternative f) => Semigroupal (->) These These These (Star f) where+  combine :: (Applicative f) => These (Star f x y) (Star f x' y') -> Star f (These x x') (These y y')   combine = \case     This (Star fxy) -> Star $ these (fmap This . fxy) (const empty) (\x _ -> This <$> fxy x)     That (Star fxy') -> Star $ these (const empty) (fmap That . fxy') (\_ x' -> That <$> fxy' x')     These (Star fxy) (Star fxy') -> Star $ these (fmap This . fxy) (fmap That . fxy') (\x x' -> liftA2 These (fxy x) (fxy' x')) -instance Alternative f => Semigroupal (->) Either Either Either (Star f) where+instance (Alternative f) => Semigroupal (->) Either Either Either (Star f) where   combine :: Either (Star f x y) (Star f x' y') -> Star f (Either x x') (Either y y')   combine = \case     Left (Star fxy) -> Star $ either (fmap Left . fxy) (const empty)     Right (Star fxy') -> Star $ either (const empty) (fmap Right . fxy') -instance Alternative f => Semigroupal (->) (,) Either (,) (Star f) where+instance (Alternative f) => Semigroupal (->) (,) Either (,) (Star f) where   combine :: (Star f x y, Star f x' y') -> Star f (x, x') (Either y y')   combine (Star f, Star g) = Star $ \(x, x') -> (Left <$> f x) <|> (Right <$> g x') -instance Applicative f => Semigroupal (->) (,) (,) (,) (Kleisli f) where+instance (Applicative f) => Semigroupal (->) (,) (,) (,) (Kleisli f) where   combine :: (Kleisli f x y, Kleisli f x' y') -> Kleisli f (x, x') (y, y')   combine (Kleisli fxy, Kleisli fxy') = Kleisli $ \(x, x') -> liftA2 (,) (fxy x) (fxy' x') -instance Functor f => Semigroupal (->) Either Either (,) (Kleisli f) where+instance (Functor f) => Semigroupal (->) Either Either (,) (Kleisli f) where   combine :: (Kleisli f x y, Kleisli f x' y') -> Kleisli f (Either x x') (Either y y')   combine (Kleisli fxy, Kleisli fxy') = Kleisli $ either (fmap Left . fxy) (fmap Right . fxy') -instance Applicative f => Semigroupal (->) These These (,) (Kleisli f) where+instance (Applicative f) => Semigroupal (->) These These (,) (Kleisli f) where   combine :: (Kleisli f x y, Kleisli f x' y') -> Kleisli f (These x x') (These y y')   combine (Kleisli fxy, Kleisli fxy') = Kleisli $ these (fmap This . fxy) (fmap That . fxy') (\x x' -> liftA2 These (fxy x) (fxy' x')) -instance Alternative f => Semigroupal (->) These These These (Kleisli f) where-  combine :: Applicative f => These (Kleisli f x y) (Kleisli f x' y') -> Kleisli f (These x x') (These y y')+instance (Alternative f) => Semigroupal (->) These These These (Kleisli f) where+  combine :: (Applicative f) => These (Kleisli f x y) (Kleisli f x' y') -> Kleisli f (These x x') (These y y')   combine = \case     This (Kleisli fxy) -> Kleisli $ these (fmap This . fxy) (const empty) (\x _ -> This <$> fxy x)     That (Kleisli fxy') -> Kleisli $ these (const empty) (fmap That . fxy') (\_ x' -> That <$> fxy' x')     These (Kleisli fxy) (Kleisli fxy') -> Kleisli $ these (fmap This . fxy) (fmap That . fxy') (\x x' -> liftA2 These (fxy x) (fxy' x')) -instance Alternative f => Semigroupal (->) Either Either Either (Kleisli f) where+instance (Alternative f) => Semigroupal (->) Either Either Either (Kleisli f) where   combine :: Either (Kleisli f x y) (Kleisli f x' y') -> Kleisli f (Either x x') (Either y y')   combine = \case     Left (Kleisli fxy) -> Kleisli $ either (fmap Left . fxy) (const empty)     Right (Kleisli fxy') -> Kleisli $ either (const empty) (fmap Right . fxy') -instance Alternative f => Semigroupal (->) (,) Either (,) (Kleisli f) where+instance (Alternative f) => Semigroupal (->) (,) Either (,) (Kleisli f) where   combine :: (Kleisli f x y, Kleisli f x' y') -> Kleisli f (x, x') (Either y y')   combine (Kleisli f, Kleisli g) = Kleisli $ \(x, x') -> (Left <$> f x) <|> (Right <$> g x') -instance Alternative f => Semigroupal (->) (,) (,) (,) (Forget (f r)) where+instance (Alternative f) => Semigroupal (->) (,) (,) (,) (Forget (f r)) where   combine :: (Forget (f r) x y, Forget (f r) x' y') -> Forget (f r) (x, x') (y, y')   combine (Forget f, Forget g) = Forget $ \(x, x') -> f x <|> g x' @@ -202,22 +412,72 @@   combine :: (Forget (f r) x y, Forget (f r) x' y') -> Forget (f r) (Either x x') (Either y y')   combine (Forget f, Forget g) = Forget $ either f g -instance Alternative f => Semigroupal (->) Either Either Either (Forget (f r)) where+instance (Alternative f) => Semigroupal (->) Either Either Either (Forget (f r)) where   combine :: Either (Forget (f r) x y) (Forget (f r) x' y') -> Forget (f r) (Either x x') (Either y y')   combine = \case     Left (Forget f) -> Forget $ either f (const empty)     Right (Forget g) -> Forget $ either (const empty) g -instance Alternative f => Semigroupal (->) (,) Either (,) (Forget (f r)) where+instance (Alternative f) => Semigroupal (->) (,) Either (,) (Forget (f r)) where   combine :: (Forget (f r) x y, Forget (f r) x' y') -> Forget (f r) (x, x') (Either y y')   combine (Forget f, Forget g) = Forget $ \(x, x') -> f x <|> g x' +infixr 9 |??|++(|??|) :: (Semigroupal (->) tC1 tC2 (,) p) => p a b -> p a' b' -> p (a `tC1` a') (b `tC2` b')+(|??|) = curry combine++infixr 9 |**|++(|**|) :: (Semigroupal (->) (,) (,) (,) p) => p a b -> p a' b' -> p (a, a') (b, b')+(|**|) = curry combine++infixr 9 |*+|++(|*+|) :: (Semigroupal (->) (,) Either (,) p) => p a b -> p a' b' -> p (a, a') (Either b b')+(|*+|) = curry combine++infixr 9 |*&|++(|*&|) :: (Semigroupal (->) (,) These (,) p) => p a b -> p a' b' -> p (a, a') (These b b')+(|*&|) = curry combine++infixr 9 |++|++(|++|) :: (Semigroupal (->) Either Either (,) p) => p a b -> p a' b' -> p (Either a a') (Either b b')+(|++|) = curry combine++infixr 9 |+*|++(|+*|) :: (Semigroupal (->) Either (,) (,) p) => p a b -> p a' b' -> p (Either a a') (b, b')+(|+*|) = curry combine++infixr 9 |+&|++(|+&|) :: (Semigroupal (->) These (,) (,) p) => p a b -> p a' b' -> p (These a a') (b, b')+(|+&|) = curry combine++infixr 9 |&&|++(|&&|) :: (Semigroupal (->) These These (,) p) => p a b -> p a' b' -> p (These a a') (These b b')+(|&&|) = curry combine++infixr 9 |&*|++(|&*|) :: (Semigroupal (->) These (,) (,) p) => p a b -> p a' b' -> p (These a a') (b, b')+(|&*|) = curry combine++infixr 9 |&+|++(|&+|) :: (Semigroupal (->) These Either (,) p) => p a b -> p a' b' -> p (These a a') (Either b b')+(|&+|) = curry combine+ --------------------------------------------------------------------------------  -- | Given monoidal categories \((\mathcal{C}, \otimes, I_{\mathcal{C}})\) and \((\mathcal{D}, \bullet, I_{\mathcal{D}})\). -- A bifunctor \(F : \mathcal{C_1} \times \mathcal{C_2} \to \mathcal{D}\) is 'Unital' if it supports a morphism -- \(\phi : I_{\mathcal{D}} \to F\ I_{\mathcal{C_1}}\ I_{\mathcal{C_2}}\), which we call 'introduce'.-class Unital cat i1 i2 io f where+class Unital cat iC1 iC2 iD f where   -- | @introduce@ maps from the identity in \(\mathcal{C_1} \times \mathcal{C_2}\) to the   -- identity in \(\mathcal{D}\).   --@@ -226,21 +486,56 @@   -- >>> introduce @(->) @() @() @() @(,) ()   -- ((),())   ---  -- >>> :t introduce @(->) @Void @() @() @Either-  -- introduce @(->) @Void @() @() @Either :: () -> Either Void ()-  --   -- >>> introduce @(->) @Void @() @() @Either ()   -- Right ()-  introduce :: cat io (f i1 i2)+  introduce :: cat iD (f iC1 iC2) +instance (Biapplicative p) => Unital (->) () () () (FromBiapplicative p) where+  introduce :: () -> FromBiapplicative p () ()+  introduce () = bipure () ()++deriving via FromBiapplicative (,) instance Unital (->) () () () (,)++deriving via FromBiapplicative ((,,) x) instance (Monoid x) => Unital (->) () () () ((,,) x)++deriving via FromBiapplicative ((,,,) x y) instance (Monoid x, Monoid y) => Unital (->) () () () ((,,,) x y)++deriving via FromBiapplicative ((,,,,) x y z) instance (Monoid x, Monoid y, Monoid z) => Unital (->) () () () ((,,,,) x y z)++deriving via FromBiapplicative ((,,,,,) x y z w) instance (Monoid x, Monoid y, Monoid z, Monoid w) => Unital (->) () () () ((,,,,,) x y z w)++deriving via FromBiapplicative ((,,,,,,) x y z w v) instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Unital (->) () () () ((,,,,,,) x y z w v)++deriving via FromBiapplicative Arg instance Unital (->) () () () Arg++deriving via FromBiapplicative Const instance Unital (->) () () () Const++deriving via FromBiapplicative (Biap p) instance (Biapplicative p) => Unital (->) () () () (Biap p)++deriving via FromBiapplicative Tagged instance Unital (->) () () () Tagged++deriving via FromBiapplicative (Clown f) instance (Applicative f) => Unital (->) () () () (Clown f)++deriving via FromBiapplicative (Flip p) instance (Biapplicative p) => Unital (->) () () () (Flip p)++deriving via FromBiapplicative (Joker g) instance (Applicative g) => Unital (->) () () () (Joker g)++deriving via FromBiapplicative (WrappedBifunctor p) instance (Biapplicative p) => Unital (->) () () () (WrappedBifunctor p)++-- | Componentwise 'introduce', delegating to each component's 'Unital'. Covers+-- every unit pair that both components support, covariant and profunctor alike.+instance (Unital (->) iC1 iC2 () f, Unital (->) iC1 iC2 () g) => Unital (->) iC1 iC2 () (Product f g) where+  introduce :: () -> Product f g iC1 iC2+  introduce () = Pair (introduce @(->) @iC1 @iC2 @() ()) (introduce @(->) @iC1 @iC2 @() ())++deriving via FromBiapplicative (Tannen f p) instance (Applicative f, Biapplicative p) => Unital (->) () () () (Tannen f p)++deriving via FromBiapplicative (Biff p f g) instance (Applicative f, Applicative g, Biapplicative p) => Unital (->) () () () (Biff p f g)+ instance (Profunctor p, Category p) => Unital (->) () () () (StrongCategory p) where   introduce :: () -> StrongCategory p () ()   introduce () = StrongCategory id -instance Unital (->) () () () (,) where-  introduce :: () -> ((), ())-  introduce = split- instance Unital (->) Void Void Void (,) where   introduce :: Void -> (Void, Void)   introduce = spawn@@ -265,11 +560,7 @@   introduce :: () -> Void -> Void   introduce () = absurd -instance Applicative f => Unital (->) () () () (Joker f) where-  introduce :: () -> Joker f () ()-  introduce = Joker . pure--instance Alternative f => Unital (->) Void Void () (Joker f) where+instance (Alternative f) => Unital (->) Void Void () (Joker f) where   introduce :: () -> Joker f Void Void   introduce () = Joker empty @@ -277,7 +568,7 @@   introduce :: Void -> Joker f Void Void   introduce = absurd -instance Applicative f => Unital (->) () () () (Star f) where+instance (Applicative f) => Unital (->) () () () (Star f) where   introduce :: () -> Star f () ()   introduce () = Star pure @@ -285,15 +576,15 @@   introduce :: () -> Star f Void Void   introduce () = Star absurd -instance Alternative f => Unital (->) Void Void Void (Star f) where+instance (Alternative f) => Unital (->) Void Void Void (Star f) where   introduce :: Void -> Star f Void Void   introduce = absurd -instance Alternative f => Unital (->) () Void () (Star f) where+instance (Alternative f) => Unital (->) () Void () (Star f) where   introduce :: () -> Star f () Void   introduce () = Star $ const empty -instance Applicative f => Unital (->) () () () (Kleisli f) where+instance (Applicative f) => Unital (->) () () () (Kleisli f) where   introduce :: () -> Kleisli f () ()   introduce () = Kleisli pure @@ -301,11 +592,11 @@   introduce :: () -> Kleisli f Void Void   introduce () = Kleisli absurd -instance Alternative f => Unital (->) Void Void Void (Kleisli f) where+instance (Alternative f) => Unital (->) Void Void Void (Kleisli f) where   introduce :: Void -> Kleisli f Void Void   introduce = absurd -instance Alternative f => Unital (->) () Void () (Kleisli f) where+instance (Alternative f) => Unital (->) () Void () (Kleisli f) where   introduce :: () -> Kleisli f () Void   introduce () = Kleisli $ const empty @@ -349,18 +640,50 @@ -- 'combine' 'Control.Category..' 'Control.Category.Tensor.glmap' 'introduce' ≡ 'fmap' ('bwd' 'unitl') 'Control.Category..' 'fwd' 'unitl' -- @ class-  ( Tensor cat t1 i1,-    Tensor cat t2 i2,-    Tensor cat to io,-    Semigroupal cat t1 t2 to f,-    Unital cat i1 i2 io f+  ( Tensor cat tC1 iC1,+    Tensor cat tC2 iC2,+    Tensor cat tD iD,+    Semigroupal cat tC1 tC2 tD f,+    Unital cat iC1 iC2 iD f   ) =>-  Monoidal cat t1 i1 t2 i2 to io f--instance (Strong p, Semigroupoid p, Category p) => Monoidal (->) (,) () (,) () (,) () (StrongCategory p)+  Monoidal cat tC1 iC1 tC2 iC2 tD iD f  instance Monoidal (->) (,) () (,) () (,) () (,) +instance (Monoid x) => Monoidal (->) (,) () (,) () (,) () ((,,) x)++instance (Monoid x, Monoid y) => Monoidal (->) (,) () (,) () (,) () ((,,,) x y)++instance (Monoid x, Monoid y, Monoid z) => Monoidal (->) (,) () (,) () (,) () ((,,,,) x y z)++instance (Monoid x, Monoid y, Monoid z, Monoid w) => Monoidal (->) (,) () (,) () (,) () ((,,,,,) x y z w)++instance (Monoid x, Monoid y, Monoid z, Monoid w, Monoid v) => Monoidal (->) (,) () (,) () (,) () ((,,,,,,) x y z w v)++instance Monoidal (->) (,) () (,) () (,) () Arg++instance Monoidal (->) (,) () (,) () (,) () Const++instance (Biapplicative p) => Monoidal (->) (,) () (,) () (,) () (Biap p)++instance Monoidal (->) (,) () (,) () (,) () Tagged++instance (Applicative f) => Monoidal (->) (,) () (,) () (,) () (Clown f)++instance (Biapplicative p) => Monoidal (->) (,) () (,) () (,) () (Flip p)++instance (Applicative g) => Monoidal (->) (,) () (,) () (,) () (Joker g)++instance (Biapplicative p) => Monoidal (->) (,) () (,) () (,) () (WrappedBifunctor p)++instance (Semigroupal (->) tC1 tC2 (,) f, Semigroupal (->) tC1 tC2 (,) g, Unital (->) iC1 iC2 () f, Unital (->) iC1 iC2 () g, Tensor (->) tC1 iC1, Tensor (->) tC2 iC2) => Monoidal (->) tC1 iC1 tC2 iC2 (,) () (Product f g)++instance (Applicative f, Biapplicative p) => Monoidal (->) (,) () (,) () (,) () (Tannen f p)++instance (Applicative f, Applicative g, Biapplicative p) => Monoidal (->) (,) () (,) () (,) () (Biff p f g)++instance (Strong p, Semigroupoid p, Category p) => Monoidal (->) (,) () (,) () (,) () (StrongCategory p)+ instance Monoidal (->) Either Void Either Void Either Void (,)  instance Monoidal (->) Either Void Either Void Either Void Either@@ -373,40 +696,38 @@  instance Monoidal (->) Either Void Either Void (,) () (->) -instance Applicative f => Monoidal (->) (,) () (,) () (,) () (Joker f)--instance Alternative f => Monoidal (->) Either Void Either Void (,) () (Joker f)+instance (Alternative f) => Monoidal (->) Either Void Either Void (,) () (Joker f) -instance Functor f => Monoidal (->) Either Void Either Void Either Void (Joker f)+instance (Functor f) => Monoidal (->) Either Void Either Void Either Void (Joker f) -instance Applicative f => Monoidal (->) (,) () (,) () (,) () (Star f)+instance (Applicative f) => Monoidal (->) (,) () (,) () (,) () (Star f) -instance Functor f => Monoidal (->) Either Void Either Void (,) () (Star f)+instance (Functor f) => Monoidal (->) Either Void Either Void (,) () (Star f) -instance Applicative f => Monoidal (->) These Void These Void (,) () (Star f)+instance (Applicative f) => Monoidal (->) These Void These Void (,) () (Star f) -instance Alternative f => Monoidal (->) Either Void Either Void Either Void (Star f)+instance (Alternative f) => Monoidal (->) Either Void Either Void Either Void (Star f) -instance Alternative f => Monoidal (->) These Void These Void These Void (Star f)+instance (Alternative f) => Monoidal (->) These Void These Void These Void (Star f) -instance Alternative f => Monoidal (->) (,) () Either Void (,) () (Star f)+instance (Alternative f) => Monoidal (->) (,) () Either Void (,) () (Star f) -instance Applicative f => Monoidal (->) (,) () (,) () (,) () (Kleisli f)+instance (Applicative f) => Monoidal (->) (,) () (,) () (,) () (Kleisli f) -instance Functor f => Monoidal (->) Either Void Either Void (,) () (Kleisli f)+instance (Functor f) => Monoidal (->) Either Void Either Void (,) () (Kleisli f) -instance Applicative f => Monoidal (->) These Void These Void (,) () (Kleisli f)+instance (Applicative f) => Monoidal (->) These Void These Void (,) () (Kleisli f) -instance Alternative f => Monoidal (->) Either Void Either Void Either Void (Kleisli f)+instance (Alternative f) => Monoidal (->) Either Void Either Void Either Void (Kleisli f) -instance Alternative f => Monoidal (->) These Void These Void These Void (Kleisli f)+instance (Alternative f) => Monoidal (->) These Void These Void These Void (Kleisli f) -instance Alternative f => Monoidal (->) (,) () Either Void (,) () (Kleisli f)+instance (Alternative f) => Monoidal (->) (,) () Either Void (,) () (Kleisli f)  newtype StrongCategory p a b = StrongCategory (p a b)   deriving (Functor, Applicative, Monad, Profunctor, Category) -instance Semigroupoid p => Semigroupoid (StrongCategory p) where+instance (Semigroupoid p) => Semigroupoid (StrongCategory p) where   o :: StrongCategory p b c -> StrongCategory p a b -> StrongCategory p a c   o (StrongCategory f) (StrongCategory g) = StrongCategory (f `o` g) 

@@ -2,92 +2,215 @@  module Data.Bifunctor.Monoidal.Specialized where +--------------------------------------------------------------------------------+ import Control.Category.Cartesian import Control.Category.Tensor ()+import Data.Bifunctor import Data.Bifunctor.Monoidal import Data.Functor.Contravariant import Data.Profunctor-import Data.These import Data.Void import Prelude hiding ((&&), (||)) +--------------------------------------------------------------------------------++-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Void (Void)+-- >>> import Data.Tagged (Tagged (..), unTagged)+-- >>> import Data.Profunctor (Star (..), Forget (..))+-- >>> let evens = Star (\n -> if even n then Just n else Nothing) :: Star Maybe Int Int+-- >>> let positives = Star (\n -> if n > 0 then Just n else Nothing) :: Star Maybe Int Int+-- >>> let checker = Forget (\e -> Just (either negate (\b -> if b then 1 else 0) e)) :: Forget (Maybe Int) (Either Int Bool) (Either () ())+-- >>> let idForget = Forget Just :: Forget (Maybe Int) Int (Either () ())++--------------------------------------------------------------------------------+ -- | Split the input between the two arguments and multiply their outputs.-mux :: Semigroupal (->) (,) (,) (,) p => p a b -> p c d -> p (a, c) (b, d)+--+-- ==== __Examples__+--+-- >>> mux (show :: Int -> String) not (123, False)+-- ("123",True)+mux :: (Semigroupal (->) (,) (,) (,) p) => p a b -> p c d -> p (a, c) (b, d) mux = curry combine  infixr 3 ***  -- | Infix operator for 'mux'.-(***) :: Semigroupal (->) (,) (,) (,) p => p a b -> p c d -> p (a, c) (b, d)+--+-- ==== __Examples__+--+-- >>> ((show :: Int -> String) *** not) (123, False)+-- ("123",True)+(***) :: (Semigroupal (->) (,) (,) (,) p) => p a b -> p c d -> p (a, c) (b, d) (***) = mux  -- | Split the input between the two arguments and sum their outputs.-demux :: Semigroupal (->) Either Either (,) p => p a b -> p c d -> p (Either a c) (Either b d)+--+-- ==== __Examples__+--+-- >>> demux (show :: Int -> String) not (Left 5 :: Either Int Bool)+-- Left "5"+--+-- >>> demux (show :: Int -> String) not (Right True :: Either Int Bool)+-- Right False+demux :: (Semigroupal (->) Either Either (,) p) => p a b -> p c d -> p (Either a c) (Either b d) demux = curry combine  infixr 2 +++  -- | Infix operator for 'demux'.-(+++) :: Semigroupal (->) Either Either (,) p => p a b -> p c d -> p (Either a c) (Either b d)+--+-- ==== __Examples__+--+-- >>> ((show :: Int -> String) +++ not) (Left 5 :: Either Int Bool)+-- Left "5"+(+++) :: (Semigroupal (->) Either Either (,) p) => p a b -> p c d -> p (Either a c) (Either b d) (+++) = demux  -- | Send the whole input to the two arguments and multiply their outputs.+--+-- ==== __Examples__+--+-- >>> fanout (show :: Int -> String) even (4 :: Int)+-- ("4",True) fanout :: (Profunctor p, Semigroupal (->) (,) (,) (,) p) => p x a -> p x b -> p x (a, b) fanout pxa pxb = lmap split' $ pxa *** pxb  infixr 3 &&&  -- | Infix operator for 'fanout'.+--+-- ==== __Examples__+--+-- >>> ((show :: Int -> String) &&& even) (4 :: Int)+-- ("4",True) (&&&) :: (Profunctor p, Semigroupal (->) (,) (,) (,) p) => p x a -> p x b -> p x (a, b) (&&&) = fanout  -- | Split the input between the two arguments and merge their outputs.+--+-- ==== __Examples__+--+-- >>> fanin (show :: Int -> String) (show :: Bool -> String) (Left 5 :: Either Int Bool)+-- "5"+--+-- >>> fanin (show :: Int -> String) (show :: Bool -> String) (Right True :: Either Int Bool)+-- "True" fanin :: (Profunctor p, Semigroupal (->) Either Either (,) p) => p a x -> p b x -> p (Either a b) x fanin pax pbx = rmap merge' $ pax +++ pbx  infixr 2 |||  -- | Infix operator for 'fanin'.+--+-- ==== __Examples__+--+-- >>> ((show :: Int -> String) ||| (show :: Bool -> String)) (Left 5 :: Either Int Bool)+-- "5" (|||) :: (Profunctor p, Semigroupal (->) Either Either (,) p) => p a x -> p b x -> p (Either a b) x (|||) = fanin --- | Split the input between the two arguments and and sum their outputs.-switch :: Semigroupal (->) (,) Either (,) p => p a b -> p c d -> p (a, c) (Either b d)+-- | Split the input between the two arguments and sum their outputs.+--+-- Demonstrated on @'Star' 'Maybe'@, a parser-like profunctor. @evens@ succeeds on+-- even inputs and @positives@ on positive ones.+--+-- ==== __Examples__+--+-- >>> runStar (switch evens positives) (4, 5)+-- Just (Left 4)+--+-- >>> runStar (switch evens positives) (5, 5)+-- Just (Right 5)+switch :: (Semigroupal (->) (,) Either (,) p) => p a b -> p c d -> p (a, c) (Either b d) switch = curry combine  infixr 5 &|  -- | Infix operator for 'switch'.-(&|) :: Semigroupal (->) (,) Either (,) p => p a b -> p c d -> p (a, c) (Either b d)+--+-- ==== __Examples__+--+-- >>> runStar (evens &| positives) (5, 5)+-- Just (Right 5)+(&|) :: (Semigroupal (->) (,) Either (,) p) => p a b -> p c d -> p (a, c) (Either b d) (&|) = switch  -- | Send the whole input to the two arguments and sum their outputs.-union :: Profunctor p => Semigroupal (->) (,) Either (,) p => p x a -> p x b -> p x (Either a b)+--+-- ==== __Examples__+--+-- >>> runStar (union evens positives) 4+-- Just (Left 4)+union :: (Profunctor p) => (Semigroupal (->) (,) Either (,) p) => p x a -> p x b -> p x (Either a b) union pxa pxb = lmap split' $ pxa &| pxb  -- | Split the input between the two arguments then merge their outputs.+--+-- ==== __Examples__+--+-- >>> runStar (divide evens positives) (4, 5)+-- Just 4 divide :: (Profunctor p, Semigroupal (->) (,) Either (,) p) => p a x -> p b x -> p (a, b) x divide pxa pxb = rmap merge' $ pxa &| pxb  -- | Split the input between the two arguments then multiply their outputs.-splice :: Semigroupal (->) Either (,) (,) p => p a b -> p c d -> p (Either a c) (b, d)+--+-- ==== __Examples__+--+-- >>> splice (Right True :: Either Int Bool) (Right (7 :: Int) :: Either Int Int)+-- Right (True,7)+splice :: (Semigroupal (->) Either (,) (,) p) => p a b -> p c d -> p (Either a c) (b, d) splice = curry combine  infix 5 |&  -- | Infix operator for 'splice'.-(|&) :: Semigroupal (->) Either (,) (,) p => p a b -> p c d -> p (Either a c) (b, d)+--+-- ==== __Examples__+--+-- >>> (Right True :: Either Int Bool) |& (Right (7 :: Int) :: Either Int Int)+-- Right (True,7)+(|&) :: (Semigroupal (->) Either (,) (,) p) => p a b -> p c d -> p (Either a c) (b, d) (|&) = splice -diverge :: Semigroupal (->) Either Either Either p => Either (p a b) (p c d) -> p (Either a c) (Either b d)+-- | Route a choice of two profunctors to a profunctor over sums.+--+-- ==== __Examples__+--+-- >>> runStar (diverge (Left evens :: Either (Star Maybe Int Int) (Star Maybe Int Int))) (Left 4)+-- Just (Left 4)+diverge :: (Semigroupal (->) Either Either Either p) => Either (p a b) (p c d) -> p (Either a c) (Either b d) diverge = combine -contramapMaybe :: Profunctor p => Semigroupal (->) Either Either Either p => (a -> Maybe b) -> p b x -> p a x+-- | Precompose a profunctor with a partial function, discarding 'Nothing's.+--+-- ==== __Examples__+--+-- >>> runStar (contramapMaybe (\x -> if x > 10 then Just x else Nothing) evens) 12+-- Just 12+contramapMaybe :: (Profunctor p) => (Semigroupal (->) Either Either Either p) => (a -> Maybe b) -> p b x -> p a x contramapMaybe f = dimap (maybe (Right ()) Left . f) merge' . ultraleft +-- | Combine a choice of profunctors sharing an input, tensoring their outputs.+--+-- ==== __Examples__+--+-- >>> (zig (Left (show :: Int -> String)) :: Int -> Either String ()) 5+-- Left "5" zig :: (Profunctor p, Semigroupal (->) (,) t Either p) => Either (p x a) (p x b) -> p x (t a b) zig = lmap split' . combine +-- | Combine a choice of profunctors sharing an output, tensoring their inputs.+--+-- ==== __Examples__+--+-- >>> (zag (Left (show :: Int -> String)) :: (Int, ()) -> String) (5, ())+-- "5" zag :: (Profunctor p, Semigroupal (->) t Either Either p) => Either (p a x) (p b x) -> p (t a b) x zag = rmap merge' . combine @@ -97,53 +220,185 @@ ultrasecond :: (Profunctor p, Semigroupal (->) (,) (,) Either p) => p a b -> p (x, a) (y, b) ultrasecond = zag . Right . zig . Right +-- | Widen a profunctor's input and output on the left of a sum.+--+-- ==== __Examples__+--+-- >>> runStar (ultraleft evens) (Left 4 :: Either Int Int)+-- Just (Left 4) ultraleft :: (Profunctor p, Semigroupal (->) Either Either Either p) => p a b -> p (Either a x) (Either b y) ultraleft = zag . Left . zig . Left +-- | Widen a profunctor's input and output on the right of a sum.+--+-- ==== __Examples__+--+-- >>> runStar (ultraright evens) (Right 4 :: Either Int Int)+-- Just (Right 4) ultraright :: (Profunctor p, Semigroupal (->) Either Either Either p) => p a b -> p (Either x a) (Either y b) ultraright = zag . Right . zig . Right -comux :: forall p a b c d. Semigroupal Op (,) (,) (,) p => p (a, c) (b, d) -> (p a b, p c d)+-- | Split a bifunctor over a product into its two factors.+--+-- ==== __Examples__+--+-- >>> comux ((1, 2), (3, 4)) :: ((Int, Int), (Int, Int))+-- ((1,3),(2,4))+comux :: forall p a b c d. (Semigroupal Op (,) (,) (,) p) => p (a, c) (b, d) -> (p a b, p c d) comux = getOp combine -undivide :: forall p x a b. Profunctor p => Semigroupal Op (,) (,) (,) p => p (a, b) x -> (p a x, p b x)+-- | Split a profunctor over a product input into its two factors.+--+-- ==== __Examples__+--+-- >>> unTagged (fst (undivide (Tagged 42 :: Tagged (Int, Bool) Int)))+-- 42+undivide :: forall p x a b. (Profunctor p) => (Semigroupal Op (,) (,) (,) p) => p (a, b) x -> (p a x, p b x) undivide = comux . rmap split' -codemux :: forall p a b c d. Semigroupal Op Either Either (,) p => p (Either a c) (Either b d) -> (p a b, p c d)+-- | Split a profunctor over a sum on both sides into its two factors.+--+-- ==== __Examples__+--+-- >>> runForget (fst (codemux checker)) 5+-- Just (-5)+codemux :: forall p a b c d. (Semigroupal Op Either Either (,) p) => p (Either a c) (Either b d) -> (p a b, p c d) codemux = getOp combine -partition :: forall p x a b. Profunctor p => Semigroupal Op Either Either (,) p => p x (Either a b) -> (p x a, p x b)+-- | Split a profunctor over a sum output into its two branches.+--+-- ==== __Examples__+--+-- >>> runForget (fst (partition idForget)) 5+-- Just 5+partition :: forall p x a b. (Profunctor p) => (Semigroupal Op Either Either (,) p) => p x (Either a b) -> (p x a, p x b) partition = codemux . lmap merge' -coswitch :: forall p a b c d. Semigroupal Op Either (,) (,) p => p (Either a c) (b, d) -> (p a b, p c d)+coswitch :: forall p a b c d. (Semigroupal Op Either (,) (,) p) => p (Either a c) (b, d) -> (p a b, p c d) coswitch = getOp combine -unfanin :: forall p x a b. Profunctor p => Semigroupal Op Either (,) (,) p => p (Either a b) x -> (p a x, p b x)+unfanin :: forall p x a b. (Profunctor p) => (Semigroupal Op Either (,) (,) p) => p (Either a b) x -> (p a x, p b x) unfanin = coswitch . rmap split' -unzip :: forall p x a b. Profunctor p => Semigroupal Op Either (,) (,) p => p x (a, b) -> (p x a, p x b)+unzip :: forall p x a b. (Profunctor p) => (Semigroupal Op Either (,) (,) p) => p x (a, b) -> (p x a, p x b) unzip = coswitch . lmap merge' -cosplice :: forall p a b c d. Semigroupal Op (,) Either (,) p => p (a, c) (Either b d) -> (p a b, p c d)+cosplice :: forall p a b c d. (Semigroupal Op (,) Either (,) p) => p (a, c) (Either b d) -> (p a b, p c d) cosplice = getOp combine -terminal :: forall p a. Profunctor p => Unital (->) () () () p => p a ()+-- | The unique morphism into the terminal object @()@.+--+-- ==== __Examples__+--+-- >>> terminal (5 :: Int)+-- ()+terminal :: forall p a. (Profunctor p) => (Unital (->) () () () p) => p a () terminal = lmap (const ()) $ introduce () -ppure :: forall p a. Profunctor p => Unital (->) () () () p => Strong p => p a a+-- | The reflexive morphism of a 'Strong', 'Unital' profunctor.+--+-- ==== __Examples__+--+-- >>> ppure (5 :: Int)+-- 5+ppure :: forall p a. (Profunctor p) => (Unital (->) () () () p) => (Strong p) => p a a ppure = dimap ((),) projr $ first' (introduce () :: p () ()) -initial :: forall p a. Profunctor p => Unital (->) Void Void () p => p Void a+initial :: forall p a. (Profunctor p) => (Unital (->) Void Void () p) => p Void a initial = rmap absurd $ introduce () -poly :: forall p a b. Profunctor p => Unital (->) () Void () p => p a b+-- | The empty profunctor, producing no output for any input.+--+-- ==== __Examples__+--+-- >>> runStar (poly :: Star Maybe Int Bool) 5+-- Nothing+poly :: forall p a b. (Profunctor p) => (Unital (->) () Void () p) => p a b poly = dimap (const ()) absurd $ introduce () -mono :: forall p. Unital (->) Void () () p => p Void ()+-- | The unique morphism from the initial object.+--+-- ==== __Examples__+--+-- >>> mono :: Either Void ()+-- Right ()+mono :: forall p. (Unital (->) Void () () p) => p Void () mono = introduce () +-- | Duplicate a value into both components of a pair.+--+-- ==== __Examples__+--+-- >>> split' True+-- (True,True) split' :: a -> (a, a) split' = split @(->) @(,) +-- | Collapse a sum of a type with itself.+--+-- ==== __Examples__+--+-- >>> merge' (Left True :: Either Bool Bool)+-- True merge' :: Either a a -> a merge' = merge @(->) @Either++-- | Lift two values into a 'Unital' bifunctor.+--+-- ==== __Examples__+--+-- >>> bipure (0 :: Int) True :: (Int, Bool)+-- (0,True)+bipure :: (Bifunctor p, Unital (->) () () () p) => a -> b -> p a b+bipure a b = bimap (const a) (const b) $ introduce @_ @() @() ()++-- | Combine two bifunctors component-wise under a pair of binary functions.+--+-- ==== __Examples__+--+-- >>> biliftA2 (+) (\a b -> a && b) (1 :: Int, True) (3, False)+-- (4,False)+biliftA2 :: (Bifunctor m, Semigroupal (->) (,) (,) (,) m) => (a -> b -> c) -> (d -> e -> f) -> m a d -> m b e -> m c f+biliftA2 f g m1 m2 = bimap (uncurry f) (uncurry g) $ combine (m1, m2)++-- | Apply a bifunctor of functions to a bifunctor of arguments.+--+-- ==== __Examples__+--+-- >>> biapply (negate, not) (5 :: Int, True)+-- (-5,False)+biapply :: (Bifunctor p, Semigroupal (->) (,) (,) (,) p) => p (a -> b) (c -> d) -> p a c -> p b d+biapply = fmap (bimap (uncurry ($)) (uncurry ($))) . mux++infixl 4 <<*>>++-- | Infix operator for 'biapply'.+--+-- ==== __Examples__+--+-- >>> (negate, not) <<*>> (5 :: Int, True)+-- (-5,False)+(<<*>>) :: (Bifunctor p, Semigroupal (->) (,) (,) (,) p) => p (a -> b) (c -> d) -> p a c -> p b d+(<<*>>) = biapply++infixl 4 *>>++-- | Sequence two bifunctors, keeping the outputs of the second.+--+-- ==== __Examples__+--+-- >>> (1 :: Int, True) *>> (3 :: Int, False)+-- (3,False)+(*>>) :: (Bifunctor p, Semigroupal (->) (,) (,) (,) p) => p a b -> p c d -> p c d+(*>>) = biliftA2 (const id) (const id)++infixl 4 <<*++-- | Sequence two bifunctors, keeping the outputs of the first.+--+-- ==== __Examples__+--+-- >>> (1 :: Int, True) <<* (3 :: Int, False)+-- (1,True)+(<<*) :: (Bifunctor p, Semigroupal (->) (,) (,) (,) p) => p a b -> p c d -> p a b+(<<*) = biliftA2 const const

@@ -0,0 +1,350 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++-- | Rank-2 monoidal bifunctors: the analogue of "Data.Functor.Rank2.Monoidal"+-- for higher-kinded data interpreted by a bifunctor,+-- @b :: (Type -> Type -> Type) -> Type@.+--+-- A rank-2 bifunctor is a functor \(B : [\mathcal{Hask}^{2}, \mathcal{Hask}] \to \mathcal{Hask}\)+-- from the bifunctor category to @Hask@. @b p@ reinterprets each field of the+-- record @b@ through @p@, so the fields have the shape @p a b@ as in+-- "Data.Bifunctor.Rank2.Traversable". "Kindly.Rank2" already supplies the+-- functorial action. This module adds the /monoidal/ structure on top of it.+--+-- The classes take a single domain tensor, like their+-- "Data.Functor.Rank2.Monoidal" siblings and unlike "Data.Bifunctor.Monoidal".+-- A bifunctor's domain is a product category \(\mathcal{C_1} \times \mathcal{C_2}\),+-- so a tensor on it is a pair of tensors, which is why+-- 'Data.Bifunctor.Monoidal.Semigroupal' carries both @tC1@ and @tC2@. The+-- bifunctor category is one category, so a rank-2 bifunctor needs only one+-- tensor. The extra arity shows up in the tensors themselves+-- ('Data.Bifunctor.Product.Product' rather than 'Data.Functor.Product.Product')+-- and in the field shape, not in the class parameters.+--+-- A product-shaped record is monoidal at three instantiations, all derivable+-- from the record's 'GHC.Generics' structure:+--+-- * __Covariant product__, @'Monoidal' (->) 'Product' ('Joker' 'Data.Proxy.Proxy') (,) () b@.+--   'combine' zips two records field-wise into 'Data.Bifunctor.Product.Pair's and+--   'introduce' fills every field with the unit bifunctor.+--+-- * __Coproduct__, @'Monoidal' (->) 'Sum' ('Joker' V1) 'Either' 'Data.Void.Void' b@.+--   'combine' injects a whole record of @p@ or a whole record of @q@ into a record+--   of @'Sum' p q@, all on one side (@'gcombineSum'@). 'introduce' is+--   'Data.Void.absurd'.+--+-- * __Oplax product__ (the @'Op'@ dual of the first), @'Monoidal' 'Op' 'Product' ('Joker' 'Data.Proxy.Proxy') (,) () b@.+--   'combine' unzips a record of 'Data.Bifunctor.Product.Pair's back into two+--   records (@'gsplitProduct'@). 'introduce' is @'Op' ('const' ())@.+--+-- The tensor units are spelled with 'Joker' because @bifunctors@ ships no unit+-- or empty bifunctor of its own. @'Joker' 'Data.Proxy.Proxy'@ is the bifunctor+-- constant at @()@ (the unit of 'Product') and @'Joker' V1@ is the empty+-- bifunctor (the unit of 'Sum'). The latter is a phantom, since+-- @'introduce' = 'Data.Void.absurd'@ never builds a value at it.+--+-- The coproduct has no oplax dual here. A record of independent @'Sum' p q@+-- fields picks per field, so there is no single @'Either' (b p) (b q)@ to+-- project back to. There is also no @These@ instantiation, because the ecosystem+-- has no bifunctor analogue of 'Data.Functor.These.These1'. The @Divisible@ \/+-- @Decidable@-style duals need the interpretation in negative position, which is+-- not the @p a b@ field shape the generic machinery walks.+--+-- The generic derivation covers records whose fields all have the shape @p a b@.+-- Sums and nested HKD fields are not supported, matching+-- "Data.Bifunctor.Rank2.Traversable".+module Data.Bifunctor.Rank2.Monoidal+  ( -- * Semigroupal+    Semigroupal (..),++    -- * Unital+    Unital (..),++    -- * Monoidal+    Monoidal,++    -- * Generic derivation helpers+    gcombineProduct,+    gsplitProduct,+    gcombineSum,+  )+where++--------------------------------------------------------------------------------++import Data.Bifunctor.Joker (Joker (..))+import Data.Bifunctor.Product (Product (..))+import Data.Bifunctor.Sum (Sum (..))+import Data.Either (Either (..), either)+import Data.Function ((.))+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy (..))+#if MIN_VERSION_base(4,17,0)+-- On GHC 9.4+ (@base >= 4.17@) @~@ is an ordinary type operator rather than+-- built-in syntax, so under @NoImplicitPrelude@ it must be brought into scope.+-- Earlier GHCs still treat @~@ as built-in syntax and do not export it.+import Data.Type.Equality (type (~))+#endif+import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), type (:*:) (..))++--------------------------------------------------------------------------------++-- $setup+-- >>> :set -XDeriveGeneric -XStandaloneDeriving -XFlexibleContexts -XMultiParamTypeClasses -XTypeApplications+-- >>> import Prelude+-- >>> import GHC.Generics (Generic)+-- >>> import Data.Bifunctor.Joker (Joker (..))+-- >>> import Data.Bifunctor.Product (Product (..))+-- >>> import Data.Bifunctor.Sum (Sum (..))+-- >>> import Data.Proxy (Proxy (..))+-- >>> :{+-- data Rec p = Rec {rFst :: p Int Bool, rSnd :: p String Int} deriving Generic+-- deriving instance (Show (p Int Bool), Show (p String Int)) => Show (Rec p)+-- instance Semigroupal (->) Product (,) Rec+-- instance Unital (->) (Joker Proxy) () Rec+-- instance Monoidal (->) Product (Joker Proxy) (,) () Rec+-- instance Semigroupal (->) Sum Either Rec where combine = gcombineSum+-- :}++--------------------------------------------------------------------------------++-- | The rank-2 analogue of 'Data.Bifunctor.Monoidal.Semigroupal'. Given a+-- monoidal structure \(\otimes\) on the bifunctor category and \(\bullet\) on+-- @Hask@, a rank-2 bifunctor @b@ is 'Semigroupal' if it carries a natural+-- transformation \(\phi_{p,q} : b\ p \bullet b\ q \to b\ (p \otimes q)\), which+-- we call 'combine'.+--+-- * @cat@ is the codomain category (@Hask@, or 'Op' for the oplax dual).+-- * @tC@ is the domain tensor, acting on bifunctors (e.g. 'Product', 'Sum').+-- * @tD@ is the codomain tensor, acting on @Hask@ (e.g. @(,)@, 'Either').+-- * @b@ is the higher-kinded record.+--+-- The empty-instance default derives the covariant 'Product' instantiation. For+-- the coproduct and oplax-product instantiations, supply @'combine'@ from the+-- exported generic helpers (see 'gcombineSum' and 'gsplitProduct').+type Semigroupal ::+  (Type -> Type -> Type) ->+  ((Type -> Type -> Type) -> (Type -> Type -> Type) -> (Type -> Type -> Type)) ->+  (Type -> Type -> Type) ->+  ((Type -> Type -> Type) -> Type) ->+  Constraint+class Semigroupal cat tC tD b where+  -- | ==== __Examples__+  --+  -- Zip two records field-wise (the covariant 'Product' instantiation):+  --+  -- >>> combine @(->) @Product @(,) (Rec (1, True) ("hi", 2) :: Rec (,), Rec (Left 3) (Right 4) :: Rec Either)+  -- Rec {rFst = Pair (1,True) (Left 3), rSnd = Pair ("hi",2) (Right 4)}+  --+  -- Inject a whole record onto one side of a 'Sum' (the coproduct instantiation):+  --+  -- >>> combine @(->) @Sum @Either (Left (Rec (1, True) ("hi", 2)) :: Either (Rec (,)) (Rec Either))+  -- Rec {rFst = L2 (1,True), rSnd = L2 ("hi",2)}+  combine :: forall p q. cat (tD (b p) (b q)) (b (tC p q))+  default combine ::+    forall p q.+    ( cat ~ (->),+      tC ~ Product,+      tD ~ (,),+      Generic (b p),+      Generic (b q),+      Generic (b (Product p q)),+      GSemigroupal (Rep (b p)) (Rep (b q)) (Rep (b (Product p q)))+    ) =>+    cat (tD (b p) (b q)) (b (tC p q))+  combine = gcombineProduct++--------------------------------------------------------------------------------++-- | The rank-2 analogue of 'Data.Bifunctor.Monoidal.Unital'. A rank-2 bifunctor+-- @b@ is 'Unital' if it carries a morphism from the codomain unit to @b@ at the+-- domain unit, which we call 'introduce'.+--+-- * @cat@ is the codomain category (@Hask@, or 'Op' for the oplax dual).+-- * @iC@ is the domain unit, a bifunctor (the unit of @tC@;+--   @'Joker' 'Data.Proxy.Proxy'@ for 'Product', @'Joker' V1@ for 'Sum').+-- * @iD@ is the codomain unit (the unit of @tD@; @()@ for @(,)@, 'Data.Void.Void'+--   for 'Either').+-- * @b@ is the higher-kinded record.+--+-- The empty-instance default derives the covariant @'Joker' 'Data.Proxy.Proxy'@+-- unit. The coproduct unit is @'introduce' = 'Data.Void.absurd'@ and the+-- oplax-product unit is @'introduce' = 'Op' ('const' ())@. Both are trivial+-- enough to write inline.+type Unital ::+  (Type -> Type -> Type) ->+  (Type -> Type -> Type) ->+  Type ->+  ((Type -> Type -> Type) -> Type) ->+  Constraint+class Unital cat iC iD b where+  -- | ==== __Examples__+  --+  -- >>> introduce @(->) @(Joker Proxy) @() @Rec ()+  -- Rec {rFst = Joker {runJoker = Proxy}, rSnd = Joker {runJoker = Proxy}}+  introduce :: cat iD (b iC)+  default introduce ::+    ( cat ~ (->),+      iC ~ Joker Proxy,+      iD ~ (),+      Generic (b (Joker Proxy)),+      GUnital (Rep (b (Joker Proxy)))+    ) =>+    cat iD (b iC)+  introduce () = to gintroduce++--------------------------------------------------------------------------------++-- | The rank-2 analogue of 'Data.Bifunctor.Monoidal.Monoidal'. A rank-2+-- bifunctor that is both 'Semigroupal' and 'Unital', preserving the monoidal+-- structure between the bifunctor category and @Hask@.+type Monoidal ::+  (Type -> Type -> Type) ->+  ((Type -> Type -> Type) -> (Type -> Type -> Type) -> (Type -> Type -> Type)) ->+  (Type -> Type -> Type) ->+  (Type -> Type -> Type) ->+  Type ->+  ((Type -> Type -> Type) -> Type) ->+  Constraint+class+  ( Semigroupal cat tC tD b,+    Unital cat iC iD b+  ) =>+  Monoidal cat tC iC tD iD b++--------------------------------------------------------------------------------+-- Generic derivation helpers.++-- | Generic covariant product 'combine': zip two records field-wise into+-- 'Data.Bifunctor.Product.Pair's. This is the default for+-- @'Semigroupal' (->) 'Product' (,)@.+--+-- ==== __Examples__+--+-- >>> gcombineProduct (Rec (1, True) ("hi", 2) :: Rec (,), Rec (Left 3) (Right 4) :: Rec Either)+-- Rec {rFst = Pair (1,True) (Left 3), rSnd = Pair ("hi",2) (Right 4)}+gcombineProduct ::+  ( Generic (b p),+    Generic (b q),+    Generic (b (Product p q)),+    GSemigroupal (Rep (b p)) (Rep (b q)) (Rep (b (Product p q)))+  ) =>+  (b p, b q) ->+  b (Product p q)+gcombineProduct (bp, bq) = to (gcombine (from bp, from bq))++-- | Generic oplax product 'combine': unzip a record of+-- 'Data.Bifunctor.Product.Pair's back into two records. Wrap in 'Op' for+-- @'Semigroupal' 'Op' 'Product' (,)@: @combine = 'Op' 'gsplitProduct'@.+--+-- ==== __Examples__+--+-- >>> gsplitProduct (Rec (Pair (1, True) (Left 3)) (Pair ("hi", 2) (Right 4)))+-- (Rec {rFst = (1,True), rSnd = ("hi",2)},Rec {rFst = Left 3, rSnd = Right 4})+gsplitProduct ::+  ( Generic (b p),+    Generic (b q),+    Generic (b (Product p q)),+    GSemigroupal (Rep (b p)) (Rep (b q)) (Rep (b (Product p q)))+  ) =>+  b (Product p q) ->+  (b p, b q)+gsplitProduct bpq = case gsplit (from bpq) of (l, r) -> (to l, to r)++-- | Generic coproduct 'combine': inject a whole record of @p@ or a whole record+-- of @q@ into a record of @'Sum' p q@, all on one side. This is @combine@ for+-- @'Semigroupal' (->) 'Sum' 'Either'@.+--+-- ==== __Examples__+--+-- >>> gcombineSum (Right (Rec (Left 3) (Right 4)) :: Either (Rec (,)) (Rec Either))+-- Rec {rFst = R2 (Left 3), rSnd = R2 (Right 4)}+gcombineSum ::+  ( Generic (b p),+    Generic (b q),+    Generic (b (Sum p q)),+    GCoproduct (Rep (b p)) (Rep (b q)) (Rep (b (Sum p q)))+  ) =>+  Either (b p) (b q) ->+  b (Sum p q)+gcombineSum = either (to . ginjectL . from) (to . ginjectR . from)++--------------------------------------------------------------------------------+-- Generic workers for the product tensor (zip and its inverse split).++-- | Generic worker for the 'Product' tensor. The three representations are+-- @'Rep' (b p)@, @'Rep' (b q)@, and @'Rep' (b (Product p q))@. They are+-- structurally identical up to the field interpretation, which 'gcombine' fuses+-- into a 'Data.Bifunctor.Product.Pair' and 'gsplit' takes apart.+type GSemigroupal :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint+class GSemigroupal repp repq reph where+  gcombine :: (repp x, repq x) -> reph x+  gsplit :: reph x -> (repp x, repq x)++instance (GSemigroupal repp repq reph) => GSemigroupal (M1 i c repp) (M1 i c repq) (M1 i c reph) where+  gcombine (M1 a, M1 b) = M1 (gcombine (a, b))+  gsplit (M1 a) = case gsplit a of (l, r) -> (M1 l, M1 r)++instance (GSemigroupal p1 q1 h1, GSemigroupal p2 q2 h2) => GSemigroupal (p1 :*: p2) (q1 :*: q2) (h1 :*: h2) where+  gcombine (a1 :*: a2, b1 :*: b2) = gcombine (a1, b1) :*: gcombine (a2, b2)+  gsplit (a1 :*: a2) = case (gsplit a1, gsplit a2) of ((l1, r1), (l2, r2)) -> (l1 :*: l2, r1 :*: r2)++instance GSemigroupal (K1 i (p a b)) (K1 i (q a b)) (K1 i (Product p q a b)) where+  gcombine (K1 pab, K1 qab) = K1 (Pair pab qab)+  gsplit (K1 (Pair pab qab)) = (K1 pab, K1 qab)++instance GSemigroupal U1 U1 U1 where+  gcombine (U1, U1) = U1+  gsplit U1 = (U1, U1)++--------------------------------------------------------------------------------+-- Generic worker for the coproduct tensor (all-left \/ all-right injection).++-- | Generic worker for the 'Sum' tensor. 'ginjectL' sends a record of @p@ to a+-- record of @'Sum' p q@ with every field 'L2'. 'ginjectR' does the same with+-- 'R2'.+type GCoproduct :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint+class GCoproduct repp repq reph | reph -> repp repq where+  ginjectL :: repp x -> reph x+  ginjectR :: repq x -> reph x++instance (GCoproduct repp repq reph) => GCoproduct (M1 i c repp) (M1 i c repq) (M1 i c reph) where+  ginjectL (M1 a) = M1 (ginjectL a)+  ginjectR (M1 a) = M1 (ginjectR a)++instance (GCoproduct p1 q1 h1, GCoproduct p2 q2 h2) => GCoproduct (p1 :*: p2) (q1 :*: q2) (h1 :*: h2) where+  ginjectL (a1 :*: a2) = ginjectL a1 :*: ginjectL a2+  ginjectR (a1 :*: a2) = ginjectR a1 :*: ginjectR a2++instance GCoproduct (K1 i (p a b)) (K1 i (q a b)) (K1 i (Sum p q a b)) where+  ginjectL (K1 pab) = K1 (L2 pab)+  ginjectR (K1 qab) = K1 (R2 qab)++instance GCoproduct U1 U1 U1 where+  ginjectL U1 = U1+  ginjectR U1 = U1++--------------------------------------------------------------------------------+-- Generic worker for the unit (fill every field with the domain unit).++-- | Generic worker for 'introduce' at the covariant @'Joker' 'Data.Proxy.Proxy'@+-- unit. Fills every field of @'Rep' (b ('Joker' 'Data.Proxy.Proxy'))@ with the+-- unit bifunctor.+type GUnital :: (Type -> Type) -> Constraint+class GUnital rep where+  gintroduce :: rep x++instance (GUnital rep) => GUnital (M1 i c rep) where+  gintroduce = M1 gintroduce++instance (GUnital p, GUnital q) => GUnital (p :*: q) where+  gintroduce = gintroduce :*: gintroduce++instance GUnital (K1 i (Joker Proxy a b)) where+  gintroduce = K1 (Joker Proxy)++instance GUnital U1 where+  gintroduce = U1

@@ -0,0 +1,109 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE StandaloneKindSignatures #-}++-- | Rank-2 traversal for higher-kinded data interpreted by a bifunctor of any variance.+module Data.Bifunctor.Rank2.Traversable+  ( Traversable (..),+    First (..),+    Second (..),+  )+where++--------------------------------------------------------------------------------++import Control.Applicative+import Data.Bifunctor (Bifunctor (..))+import Data.Bifunctor.Monoidal (Monoidal, Semigroupal (..), Unital (..))+import Data.Functor.Contravariant (Contravariant (..))+import Data.Isomorphism (Iso (..))+import Data.Kind (Constraint, Type)+import GHC.Generics (Generic (..), Generic1, K1 (..), M1 (..), U1 (..), type (:*:) (..))+import Kindly qualified+import Prelude hiding (Traversable (..))++--------------------------------------------------------------------------------++-- | Higher-kinded data that distributes over any bifunctor 'Monoidal' with+-- respect to tupling, splitting each field @p a b@ into its 'First' and+-- 'Second' projections. The two positions may have either variance, selected+-- by @cat1@ and @cat2@: at a profunctor (@cat1 ~ Op@, @cat2 ~ (->)@)+-- 'sequence' consumes the record of first arguments and produces the record+-- of second arguments; at a covariant bifunctor (both @(->)@) it is the+-- 'Biapplicative' unzip.+--+-- The generic default covers records whose fields all have the shape+-- @p a b@. Sums and nested HKD fields are not supported.+class Traversable hkd where+  -- | Pull the interpretation bifunctor out of the record.+  sequence :: forall cat1 cat2 p. (Kindly.Bifunctor cat1 cat2 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Monoidal (->) (,) () (,) () (,) () p) => hkd p -> p (hkd First) (hkd Second)+  default sequence :: forall cat1 cat2 p. (Kindly.Bifunctor cat1 cat2 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Monoidal (->) (,) () (,) () (,) () p, Generic (hkd p), Generic (hkd First), Generic (hkd Second), GTraversable p (Rep (hkd p)) (Rep (hkd First)) (Rep (hkd Second))) => hkd p -> p (hkd First) (hkd Second)+  sequence = Kindly.bimapIso (Iso to from) (Iso to from) . gsequence @p @(Rep (hkd p)) @(Rep (hkd First)) @(Rep (hkd Second)) . from++type GTraversable :: (Type -> Type -> Type) -> (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint+class GTraversable p f g h where+  gsequence :: f x -> p (g x) (h x)++instance (Kindly.Bifunctor cat1 cat2 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, GTraversable p f g h) => GTraversable p (M1 _1 _2 f) (M1 _1 _2 g) (M1 _1 _2 h) where+  gsequence :: M1 _1 _2 f x -> p (M1 _1 _2 g x) (M1 _1 _2 h x)+  gsequence (M1 f) = Kindly.bimapIso (Iso M1 unM1) (Iso M1 unM1) $ gsequence f++instance (Kindly.Bifunctor cat1 cat2 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2) => GTraversable p (K1 _1 (p a b)) (K1 _1 (First a b)) (K1 _1 (Second a b)) where+  gsequence :: K1 _1 (p a b) x -> p (K1 _1 (First a b) x) (K1 _1 (Second a b) x)+  gsequence (K1 f) = Kindly.bimapIso (Iso (K1 . First) (unFirst . unK1)) (Iso (K1 . Second) (unSecond . unK1)) f++instance (Kindly.Bifunctor cat1 cat2 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Monoidal (->) (,) () (,) () (,) () p) => GTraversable p U1 U1 U1 where+  gsequence :: U1 x -> p (U1 x) (U1 x)+  gsequence U1 = Kindly.bimapIso (Iso (const U1) (const ())) (Iso (const U1) (const ())) $ introduce @_ @_ @() ()++instance (Kindly.Bifunctor cat1 cat2 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Monoidal (->) (,) () (,) () (,) () p, GTraversable p f1 g1 h1, GTraversable p f2 g2 h2) => GTraversable p (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where+  gsequence :: (:*:) f1 f2 x -> p ((:*:) g1 g2 x) ((:*:) h1 h2 x)+  gsequence (hkd1 :*: hkd2) =+    let phkd1 = gsequence hkd1+        phkd2 = gsequence hkd2+     in Kindly.bimapIso (Iso (uncurry (:*:)) (\(x :*: y) -> (x, y))) (Iso (uncurry (:*:)) (\(x :*: y) -> (x, y))) $ combine (phkd1, phkd2)++--------------------------------------------------------------------------------++-- | Projects a field's first argument: @First x y@ holds the @x@.+type First :: Type -> Type -> Type+newtype First x y = First {unFirst :: x}+  deriving stock (Generic, Generic1, Functor)+  deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid)++instance Contravariant (First x) where+  contramap :: (a' -> a) -> First x a -> First x a'+  contramap _ (First x) = First x++instance (Monoid x) => Applicative (First x) where+  pure :: a -> First x a+  pure _ = First mempty++  liftA2 :: (a -> b -> c) -> First x a -> First x b -> First x c+  liftA2 _ (First x) (First x') = First (x <> x')++instance Bifunctor First where+  bimap :: (a -> b) -> (c -> d) -> First a c -> First b d+  bimap f _ (First x) = First (f x)++--------------------------------------------------------------------------------++-- | Projects a field's second argument: @Second x y@ holds the @y@.+type Second :: Type -> Type -> Type+newtype Second x y = Second {unSecond :: y}+  deriving stock (Generic, Generic1, Functor)+  deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid)++instance Applicative (Second x) where+  pure :: a -> Second x a+  pure = Second++  liftA2 :: (a -> b -> c) -> Second x a -> Second x b -> Second x c+  liftA2 f (Second y) (Second y') = Second (f y y')++instance Bifunctor Second where+  bimap :: (a -> b) -> (c -> d) -> Second a c -> Second b d+  bimap _ g (Second y) = Second (g y)

@@ -21,6 +21,14 @@  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Functor.Identity (Identity (..))+-- >>> import Control.Category.Tensor (Iso (..), fwd)++--------------------------------------------------------------------------------+ -- | A functor is 'Invariant' if it is parametric in its type -- parameter @a@. --@@ -42,25 +50,31 @@   -- >>> invmap @Identity (read @Bool) show (Identity "True")   -- Identity True   invmap :: (a -> a') -> (a' -> a) -> f a -> f a'-  default invmap :: Functor f => (a -> a') -> (a' -> a) -> f a -> f a'+  default invmap :: (Functor f) => (a -> a') -> (a' -> a) -> f a -> f a'   invmap = invmapFunctor -invIso :: Invariant f => Iso (->) a a' -> Iso (->) (f a) (f a')+-- | Lift an 'Iso' through an 'Invariant' functor.+--+-- ==== __Examples__+--+-- >>> fwd (invIso @Identity (Iso (read @Bool) show)) (Identity "True")+-- Identity True+invIso :: (Invariant f) => Iso (->) a a' -> Iso (->) (f a) (f a') invIso (Iso f g) = Iso (invmap f g) (invmap g f)  newtype FromFunctor f a = FromFunctor {runBi :: f a}  -- | Every 'Functor' is also an 'Invariant' functor.-invmapFunctor :: Functor f => (a -> b) -> (b -> a) -> f a -> f b+invmapFunctor :: (Functor f) => (a -> b) -> (b -> a) -> f a -> f b invmapFunctor = flip $ const fmap -instance Functor f => Invariant (FromFunctor f) where+instance (Functor f) => Invariant (FromFunctor f) where   invmap :: (a -> a') -> (a' -> a) -> FromFunctor f a -> FromFunctor f a'   invmap f _ = FromFunctor . fmap f . runBi  newtype FromContra f a = FromContra {runContra :: f a} -instance Contravariant f => Invariant (FromContra f) where+instance (Contravariant f) => Invariant (FromContra f) where   invmap :: (a -> a') -> (a' -> a) -> FromContra f a -> FromContra f a'   invmap _ g = FromContra . contramap g . runContra 

@@ -32,6 +32,13 @@  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Functor.Contravariant (Predicate (..))++--------------------------------------------------------------------------------+ newtype FromContra f a = FromContra (f a)   deriving newtype (Contravariant) @@ -40,35 +47,32 @@  -------------------------------------------------------------------------------- -class LeftModule cat t1 f where+class LeftModule cat tC f where   -- | ==== __Examples__   --   -- >>> :t lstrength @(->) @(,) @Predicate (Predicate @Int (> 10))   -- lstrength @(->) @(,) @Predicate (Predicate @Int (> 10)) :: Predicate (Int, x)   ---  -- >>> :t lstrength @(->) @Either @[]-  -- lstrength @(->) @Either @[] :: a -> [Either a x]-  --   -- >>> lstrength @(->) @Either @[] [True, False]   -- [Left True,Left False]-  lstrength :: cat (f a) (f (t1 a x))+  lstrength :: cat (f a) (f (tC a x)) -instance Contravariant f => LeftModule (->) (,) (FromContra f) where+instance (Contravariant f) => LeftModule (->) (,) (FromContra f) where   lstrength :: FromContra f a -> FromContra f (a, x)   lstrength = contramap fst -instance Contravariant f => LeftModule Op Either (FromContra f) where+instance (Contravariant f) => LeftModule Op Either (FromContra f) where   lstrength = Op (contramap Left) -instance Functor f => LeftModule (->) Either (FromFunctor f) where+instance (Functor f) => LeftModule (->) Either (FromFunctor f) where   lstrength :: FromFunctor f a -> FromFunctor f (Either a x)   lstrength = fmap Left -instance Functor f => LeftModule (->) These (FromFunctor f) where+instance (Functor f) => LeftModule (->) These (FromFunctor f) where   lstrength :: FromFunctor f a -> FromFunctor f (These a x)   lstrength = fmap This -instance Functor f => LeftModule Op (,) (FromFunctor f) where+instance (Functor f) => LeftModule Op (,) (FromFunctor f) where   lstrength = Op (fmap fst)  deriving via (FromContra Comparison) instance LeftModule (->) (,) Comparison@@ -87,9 +91,9 @@  deriving via (FromContra (Const a)) instance LeftModule (->) (,) (Const a) -deriving via (FromContra (Alt f)) instance Contravariant f => LeftModule (->) (,) (Alt f)+deriving via (FromContra (Alt f)) instance (Contravariant f) => LeftModule (->) (,) (Alt f) -deriving via (FromContra (Rec1 f)) instance Contravariant f => LeftModule (->) (,) (Rec1 f)+deriving via (FromContra (Rec1 f)) instance (Contravariant f) => LeftModule (->) (,) (Rec1 f)  deriving via (FromContra (Product f g)) instance (Contravariant f, Contravariant g) => LeftModule (->) (,) (Product f g) @@ -105,7 +109,7 @@  deriving via (FromContra (f :.: g)) instance (Functor f, Contravariant g) => LeftModule (->) (,) (f :.: g) -deriving via (FromContra (M1 i c f)) instance Contravariant f => LeftModule (->) (,) (M1 i c f)+deriving via (FromContra (M1 i c f)) instance (Contravariant f) => LeftModule (->) (,) (M1 i c f)  deriving via (FromContra Comparison) instance LeftModule Op Either Comparison @@ -123,9 +127,9 @@  deriving via (FromContra (Const a)) instance LeftModule Op Either (Const a) -deriving via (FromContra (Alt f)) instance Contravariant f => LeftModule Op Either (Alt f)+deriving via (FromContra (Alt f)) instance (Contravariant f) => LeftModule Op Either (Alt f) -deriving via (FromContra (Rec1 f)) instance Contravariant f => LeftModule Op Either (Rec1 f)+deriving via (FromContra (Rec1 f)) instance (Contravariant f) => LeftModule Op Either (Rec1 f)  deriving via (FromContra (Product f g)) instance (Contravariant f, Contravariant g) => LeftModule Op Either (Product f g) @@ -141,7 +145,7 @@  deriving via (FromContra (f :.: g)) instance (Functor f, Contravariant g) => LeftModule Op Either (f :.: g) -deriving via (FromContra (M1 i c f)) instance Contravariant f => LeftModule Op Either (M1 i c f)+deriving via (FromContra (M1 i c f)) instance (Contravariant f) => LeftModule Op Either (M1 i c f)  deriving via FromFunctor Identity instance LeftModule (->) Either Identity @@ -227,35 +231,33 @@  -------------------------------------------------------------------------------- -class RightModule cat t1 f where+class RightModule cat tC f where   -- | ==== __Examples__   --   -- >>> :t rstrength @(->) @(,) @Predicate (Predicate @Int (> 10))   -- rstrength @(->) @(,) @Predicate (Predicate @Int (> 10)) :: Predicate (x, Int)   ---  -- >>> :t rstrength @(->) @Either @[]-  -- rstrength @(->) @Either @[] :: [a] -> [Either x a]   -- >>> rstrength @(->) @Either @[] [True, False]   -- [Right True,Right False]-  rstrength :: cat (f a) (f (t1 x a))+  rstrength :: cat (f a) (f (tC x a)) -instance Contravariant f => RightModule (->) (,) (FromContra f) where+instance (Contravariant f) => RightModule (->) (,) (FromContra f) where   rstrength :: FromContra f a -> FromContra f (x, a)   rstrength = contramap snd -instance Contravariant f => RightModule Op Either (FromContra f) where+instance (Contravariant f) => RightModule Op Either (FromContra f) where   rstrength :: Op (FromContra f a) (FromContra f (Either x a))   rstrength = Op (contramap Right) -instance Functor f => RightModule (->) Either (FromFunctor f) where+instance (Functor f) => RightModule (->) Either (FromFunctor f) where   rstrength :: FromFunctor f a -> FromFunctor f (Either x a)   rstrength = fmap Right -instance Functor f => RightModule (->) These (FromFunctor f) where+instance (Functor f) => RightModule (->) These (FromFunctor f) where   rstrength :: FromFunctor f a -> FromFunctor f (These x a)   rstrength = fmap That -instance Functor f => RightModule Op (,) (FromFunctor f) where+instance (Functor f) => RightModule Op (,) (FromFunctor f) where   rstrength :: Op (FromFunctor f a) (FromFunctor f (x, a))   rstrength = Op (fmap snd) @@ -275,9 +277,9 @@  deriving via (FromContra (Const a)) instance RightModule (->) (,) (Const a) -deriving via (FromContra (Alt f)) instance Contravariant f => RightModule (->) (,) (Alt f)+deriving via (FromContra (Alt f)) instance (Contravariant f) => RightModule (->) (,) (Alt f) -deriving via (FromContra (Rec1 f)) instance Contravariant f => RightModule (->) (,) (Rec1 f)+deriving via (FromContra (Rec1 f)) instance (Contravariant f) => RightModule (->) (,) (Rec1 f)  deriving via (FromContra (Product f g)) instance (Contravariant f, Contravariant g) => RightModule (->) (,) (Product f g) @@ -293,7 +295,7 @@  deriving via (FromContra (f :.: g)) instance (Functor f, Contravariant g) => RightModule (->) (,) (f :.: g) -deriving via (FromContra (M1 i c f)) instance Contravariant f => RightModule (->) (,) (M1 i c f)+deriving via (FromContra (M1 i c f)) instance (Contravariant f) => RightModule (->) (,) (M1 i c f)  deriving via (FromContra Comparison) instance RightModule Op Either Comparison @@ -311,9 +313,9 @@  deriving via (FromContra (Const a)) instance RightModule Op Either (Const a) -deriving via (FromContra (Alt f)) instance Contravariant f => RightModule Op Either (Alt f)+deriving via (FromContra (Alt f)) instance (Contravariant f) => RightModule Op Either (Alt f) -deriving via (FromContra (Rec1 f)) instance Contravariant f => RightModule Op Either (Rec1 f)+deriving via (FromContra (Rec1 f)) instance (Contravariant f) => RightModule Op Either (Rec1 f)  deriving via (FromContra (Product f g)) instance (Contravariant f, Contravariant g) => RightModule Op Either (Product f g) @@ -329,7 +331,7 @@  deriving via (FromContra (f :.: g)) instance (Functor f, Contravariant g) => RightModule Op Either (f :.: g) -deriving via (FromContra (M1 i c f)) instance Contravariant f => RightModule Op Either (M1 i c f)+deriving via (FromContra (M1 i c f)) instance (Contravariant f) => RightModule Op Either (M1 i c f)  deriving via FromFunctor Identity instance RightModule (->) Either Identity @@ -415,17 +417,17 @@  -------------------------------------------------------------------------------- -class (LeftModule cat t1 f, RightModule cat t1 f) => Bimodule cat t1 f+class (LeftModule cat tC f, RightModule cat tC f) => Bimodule cat tC f -instance Contravariant f => Bimodule (->) (,) (FromContra f)+instance (Contravariant f) => Bimodule (->) (,) (FromContra f) -instance Contravariant f => Bimodule Op Either (FromContra f)+instance (Contravariant f) => Bimodule Op Either (FromContra f) -instance Functor f => Bimodule (->) Either (FromFunctor f)+instance (Functor f) => Bimodule (->) Either (FromFunctor f) -instance Functor f => Bimodule (->) These (FromFunctor f)+instance (Functor f) => Bimodule (->) These (FromFunctor f) -instance Functor f => Bimodule Op (,) (FromFunctor f)+instance (Functor f) => Bimodule Op (,) (FromFunctor f)  deriving via (FromContra Comparison) instance Bimodule (->) (,) Comparison @@ -443,9 +445,9 @@  deriving via (FromContra (Const a)) instance Bimodule (->) (,) (Const a) -deriving via (FromContra (Alt f)) instance Contravariant f => Bimodule (->) (,) (Alt f)+deriving via (FromContra (Alt f)) instance (Contravariant f) => Bimodule (->) (,) (Alt f) -deriving via (FromContra (Rec1 f)) instance Contravariant f => Bimodule (->) (,) (Rec1 f)+deriving via (FromContra (Rec1 f)) instance (Contravariant f) => Bimodule (->) (,) (Rec1 f)  deriving via (FromContra (Product f g)) instance (Contravariant f, Contravariant g) => Bimodule (->) (,) (Product f g) @@ -461,7 +463,7 @@  deriving via (FromContra (f :.: g)) instance (Functor f, Contravariant g) => Bimodule (->) (,) (f :.: g) -deriving via (FromContra (M1 i c f)) instance Contravariant f => Bimodule (->) (,) (M1 i c f)+deriving via (FromContra (M1 i c f)) instance (Contravariant f) => Bimodule (->) (,) (M1 i c f)  deriving via (FromContra Comparison) instance Bimodule Op Either Comparison @@ -479,9 +481,9 @@  deriving via (FromContra (Const a)) instance Bimodule Op Either (Const a) -deriving via (FromContra (Alt f)) instance Contravariant f => Bimodule Op Either (Alt f)+deriving via (FromContra (Alt f)) instance (Contravariant f) => Bimodule Op Either (Alt f) -deriving via (FromContra (Rec1 f)) instance Contravariant f => Bimodule Op Either (Rec1 f)+deriving via (FromContra (Rec1 f)) instance (Contravariant f) => Bimodule Op Either (Rec1 f)  deriving via (FromContra (Product f g)) instance (Contravariant f, Contravariant g) => Bimodule Op Either (Product f g) @@ -497,7 +499,7 @@  deriving via (FromContra (f :.: g)) instance (Functor f, Contravariant g) => Bimodule Op Either (f :.: g) -deriving via (FromContra (M1 i c f)) instance Contravariant f => Bimodule Op Either (M1 i c f)+deriving via (FromContra (M1 i c f)) instance (Contravariant f) => Bimodule Op Either (M1 i c f)  deriving via FromFunctor Identity instance Bimodule (->) Either Identity 

@@ -1,26 +1,34 @@+{-# LANGUAGE CPP #-}+ module Data.Functor.Monoidal   ( -- * Semigroupal     Semigroupal (..),     (|?|),     (|*|),-    type (|*|),     (|+|),-    type (|+|),     (|&|),-    type (|&|),      -- * Unital     Unital (..),      -- * Monoidal     Monoidal,++    -- * Newtypes for Deriving Via+    FromApplicative (..),+    FromAlternative (..),+    FromSemialign (..),+    FromDivisible (..),+    FromDecidable (..),+    FromUnalign (..),+    FromAlign (..),   ) where  --------------------------------------------------------------------------------  import Control.Applicative-import Control.Applicative.Backwards (Backwards)+import Control.Applicative.Backwards (Backwards (..)) import Control.Arrow (ArrowMonad, ArrowPlus, ArrowZero, Kleisli) import Control.Category.Tensor import Control.Comonad.Identity (IdentityT)@@ -36,28 +44,38 @@ import Control.Monad.Trans.Writer.Strict (WriterT) import Data.Align import Data.Functor.Compose (Compose)-import Data.Functor.Constant (Constant)+#if MIN_VERSION_semialign(1,4,0)+import Data.Zip (Unzip)+#endif+import Data.Functor.Constant (Constant (..)) import Data.Functor.Contravariant (Comparison, Contravariant, Equivalence, Op (..), Predicate) import Data.Functor.Contravariant.Compose (ComposeCF, ComposeFC) import Data.Functor.Contravariant.Divisible (Decidable, Divisible, chosen, conquered, divided, lost) import Data.Functor.Identity-import Data.Functor.Product (Product)-import Data.Functor.Reverse (Reverse)+import Data.Functor.Product (Product (Pair))+import Data.Functor.Reverse (Reverse (..)) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty)-import Data.Monoid (Alt, Ap)-import Data.Proxy (Proxy)+import Data.Monoid (Alt (..), Ap)+import Data.Proxy (Proxy (..)) import Data.Tagged (Tagged) import Data.These import Data.Void import GHC.Conc (STM)-import GHC.Generics (M1, Rec1, U1, type (:*:), type (:.:))+import GHC.Generics (M1 (..), Rec1 (..), U1 (..), type (:*:) (..), type (:.:)) import Text.ParserCombinators.ReadP (ReadP) import Text.ParserCombinators.ReadPrec (ReadPrec) import Prelude  -------------------------------------------------------------------------------- +-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude+-- >>> import Data.Void (Void)++--------------------------------------------------------------------------------+ -- | Given monoidal categories \((\mathcal{C}, \otimes, I_{\mathcal{C}})\) and \((\mathcal{D}, \bullet, I_{\mathcal{D}})\). -- A functor \(F : \mathcal{C} \to \mathcal{D}\) is 'Semigroupal' if it supports a natural transformation -- \(\phi_{A,B} : F\ A \bullet F\ B \to F\ (A \otimes B)\), which we call 'combine'.@@ -80,7 +98,7 @@ -- @ -- 'combine' 'Control.Category..' 'grmap' 'combine' 'Control.Category..' 'bwd' 'assoc' ≡ 'fmap' ('bwd' 'assoc') 'Control.Category..' 'combine' 'Control.Category..' 'glmap' 'combine' -- @-class (Associative cat t1, Associative cat t0) => Semigroupal cat t1 t0 f where+class (Associative cat tC, Associative cat tD) => Semigroupal cat tC tD f where   -- | @combine@ is a natural transformation from functors \(\mathcal{C} × \mathcal{C}\) to \(\mathcal{D}\).   --   -- ==== __Examples__@@ -96,12 +114,12 @@   --   -- >>> combine @(->) @Either @(,) @Maybe (Nothing, Just "hello")   -- Just (Right "hello")-  combine :: (f x `t0` f x') `cat` f (x `t1` x')+  combine :: (f x `tD` f x') `cat` f (x `tC` x')  newtype FromApplicative f a = FromApplicative (f a)   deriving newtype (Functor, Applicative) -instance Applicative f => Semigroupal (->) (,) (,) (FromApplicative f) where+instance (Applicative f) => Semigroupal (->) (,) (,) (FromApplicative f) where   combine :: (FromApplicative f x, FromApplicative f x') -> FromApplicative f (x, x')   combine = uncurry (liftA2 (,)) @@ -127,7 +145,15 @@  deriving via FromApplicative IO instance Semigroupal (->) (,) (,) IO -deriving via FromApplicative (Product f g) instance (Applicative f, Applicative g) => Semigroupal (->) (,) (,) (Product f g)+-- | A single variance-agnostic 'Product' instance. @combine@ is componentwise,+-- delegating to each component's own 'Semigroupal'. It subsumes the former+-- @FromApplicative@ \/ @FromAlternative@ \/ @FromSemialign@ instances (product,+-- coproduct, and these tensors) and covers the contravariant components+-- (Divisible \/ Decidable), which previously overlapped.+instance (Semigroupal (->) tC (,) f, Semigroupal (->) tC (,) g) => Semigroupal (->) tC (,) (Product f g) where+  combine :: forall x x'. (Product f g x, Product f g x') -> Product f g (tC x x')+  combine (Pair fx gx, Pair fx' gx') =+    Pair (combine @(->) @tC @(,) (fx, fx')) (combine @(->) @tC @(,) (gx, gx'))  deriving via (FromApplicative ((,) x1)) instance (Monoid x1) => Semigroupal (->) (,) (,) ((,) x1) @@ -135,12 +161,10 @@  deriving via (FromApplicative ((,,,) x1 x2 x3)) instance (Monoid x1, Monoid x2, Monoid x3) => Semigroupal (->) (,) (,) ((,,,) x1 x2 x3) -deriving via FromApplicative (Proxy :: Type -> Type) instance Semigroupal (->) (,) (,) (Proxy :: Type -> Type)- newtype FromAlternative f a = FromAlternative (f a)   deriving newtype (Functor, Applicative, Alternative) -instance Alternative f => Semigroupal (->) Either (,) (FromAlternative f) where+instance (Alternative f) => Semigroupal (->) Either (,) (FromAlternative f) where   combine :: (FromAlternative f x, FromAlternative f x') -> FromAlternative f (Either x x')   combine (fx, fx') = fmap Left fx <|> fmap Right fx' @@ -162,34 +186,58 @@  deriving via FromAlternative (ArrowMonad a) instance (ArrowPlus a) => Semigroupal (->) Either (,) (ArrowMonad a) -deriving via FromAlternative (Proxy :: Type -> Type) instance Semigroupal (->) Either (,) (Proxy :: Type -> Type)--deriving via FromAlternative (U1 :: Type -> Type) instance Semigroupal (->) Either (,) (U1 :: Type -> Type)- deriving via FromAlternative (WrappedArrow a b) instance (ArrowZero a, ArrowPlus a) => Semigroupal (->) Either (,) (WrappedArrow a b)  deriving via FromAlternative (Kleisli m a) instance (Alternative m) => Semigroupal (->) Either (,) (Kleisli m a)  deriving via FromAlternative (Ap f) instance (Alternative f) => Semigroupal (->) Either (,) (Ap f) -deriving via FromAlternative (Alt f) instance (Alternative f) => Semigroupal (->) Either (,) (Alt f)+-- | A transparent newtype wrapper inherits its component's 'Semigroupal' at+-- every tensor and both variances, by coercion.+deriving newtype instance (Semigroupal (->) tC (,) f) => Semigroupal (->) tC (,) (Rec1 f) -deriving via FromAlternative (Rec1 f) instance (Alternative f) => Semigroupal (->) Either (,) (Rec1 f)+deriving newtype instance (Semigroupal (->) tC (,) f) => Semigroupal (->) tC (,) (M1 i c f) -deriving via FromAlternative (Product f g) instance (Alternative f, Alternative g) => Semigroupal (->) Either (,) (Product f g)+deriving newtype instance (Semigroupal (->) tC (,) f) => Semigroupal (->) tC (,) (Alt f) -deriving via FromAlternative (f :*: g) instance (Alternative f, Alternative g) => Semigroupal (->) Either (,) (f :*: g)+deriving newtype instance (Semigroupal (->) tC (,) f) => Semigroupal (->) tC (,) (Reverse f) +deriving newtype instance (Semigroupal (->) tC (,) f) => Semigroupal (->) tC (,) (Backwards f)++-- | Componentwise, like 'Product'. The generic product @f ':*:' g@ is+-- 'Semigroupal' at any tensor its components share, both variances.+instance (Semigroupal (->) tC (,) f, Semigroupal (->) tC (,) g) => Semigroupal (->) tC (,) (f :*: g) where+  combine :: forall x x'. ((f :*: g) x, (f :*: g) x') -> (f :*: g) (tC x x')+  combine (fx :*: gx, fx' :*: gx') =+    combine @(->) @tC @(,) (fx, fx') :*: combine @(->) @tC @(,) (gx, gx')++-- | Phantom (constant) functors are both covariant and contravariant at once.+-- @combine@ ignores the parameter, so one instance serves every tensor and both+-- variances. For 'Const' \/ 'Constant' it is the underlying 'Semigroup'.+instance (Associative (->) tC) => Semigroupal (->) tC (,) (Proxy :: Type -> Type) where+  combine _ = Proxy++instance (Associative (->) tC) => Semigroupal (->) tC (,) (U1 :: Type -> Type) where+  combine _ = U1++instance (Semigroup c, Associative (->) tC) => Semigroupal (->) tC (,) (Const c :: Type -> Type) where+  combine (Const a, Const b) = Const (a <> b)++instance (Semigroup c, Associative (->) tC) => Semigroupal (->) tC (,) (Constant c :: Type -> Type) where+  combine (Constant a, Constant b) = Constant (a <> b)+ deriving via FromAlternative (f `Compose` g) instance (Alternative f, Applicative g) => Semigroupal (->) Either (,) (f `Compose` g)  deriving via FromAlternative (f :.: g) instance (Alternative f, Applicative g) => Semigroupal (->) Either (,) (f :.: g) -deriving via FromAlternative (M1 i c f) instance (Alternative f) => Semigroupal (->) Either (,) (M1 i c f)- newtype FromSemialign f a = FromSemialign (f a)+#if MIN_VERSION_semialign(1,4,0)+  deriving newtype (Functor, Unzip, Semialign)+#else   deriving newtype (Functor, Semialign)+#endif -instance Semialign f => Semigroupal (->) These (,) (FromSemialign f) where+instance (Semialign f) => Semigroupal (->) These (,) (FromSemialign f) where   combine :: (FromSemialign f x, FromSemialign f x') -> FromSemialign f (These x x')   combine = uncurry align @@ -203,18 +251,14 @@  deriving via FromSemialign Identity instance Semigroupal (->) These (,) Identity -deriving via FromSemialign (Proxy :: Type -> Type) instance Semigroupal (->) These (,) (Proxy :: Type -> Type)- deriving via FromSemialign (Tagged b) instance Semigroupal (->) These (,) (Tagged b) -deriving via FromSemialign (Product f g) instance (Semialign f, Semialign g) => Semigroupal (->) These (,) (Product f g)- deriving via FromSemialign (f `Compose` g) instance (Semialign f, Semialign g) => Semigroupal (->) These (,) (f `Compose` g)  newtype FromDivisible f a = FromDivisible (f a)   deriving newtype (Contravariant, Divisible) -instance Divisible f => Semigroupal (->) (,) (,) (FromDivisible f) where+instance (Divisible f) => Semigroupal (->) (,) (,) (FromDivisible f) where   combine :: (FromDivisible f x, FromDivisible f x') -> FromDivisible f (x, x')   combine = uncurry divided @@ -224,48 +268,28 @@  deriving via FromDivisible Equivalence instance Semigroupal (->) (,) (,) Equivalence -deriving via FromDivisible (U1 :: Type -> Type) instance Semigroupal (->) (,) (,) (U1 :: Type -> Type)--deriving via FromDivisible (Op r) instance Monoid r => Semigroupal (->) (,) (,) (Op r)---- deriving via FromDivisible (Proxy :: Type -> Type) instance Semigroupal (->) (,) (,) (Proxy :: Type -> Type)-deriving via FromDivisible (MaybeT m) instance Divisible m => Semigroupal (->) (,) (,) (MaybeT m)--deriving via FromDivisible (Rec1 m) instance Divisible m => Semigroupal (->) (,) (,) (Rec1 m)--deriving via FromDivisible (Const m) instance Monoid m => Semigroupal (->) (,) (,) (Const m :: Type -> Type)--deriving via FromDivisible (Alt f) instance Divisible f => Semigroupal (->) (,) (,) (Alt f)--deriving via FromDivisible (Reverse f) instance Divisible f => Semigroupal (->) (,) (,) (Reverse f)--deriving via FromDivisible (Constant m) instance Monoid m => Semigroupal (->) (,) (,) (Constant m :: Type -> Type)+deriving via FromDivisible (Op r) instance (Monoid r) => Semigroupal (->) (,) (,) (Op r) -deriving via FromDivisible (WriterT w m) instance Divisible m => Semigroupal (->) (,) (,) (WriterT w m)+deriving via FromDivisible (MaybeT m) instance (Divisible m) => Semigroupal (->) (,) (,) (MaybeT m) -deriving via FromDivisible (Lazy.WriterT w m) instance Divisible m => Semigroupal (->) (,) (,) (Lazy.WriterT w m)+deriving via FromDivisible (WriterT w m) instance (Divisible m) => Semigroupal (->) (,) (,) (WriterT w m) -deriving via FromDivisible (StateT w m) instance Divisible m => Semigroupal (->) (,) (,) (StateT w m)+deriving via FromDivisible (Lazy.WriterT w m) instance (Divisible m) => Semigroupal (->) (,) (,) (Lazy.WriterT w m) -deriving via FromDivisible (Lazy.StateT w m) instance Divisible m => Semigroupal (->) (,) (,) (Lazy.StateT w m)+deriving via FromDivisible (StateT w m) instance (Divisible m) => Semigroupal (->) (,) (,) (StateT w m) -deriving via FromDivisible (ReaderT r m) instance Divisible m => Semigroupal (->) (,) (,) (ReaderT r m)+deriving via FromDivisible (Lazy.StateT w m) instance (Divisible m) => Semigroupal (->) (,) (,) (Lazy.StateT w m) -deriving via FromDivisible (IdentityT m) instance Divisible m => Semigroupal (->) (,) (,) (IdentityT m)+deriving via FromDivisible (ReaderT r m) instance (Divisible m) => Semigroupal (->) (,) (,) (ReaderT r m) -deriving via FromDivisible (ExceptT e m) instance Divisible m => Semigroupal (->) (,) (,) (ExceptT e m)+deriving via FromDivisible (IdentityT m) instance (Divisible m) => Semigroupal (->) (,) (,) (IdentityT m) -deriving via FromDivisible (Backwards f) instance Divisible f => Semigroupal (->) (,) (,) (Backwards f)+deriving via FromDivisible (ExceptT e m) instance (Divisible m) => Semigroupal (->) (,) (,) (ExceptT e m)  deriving via FromDivisible (ComposeCF f g) instance (Divisible f, Applicative g) => Semigroupal (->) (,) (,) (ComposeCF f g)  deriving via FromDivisible (ComposeFC f g) instance (Divisible g, Applicative f) => Semigroupal (->) (,) (,) (ComposeFC f g) -deriving via FromDivisible (f :*: g) instance (Divisible f, Divisible g) => Semigroupal (->) (,) (,) (f :*: g)---- deriving via FromDivisible (Product f g)           instance (Divisible f, Divisible g) => Semigroupal (->) (,) (,) (Product f g)-deriving via FromDivisible (M1 i c f) instance Divisible f => Semigroupal (->) (,) (,) (M1 i c f)- deriving via FromDivisible (f :.: g) instance (Applicative f, Divisible g) => Semigroupal (->) (,) (,) (f :.: g)  -- deriving via FromDivisible (Compose f g)           instance (Applicative f, Divisible g) => Semigroupal (->) (,) (,) (Compose f g)@@ -276,7 +300,7 @@ newtype FromDecidable f a = FromDecidable (f a)   deriving newtype (Contravariant, Divisible, Decidable) -instance Decidable f => Semigroupal (->) Either (,) (FromDecidable f) where+instance (Decidable f) => Semigroupal (->) Either (,) (FromDecidable f) where   combine :: (FromDecidable f x, FromDecidable f x') -> FromDecidable f (Either x x')   combine = uncurry chosen @@ -286,73 +310,73 @@  deriving via FromDecidable Equivalence instance Semigroupal (->) Either (,) Equivalence --- deriving via FromDecidable (U1 :: Type -> Type)    instance Semigroupal (->) Either (,) (U1 :: Type -> Type)-deriving via FromDecidable (Op r) instance Monoid r => Semigroupal (->) Either (,) (Op r)---- deriving via FromDecidable (Proxy :: Type -> Type) instance Semigroupal (->) Either (,) (Proxy :: Type -> Type)-deriving via FromDecidable (MaybeT m) instance Decidable m => Semigroupal (->) Either (,) (MaybeT m)---- deriving via FromDecidable (Rec1 m)                instance Decidable m => Semigroupal (->) Either (,) (Rec1 m)--- deriving via FromDecidable (Alt f)                 instance Decidable f => Semigroupal (->) Either (,) (Alt f)-deriving via FromDecidable (Reverse f) instance Decidable f => Semigroupal (->) Either (,) (Reverse f)+deriving via FromDecidable (Op r) instance (Monoid r) => Semigroupal (->) Either (,) (Op r) -deriving via FromDecidable (WriterT w m) instance Decidable m => Semigroupal (->) Either (,) (WriterT w m)+deriving via FromDecidable (MaybeT m) instance (Decidable m) => Semigroupal (->) Either (,) (MaybeT m) -deriving via FromDecidable (Lazy.WriterT w m) instance Decidable m => Semigroupal (->) Either (,) (Lazy.WriterT w m)+deriving via FromDecidable (WriterT w m) instance (Decidable m) => Semigroupal (->) Either (,) (WriterT w m) -deriving via FromDecidable (StateT w m) instance Decidable m => Semigroupal (->) Either (,) (StateT w m)+deriving via FromDecidable (Lazy.WriterT w m) instance (Decidable m) => Semigroupal (->) Either (,) (Lazy.WriterT w m) -deriving via FromDecidable (Lazy.StateT w m) instance Decidable m => Semigroupal (->) Either (,) (Lazy.StateT w m)+deriving via FromDecidable (StateT w m) instance (Decidable m) => Semigroupal (->) Either (,) (StateT w m) -deriving via FromDecidable (ReaderT r m) instance Decidable m => Semigroupal (->) Either (,) (ReaderT r m)+deriving via FromDecidable (Lazy.StateT w m) instance (Decidable m) => Semigroupal (->) Either (,) (Lazy.StateT w m) -deriving via FromDecidable (IdentityT m) instance Decidable m => Semigroupal (->) Either (,) (IdentityT m)+deriving via FromDecidable (ReaderT r m) instance (Decidable m) => Semigroupal (->) Either (,) (ReaderT r m) -deriving via FromDecidable (Backwards f) instance Decidable f => Semigroupal (->) Either (,) (Backwards f)+deriving via FromDecidable (IdentityT m) instance (Decidable m) => Semigroupal (->) Either (,) (IdentityT m)  deriving via FromDecidable (ComposeFC f g) instance (Decidable g, Applicative f) => Semigroupal (->) Either (,) (ComposeFC f g) --- deriving via FromDecidable (f :*: g)               instance (Decidable f, Decidable g) => Semigroupal (->) Either (,) (f :*: g)--- deriving via FromDecidable (Product f g)           instance (Decidable f, Decidable g) => Semigroupal (->) Either (,) (Product f g)--- deriving via FromDecidable (M1 i c f)              instance Decidable f => Semigroupal (->) Either (,) (M1 i c f) -- deriving via FromDecidable (f :.: g)               instance (Applicative f, Decidable g) => Semigroupal (->) Either (,) (f :.: g) -- deriving via FromDecidable (Compose f g)           instance (Applicative f, Decidable g) => Semigroupal (->) Either (,) (Compose f g) deriving via FromDecidable (RWST r w s m) instance (Decidable m) => Semigroupal (->) Either (,) (RWST r w s m)  deriving via FromDecidable (Lazy.RWST r w s m) instance (Decidable m) => Semigroupal (->) Either (,) (Lazy.RWST r w s m) +newtype FromUnalign f a = FromUnalign (f a)+#if MIN_VERSION_semialign(1,4,0)+  deriving (Functor, Unzip, Semialign, Unalign)+#else+  deriving (Functor, Semialign, Unalign)+#endif++instance (Unalign f) => Semigroupal Op These (,) (FromUnalign f) where+  combine :: Op (FromUnalign f x, FromUnalign f x') (FromUnalign f (These x x'))+  combine = Op unalign++deriving via FromUnalign Maybe instance Semigroupal Op These (,) Maybe++deriving via FromUnalign (Proxy :: Type -> Type) instance Semigroupal Op These (,) (Proxy :: Type -> Type)++deriving via FromUnalign (Product f g) instance (Unalign f, Unalign g) => Semigroupal Op These (,) (Product f g)+ infixr 9 |?| -(|?|) :: Semigroupal (->) t1 (,) f => f a -> f b -> f (a `t1` b)+(|?|) :: (Semigroupal (->) tC (,) f) => f a -> f b -> f (a `tC` b) (|?|) = curry combine  infixr 4 |*| -(|*|) :: Semigroupal (->) (,) (,) f => f a -> f b -> f (a, b)+(|*|) :: (Semigroupal (->) (,) (,) f) => f a -> f b -> f (a, b) (|*|) = curry combine  infixr 3 |+| -(|+|) :: Semigroupal (->) Either (,) f => f a -> f b -> f (Either a b)+(|+|) :: (Semigroupal (->) Either (,) f) => f a -> f b -> f (Either a b) (|+|) = curry combine  infixr 3 |&| -(|&|) :: Semigroupal (->) These (,) f => f a -> f b -> f (These a b)+(|&|) :: (Semigroupal (->) These (,) f) => f a -> f b -> f (These a b) (|&|) = curry combine -type (|*|) = (,)--type (|+|) = Either--type (|&|) = These- --------------------------------------------------------------------------------  -- | Given monoidal categories \((\mathcal{C}, \otimes, I_{\mathcal{C}})\) and \((\mathcal{D}, \bullet, I_{\mathcal{D}})\). -- A functor \(F : \mathcal{C} \to \mathcal{D}\) is 'Unital' if it supports a morphism \(\phi : I_{\mathcal{D}} \to F\ I_{\mathcal{C}}\), -- which we call 'introduce'.-class Unital cat i1 i0 f where+class Unital cat iC iD f where   -- | @introduce@ maps from the identity in \(\mathcal{C}\) to the   -- identity in \(\mathcal{D}\).   --@@ -361,14 +385,11 @@   -- >>> introduce @(->) @() @() @Maybe ()   -- Just ()   ---  -- >>> :t introduce @(->) @Void @() @Maybe-  -- introduce @(->) @Void @() @Maybe :: () -> Maybe Void-  --   -- >>> introduce @(->) @Void @() @Maybe ()   -- Nothing-  introduce :: cat i0 (f i1)+  introduce :: cat iD (f iC) -instance Applicative f => Unital (->) () () (FromApplicative f) where+instance (Applicative f) => Unital (->) () () (FromApplicative f) where   introduce :: () -> FromApplicative f ()   introduce = pure @@ -388,7 +409,12 @@  deriving via FromApplicative IO instance Unital (->) () () IO -deriving via FromApplicative (Product f g) instance (Applicative f, Applicative g) => Unital (->) () () (Product f g)+-- | Componentwise 'introduce', delegating to each component's 'Unital'. Covers+-- both the product unit @()@ and the coproduct unit @Void@, covariant and+-- contravariant alike.+instance (Unital (->) iC () f, Unital (->) iC () g) => Unital (->) iC () (Product f g) where+  introduce :: () -> Product f g iC+  introduce () = Pair (introduce @(->) @iC @() ()) (introduce @(->) @iC @() ())  deriving via (FromApplicative ((,) x1)) instance (Monoid x1) => Unital (->) () () ((,) x1) @@ -396,7 +422,7 @@  deriving via (FromApplicative ((,,,) x1 x2 x3)) instance (Monoid x1, Monoid x2, Monoid x3) => Unital (->) () () ((,,,) x1 x2 x3) -instance Alternative f => Unital (->) Void () (FromAlternative f) where+instance (Alternative f) => Unital (->) Void () (FromAlternative f) where   introduce :: () -> FromAlternative f Void   introduce () = empty @@ -418,82 +444,93 @@  deriving via FromAlternative (ArrowMonad a) instance (ArrowPlus a) => Unital (->) Void () (ArrowMonad a) -deriving via FromAlternative (Proxy :: Type -> Type) instance Unital (->) Void () (Proxy :: Type -> Type)--deriving via FromAlternative (U1 :: Type -> Type) instance Unital (->) Void () (U1 :: Type -> Type)- deriving via FromAlternative (WrappedArrow a b) instance (ArrowZero a, ArrowPlus a) => Unital (->) Void () (WrappedArrow a b)  deriving via FromAlternative (Kleisli m a) instance (Alternative m) => Unital (->) Void () (Kleisli m a)  deriving via FromAlternative (Ap f) instance (Alternative f) => Unital (->) Void () (Ap f) -deriving via FromAlternative (Alt f) instance (Alternative f) => Unital (->) Void () (Alt f)+deriving newtype instance (Unital (->) iC () f) => Unital (->) iC () (Rec1 f) -deriving via FromAlternative (Rec1 f) instance (Alternative f) => Unital (->) Void () (Rec1 f)+deriving newtype instance (Unital (->) iC () f) => Unital (->) iC () (M1 i c f) -deriving via FromAlternative (Product f g) instance (Alternative f, Alternative g) => Unital (->) Void () (Product f g)+deriving newtype instance (Unital (->) iC () f) => Unital (->) iC () (Alt f) -deriving via FromAlternative (f :*: g) instance (Alternative f, Alternative g) => Unital (->) Void () (f :*: g)+deriving newtype instance (Unital (->) iC () f) => Unital (->) iC () (Reverse f) -deriving via FromAlternative (f `Compose` g) instance (Alternative f, Applicative g) => Unital (->) Void () (f `Compose` g)+deriving newtype instance (Unital (->) iC () f) => Unital (->) iC () (Backwards f) -deriving via FromAlternative (f :.: g) instance (Alternative f, Applicative g) => Unital (->) Void () (f :.: g)+instance (Unital (->) iC () f, Unital (->) iC () g) => Unital (->) iC () (f :*: g) where+  introduce :: () -> (f :*: g) iC+  introduce () = introduce @(->) @iC @() () :*: introduce @(->) @iC @() () -deriving via FromAlternative (M1 i c f) instance (Alternative f) => Unital (->) Void () (M1 i c f)+instance Unital (->) iC () (Proxy :: Type -> Type) where+  introduce _ = Proxy -instance Divisible f => Unital (->) () () (FromDivisible f) where-  introduce :: () -> FromDivisible f ()-  introduce () = FromDivisible conquered+instance Unital (->) iC () (U1 :: Type -> Type) where+  introduce _ = U1 -deriving via FromDivisible Predicate instance Unital (->) () () Predicate+instance (Monoid c) => Unital (->) iC () (Const c :: Type -> Type) where+  introduce _ = Const mempty -deriving via FromDivisible Comparison instance Unital (->) () () Comparison+instance (Monoid c) => Unital (->) iC () (Constant c :: Type -> Type) where+  introduce _ = Constant mempty -deriving via FromDivisible Equivalence instance Unital (->) () () Equivalence+deriving via FromAlternative (f `Compose` g) instance (Alternative f, Applicative g) => Unital (->) Void () (f `Compose` g) -deriving via FromDivisible (U1 :: Type -> Type) instance Unital (->) () () (U1 :: Type -> Type)+deriving via FromAlternative (f :.: g) instance (Alternative f, Applicative g) => Unital (->) Void () (f :.: g) -deriving via FromDivisible (Op r) instance Monoid r => Unital (->) () () (Op r)+newtype FromAlign f a = FromAlign (f a)+#if MIN_VERSION_semialign(1,4,0)+  deriving (Functor, Unzip, Semialign, Align)+#else+  deriving (Functor, Semialign, Align)+#endif --- deriving via FromDivisible (Proxy :: Type -> Type) instance Unital (->) () () (Proxy :: Type -> Type)-deriving via FromDivisible (MaybeT m) instance Divisible m => Unital (->) () () (MaybeT m)+instance (Align f) => Unital (->) Void () (FromAlign f) where+  introduce :: (Align f) => () -> FromAlign f Void+  introduce () = FromAlign nil -deriving via FromDivisible (Rec1 m) instance Divisible m => Unital (->) () () (Rec1 m)+-- deriving via FromAlign [] instance Unital (->) Void () [] -deriving via FromDivisible (Const m) instance Monoid m => Unital (->) () () (Const m :: Type -> Type)+-- deriving via FromAlign Maybe instance Unital (->) Void () Maybe -deriving via FromDivisible (Alt f) instance Divisible f => Unital (->) () () (Alt f)+-- deriving via FromAlign ZipList instance Unital (->) Void () ZipList -deriving via FromDivisible (Reverse f) instance Divisible f => Unital (->) () () (Reverse f)+-- deriving via FromAlign (Compose f g) instance (Align f, Semialign g) => Unital (->) Void () (Compose f g) -deriving via FromDivisible (Constant m) instance Monoid m => Unital (->) () () (Constant m :: Type -> Type)+instance (Divisible f) => Unital (->) () () (FromDivisible f) where+  introduce :: () -> FromDivisible f ()+  introduce () = FromDivisible conquered -deriving via FromDivisible (WriterT w m) instance Divisible m => Unital (->) () () (WriterT w m)+deriving via FromDivisible Predicate instance Unital (->) () () Predicate -deriving via FromDivisible (Lazy.WriterT w m) instance Divisible m => Unital (->) () () (Lazy.WriterT w m)+deriving via FromDivisible Comparison instance Unital (->) () () Comparison -deriving via FromDivisible (StateT w m) instance Divisible m => Unital (->) () () (StateT w m)+deriving via FromDivisible Equivalence instance Unital (->) () () Equivalence -deriving via FromDivisible (Lazy.StateT w m) instance Divisible m => Unital (->) () () (Lazy.StateT w m)+deriving via FromDivisible (Op r) instance (Monoid r) => Unital (->) () () (Op r) -deriving via FromDivisible (ReaderT r m) instance Divisible m => Unital (->) () () (ReaderT r m)+deriving via FromDivisible (MaybeT m) instance (Divisible m) => Unital (->) () () (MaybeT m) -deriving via FromDivisible (IdentityT m) instance Divisible m => Unital (->) () () (IdentityT m)+deriving via FromDivisible (WriterT w m) instance (Divisible m) => Unital (->) () () (WriterT w m) -deriving via FromDivisible (ExceptT e m) instance Divisible m => Unital (->) () () (ExceptT e m)+deriving via FromDivisible (Lazy.WriterT w m) instance (Divisible m) => Unital (->) () () (Lazy.WriterT w m) -deriving via FromDivisible (Backwards f) instance Divisible f => Unital (->) () () (Backwards f)+deriving via FromDivisible (StateT w m) instance (Divisible m) => Unital (->) () () (StateT w m) -deriving via FromDivisible (ComposeCF f g) instance (Divisible f, Applicative g) => Unital (->) () () (ComposeCF f g)+deriving via FromDivisible (Lazy.StateT w m) instance (Divisible m) => Unital (->) () () (Lazy.StateT w m) -deriving via FromDivisible (ComposeFC f g) instance (Divisible g, Applicative f) => Unital (->) () () (ComposeFC f g)+deriving via FromDivisible (ReaderT r m) instance (Divisible m) => Unital (->) () () (ReaderT r m) -deriving via FromDivisible (f :*: g) instance (Divisible f, Divisible g) => Unital (->) () () (f :*: g)+deriving via FromDivisible (IdentityT m) instance (Divisible m) => Unital (->) () () (IdentityT m) --- deriving via FromDivisible (Product f g)           instance (Divisible f, Divisible g) => Unital (->) () () (Product f g)-deriving via FromDivisible (M1 i c f) instance Divisible f => Unital (->) () () (M1 i c f)+deriving via FromDivisible (ExceptT e m) instance (Divisible m) => Unital (->) () () (ExceptT e m) +deriving via FromDivisible (ComposeCF f g) instance (Divisible f, Applicative g) => Unital (->) () () (ComposeCF f g)++deriving via FromDivisible (ComposeFC f g) instance (Divisible g, Applicative f) => Unital (->) () () (ComposeFC f g)+ deriving via FromDivisible (f :.: g) instance (Applicative f, Divisible g) => Unital (->) () () (f :.: g)  -- deriving via FromDivisible (Compose f g)           instance (Applicative f, Divisible g) => Unital (->) () () (Compose f g)@@ -501,7 +538,7 @@  deriving via FromDivisible (Lazy.RWST r w s m) instance (Divisible m) => Unital (->) () () (Lazy.RWST r w s m) -instance Decidable f => Unital (->) Void () (FromDecidable f) where+instance (Decidable f) => Unital (->) Void () (FromDecidable f) where   introduce :: () -> FromDecidable f Void   introduce () = FromDecidable lost @@ -511,35 +548,24 @@  deriving via FromDecidable Equivalence instance Unital (->) Void () Equivalence --- deriving via FromDecidable (U1 :: Type -> Type)    instance Unital (->) Void () (U1 :: Type -> Type)-deriving via FromDecidable (Op r) instance Monoid r => Unital (->) Void () (Op r)---- deriving via FromDecidable (Proxy :: Type -> Type) instance Unital (->) Void () (Proxy :: Type -> Type)-deriving via FromDecidable (MaybeT m) instance Decidable m => Unital (->) Void () (MaybeT m)---- deriving via FromDecidable (Rec1 m)                instance Decidable m => Unital (->) Void () (Rec1 m)--- deriving via FromDecidable (Alt f)                 instance Decidable f => Unital (->) Void () (Alt f)-deriving via FromDecidable (Reverse f) instance Decidable f => Unital (->) Void () (Reverse f)+deriving via FromDecidable (Op r) instance (Monoid r) => Unital (->) Void () (Op r) -deriving via FromDecidable (WriterT w m) instance Decidable m => Unital (->) Void () (WriterT w m)+deriving via FromDecidable (MaybeT m) instance (Decidable m) => Unital (->) Void () (MaybeT m) -deriving via FromDecidable (Lazy.WriterT w m) instance Decidable m => Unital (->) Void () (Lazy.WriterT w m)+deriving via FromDecidable (WriterT w m) instance (Decidable m) => Unital (->) Void () (WriterT w m) -deriving via FromDecidable (StateT w m) instance Decidable m => Unital (->) Void () (StateT w m)+deriving via FromDecidable (Lazy.WriterT w m) instance (Decidable m) => Unital (->) Void () (Lazy.WriterT w m) -deriving via FromDecidable (Lazy.StateT w m) instance Decidable m => Unital (->) Void () (Lazy.StateT w m)+deriving via FromDecidable (StateT w m) instance (Decidable m) => Unital (->) Void () (StateT w m) -deriving via FromDecidable (ReaderT r m) instance Decidable m => Unital (->) Void () (ReaderT r m)+deriving via FromDecidable (Lazy.StateT w m) instance (Decidable m) => Unital (->) Void () (Lazy.StateT w m) -deriving via FromDecidable (IdentityT m) instance Decidable m => Unital (->) Void () (IdentityT m)+deriving via FromDecidable (ReaderT r m) instance (Decidable m) => Unital (->) Void () (ReaderT r m) -deriving via FromDecidable (Backwards f) instance Decidable f => Unital (->) Void () (Backwards f)+deriving via FromDecidable (IdentityT m) instance (Decidable m) => Unital (->) Void () (IdentityT m)  deriving via FromDecidable (ComposeFC f g) instance (Decidable g, Applicative f) => Unital (->) Void () (ComposeFC f g) --- deriving via FromDecidable (f :*: g)               instance (Decidable f, Decidable g) => Unital (->) Void () (f :*: g)--- deriving via FromDecidable (Product f g)           instance (Decidable f, Decidable g) => Unital (->) Void () (Product f g)--- deriving via FromDecidable (M1 i c f)              instance Decidable f => Unital (->) Void () (M1 i c f) -- deriving via FromDecidable (f :.: g)               instance (Applicative f, Decidable g) => Unital (->) Void () (f :.: g) -- deriving via FromDecidable (Compose f g)           instance (Applicative f, Decidable g) => Unital (->) Void () (Compose f g) deriving via FromDecidable (RWST r w s m) instance (Decidable m) => Unital (->) Void () (RWST r w s m)@@ -585,14 +611,14 @@ --   'combine' 'Control.Category..' 'glmap' 'introduce' ≡ 'fmap' ('bwd' 'unitl') 'Control.Category..' 'fwd' 'unitl' -- @ class-  ( Tensor cat t1 i1,-    Tensor cat t0 i0,-    Semigroupal cat t1 t0 f,-    Unital cat i1 i0 f+  ( Tensor cat tC iC,+    Tensor cat tD iD,+    Semigroupal cat tC tD f,+    Unital cat iC iD f   ) =>-  Monoidal cat t1 i1 t0 i0 f+  Monoidal cat tC iC tD iD f -instance Applicative f => Monoidal (->) (,) () (,) () (FromApplicative f)+instance (Applicative f) => Monoidal (->) (,) () (,) () (FromApplicative f)  deriving via FromApplicative Identity instance Monoidal (->) (,) () (,) () Identity @@ -610,7 +636,7 @@  deriving via FromApplicative IO instance Monoidal (->) (,) () (,) () IO -deriving via FromApplicative (Product f g) instance (Applicative f, Applicative g) => Monoidal (->) (,) () (,) () (Product f g)+instance (Semigroupal (->) tC (,) f, Semigroupal (->) tC (,) g, Unital (->) iC () f, Unital (->) iC () g, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Product f g)  deriving via (FromApplicative ((,) x1)) instance (Monoid x1) => Monoidal (->) (,) () (,) () ((,) x1) @@ -618,7 +644,7 @@  deriving via (FromApplicative ((,,,) x1 x2 x3)) instance (Monoid x1, Monoid x2, Monoid x3) => Monoidal (->) (,) () (,) () ((,,,) x1 x2 x3) -instance Alternative f => Monoidal (->) Either Void (,) () (FromAlternative f)+instance (Alternative f) => Monoidal (->) Either Void (,) () (FromAlternative f)  deriving via FromAlternative ZipList instance Monoidal (->) Either Void (,) () ZipList @@ -638,78 +664,64 @@  deriving via FromAlternative (ArrowMonad a) instance (ArrowPlus a) => Monoidal (->) Either Void (,) () (ArrowMonad a) -deriving via FromAlternative (Proxy :: Type -> Type) instance Monoidal (->) Either Void (,) () (Proxy :: Type -> Type)--deriving via FromAlternative (U1 :: Type -> Type) instance Monoidal (->) Either Void (,) () (U1 :: Type -> Type)- deriving via FromAlternative (WrappedArrow a b) instance (ArrowZero a, ArrowPlus a) => Monoidal (->) Either Void (,) () (WrappedArrow a b)  deriving via FromAlternative (Kleisli m a) instance (Alternative m) => Monoidal (->) Either Void (,) () (Kleisli m a)  deriving via FromAlternative (Ap f) instance (Alternative f) => Monoidal (->) Either Void (,) () (Ap f) -deriving via FromAlternative (Alt f) instance (Alternative f) => Monoidal (->) Either Void (,) () (Alt f)--deriving via FromAlternative (Rec1 f) instance (Alternative f) => Monoidal (->) Either Void (,) () (Rec1 f)--deriving via FromAlternative (Product f g) instance (Alternative f, Alternative g) => Monoidal (->) Either Void (,) () (Product f g)+instance (Semigroupal (->) tC (,) f, Unital (->) iC () f, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Rec1 f) -deriving via FromAlternative (f :*: g) instance (Alternative f, Alternative g) => Monoidal (->) Either Void (,) () (f :*: g)+instance (Semigroupal (->) tC (,) f, Unital (->) iC () f, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (M1 i c f) -deriving via FromAlternative (f `Compose` g) instance (Alternative f, Applicative g) => Monoidal (->) Either Void (,) () (f `Compose` g)+instance (Semigroupal (->) tC (,) f, Unital (->) iC () f, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Alt f) -deriving via FromAlternative (f :.: g) instance (Alternative f, Applicative g) => Monoidal (->) Either Void (,) () (f :.: g)+instance (Semigroupal (->) tC (,) f, Unital (->) iC () f, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Reverse f) -deriving via FromAlternative (M1 i c f) instance (Alternative f) => Monoidal (->) Either Void (,) () (M1 i c f)+instance (Semigroupal (->) tC (,) f, Unital (->) iC () f, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Backwards f) -deriving via FromDivisible Predicate instance Monoidal (->) (,) () (,) () Predicate+instance (Semigroupal (->) tC (,) f, Semigroupal (->) tC (,) g, Unital (->) iC () f, Unital (->) iC () g, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (f :*: g) -deriving via FromDivisible Comparison instance Monoidal (->) (,) () (,) () Comparison+instance (Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Proxy :: Type -> Type) -deriving via FromDivisible Equivalence instance Monoidal (->) (,) () (,) () Equivalence+instance (Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (U1 :: Type -> Type) -deriving via FromDivisible (U1 :: Type -> Type) instance Monoidal (->) (,) () (,) () (U1 :: Type -> Type)+instance (Monoid c, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Const c :: Type -> Type) -deriving via FromDivisible (Op r) instance Monoid r => Monoidal (->) (,) () (,) () (Op r)+instance (Monoid c, Tensor (->) tC iC) => Monoidal (->) tC iC (,) () (Constant c :: Type -> Type) --- deriving via FromDivisible (Proxy :: Type -> Type) instance Monoidal (->) (,) () (,) () (Proxy :: Type -> Type)-deriving via FromDivisible (MaybeT m) instance Divisible m => Monoidal (->) (,) () (,) () (MaybeT m)+deriving via FromAlternative (f `Compose` g) instance (Alternative f, Applicative g) => Monoidal (->) Either Void (,) () (f `Compose` g) -deriving via FromDivisible (Rec1 m) instance Divisible m => Monoidal (->) (,) () (,) () (Rec1 m)+deriving via FromAlternative (f :.: g) instance (Alternative f, Applicative g) => Monoidal (->) Either Void (,) () (f :.: g) -deriving via FromDivisible (Const m) instance Monoid m => Monoidal (->) (,) () (,) () (Const m :: Type -> Type)+deriving via FromDivisible Predicate instance Monoidal (->) (,) () (,) () Predicate -deriving via FromDivisible (Alt f) instance Divisible f => Monoidal (->) (,) () (,) () (Alt f)+deriving via FromDivisible Comparison instance Monoidal (->) (,) () (,) () Comparison -deriving via FromDivisible (Reverse f) instance Divisible f => Monoidal (->) (,) () (,) () (Reverse f)+deriving via FromDivisible Equivalence instance Monoidal (->) (,) () (,) () Equivalence -deriving via FromDivisible (Constant m) instance Monoid m => Monoidal (->) (,) () (,) () (Constant m :: Type -> Type)+deriving via FromDivisible (Op r) instance (Monoid r) => Monoidal (->) (,) () (,) () (Op r) -deriving via FromDivisible (WriterT w m) instance Divisible m => Monoidal (->) (,) () (,) () (WriterT w m)+deriving via FromDivisible (MaybeT m) instance (Divisible m) => Monoidal (->) (,) () (,) () (MaybeT m) -deriving via FromDivisible (Lazy.WriterT w m) instance Divisible m => Monoidal (->) (,) () (,) () (Lazy.WriterT w m)+deriving via FromDivisible (WriterT w m) instance (Divisible m) => Monoidal (->) (,) () (,) () (WriterT w m) -deriving via FromDivisible (StateT w m) instance Divisible m => Monoidal (->) (,) () (,) () (StateT w m)+deriving via FromDivisible (Lazy.WriterT w m) instance (Divisible m) => Monoidal (->) (,) () (,) () (Lazy.WriterT w m) -deriving via FromDivisible (Lazy.StateT w m) instance Divisible m => Monoidal (->) (,) () (,) () (Lazy.StateT w m)+deriving via FromDivisible (StateT w m) instance (Divisible m) => Monoidal (->) (,) () (,) () (StateT w m) -deriving via FromDivisible (ReaderT r m) instance Divisible m => Monoidal (->) (,) () (,) () (ReaderT r m)+deriving via FromDivisible (Lazy.StateT w m) instance (Divisible m) => Monoidal (->) (,) () (,) () (Lazy.StateT w m) -deriving via FromDivisible (IdentityT m) instance Divisible m => Monoidal (->) (,) () (,) () (IdentityT m)+deriving via FromDivisible (ReaderT r m) instance (Divisible m) => Monoidal (->) (,) () (,) () (ReaderT r m) -deriving via FromDivisible (ExceptT e m) instance Divisible m => Monoidal (->) (,) () (,) () (ExceptT e m)+deriving via FromDivisible (IdentityT m) instance (Divisible m) => Monoidal (->) (,) () (,) () (IdentityT m) -deriving via FromDivisible (Backwards f) instance Divisible f => Monoidal (->) (,) () (,) () (Backwards f)+deriving via FromDivisible (ExceptT e m) instance (Divisible m) => Monoidal (->) (,) () (,) () (ExceptT e m)  deriving via FromDivisible (ComposeCF f g) instance (Divisible f, Applicative g) => Monoidal (->) (,) () (,) () (ComposeCF f g)  deriving via FromDivisible (ComposeFC f g) instance (Divisible g, Applicative f) => Monoidal (->) (,) () (,) () (ComposeFC f g) -deriving via FromDivisible (f :*: g) instance (Divisible f, Divisible g) => Monoidal (->) (,) () (,) () (f :*: g)---- deriving via FromDivisible (Product f g)           instance (Divisible f, Divisible g) => Monoidal (->) (,) () (,) () (Product f g)-deriving via FromDivisible (M1 i c f) instance Divisible f => Monoidal (->) (,) () (,) () (M1 i c f)- deriving via FromDivisible (f :.: g) instance (Applicative f, Divisible g) => Monoidal (->) (,) () (,) () (f :.: g)  -- deriving via FromDivisible (Compose f g)           instance (Applicative f, Divisible g) => Monoidal (->) (,) () (,) () (Compose f g)@@ -723,35 +735,24 @@  deriving via FromDecidable Equivalence instance Monoidal (->) Either Void (,) () Equivalence --- deriving via FromDecidable (U1 :: Type -> Type)    instance Monoidal (->) Either Void (,) () (U1 :: Type -> Type)-deriving via FromDecidable (Op r) instance Monoid r => Monoidal (->) Either Void (,) () (Op r)---- deriving via FromDecidable (Proxy :: Type -> Type) instance Monoidal (->) Either Void (,) () (Proxy :: Type -> Type)-deriving via FromDecidable (MaybeT m) instance Decidable m => Monoidal (->) Either Void (,) () (MaybeT m)---- deriving via FromDecidable (Rec1 m)                instance Decidable m => Monoidal (->) Either Void (,) () (Rec1 m)--- deriving via FromDecidable (Alt f)                 instance Decidable f => Monoidal (->) Either Void (,) () (Alt f)-deriving via FromDecidable (Reverse f) instance Decidable f => Monoidal (->) Either Void (,) () (Reverse f)+deriving via FromDecidable (Op r) instance (Monoid r) => Monoidal (->) Either Void (,) () (Op r) -deriving via FromDecidable (WriterT w m) instance Decidable m => Monoidal (->) Either Void (,) () (WriterT w m)+deriving via FromDecidable (MaybeT m) instance (Decidable m) => Monoidal (->) Either Void (,) () (MaybeT m) -deriving via FromDecidable (Lazy.WriterT w m) instance Decidable m => Monoidal (->) Either Void (,) () (Lazy.WriterT w m)+deriving via FromDecidable (WriterT w m) instance (Decidable m) => Monoidal (->) Either Void (,) () (WriterT w m) -deriving via FromDecidable (StateT w m) instance Decidable m => Monoidal (->) Either Void (,) () (StateT w m)+deriving via FromDecidable (Lazy.WriterT w m) instance (Decidable m) => Monoidal (->) Either Void (,) () (Lazy.WriterT w m) -deriving via FromDecidable (Lazy.StateT w m) instance Decidable m => Monoidal (->) Either Void (,) () (Lazy.StateT w m)+deriving via FromDecidable (StateT w m) instance (Decidable m) => Monoidal (->) Either Void (,) () (StateT w m) -deriving via FromDecidable (ReaderT r m) instance Decidable m => Monoidal (->) Either Void (,) () (ReaderT r m)+deriving via FromDecidable (Lazy.StateT w m) instance (Decidable m) => Monoidal (->) Either Void (,) () (Lazy.StateT w m) -deriving via FromDecidable (IdentityT m) instance Decidable m => Monoidal (->) Either Void (,) () (IdentityT m)+deriving via FromDecidable (ReaderT r m) instance (Decidable m) => Monoidal (->) Either Void (,) () (ReaderT r m) -deriving via FromDecidable (Backwards f) instance Decidable f => Monoidal (->) Either Void (,) () (Backwards f)+deriving via FromDecidable (IdentityT m) instance (Decidable m) => Monoidal (->) Either Void (,) () (IdentityT m)  deriving via FromDecidable (ComposeFC f g) instance (Decidable g, Applicative f) => Monoidal (->) Either Void (,) () (ComposeFC f g) --- deriving via FromDecidable (f :*: g)               instance (Decidable f, Decidable g) => Monoidal (->) Either Void (,) () (f :*: g)--- deriving via FromDecidable (Product f g)           instance (Decidable f, Decidable g) => Monoidal (->) Either Void (,) () (Product f g)--- deriving via FromDecidable (M1 i c f)              instance Decidable f => Monoidal (->) Either Void (,) () (M1 i c f) -- deriving via FromDecidable (f :.: g)               instance (Applicative f, Decidable g) => Monoidal (->) Either Void (,) () (f :.: g) -- deriving via FromDecidable (Compose f g)           instance (Applicative f, Decidable g) => Monoidal (->) Either Void (,) () (Compose f g) deriving via FromDecidable (RWST r w s m) instance (Decidable m) => Monoidal (->) Either Void (,) () (RWST r w s m)

@@ -0,0 +1,253 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}++-- | Generic deriving of 'Semigroupal' instances via @kind-generics@.+--+-- The @kind-generics@ 'RepK' represents a type parameter structurally,+-- whether it occurs covariantly (as in an @Applicative@) or contravariantly+-- (as in a @Divisible@). One mechanism therefore derives+-- @'Semigroupal' (->) tC (,)@ for both, across the domain tensors @(,)@+-- (Applicative and Divisible), @Either@ (Alternative and Decidable), and+-- @These@ (Semialign).+--+-- > data Foo a = Foo (Maybe a) [a]+-- > $(deriveGenericK ''Foo)+-- > deriving via FromGeneric Foo instance Semigroupal (->) (,) (,) Foo+module Data.Functor.Monoidal.Generic+  ( FromGeneric (..),+    FromRepresentable (..),+    GSemigroupalK (..),+    GCosemigroupalK (..),+    GUnitalK (..),+  )+where++import Control.Category.Tensor (Associative, Tensor)+import Data.Distributive (Distributive)+import Data.Functor.Contravariant (Op (..))+import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..))+import Generics.Kind+import Prelude++-- | @combine@ over a @kind-generics@ 'RepK', for the product codomain tensor+-- @(,)@ and an arbitrary domain tensor @tC@.+class GSemigroupalK tC rep where+  gcombineK :: rep (x :&&: LoT0) -> rep (x' :&&: LoT0) -> rep (tC x x' :&&: LoT0)++-- | The empty constructor.+instance GSemigroupalK tC U1 where+  gcombineK U1 U1 = U1++-- | Metadata is transparent.+instance (GSemigroupalK tC f) => GSemigroupalK tC (M1 i c f) where+  gcombineK (M1 a) (M1 b) = M1 (gcombineK a b)++-- | Combine each side of a product componentwise, for any codomain tensor.+instance (GSemigroupalK tC f, GSemigroupalK tC g) => GSemigroupalK tC (f :*: g) where+  gcombineK (a :*: b) (a' :*: b') = gcombineK a a' :*: gcombineK b b'++-- | The bare parameter, like 'GHC.Generics.Par1'. Only the product tensor+-- @(,)@ has a canonical merge of two values into one.+instance GSemigroupalK (,) (Field Var0) where+  gcombineK (Field x) (Field x') = Field (x, x')++-- | A constant field merges with its 'Monoid'. The value does not mention the+-- parameter, so this holds for any tensor.+instance (Monoid c) => GSemigroupalK tC (Field (Kon c)) where+  gcombineK (Field c) (Field c') = Field (c <> c')++-- | A sub-functor @g@ applied to the parameter delegates to @g@'s own+-- 'Semigroupal' instance at tensor @tC@. This holds whether @g@ is covariant+-- (Applicative, Alternative, Semialign) or contravariant (Divisible, Decidable).+instance (Semigroupal (->) tC (,) g) => GSemigroupalK tC (Field (Kon g :@: Var0)) where+  gcombineK (Field a) (Field b) = Field (combine @(->) @tC @(,) (a, b))++-- | A nested field @f (g a)@. Product-combine the outer functor, then map the+-- inner combine over it.+instance+  (Semigroupal (->) (,) (,) f, Functor f, Semigroupal (->) tC (,) g) =>+  GSemigroupalK tC (Field (Kon f :@: (Kon g :@: Var0)))+  where+  gcombineK (Field a) (Field b) =+    Field (fmap (combine @(->) @tC @(,)) (combine @(->) @(,) @(,) (a, b)))++-- | A bare function field @x -> r@, the shape of primitive contravariants like+-- 'Data.Functor.Contravariant.Predicate' and @'Op' r@. @kind-generics@+-- represents it as an application of @(->)@. It delegates to the @'Op' r@+-- instance at the same tensor (Divisible at @(,)@, Decidable at @Either@).+instance+  (Semigroupal (->) tC (,) (Op r)) =>+  GSemigroupalK tC (Field ((Kon (->) :@: Var0) :@: Kon r))+  where+  gcombineK (Field h1) (Field h2) =+    Field (getOp (combine @(->) @tC @(,) (Op h1, Op h2)))++-- | The deriving-via vehicle.+--+-- > deriving via FromGeneric Foo instance Semigroupal (->) tC (,) Foo+newtype FromGeneric f a = FromGeneric (f a)++instance+  (GenericK f, GSemigroupalK tC (RepK f), Associative (->) tC) =>+  Semigroupal (->) tC (,) (FromGeneric f)+  where+  combine ::+    forall x x'.+    (FromGeneric f x, FromGeneric f x') ->+    FromGeneric f (tC x x')+  combine (FromGeneric fx, FromGeneric fx') =+    FromGeneric+      ( toK @_ @f @(tC x x' :&&: LoT0)+          (gcombineK (fromK @_ @f @(x :&&: LoT0) fx) (fromK @_ @f @(x' :&&: LoT0) fx'))+      )++--------------------------------------------------------------------------------+-- Split (Op), the comonoidal direction for the product tensor++-- | @combine@ over @Op@ for the product tensor. Splits one structure into two.+--+-- @rep ((x, x') :&&: LoT0) -> (rep (x :&&: LoT0), rep (x' :&&: LoT0))@+class GCosemigroupalK rep where+  gcosplitK :: rep ((x, x') :&&: LoT0) -> (rep (x :&&: LoT0), rep (x' :&&: LoT0))++instance GCosemigroupalK U1 where+  gcosplitK U1 = (U1, U1)++instance (GCosemigroupalK f) => GCosemigroupalK (M1 i c f) where+  gcosplitK (M1 a) = let (l, r) = gcosplitK a in (M1 l, M1 r)++instance (GCosemigroupalK f, GCosemigroupalK g) => GCosemigroupalK (f :*: g) where+  gcosplitK (a :*: b) =+    let (al, ar) = gcosplitK a+        (bl, br) = gcosplitK b+     in (al :*: bl, ar :*: br)++-- | Splitting a sum is total. The single input constructor determines matched+-- outputs. @:+:@ has none of the mismatched-constructor trouble that blocks+-- the combine direction.+instance (GCosemigroupalK f, GCosemigroupalK g) => GCosemigroupalK (f :+: g) where+  gcosplitK (L1 a) = let (l, r) = gcosplitK a in (L1 l, L1 r)+  gcosplitK (R1 b) = let (l, r) = gcosplitK b in (R1 l, R1 r)++-- | The bare parameter splits the pair.+instance GCosemigroupalK (Field Var0) where+  gcosplitK (Field (x, x')) = (Field x, Field x')++-- | A constant field is duplicated.+instance GCosemigroupalK (Field (Kon c)) where+  gcosplitK (Field c) = (Field c, Field c)++-- | A sub-functor uses the functorial unzip @fmap fst@ and @fmap snd@. This is+-- total for any 'Functor' and gives the standalone split.+instance (Functor g) => GCosemigroupalK (Field (Kon g :@: Var0)) where+  gcosplitK (Field gxx) = (Field (fmap fst gxx), Field (fmap snd gxx))++-- | A nested field @f (g a)@ splits with a double @fmap@.+instance (Functor f, Functor g) => GCosemigroupalK (Field (Kon f :@: (Kon g :@: Var0))) where+  gcosplitK (Field fgxx) = (Field (fmap (fmap fst) fgxx), Field (fmap (fmap snd) fgxx))++-- | The generic split, shared by both vehicles below.+gsplit ::+  forall f x x'.+  (GenericK f, GCosemigroupalK (RepK f)) =>+  f (x, x') ->+  (f x, f x')+gsplit fxx =+  let (l, r) = gcosplitK (fromK @_ @f @((x, x') :&&: LoT0) fxx)+   in (toK @_ @f @(x :&&: LoT0) l, toK @_ @f @(x' :&&: LoT0) r)++-- | The standalone split.+--+-- > deriving via FromGeneric Foo instance Semigroupal Op (,) (,) Foo+--+-- This has unzip semantics and is total, even on sums. It does not always+-- invert the cartesian @combine@.+instance+  (GenericK f, GCosemigroupalK (RepK f)) =>+  Semigroupal Op (,) (,) (FromGeneric f)+  where+  combine :: Op (FromGeneric f x, FromGeneric f x') (FromGeneric f (x, x'))+  combine = Op (\(FromGeneric fxx) -> let (a, b) = gsplit fxx in (FromGeneric a, FromGeneric b))++-- | The coherent split, gated on 'Distributive'. A split inverts the cartesian+-- @combine@ when the functor is representable. This vehicle compiles+-- only for representable functors.+--+-- > deriving via FromRepresentable Foo instance Semigroupal Op (,) (,) Foo+newtype FromRepresentable f a = FromRepresentable (f a)++instance+  (GenericK f, GCosemigroupalK (RepK f), Distributive f) =>+  Semigroupal Op (,) (,) (FromRepresentable f)+  where+  combine :: Op (FromRepresentable f x, FromRepresentable f x') (FromRepresentable f (x, x'))+  combine = Op (\(FromRepresentable fxx) -> let (a, b) = gsplit fxx in (FromRepresentable a, FromRepresentable b))++--------------------------------------------------------------------------------+-- Unital and Monoidal++-- | @introduce@ over a @kind-generics@ 'RepK', building the unit-filled+-- structure at a domain unit @iC@. This is @()@ for the product tensor+-- (Applicative and Divisible) and @Void@ for @Either@ and @These@ (Alternative+-- and Decidable).+class GUnitalK iC rep where+  gintroduceK :: rep (iC :&&: LoT0)++instance GUnitalK iC U1 where+  gintroduceK = U1++instance (GUnitalK iC f) => GUnitalK iC (M1 i c f) where+  gintroduceK = M1 gintroduceK++instance (GUnitalK iC f, GUnitalK iC g) => GUnitalK iC (f :*: g) where+  gintroduceK = gintroduceK :*: gintroduceK++-- | A bare parameter can only be introduced at the product unit @()@, the one+-- unit object with a canonical inhabitant. There is no value of @Void@ to place+-- here. A type with a bare-parameter field has no @Either@/@These@ unit.+instance GUnitalK () (Field Var0) where+  gintroduceK = Field ()++-- | A constant field is the 'Monoid' identity, at any unit.+instance (Monoid c) => GUnitalK iC (Field (Kon c)) where+  gintroduceK = Field mempty++-- | A sub-functor delegates to its own 'Unital' instance at the same unit.+instance (Unital (->) iC () g) => GUnitalK iC (Field (Kon g :@: Var0)) where+  gintroduceK = Field (introduce @(->) @iC @() ())++-- | A nested field @f (g iC)@. The outer functor at the product unit, the inner+-- at @iC@, mirroring the nested @combine@.+instance+  (Functor f, Unital (->) () () f, Unital (->) iC () g) =>+  GUnitalK iC (Field (Kon f :@: (Kon g :@: Var0)))+  where+  gintroduceK =+    Field (fmap (const (introduce @(->) @iC @() ())) (introduce @(->) @() @() ()))++-- | A bare function field's unit delegates to @'Op' r@ (@conquer@ at @()@,+-- @lose@ at @Void@).+instance+  (Unital (->) iC () (Op r)) =>+  GUnitalK iC (Field ((Kon (->) :@: Var0) :@: Kon r))+  where+  gintroduceK = Field (getOp (introduce @(->) @iC @() ()))++-- | The unit vehicle, at any domain unit @iC@:+--+-- > deriving via FromGeneric Foo instance Unital (->) () () Foo+-- > deriving via FromGeneric Foo instance Unital (->) Void () Foo+instance (GenericK f, GUnitalK iC (RepK f)) => Unital (->) iC () (FromGeneric f) where+  introduce :: () -> FromGeneric f iC+  introduce () = FromGeneric (toK @_ @f @(iC :&&: LoT0) gintroduceK)++-- | @Monoidal@ from 'Semigroupal' plus 'Unital', for any codomain+-- tensor @tC@ paired with its unit @iC@:+--+-- > deriving via FromGeneric Foo instance Monoidal (->) (,) () (,) () Foo+-- > deriving via FromGeneric Foo instance Monoidal (->) Either Void (,) () Foo+instance+  (GenericK f, GSemigroupalK tC (RepK f), GUnitalK iC (RepK f), Tensor (->) tC iC) =>+  Monoidal (->) tC iC (,) () (FromGeneric f)

@@ -0,0 +1,278 @@+{-# LANGUAGE CPP #-}++module Data.Functor.Monoidal.Specialized+  ( -- * Applicative+    pure,+    liftA2,+    (<*>),+    (*>),+    (<*),++    -- * Alternative+    empty,+    (<|>),+    liftAlt2,++    -- * Semialign+    align,+    alignWith,++    -- * Divisible+    divide,+    conquer,+    divided,+    conquered,+    liftD,++    -- * Decidable+    lose,+    choose,+    chosen,+    lost,++    -- * Selection+    decide,+    branch,+    select,+  )+where++--------------------------------------------------------------------------------++import Data.Bifunctor.Monoidal.Specialized (merge')+import Data.Functor.Contravariant (Contravariant (..), Op (..))+import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..))+import Data.These (These)+import Data.Void (Void, absurd)+#if MIN_VERSION_base(4,18,0)+import Prelude hiding ((<*>), (*>), (<*), liftA2, pure)+#else+import Prelude hiding ((<*>), (*>), (<*), pure)+#endif++--------------------------------------------------------------------------------++-- $setup+-- >>> :set -dppr-cols=1000+-- >>> import Prelude hiding (pure, (<*>), (*>), (<*))+-- >>> import Data.Functor.Contravariant (Predicate (..), getPredicate)+-- >>> import Data.Functor.Identity (Identity (..))+-- >>> import Data.These (These (..), these)+-- >>> import Data.Void (Void)++--------------------------------------------------------------------------------++-- | 'Control.Applicative.pure' specialized to a 'Unital' functor.+--+-- ==== __Examples__+--+-- >>> pure @Maybe (5 :: Int)+-- Just 5+pure :: (Functor f, Unital (->) () () f) => a -> f a+pure a = a <$ introduce @_ @() @() ()++-- | 'Control.Applicative.liftA2' specialized to a 'Semigroupal' functor.+liftA2 :: (Functor f, Semigroupal (->) (,) (,) f) => (a -> b -> c) -> f a -> f b -> f c+liftA2 f fa fb = uncurry f <$> combine (fa, fb)++infixl 4 <*>++-- | 'Control.Applicative.<*>' specialized to a 'Semigroupal' functor.+--+-- ==== __Examples__+--+-- >>> Just not <*> Just True+-- Just False+(<*>) :: (Functor f, Semigroupal (->) (,) (,) f) => f (a -> b) -> f a -> f b+ff <*> fa = liftA2 ($) ff fa++infixl 4 *>++-- | Sequence two actions, keeping the result of the second.+--+-- ==== __Examples__+--+-- >>> Just (1 :: Int) *> Just 2+-- Just 2+(*>) :: (Functor f, Semigroupal (->) (,) (,) f) => f a -> f b -> f b+(*>) = liftA2 (const id)++infixl 4 <*++-- | Sequence two actions, keeping the result of the first.+--+-- ==== __Examples__+--+-- >>> Just (1 :: Int) <* Just 2+-- Just 1+(<*) :: (Functor f, Semigroupal (->) (,) (,) f) => f a -> f b -> f a+(<*) = liftA2 const++--------------------------------------------------------------------------------++infixl 3 <|>++-- | 'Control.Applicative.<|>' specialized to a 'Semigroupal' functor over 'Either'.+--+-- ==== __Examples__+--+-- >>> Just (1 :: Int) <|> Just 2+-- Just 1+--+-- >>> (Nothing :: Maybe Int) <|> Just 2+-- Just 2+(<|>) :: (Functor f, Semigroupal (->) Either (,) f) => f a -> f a -> f a+fa <|> fb = liftAlt2 merge' fa fb++-- | 'Control.Applicative.empty' specialized to a 'Unital' functor over 'Void'.+--+-- ==== __Examples__+--+-- >>> empty :: Maybe Int+-- Nothing+empty :: forall f a. (Functor f, Unital (->) Void () f) => f a+empty = absurd <$> introduce @(->) @Void @() @f ()++-- | Combine two actions under a function of their sum.+--+-- ==== __Examples__+--+-- >>> liftAlt2 (either negate id) (Just (3 :: Int)) (Nothing :: Maybe Int)+-- Just (-3)+liftAlt2 :: (Functor f, Semigroupal (->) Either (,) f) => (Either a b -> c) -> f a -> f b -> f c+liftAlt2 f fa fb = f <$> combine (fa, fb)++--------------------------------------------------------------------------------++-- | 'Data.Align.align' specialized to a 'Semigroupal' functor over 'These'.+--+-- ==== __Examples__+--+-- >>> align (Just (1 :: Int)) (Just (2 :: Int))+-- Just (These 1 2)+--+-- >>> align (Just (1 :: Int)) (Nothing :: Maybe Int)+-- Just (This 1)+align :: (Functor f, Semigroupal (->) These (,) f) => f a -> f b -> f (These a b)+align = curry combine++-- | 'Data.Align.alignWith' specialized to a 'Semigroupal' functor over 'These'.+--+-- ==== __Examples__+--+-- >>> alignWith (these id id (+)) [1, 2 :: Int] [10, 20, 30]+-- [11,22,30]+alignWith :: (Functor f, Semigroupal (->) These (,) f) => (These a b -> c) -> f a -> f b -> f c+alignWith f fa fb = f <$> combine @_ @These (fa, fb)++--------------------------------------------------------------------------------++-- | 'Data.Functor.Contravariant.Divisible.divide' specialized to a 'Semigroupal' functor.+--+-- ==== __Examples__+--+-- >>> getPredicate (divide (\x -> (x, x)) (Predicate even) (Predicate (> 0))) (4 :: Int)+-- True+divide :: (Contravariant f, Semigroupal (->) (,) (,) f) => (c -> (a, b)) -> f a -> f b -> f c+divide f fa fb = contramap f $ combine (fa, fb)++-- | 'Data.Functor.Contravariant.Divisible.conquer' specialized to a 'Unital' functor.+--+-- ==== __Examples__+--+-- >>> getPredicate (conquer :: Predicate Int) 5+-- True+conquer :: (Contravariant f, Unital (->) () () f) => f a+conquer = contramap (const ()) conquered++-- | Combine two contravariant actions into one over their product.+--+-- ==== __Examples__+--+-- >>> getPredicate (divided (Predicate even) (Predicate (> 0))) (4 :: Int, 1 :: Int)+-- True+divided :: (Semigroupal (->) (,) (,) f) => f a -> f b -> f (a, b)+divided = curry combine++-- | The unit of 'divided'.+--+-- ==== __Examples__+--+-- >>> getPredicate conquered ()+-- True+conquered :: (Unital (->) () () f) => f ()+conquered = introduce ()++-- | Contravariantly map over a 'Monoidal' functor.+--+-- ==== __Examples__+--+-- >>> getPredicate (liftD (+ 1) (Predicate even)) (3 :: Int)+-- True+liftD :: (Contravariant f, Monoidal (->) (,) () (,) () f) => (a -> b) -> f b -> f a+liftD f = divide ((,) () . f) conquer++--------------------------------------------------------------------------------++-- | 'Data.Functor.Contravariant.Decidable.lose' specialized to a 'Unital' functor over 'Void'.+lose :: (Contravariant f, Unital (->) Void () f) => (a -> Void) -> f a+lose f = contramap f lost++-- | 'Data.Functor.Contravariant.Decidable.choose' specialized to a 'Semigroupal' functor over 'Either'.+--+-- ==== __Examples__+--+-- >>> getPredicate (choose (\n -> if even n then Left n else Right n) (Predicate (> 0)) (Predicate (< 0))) (4 :: Int)+-- True+choose :: (Contravariant f, Semigroupal (->) Either (,) f) => (c -> Either a b) -> f a -> f b -> f c+choose f fa fb = contramap f $ combine (fa, fb)++-- | Combine two contravariant actions into one over their sum.+--+-- ==== __Examples__+--+-- >>> getPredicate (chosen (Predicate even) (Predicate (> 0))) (Left 4 :: Either Int Int)+-- True+chosen :: (Contravariant f, Semigroupal (->) Either (,) f) => f b -> f c -> f (Either b c)+chosen = curry combine++-- | The unit of 'chosen'.+--+-- ==== __Examples__+--+-- >>> lost :: Maybe Void+-- Nothing+lost :: (Unital (->) Void () f) => f Void+lost = introduce ()++--------------------------------------------------------------------------------++-- | Pull a choice out of a functor.+--+-- ==== __Examples__+--+-- >>> decide (Identity (Left 5) :: Identity (Either Int Int))+-- Left (Identity 5)+decide :: (Functor f, Semigroupal Op Either Either f) => f (Either a b) -> Either (f a) (f b)+decide = getOp combine++-- | Branch on a choice, applying the matching function.+--+-- ==== __Examples__+--+-- >>> branch (Identity (Left 5) :: Identity (Either Int Int)) (Identity negate) (Identity id)+-- Identity (-5)+branch :: (Functor f, Semigroupal Op Either Either f, Semigroupal (->) (,) (,) f) => f (Either a b) -> f (a -> c) -> f (b -> c) -> f c+branch fab fac fbc =+  case decide fab of+    Left fa -> (\(a, f) -> f a) <$> combine (fa, fac)+    Right fb -> (\(b, f) -> f b) <$> combine (fb, fbc)++-- | Apply the function only when the value is a 'Left'.+--+-- ==== __Examples__+--+-- >>> select (Identity (Left 5) :: Identity (Either Int Int)) (Identity negate)+-- Identity (-5)+select :: (Functor f, Semigroupal Op Either Either f, Monoidal (->) (,) () (,) () f) => f (Either a b) -> f (a -> b) -> f b+select fa ff = branch fa ff (id <$ introduce @(->) @() ())

@@ -0,0 +1,414 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}++-- | Rank-2 monoidal functors: the analogue of "Data.Functor.Monoidal" one level+-- up, for higher-kinded data @b :: (Type -> Type) -> Type@.+--+-- A rank-2 functor is a functor \(B : [\mathcal{Hask}, \mathcal{Hask}] \to \mathcal{Hask}\)+-- from the functor category to @Hask@; @b f@ reinterprets each field of the+-- record @b@ through @f@. "Kindly.Rank2" already supplies the functorial action+-- (@'Kindly.bmap1' :: (forall x. f x -> g x) -> b f -> b g@). This module adds the+-- /monoidal/ structure on top of it, the same way "Data.Functor.Monoidal" adds+-- 'Data.Functor.Monoidal.combine' \/ 'Data.Functor.Monoidal.introduce' on top of+-- an ordinary 'Functor'.+--+-- The classes keep the same parameter shape as their rank-1 siblings, only+-- lifted a kind: the domain tensor @tC@ now acts on functors while the codomain+-- tensor @tD@ still acts on @Hask@. A product-shaped record is monoidal at three+-- instantiations, all derivable from the record's 'GHC.Generics' structure:+--+-- * __Covariant product__, @'Monoidal' (->) 'Product' 'Data.Proxy.Proxy' (,) () b@.+--   This is @barbies@' @ApplicativeB@: 'combine' zips two records field-wise into+--   'Data.Functor.Product.Pair's (@bprod@) and 'introduce' fills every field with+--   'Data.Proxy.Proxy' (@bpure Proxy@).+--+-- * __Coproduct__, @'Monoidal' (->) 'Sum' V1 'Either' 'Data.Void.Void' b@. 'combine'+--   injects a whole record of @f@ or a whole record of @g@ into a record of+--   @'Sum' f g@, all on one side (@'gcombineSum'@). 'introduce' is+--   'Data.Void.absurd'.+--+-- * __These__, @'Monoidal' (->) 'These1' V1 'These' 'Data.Void.Void' b@. 'combine'+--   follows the outer 'These'. A record of @f@ becomes all-'This1', a record of+--   @g@ all-'That1', and a pair of records a field-wise 'These1'+--   (@'gcombineThese'@). 'introduce' is 'Data.Void.absurd'.+--+-- * __Oplax product__ (the @'Op'@ dual of the first), @'Monoidal' 'Op' 'Product' 'Data.Proxy.Proxy' (,) () b@.+--   'combine' unzips a record of 'Data.Functor.Product.Pair's back into two+--   records (@'gsplitProduct'@). 'introduce' is @'Op' ('const' ())@.+--+-- The coproduct and These have no oplax dual here. A record of independent+-- @'Sum' f g@ or @'These1' f g@ fields picks per field, so there is no single+-- @'Either' (b f) (b g)@ or @'These' (b f) (b g)@ to project back to. The+-- @Divisible@ \/ @Decidable@-style contravariant-functor duals need @f@ in+-- negative position, which is not the @f a@ field shape the generic machinery+-- walks. Neither is provided.+--+-- The generic derivation covers records whose fields all have the shape @f a@.+-- Sums and nested HKD fields are not supported, matching+-- "Data.Functor.Rank2.Traversable".+module Data.Functor.Rank2.Monoidal+  ( -- * Semigroupal+    Semigroupal (..),++    -- * Unital+    Unital (..),++    -- * Monoidal+    Monoidal,++    -- * Generic derivation helpers+    gcombineProduct,+    gsplitProduct,+    gcombineSum,+    gcombineThese,+  )+where++--------------------------------------------------------------------------------++import Data.Either (Either (..), either)+import Data.Function ((.))+import Data.Functor.Product (Product (..))+import Data.Functor.Sum (Sum (..))+import Data.Functor.These (These1 (..))+import Data.Kind (Constraint, Type)+import Data.Proxy (Proxy (..))+import Data.These (These (..), these)+#if MIN_VERSION_base(4,17,0)+-- On GHC 9.4+ (@base >= 4.17@) @~@ is an ordinary type operator rather than+-- built-in syntax, so under @NoImplicitPrelude@ it must be brought into scope.+-- Earlier GHCs still treat @~@ as built-in syntax and do not export it.+import Data.Type.Equality (type (~))+#endif+import GHC.Generics (Generic (..), K1 (..), M1 (..), U1 (..), type (:*:) (..))++--------------------------------------------------------------------------------++-- $setup+-- >>> :set -XDeriveGeneric -XStandaloneDeriving -XFlexibleContexts -XMultiParamTypeClasses -XTypeApplications+-- >>> import Prelude+-- >>> import GHC.Generics (Generic)+-- >>> import Data.Functor.Product (Product (..))+-- >>> import Data.Functor.Sum (Sum (..))+-- >>> import Data.Functor.These (These1 (..))+-- >>> import Data.Proxy (Proxy (..))+-- >>> import Data.These (These (..))+-- >>> :{+-- data Rec f = Rec {rFst :: f Int, rSnd :: f Bool} deriving Generic+-- deriving instance (Show (f Int), Show (f Bool)) => Show (Rec f)+-- instance Semigroupal (->) Product (,) Rec+-- instance Unital (->) Proxy () Rec+-- instance Monoidal (->) Product Proxy (,) () Rec+-- instance Semigroupal (->) Sum Either Rec where combine = gcombineSum+-- instance Semigroupal (->) These1 These Rec where combine = gcombineThese+-- :}++--------------------------------------------------------------------------------++-- | The rank-2 analogue of 'Data.Functor.Monoidal.Semigroupal'. Given a+-- monoidal structure \(\otimes\) on the functor category and \(\bullet\) on+-- @Hask@, a rank-2 functor @b@ is 'Semigroupal' if it carries a natural+-- transformation \(\phi_{f,g} : b\ f \bullet b\ g \to b\ (f \otimes g)\), which+-- we call 'combine'.+--+-- The parameters mirror the rank-1 class one kind up:+--+-- * @cat@ is the codomain category (@Hask@, or 'Op' for the oplax duals).+-- * @tC@ is the domain tensor, acting on functors (e.g. 'Product', 'Sum').+-- * @tD@ is the codomain tensor, acting on @Hask@ (e.g. @(,)@, 'Either').+-- * @b@ is the higher-kinded record.+--+-- The empty-instance default derives the covariant 'Product' instantiation. For+-- the coproduct and oplax-product instantiations, supply @'combine'@ from the+-- exported generic helpers (see 'gcombineSum' and 'gsplitProduct').+type Semigroupal ::+  (Type -> Type -> Type) ->+  ((Type -> Type) -> (Type -> Type) -> (Type -> Type)) ->+  (Type -> Type -> Type) ->+  ((Type -> Type) -> Type) ->+  Constraint+class Semigroupal cat tC tD b where+  -- | ==== __Examples__+  --+  -- Zip two records field-wise (the covariant 'Product' instantiation):+  --+  -- >>> combine @(->) @Product @(,) (Rec (Just 1) (Just True), Rec [10, 20] [False])+  -- Rec {rFst = Pair (Just 1) [10,20], rSnd = Pair (Just True) [False]}+  --+  -- Inject a whole record onto one side of a 'Sum' (the coproduct instantiation):+  --+  -- >>> combine @(->) @Sum @Either (Left (Rec (Just 1) (Just True)) :: Either (Rec Maybe) (Rec []))+  -- Rec {rFst = InL (Just 1), rSnd = InL (Just True)}+  --+  -- Merge two records field-wise through a 'These' (the These instantiation):+  --+  -- >>> combine @(->) @These1 @These (These (Rec (Just 1) (Just True)) (Rec [10] [False]) :: These (Rec Maybe) (Rec []))+  -- Rec {rFst = These1 (Just 1) [10], rSnd = These1 (Just True) [False]}+  combine :: forall f g. cat (tD (b f) (b g)) (b (tC f g))+  default combine ::+    forall f g.+    ( cat ~ (->),+      tC ~ Product,+      tD ~ (,),+      Generic (b f),+      Generic (b g),+      Generic (b (Product f g)),+      GSemigroupal (Rep (b f)) (Rep (b g)) (Rep (b (Product f g)))+    ) =>+    cat (tD (b f) (b g)) (b (tC f g))+  combine = gcombineProduct++--------------------------------------------------------------------------------++-- | The rank-2 analogue of 'Data.Functor.Monoidal.Unital'. A rank-2 functor+-- @b@ is 'Unital' if it carries a morphism from the codomain unit to @b@ at the+-- domain unit, which we call 'introduce'.+--+-- * @cat@ is the codomain category (@Hask@, or 'Op' for the oplax duals).+-- * @iC@ is the domain unit, a functor (the unit of @tC@; 'Proxy' for 'Product',+--   @V1@ for 'Sum').+-- * @iD@ is the codomain unit (the unit of @tD@; @()@ for @(,)@, 'Data.Void.Void'+--   for 'Either').+-- * @b@ is the higher-kinded record.+--+-- The empty-instance default derives the covariant 'Proxy' unit. The coproduct+-- unit is @'introduce' = 'Data.Void.absurd'@ and the oplax-product unit is+-- @'introduce' = 'Op' ('const' ())@. Both are trivial enough to write inline.+type Unital ::+  (Type -> Type -> Type) ->+  (Type -> Type) ->+  Type ->+  ((Type -> Type) -> Type) ->+  Constraint+class Unital cat iC iD b where+  -- | ==== __Examples__+  --+  -- >>> introduce @(->) @Proxy @() @Rec ()+  -- Rec {rFst = Proxy, rSnd = Proxy}+  introduce :: cat iD (b iC)+  default introduce ::+    ( cat ~ (->),+      iC ~ Proxy,+      iD ~ (),+      Generic (b Proxy),+      GUnital (Rep (b Proxy))+    ) =>+    cat iD (b iC)+  introduce () = to gintroduce++--------------------------------------------------------------------------------++-- | The rank-2 analogue of 'Data.Functor.Monoidal.Monoidal'. A rank-2 functor+-- that is both 'Semigroupal' and 'Unital', preserving the monoidal structure+-- between the functor category and @Hask@. At+-- @'Monoidal' (->) 'Product' 'Proxy' (,) () b@ this is @barbies@' @ApplicativeB@.+type Monoidal ::+  (Type -> Type -> Type) ->+  ((Type -> Type) -> (Type -> Type) -> (Type -> Type)) ->+  (Type -> Type) ->+  (Type -> Type -> Type) ->+  Type ->+  ((Type -> Type) -> Type) ->+  Constraint+class+  ( Semigroupal cat tC tD b,+    Unital cat iC iD b+  ) =>+  Monoidal cat tC iC tD iD b++--------------------------------------------------------------------------------+-- Generic derivation helpers.++-- | Generic covariant product 'combine': zip two records field-wise into+-- 'Data.Functor.Product.Pair's. This is the default for+-- @'Semigroupal' (->) 'Product' (,)@.+--+-- ==== __Examples__+--+-- >>> gcombineProduct (Rec (Just 1) (Just True), Rec [10] [False])+-- Rec {rFst = Pair (Just 1) [10], rSnd = Pair (Just True) [False]}+gcombineProduct ::+  ( Generic (b f),+    Generic (b g),+    Generic (b (Product f g)),+    GSemigroupal (Rep (b f)) (Rep (b g)) (Rep (b (Product f g)))+  ) =>+  (b f, b g) ->+  b (Product f g)+gcombineProduct (bf, bg) = to (gcombine (from bf, from bg))++-- | Generic oplax product 'combine': unzip a record of+-- 'Data.Functor.Product.Pair's back into two records. Wrap in 'Op' for+-- @'Semigroupal' 'Op' 'Product' (,)@: @combine = 'Op' 'gsplitProduct'@.+--+-- ==== __Examples__+--+-- >>> gsplitProduct (Rec (Pair (Just 1) [10]) (Pair (Just True) [False]))+-- (Rec {rFst = Just 1, rSnd = Just True},Rec {rFst = [10], rSnd = [False]})+gsplitProduct ::+  ( Generic (b f),+    Generic (b g),+    Generic (b (Product f g)),+    GSemigroupal (Rep (b f)) (Rep (b g)) (Rep (b (Product f g)))+  ) =>+  b (Product f g) ->+  (b f, b g)+gsplitProduct bfg = case gsplit (from bfg) of (l, r) -> (to l, to r)++-- | Generic coproduct 'combine': inject a whole record of @f@ or a whole record+-- of @g@ into a record of @'Sum' f g@, all on one side. This is @combine@ for+-- @'Semigroupal' (->) 'Sum' 'Either'@.+--+-- ==== __Examples__+--+-- >>> gcombineSum (Right (Rec [10] [False]) :: Either (Rec Maybe) (Rec []))+-- Rec {rFst = InR [10], rSnd = InR [False]}+gcombineSum ::+  ( Generic (b f),+    Generic (b g),+    Generic (b (Sum f g)),+    GCoproduct (Rep (b f)) (Rep (b g)) (Rep (b (Sum f g)))+  ) =>+  Either (b f) (b g) ->+  b (Sum f g)+gcombineSum = either (to . ginjectL . from) (to . ginjectR . from)++-- | Generic These 'combine': following the outer 'These', send a record of @f@+-- to an all-'This1' record, a record of @g@ to an all-'That1' record, or a pair+-- of records to a field-wise 'These1' record of @'These1' f g@. This is+-- @combine@ for @'Semigroupal' (->) 'These1' 'These'@.+--+-- ==== __Examples__+--+-- >>> gcombineThese (This (Rec (Just 1) (Just True)) :: These (Rec Maybe) (Rec []))+-- Rec {rFst = This1 (Just 1), rSnd = This1 (Just True)}+--+-- >>> gcombineThese (That (Rec [10] [False]) :: These (Rec Maybe) (Rec []))+-- Rec {rFst = That1 [10], rSnd = That1 [False]}+--+-- >>> gcombineThese (These (Rec (Just 1) (Just True)) (Rec [10] [False]) :: These (Rec Maybe) (Rec []))+-- Rec {rFst = These1 (Just 1) [10], rSnd = These1 (Just True) [False]}+gcombineThese ::+  ( Generic (b f),+    Generic (b g),+    Generic (b (These1 f g)),+    GThese (Rep (b f)) (Rep (b g)) (Rep (b (These1 f g)))+  ) =>+  These (b f) (b g) ->+  b (These1 f g)+gcombineThese =+  these+    (to . gthis . from)+    (to . gthat . from)+    (\bf bg -> to (gthese (from bf) (from bg)))++--------------------------------------------------------------------------------+-- Generic workers for the product tensor (zip and its inverse split).++-- | Generic worker for the 'Product' tensor. The three representations are+-- @'Rep' (b f)@, @'Rep' (b g)@, and @'Rep' (b (Product f g))@. They are+-- structurally identical up to the field interpretation, which 'gcombine' fuses+-- into a 'Data.Functor.Product.Pair' and 'gsplit' takes apart.+type GSemigroupal :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint+class GSemigroupal repf repg reph where+  gcombine :: (repf x, repg x) -> reph x+  gsplit :: reph x -> (repf x, repg x)++instance (GSemigroupal repf repg reph) => GSemigroupal (M1 i c repf) (M1 i c repg) (M1 i c reph) where+  gcombine (M1 a, M1 b) = M1 (gcombine (a, b))+  gsplit (M1 a) = case gsplit a of (l, r) -> (M1 l, M1 r)++instance (GSemigroupal f1 g1 h1, GSemigroupal f2 g2 h2) => GSemigroupal (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where+  gcombine (a1 :*: a2, b1 :*: b2) = gcombine (a1, b1) :*: gcombine (a2, b2)+  gsplit (a1 :*: a2) = case (gsplit a1, gsplit a2) of ((l1, r1), (l2, r2)) -> (l1 :*: l2, r1 :*: r2)++instance GSemigroupal (K1 i (p a)) (K1 i (q a)) (K1 i (Product p q a)) where+  gcombine (K1 pa, K1 qa) = K1 (Pair pa qa)+  gsplit (K1 (Pair pa qa)) = (K1 pa, K1 qa)++instance GSemigroupal U1 U1 U1 where+  gcombine (U1, U1) = U1+  gsplit U1 = (U1, U1)++--------------------------------------------------------------------------------+-- Generic worker for the coproduct tensor (all-left \/ all-right injection).++-- | Generic worker for the 'Sum' tensor. 'ginjectL' sends a record of @f@ to a+-- record of @'Sum' f g@ with every field 'InL'; 'ginjectR' does the same with+-- 'InR'.+type GCoproduct :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint+class GCoproduct repf repg reph | reph -> repf repg where+  ginjectL :: repf x -> reph x+  ginjectR :: repg x -> reph x++instance (GCoproduct repf repg reph) => GCoproduct (M1 i c repf) (M1 i c repg) (M1 i c reph) where+  ginjectL (M1 a) = M1 (ginjectL a)+  ginjectR (M1 a) = M1 (ginjectR a)++instance (GCoproduct f1 g1 h1, GCoproduct f2 g2 h2) => GCoproduct (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where+  ginjectL (a1 :*: a2) = ginjectL a1 :*: ginjectL a2+  ginjectR (a1 :*: a2) = ginjectR a1 :*: ginjectR a2++instance GCoproduct (K1 i (f a)) (K1 i (g a)) (K1 i (Sum f g a)) where+  ginjectL (K1 fa) = K1 (InL fa)+  ginjectR (K1 ga) = K1 (InR ga)++instance GCoproduct U1 U1 U1 where+  ginjectL U1 = U1+  ginjectR U1 = U1++--------------------------------------------------------------------------------+-- Generic worker for the These tensor (per-side injection following an outer These).++-- | Generic worker for the 'These1' tensor. 'gthis' sends a record of @f@ to an+-- all-'This1' record, 'gthat' a record of @g@ to an all-'That1' record, and+-- 'gthese' a pair of records to a field-wise 'These1' record.+type GThese :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint+class GThese repf repg reph | reph -> repf repg where+  gthis :: repf x -> reph x+  gthat :: repg x -> reph x+  gthese :: repf x -> repg x -> reph x++instance (GThese repf repg reph) => GThese (M1 i c repf) (M1 i c repg) (M1 i c reph) where+  gthis (M1 a) = M1 (gthis a)+  gthat (M1 a) = M1 (gthat a)+  gthese (M1 a) (M1 b) = M1 (gthese a b)++instance (GThese f1 g1 h1, GThese f2 g2 h2) => GThese (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) where+  gthis (a1 :*: a2) = gthis a1 :*: gthis a2+  gthat (a1 :*: a2) = gthat a1 :*: gthat a2+  gthese (a1 :*: a2) (b1 :*: b2) = gthese a1 b1 :*: gthese a2 b2++instance GThese (K1 i (f a)) (K1 i (g a)) (K1 i (These1 f g a)) where+  gthis (K1 fa) = K1 (This1 fa)+  gthat (K1 ga) = K1 (That1 ga)+  gthese (K1 fa) (K1 ga) = K1 (These1 fa ga)++instance GThese U1 U1 U1 where+  gthis U1 = U1+  gthat U1 = U1+  gthese U1 U1 = U1++--------------------------------------------------------------------------------+-- Generic worker for the unit (fill every field with the domain unit).++-- | Generic worker for 'introduce' at the covariant 'Proxy' unit: fills every+-- field of @'Rep' (b Proxy)@ with 'Proxy'.+type GUnital :: (Type -> Type) -> Constraint+class GUnital rep where+  gintroduce :: rep x++instance (GUnital rep) => GUnital (M1 i c rep) where+  gintroduce = M1 gintroduce++instance (GUnital f, GUnital g) => GUnital (f :*: g) where+  gintroduce = gintroduce :*: gintroduce++instance GUnital (K1 i (Proxy a)) where+  gintroduce = K1 Proxy++instance GUnital U1 where+  gintroduce = U1