diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/examples/co-log/Main.hs b/examples/co-log/Main.hs --- a/examples/co-log/Main.hs +++ b/examples/co-log/Main.hs @@ -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 diff --git a/laws/Control/Category/Cartesian/Laws.hs b/laws/Control/Category/Cartesian/Laws.hs new file mode 100644 --- /dev/null +++ b/laws/Control/Category/Cartesian/Laws.hs @@ -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) + ] diff --git a/laws/Control/Category/Laws/Internal.hs b/laws/Control/Category/Laws/Internal.hs new file mode 100644 --- /dev/null +++ b/laws/Control/Category/Laws/Internal.hs @@ -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 diff --git a/laws/Control/Category/Tensor/Laws.hs b/laws/Control/Category/Tensor/Laws.hs new file mode 100644 --- /dev/null +++ b/laws/Control/Category/Tensor/Laws.hs @@ -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))] diff --git a/laws/Data/Bifunctor/Monoidal/Laws.hs b/laws/Data/Bifunctor/Monoidal/Laws.hs new file mode 100644 --- /dev/null +++ b/laws/Data/Bifunctor/Monoidal/Laws.hs @@ -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 "") genP + y <- forAllWith (const "") genP + z <- forAllWith (const "") 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 "") genP + y <- forAllWith (const "") 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 "") 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 "") 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) + ) diff --git a/laws/Data/Functor/Monoidal/Laws.hs b/laws/Data/Functor/Monoidal/Laws.hs new file mode 100644 --- /dev/null +++ b/laws/Data/Functor/Monoidal/Laws.hs @@ -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 "") genF + y <- forAllWith (const "") genF + z <- forAllWith (const "") 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 "") genF + y <- forAllWith (const "") 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 "") 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 "") 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) + ) diff --git a/monoidal-functors.cabal b/monoidal-functors.cabal --- a/monoidal-functors.cabal +++ b/monoidal-functors.cabal @@ -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 diff --git a/src/Control/Category/Cartesian.hs b/src/Control/Category/Cartesian.hs --- a/src/Control/Category/Cartesian.hs +++ b/src/Control/Category/Cartesian.hs @@ -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 -- @@ -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 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 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 diff --git a/src/Control/Category/Tensor.hs b/src/Control/Category/Tensor.hs --- a/src/Control/Category/Tensor.hs +++ b/src/Control/Category/Tensor.hs @@ -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 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 diff --git a/src/Control/Category/Tensor/Expr.hs b/src/Control/Category/Tensor/Expr.hs --- a/src/Control/Category/Tensor/Expr.hs +++ b/src/Control/Category/Tensor/Expr.hs @@ -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 diff --git a/src/Data/Bifunctor/BiInvariant.hs b/src/Data/Bifunctor/BiInvariant.hs --- a/src/Data/Bifunctor/BiInvariant.hs +++ b/src/Data/Bifunctor/BiInvariant.hs @@ -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) diff --git a/src/Data/Bifunctor/Module.hs b/src/Data/Bifunctor/Module.hs --- a/src/Data/Bifunctor/Module.hs +++ b/src/Data/Bifunctor/Module.hs @@ -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) diff --git a/src/Data/Bifunctor/Monoidal.hs b/src/Data/Bifunctor/Monoidal.hs --- a/src/Data/Bifunctor/Monoidal.hs +++ b/src/Data/Bifunctor/Monoidal.hs @@ -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) diff --git a/src/Data/Bifunctor/Monoidal/Specialized.hs b/src/Data/Bifunctor/Monoidal/Specialized.hs --- a/src/Data/Bifunctor/Monoidal/Specialized.hs +++ b/src/Data/Bifunctor/Monoidal/Specialized.hs @@ -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 diff --git a/src/Data/Bifunctor/Rank2/Monoidal.hs b/src/Data/Bifunctor/Rank2/Monoidal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Rank2/Monoidal.hs @@ -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 diff --git a/src/Data/Bifunctor/Rank2/Traversable.hs b/src/Data/Bifunctor/Rank2/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Bifunctor/Rank2/Traversable.hs @@ -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) diff --git a/src/Data/Functor/Invariant.hs b/src/Data/Functor/Invariant.hs --- a/src/Data/Functor/Invariant.hs +++ b/src/Data/Functor/Invariant.hs @@ -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 diff --git a/src/Data/Functor/Module.hs b/src/Data/Functor/Module.hs --- a/src/Data/Functor/Module.hs +++ b/src/Data/Functor/Module.hs @@ -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 diff --git a/src/Data/Functor/Monoidal.hs b/src/Data/Functor/Monoidal.hs --- a/src/Data/Functor/Monoidal.hs +++ b/src/Data/Functor/Monoidal.hs @@ -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) diff --git a/src/Data/Functor/Monoidal/Generic.hs b/src/Data/Functor/Monoidal/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Monoidal/Generic.hs @@ -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) diff --git a/src/Data/Functor/Monoidal/Specialized.hs b/src/Data/Functor/Monoidal/Specialized.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Monoidal/Specialized.hs @@ -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 @(->) @() ()) diff --git a/src/Data/Functor/Rank2/Monoidal.hs b/src/Data/Functor/Rank2/Monoidal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Rank2/Monoidal.hs @@ -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 diff --git a/src/Data/Functor/Rank2/Traversable.hs b/src/Data/Functor/Rank2/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Functor/Rank2/Traversable.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- | Rank-2 traversal for higher-kinded data interpreted by a functor: the +-- analogue of "Data.Traversable" one level up. Generalizes @barbies@' +-- @TraversableB@ across the variance of the interpretation functor, so it +-- covers both covariant (@Applicative@) and contravariant (@Divisible@) +-- interpretations. +module Data.Functor.Rank2.Traversable + ( Traversable (..), + ) +where + +-------------------------------------------------------------------------------- + +import Control.Monad.Identity (Identity (..)) +import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..)) +import Data.Isomorphism (Iso (..)) +import Data.Kind (Constraint, Type) +import GHC.Generics +import Kindly qualified +import Prelude hiding (Traversable (..)) + +-------------------------------------------------------------------------------- + +-- | Higher-kinded data that distributes over any functor 'Monoidal' with +-- respect to tupling. The interpretation @f@ may have either variance, +-- selected by @cat@. At a covariant functor (@cat ~ (->)@) this is the +-- monoidal presentation of @Applicative@, as in @barbies@. At a contravariant +-- functor (@cat ~ Op@) it is @Divisible@, folding a record of @f@-consumers +-- into one consumer of the whole record. +-- +-- The generic default covers records whose fields all have the shape @f a@. +-- Sums and nested HKD fields are not supported. +class Traversable hkd where + -- | Pull the interpretation functor out of the record. + sequence :: forall cat f. (Kindly.Functor cat f, Kindly.LiftIso cat, Monoidal (->) (,) () (,) () f) => hkd f -> f (hkd Identity) + default sequence :: forall cat p. (Kindly.Functor cat p, Kindly.LiftIso cat, Monoidal (->) (,) () (,) () p, Generic (hkd p), Generic (hkd Identity), GTraversable p (Rep (hkd p)) (Rep (hkd Identity))) => hkd p -> p (hkd Identity) + sequence = Kindly.mapIso (Iso to from) . gsequence @p @(Rep (hkd p)) @(Rep (hkd Identity)) . from + +type GTraversable :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint +class GTraversable f g h where + gsequence :: g x -> f (h x) + +instance (Kindly.Functor cat f, Kindly.LiftIso cat, GTraversable f g h) => GTraversable f (M1 _1 _2 g) (M1 _1 _2 h) where + gsequence :: M1 _1 _2 g x -> f (M1 _1 _2 h x) + gsequence (M1 f) = Kindly.mapIso (Iso M1 unM1) $ gsequence @f @g @h f + +instance (Kindly.Functor cat f, Kindly.LiftIso cat) => GTraversable f (K1 _1 (f a)) (K1 _1 (Identity a)) where + gsequence :: K1 _1 (f a) x -> f (K1 _1 (Identity a) x) + gsequence (K1 f) = Kindly.mapIso (Iso (K1 . Identity) (runIdentity . unK1)) f + +instance (Kindly.Functor cat f, Kindly.LiftIso cat, Monoidal (->) (,) () (,) () f) => GTraversable f U1 U1 where + gsequence :: U1 x -> f (U1 x) + gsequence U1 = Kindly.mapIso (Iso (const U1) (const ())) $ introduce @_ @() () + +instance (Kindly.Functor cat f, Kindly.LiftIso cat, Monoidal (->) (,) () (,) () f, GTraversable f g1 h1, GTraversable f g2 h2) => GTraversable f (g1 :*: g2) (h1 :*: h2) where + gsequence :: (:*:) g1 g2 x -> f ((:*:) h1 h2 x) + gsequence (hkd1 :*: hkd2) = Kindly.mapIso (Iso (uncurry (:*:)) (\(x :*: y) -> (x, y))) $ combine @_ @(,) (gsequence hkd1, gsequence hkd2) diff --git a/src/Data/Trifunctor/Module.hs b/src/Data/Trifunctor/Module.hs --- a/src/Data/Trifunctor/Module.hs +++ b/src/Data/Trifunctor/Module.hs @@ -12,14 +12,14 @@ -------------------------------------------------------------------------------- -class LeftModule cat t1 t2 t3 f where - lstrength :: cat (f a b c) (f (t1 a x) (t2 b x) (t3 c x)) +class LeftModule cat tC1 tC2 tC3 f where + lstrength :: cat (f a b c) (f (tC1 a x) (tC2 b x) (tC3 c x)) -------------------------------------------------------------------------------- -class RightModule cat t1 t2 t3 f where - rstrength :: cat (f a b c) (f (t1 x a) (t2 x b) (t3 x c)) +class RightModule cat tC1 tC2 tC3 f where + rstrength :: cat (f a b c) (f (tC1 x a) (tC2 x b) (tC3 x c)) -------------------------------------------------------------------------------- -class (LeftModule cat t1 t2 t3 f, RightModule cat t1 t2 t3 f) => Bimodule cat t1 t2 t3 f +class (LeftModule cat tC1 tC2 tC3 f, RightModule cat tC1 tC2 tC3 f) => Bimodule cat tC1 tC2 tC3 f diff --git a/src/Data/Trifunctor/Monoidal.hs b/src/Data/Trifunctor/Monoidal.hs --- a/src/Data/Trifunctor/Monoidal.hs +++ b/src/Data/Trifunctor/Monoidal.hs @@ -1,6 +1,34 @@ module Data.Trifunctor.Monoidal ( -- * Semigroupal Semigroupal (..), + (|???|), + (|***|), + (|**+|), + (|**&|), + (|*+*|), + (|*++|), + (|*+&|), + (|*&*|), + (|*&+|), + (|*&&|), + (|+**|), + (|+*+|), + (|+*&|), + (|++*|), + (|+++|), + (|++&|), + (|+&*|), + (|+&+|), + (|+&&|), + (|&**|), + (|&*+|), + (|&*&|), + (|&+*|), + (|&++|), + (|&+&|), + (|&&*|), + (|&&+|), + (|&&&|), -- * Unital Unital (..), @@ -13,11 +41,13 @@ -------------------------------------------------------------------------------- import Control.Category.Tensor (Associative, Tensor) +import Data.These (These) +import Prelude (Either, curry) -------------------------------------------------------------------------------- -- | 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} \times \mathcal{C_3} \to \mathcal{D}\) is 'Semigroupal' if it supports a +-- A trifunctor \(F : \mathcal{C_1} \times \mathcal{C_2} \times \mathcal{C_3} \to \mathcal{D}\) is 'Semigroupal' if it supports a -- natural transformation \(\phi_{ABC,XYZ} : F\ A\ B\ C \bullet F\ X\ Y\ Z \to F\ (A \otimes X)\ (B \otimes Y)\ (C \otimes Z)\), which we call 'combine'. -- -- === Laws @@ -39,30 +69,170 @@ -- 'combine' 'Control.Category..' 'Control.Category.Tensor.grmap' 'Control.Category.Tensor.combine' 'Control.Category..' 'Control.Category.Tensor.bwd' 'Control.Category.Tensor.assoc' ≡ 'Data.Functor.fmap' ('Control.Category.Tensor.bwd' 'Control.Category.Tensor.assoc') 'Control.Category..' 'combine' 'Control.Category..' 'Control.Category.Tensor.glmap' 'combine' -- @ class - ( Associative cat t1, - Associative cat t2, - Associative cat t3, - Associative cat to + ( Associative cat tC1, + Associative cat tC2, + Associative cat tC3, + Associative cat tD ) => - Semigroupal cat t1 t2 t3 to f + Semigroupal cat tC1 tC2 tC3 tD f where -- | A natural transformation \(\phi_{ABC,XYZ} : F\ A\ B\ C \bullet F\ X\ Y\ Z \to F\ (A \otimes X)\ (B \otimes Y) (C \otimes Z)\). - combine :: to (f x y z) (f x' y' z') `cat` f (t1 x x') (t2 y y') (t3 z z') + combine :: tD (f x y z) (f x' y' z') `cat` f (tC1 x x') (tC2 y y') (tC3 z z') +infixr 9 |???| + +(|???|) :: (Semigroupal (->) tC1 tC2 tC3 (,) p) => p a b c -> p a' b' c' -> p (a `tC1` a') (b `tC2` b') (c `tC3` c') +(|???|) = curry combine + +infixr 9 |***| + +(|***|) :: (Semigroupal (->) (,) (,) (,) (,) p) => p a b c -> p a' b' c' -> p (a, a') (b, b') (c, c') +(|***|) = curry combine + +infixr 9 |**+| + +(|**+|) :: (Semigroupal (->) (,) (,) Either (,) p) => p a b c -> p a' b' c' -> p (a, a') (b, b') (Either c c') +(|**+|) = curry combine + +infixr 9 |**&| + +(|**&|) :: (Semigroupal (->) (,) (,) These (,) p) => p a b c -> p a' b' c' -> p (a, a') (b, b') (These c c') +(|**&|) = curry combine + +infixr 9 |*+*| + +(|*+*|) :: (Semigroupal (->) (,) Either (,) (,) p) => p a b c -> p a' b' c' -> p (a, a') (Either b b') (c, c') +(|*+*|) = curry combine + +infixr 9 |*++| + +(|*++|) :: (Semigroupal (->) (,) Either Either (,) p) => p a b c -> p a' b' c' -> p (a, a') (Either b b') (Either c c') +(|*++|) = curry combine + +infixr 9 |*+&| + +(|*+&|) :: (Semigroupal (->) (,) Either These (,) p) => p a b c -> p a' b' c' -> p (a, a') (Either b b') (These c c') +(|*+&|) = curry combine + +infixr 9 |*&*| + +(|*&*|) :: (Semigroupal (->) (,) These (,) (,) p) => p a b c -> p a' b' c' -> p (a, a') (These b b') (c, c') +(|*&*|) = curry combine + +infixr 9 |*&+| + +(|*&+|) :: (Semigroupal (->) (,) These Either (,) p) => p a b c -> p a' b' c' -> p (a, a') (These b b') (Either c c') +(|*&+|) = curry combine + +infixr 9 |*&&| + +(|*&&|) :: (Semigroupal (->) (,) These These (,) p) => p a b c -> p a' b' c' -> p (a, a') (These b b') (These c c') +(|*&&|) = curry combine + +infixr 9 |+**| + +(|+**|) :: (Semigroupal (->) Either (,) (,) (,) p) => p a b c -> p a' b' c' -> p (Either a a') (b, b') (c, c') +(|+**|) = curry combine + +infixr 9 |+*+| + +(|+*+|) :: (Semigroupal (->) Either (,) Either (,) p) => p a b c -> p a' b' c' -> p (Either a a') (b, b') (Either c c') +(|+*+|) = curry combine + +infixr 9 |+*&| + +(|+*&|) :: (Semigroupal (->) Either (,) These (,) p) => p a b c -> p a' b' c' -> p (Either a a') (b, b') (These c c') +(|+*&|) = curry combine + +infixr 9 |++*| + +(|++*|) :: (Semigroupal (->) Either Either (,) (,) p) => p a b c -> p a' b' c' -> p (Either a a') (Either b b') (c, c') +(|++*|) = curry combine + +infixr 9 |+++| + +(|+++|) :: (Semigroupal (->) Either Either Either (,) p) => p a b c -> p a' b' c' -> p (Either a a') (Either b b') (Either c c') +(|+++|) = curry combine + +infixr 9 |++&| + +(|++&|) :: (Semigroupal (->) Either Either These (,) p) => p a b c -> p a' b' c' -> p (Either a a') (Either b b') (These c c') +(|++&|) = curry combine + +infixr 9 |+&*| + +(|+&*|) :: (Semigroupal (->) Either These (,) (,) p) => p a b c -> p a' b' c' -> p (Either a a') (These b b') (c, c') +(|+&*|) = curry combine + +infixr 9 |+&+| + +(|+&+|) :: (Semigroupal (->) Either These Either (,) p) => p a b c -> p a' b' c' -> p (Either a a') (These b b') (Either c c') +(|+&+|) = curry combine + +infixr 9 |+&&| + +(|+&&|) :: (Semigroupal (->) Either These These (,) p) => p a b c -> p a' b' c' -> p (Either a a') (These b b') (These c c') +(|+&&|) = curry combine + +infixr 9 |&**| + +(|&**|) :: (Semigroupal (->) These (,) (,) (,) p) => p a b c -> p a' b' c' -> p (These a a') (b, b') (c, c') +(|&**|) = curry combine + +infixr 9 |&*+| + +(|&*+|) :: (Semigroupal (->) These (,) Either (,) p) => p a b c -> p a' b' c' -> p (These a a') (b, b') (Either c c') +(|&*+|) = curry combine + +infixr 9 |&*&| + +(|&*&|) :: (Semigroupal (->) These (,) These (,) p) => p a b c -> p a' b' c' -> p (These a a') (b, b') (These c c') +(|&*&|) = curry combine + +infixr 9 |&+*| + +(|&+*|) :: (Semigroupal (->) These Either (,) (,) p) => p a b c -> p a' b' c' -> p (These a a') (Either b b') (c, c') +(|&+*|) = curry combine + +infixr 9 |&++| + +(|&++|) :: (Semigroupal (->) These Either Either (,) p) => p a b c -> p a' b' c' -> p (These a a') (Either b b') (Either c c') +(|&++|) = curry combine + +infixr 9 |&+&| + +(|&+&|) :: (Semigroupal (->) These Either These (,) p) => p a b c -> p a' b' c' -> p (These a a') (Either b b') (These c c') +(|&+&|) = curry combine + +infixr 9 |&&*| + +(|&&*|) :: (Semigroupal (->) These These (,) (,) p) => p a b c -> p a' b' c' -> p (These a a') (These b b') (c, c') +(|&&*|) = curry combine + +infixr 9 |&&+| + +(|&&+|) :: (Semigroupal (->) These These Either (,) p) => p a b c -> p a' b' c' -> p (These a a') (These b b') (Either c c') +(|&&+|) = curry combine + +infixr 9 |&&&| + +(|&&&|) :: (Semigroupal (->) These These These (,) p) => p a b c -> p a' b' c' -> p (These a a') (These b b') (These c c') +(|&&&|) = 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} \times \mathcal{C_3} \to \mathcal{D}\) is 'Unital' if it supports a morphism +-- A trifunctor \(F : \mathcal{C_1} \times \mathcal{C_2} \times \mathcal{C_3} \to \mathcal{D}\) is 'Unital' if it supports a morphism -- \(\phi : I_{\mathcal{D}} \to F\ I_{\mathcal{C_1}}\ I_{\mathcal{C_2}}\ I_{\mathcal{C_3}}\), which we call 'introduce'. -class Unital cat i1 i2 i3 o f where +class Unital cat iC1 iC2 iC3 iD f where -- | @introduce@ maps from the identity in \(\mathcal{C_1} \times \mathcal{C_2} \times \mathcal{C_3}\) to the -- identity in \(\mathcal{D}\). - introduce :: o `cat` f i1 i2 i3 + introduce :: iD `cat` f iC1 iC2 iC3 -------------------------------------------------------------------------------- -- | 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} \times \mathcal{C_3} \to \mathcal{D}\) is 'Monoidal' if it maps between +-- A trifunctor \(F : \mathcal{C_1} \times \mathcal{C_2} \times \mathcal{C_3} \to \mathcal{D}\) is 'Monoidal' if it maps between -- \(\mathcal{C_1} \times \mathcal{C_2}\ \times \mathcal{C_3}\) and \(\mathcal{D}\) while preserving their monoidal structure. -- Eg., a homomorphism of monoidal categories. -- @@ -99,11 +269,11 @@ -- 'combine' 'Control.Category..' 'Control.Category.Tensor.glmap' 'introduce' ≡ 'Data.Functor.fmap' ('Control.Category.Tensor.bwd' 'Control.Category.Tensor.unitl') 'Control.Category..' 'Control.Category.Tensor.fwd' 'Control.Category.Tensor.unitl' -- @ class - ( Tensor cat t1 i1, - Tensor cat t2 i2, - Tensor cat t3 i3, - Tensor cat to io, - Semigroupal cat t1 t2 t3 to f, - Unital cat i1 i2 i3 io f + ( Tensor cat tC1 iC1, + Tensor cat tC2 iC2, + Tensor cat tC3 iC3, + Tensor cat tD iD, + Semigroupal cat tC1 tC2 tC3 tD f, + Unital cat iC1 iC2 iC3 iD f ) => - Monoidal cat t1 i1 t2 i2 t3 i3 to io f + Monoidal cat tC1 iC1 tC2 iC2 tC3 iC3 tD iD f diff --git a/src/Data/Trifunctor/Rank2/Traversable.hs b/src/Data/Trifunctor/Rank2/Traversable.hs new file mode 100644 --- /dev/null +++ b/src/Data/Trifunctor/Rank2/Traversable.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE StandaloneKindSignatures #-} + +-- | Rank-2 traversal for higher-kinded data interpreted by a trifunctor of any variance. +module Data.Trifunctor.Rank2.Traversable + ( Traversable (..), + First (..), + Second (..), + Third (..), + ) +where + +-------------------------------------------------------------------------------- + +import Control.Applicative +import Data.Bifunctor (Bifunctor (..)) +import Data.Functor.Contravariant (Contravariant (..)) +import Data.Isomorphism (Iso (..)) +import Data.Kind (Constraint, Type) +import Data.Trifunctor.Monoidal (Monoidal, Semigroupal (..), Unital (..)) +import GHC.Generics (Generic (..), Generic1, K1 (..), M1 (..), U1 (..), type (:*:) (..)) +import Kindly qualified +import Prelude hiding (Traversable) + +-------------------------------------------------------------------------------- + +-- | Higher-kinded data that distributes over any trifunctor 'Monoidal' with +-- respect to tupling, splitting each field @p a b c@ into its 'First', +-- 'Second', and 'Third' projections. +-- +-- The generic default covers records whose fields all have the shape +-- @p a b c@. Sums and nested HKD fields are not supported. +class Traversable hkd where + -- | Pull the interpretation trifunctor out of the record. + sequence :: forall cat1 cat2 cat3 p. (Kindly.Trifunctor cat1 cat2 cat3 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Kindly.LiftIso cat3, Monoidal (->) (,) () (,) () (,) () (,) () p) => hkd p -> p (hkd First) (hkd Second) (hkd Third) + default sequence :: + forall cat1 cat2 cat3 p. + ( Kindly.Trifunctor cat1 cat2 cat3 p, + Kindly.LiftIso cat1, + Kindly.LiftIso cat2, + Kindly.LiftIso cat3, + Monoidal (->) (,) () (,) () (,) () (,) () p, + Generic (hkd p), + Generic (hkd First), + Generic (hkd Second), + Generic (hkd Third), + GTraversable p (Rep (hkd p)) (Rep (hkd First)) (Rep (hkd Second)) (Rep (hkd Third)) + ) => + hkd p -> + p (hkd First) (hkd Second) (hkd Third) + sequence = Kindly.trimapIso (Iso to from) (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 -> Type) -> (Type -> Type) -> Constraint +class GTraversable p f g h i where + gsequence :: f x -> p (g x) (h x) (i x) + +instance (Kindly.Trifunctor cat1 cat2 cat3 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Kindly.LiftIso cat3, GTraversable p f g h i) => GTraversable p (M1 _1 _2 f) (M1 _1 _2 g) (M1 _1 _2 h) (M1 _1 _2 i) where + gsequence :: M1 _1 _2 f x -> p (M1 _1 _2 g x) (M1 _1 _2 h x) (M1 _1 _2 i x) + gsequence (M1 f) = Kindly.trimapIso (Iso M1 unM1) (Iso M1 unM1) (Iso M1 unM1) $ gsequence @p @f @g @h @i f + +instance (Kindly.Trifunctor cat1 cat2 cat3 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Kindly.LiftIso cat3) => GTraversable p (K1 _1 (p a b c)) (K1 _1 (First a b c)) (K1 _1 (Second a b c)) (K1 _1 (Third a b c)) where + gsequence :: K1 _1 (p a b c) x -> p (K1 _1 (First a b c) x) (K1 _1 (Second a b c) x) (K1 _1 (Third a b c) x) + gsequence (K1 f) = Kindly.trimapIso (Iso (K1 . First) (unFirst . unK1)) (Iso (K1 . Second) (unSecond . unK1)) (Iso (K1 . Third) (unThird . unK1)) f + +instance (Kindly.Trifunctor cat1 cat2 cat3 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Kindly.LiftIso cat3, Monoidal (->) (,) () (,) () (,) () (,) () p) => GTraversable p U1 U1 U1 U1 where + gsequence :: U1 x -> p (U1 x) (U1 x) (U1 x) + gsequence U1 = Kindly.trimapIso (Iso (const U1) (const ())) (Iso (const U1) (const ())) (Iso (const U1) (const ())) $ introduce @_ @() @() @() () + +instance + (Kindly.Trifunctor cat1 cat2 cat3 p, Kindly.LiftIso cat1, Kindly.LiftIso cat2, Kindly.LiftIso cat3, Monoidal (->) (,) () (,) () (,) () (,) () p, GTraversable p f1 g1 h1 j1, GTraversable p f2 g2 h2 j2) => + GTraversable p (f1 :*: f2) (g1 :*: g2) (h1 :*: h2) (j1 :*: j2) + where + gsequence :: (:*:) f1 f2 x -> p ((:*:) g1 g2 x) ((:*:) h1 h2 x) ((:*:) j1 j2 x) + gsequence (hkd1 :*: hkd2) = + let phkd1 = gsequence @p @f1 @g1 @h1 @j1 hkd1 + phkd2 = gsequence @p @f2 @g2 @h2 @j2 hkd2 + in Kindly.trimapIso (Iso (uncurry (:*:)) (\(x :*: y) -> (x, y))) (Iso (uncurry (:*:)) (\(x :*: y) -> (x, y))) (Iso (uncurry (:*:)) (\(x :*: y) -> (x, y))) $ combine @_ @(,) @(,) @(,) (phkd1, phkd2) + +-------------------------------------------------------------------------------- + +-- | Projects a field's first argument: @First x y z@ holds the @x@. +type First :: Type -> Type -> Type -> Type +newtype First x y z = 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 y) where + contramap :: (a' -> a) -> First x y a -> First x y a' + contramap _ (First x) = First x + +instance (Monoid x) => Applicative (First x y) where + pure :: a -> First x y a + pure _ = First mempty + + liftA2 :: (a -> b -> c) -> First x y a -> First x y b -> First x y c + liftA2 _ (First x) (First x') = First (x <> x') + +instance Bifunctor (First x) where + bimap :: (a -> b) -> (c -> d) -> First x a c -> First x b d + bimap _ _ (First x) = First x + +-------------------------------------------------------------------------------- + +-- | Projects a field's second argument: @Second x y z@ holds the @y@. +type Second :: Type -> Type -> Type -> Type +newtype Second x y z = Second {unSecond :: y} + deriving stock (Generic, Generic1, Functor) + deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid) + +instance (Monoid y) => Applicative (Second x y) where + pure :: a -> Second x y a + pure _ = Second mempty + + liftA2 :: (a -> b -> c) -> Second x y a -> Second x y b -> Second x y c + liftA2 _ (Second y) (Second y') = Second (y <> y') + +instance Bifunctor (Second x) where + bimap :: (a -> b) -> (c -> d) -> Second x a c -> Second x b d + bimap f _ (Second a) = Second $ f a + +-------------------------------------------------------------------------------- + +-- | Projects a field's third argument: @Third x y z@ holds the @z@. +type Third :: Type -> Type -> Type -> Type +newtype Third x y z = Third {unThird :: z} + deriving stock (Generic, Generic1, Functor) + deriving newtype (Bounded, Show, Read, Eq, Ord, Enum, Num, Integral, Real, Semigroup, Monoid) + +instance Applicative (Third x y) where + pure :: a -> Third x y a + pure = Third + + liftA2 :: (a -> b -> c) -> Third x y a -> Third x y b -> Third x y c + liftA2 f (Third y) (Third y') = Third (f y y') + +instance Bifunctor (Third x) where + bimap :: (a -> b) -> (c -> d) -> Third x a c -> Third x b d + bimap _ g (Third y) = Third (g y) diff --git a/test/Control/Category/CartesianSpec.hs b/test/Control/Category/CartesianSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Category/CartesianSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Self-test. Runs the exported "Control.Category.Cartesian.Laws" 'Laws' against +-- the instances the library ships for 'Semicartesian', 'Semicocartesian', +-- 'Cartesian', and 'Cocartesian'. +-- +-- The diagonal/codiagonal coassociativity laws are non-endomorphic, so they are +-- observed forward at @('->')@ only. The projection/inclusion unit laws are +-- endomorphic, so they are additionally checked at 'Op'. The 'Cartesian' and +-- 'Cocartesian' instances for 'Op' are the duals of the @('->')@ ones. +module Control.Category.CartesianSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Category.Cartesian.Laws + ( cartesianLaws, + cocartesianLaws, + semicartesianLaws, + semicocartesianLaws, + ) +import Control.Category.LawsSupport (genTEither, labeled, runFun, runOp) +import Data.Functor.Contravariant (Op) +import Data.Void (Void) +import Hedgehog (Group (..), checkSequential) +import Prelude + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = do + semicartesian <- + checkSequential $ + Group "Semicartesian laws" $ + labeled "(->) (,)" (semicartesianLaws @(->) @(,) runFun) + semicocartesian <- + checkSequential $ + Group "Semicocartesian laws" $ + labeled "(->) Either" (semicocartesianLaws @(->) @Either runFun genTEither) + cartesian <- + checkSequential $ + Group "Cartesian laws" $ + concat + [ labeled "(->) (,) ()" (cartesianLaws @(->) @(,) @() runFun), + labeled "Op Either Void" (cartesianLaws @Op @Either @Void runOp) + ] + cocartesian <- + checkSequential $ + Group "Cocartesian laws" $ + concat + [ labeled "(->) Either Void" (cocartesianLaws @(->) @Either @Void runFun), + labeled "Op (,) ()" (cocartesianLaws @Op @(,) @() runOp) + ] + pure (and [semicartesian, semicocartesian, cartesian, cocartesian]) diff --git a/test/Control/Category/LawsSupport.hs b/test/Control/Category/LawsSupport.hs new file mode 100644 --- /dev/null +++ b/test/Control/Category/LawsSupport.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Shared scaffolding for the "Control.Category.Tensor.Laws" and +-- "Control.Category.Cartesian.Laws" self-tests. Provides the extensional +-- observers for each category, the witness generators, and the 'labeled' splice +-- that folds a sublibrary 'Laws' into a hedgehog 'Group'. +module Control.Category.LawsSupport + ( -- * Observers + runFun, + runOp, + runIso, + runStarMaybe, + runKleisliMaybe, + + -- * Generators + genInt, + genBool, + genTPair, + genTEither, + genTThese, + + -- * Group assembly + labeled, + ) +where + +-------------------------------------------------------------------------------- + +import Control.Arrow (Kleisli (..)) +import Control.Category.Tensor (Iso (..)) +import Data.Functor.Contravariant (Op (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Profunctor (Star (..)) +import Data.String (fromString) +import Data.These (These (..)) +import Hedgehog (Gen, Property, PropertyName) +import Hedgehog.Classes (Laws (..)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Prelude + +-------------------------------------------------------------------------------- +-- Extensional observers. Run a morphism on an input to get a comparable result. + +runFun :: (a -> b) -> a -> Identity b +runFun f = Identity . f + +runOp :: Op a b -> b -> Identity a +runOp o = Identity . getOp o + +runIso :: Iso (->) a b -> a -> Identity b +runIso i = Identity . fwd i + +runStarMaybe :: Star Maybe a b -> a -> Maybe b +runStarMaybe = runStar + +runKleisliMaybe :: Kleisli Maybe a b -> a -> Maybe b +runKleisliMaybe = runKleisli + +-------------------------------------------------------------------------------- +-- Generators. The @genT*@ builders are rank-2, used to assemble the nested +-- witnesses the structure laws need. + +genInt :: Gen Int +genInt = Gen.int (Range.linear (-100) 100) + +genBool :: Gen Bool +genBool = Gen.bool + +genTPair :: Gen x -> Gen y -> Gen (x, y) +genTPair gx gy = (,) <$> gx <*> gy + +genTEither :: Gen x -> Gen y -> Gen (Either x y) +genTEither gx gy = Gen.choice [Left <$> gx, Right <$> gy] + +genTThese :: Gen x -> Gen y -> Gen (These x y) +genTThese gx gy = Gen.choice [This <$> gx, That <$> gy, These <$> gx <*> gy] + +-------------------------------------------------------------------------------- + +-- | Splice a sublibrary 'Laws' into the hedgehog 'Group', prefixing each of its +-- properties with the instance under test. +labeled :: String -> Laws -> [(PropertyName, Property)] +labeled prefix ls = [(fromString (prefix <> " " <> n), p) | (n, p) <- lawsProperties ls] diff --git a/test/Control/Category/TensorSpec.hs b/test/Control/Category/TensorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Control/Category/TensorSpec.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Run the exported "Control.Category.Tensor.Laws" 'Laws' against the +-- instances the library ships for 'GBifunctor', 'Iso', 'Associative', 'Tensor', +-- and 'Symmetric', over every category that carries them. The categories are +-- @('->')@, 'Op', @'Iso' ('->')@, and @'Star' 'Maybe'@ \/ @'Kleisli' 'Maybe'@. +module Control.Category.TensorSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Arrow (Kleisli (..)) +import Control.Category.LawsSupport + ( genBool, + genInt, + genTEither, + genTPair, + genTThese, + labeled, + runFun, + runIso, + runKleisliMaybe, + runOp, + runStarMaybe, + ) +import Control.Category.Tensor (GBifunctor, Iso (..)) +import Control.Category.Tensor.Laws + ( associativeLaws, + gbifunctorLaws, + isoLaws, + symmetricLaws, + tensorLaws, + ) +import Data.Functor.Contravariant (Op (..)) +import Data.Profunctor (Star (..)) +import Data.These (These (..)) +import Data.Void (Void) +import Hedgehog (Gen, Group (..), Property, PropertyName, checkSequential) +import Prelude + +-------------------------------------------------------------------------------- +-- Pre-built witnesses for the GBifunctor arrows. + +genPairInt :: Gen (Int, Int) +genPairInt = genTPair genInt genInt + +genEitherInt :: Gen (Either Int Int) +genEitherInt = genTEither genInt genInt + +genTheseInt :: Gen (These Int Int) +genTheseInt = genTThese genInt genInt + +-------------------------------------------------------------------------------- +-- Endo-arrows per tensor factor, one pair for each category with a GBifunctor +-- instance. The 'Maybe' arrows include a failing branch so the effect is +-- exercised. + +funLeft, funRight :: (Int -> Int, Int -> Int) +funLeft = ((+ 1), (* 2)) +funRight = (subtract 3, negate) + +opLeft, opRight :: (Op Int Int, Op Int Int) +opLeft = (Op (+ 1), Op (* 2)) +opRight = (Op (subtract 3), Op negate) + +isoLeft, isoRight :: (Iso (->) Int Int, Iso (->) Int Int) +isoLeft = (Iso (+ 1) (subtract 1), Iso (* 2) (`div` 2)) +isoRight = (Iso (subtract 3) (+ 3), Iso negate negate) + +starMaybeLeft, starMaybeRight :: (Star Maybe Int Int, Star Maybe Int Int) +starMaybeLeft = (Star (\x -> Just (x + 1)), Star (\x -> if even x then Just (x * 2) else Nothing)) +starMaybeRight = (Star (\x -> Just (x - 3)), Star (\x -> Just (negate x))) + +kleisliMaybeLeft, kleisliMaybeRight :: (Kleisli Maybe Int Int, Kleisli Maybe Int Int) +kleisliMaybeLeft = (Kleisli (\x -> Just (x + 1)), Kleisli (\x -> if even x then Just (x * 2) else Nothing)) +kleisliMaybeRight = (Kleisli (\x -> Just (x - 3)), Kleisli (\x -> Just (negate x))) + +-- | 'gbifunctorLaws' for one category at all three tensors. @run@ is rank-2 so +-- the single observer serves every tensor. The endo-arrow pair is reused across +-- tensors since every factor is 'Int'. +gbimapEveryTensor :: + forall cat obs. + ( GBifunctor cat cat cat (,), + GBifunctor cat cat cat Either, + GBifunctor cat cat cat These, + Eq (obs (Int, Int)), + Show (obs (Int, Int)), + Eq (obs (Either Int Int)), + Show (obs (Either Int Int)), + Eq (obs (These Int Int)), + Show (obs (These Int Int)) + ) => + String -> + (forall z. cat z z -> z -> obs z) -> + (cat Int Int, cat Int Int) -> + (cat Int Int, cat Int Int) -> + [(PropertyName, Property)] +gbimapEveryTensor lbl run l r = + labeled (lbl <> " (,)") (gbifunctorLaws run l r genPairInt) + <> labeled (lbl <> " Either") (gbifunctorLaws run l r genEitherInt) + <> labeled (lbl <> " These") (gbifunctorLaws run l r genTheseInt) + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = do + gbifunctor <- + checkSequential $ + Group "GBifunctor laws" $ + concat + [ gbimapEveryTensor "(->)" runFun funLeft funRight, + gbimapEveryTensor "Op" runOp opLeft opRight, + gbimapEveryTensor "Iso (->)" runIso isoLeft isoRight, + labeled "Star Maybe These" (gbifunctorLaws runStarMaybe starMaybeLeft starMaybeRight genTheseInt), + labeled "Kleisli Maybe These" (gbifunctorLaws runKleisliMaybe kleisliMaybeLeft kleisliMaybeRight genTheseInt) + ] + iso <- + checkSequential $ + Group "Iso laws" $ + concat + [ labeled "(->) succ/pred" (isoLaws runFun (Iso (+ 1) (subtract 1) :: Iso (->) Int Int) genInt genInt), + labeled "(->) not/not" (isoLaws runFun (Iso not not :: Iso (->) Bool Bool) genBool genBool) + ] + associative <- + checkSequential $ + Group "Associative laws" $ + concat + [ labeled "(->) (,)" (associativeLaws runFun genTPair), + labeled "(->) Either" (associativeLaws runFun genTEither), + labeled "(->) These" (associativeLaws runFun genTThese), + labeled "Op (,)" (associativeLaws runOp genTPair), + labeled "Op Either" (associativeLaws runOp genTEither), + labeled "Op These" (associativeLaws runOp genTThese), + labeled "Star Maybe These" (associativeLaws runStarMaybe genTThese), + labeled "Kleisli Maybe These" (associativeLaws runKleisliMaybe genTThese) + ] + tensor <- + checkSequential $ + Group "Tensor laws" $ + concat + [ labeled "(->) (,) ()" (tensorLaws runFun (genTPair (pure ()) genInt) (genTPair genInt (pure ()))), + labeled "(->) Either Void" (tensorLaws runFun (Right <$> genInt :: Gen (Either Void Int)) (Left <$> genInt :: Gen (Either Int Void))), + labeled "(->) These Void" (tensorLaws runFun (That <$> genInt :: Gen (These Void Int)) (This <$> genInt :: Gen (These Int Void))), + labeled "Op (,) ()" (tensorLaws runOp (genTPair (pure ()) genInt) (genTPair genInt (pure ()))), + labeled "Op Either Void" (tensorLaws runOp (Right <$> genInt :: Gen (Either Void Int)) (Left <$> genInt :: Gen (Either Int Void))), + labeled "Op These Void" (tensorLaws runOp (That <$> genInt :: Gen (These Void Int)) (This <$> genInt :: Gen (These Int Void))), + labeled "Star Maybe These Void" (tensorLaws runStarMaybe (That <$> genInt :: Gen (These Void Int)) (This <$> genInt :: Gen (These Int Void))), + labeled "Kleisli Maybe These Void" (tensorLaws runKleisliMaybe (That <$> genInt :: Gen (These Void Int)) (This <$> genInt :: Gen (These Int Void))) + ] + symmetric <- + checkSequential $ + Group "Symmetric laws" $ + concat + [ labeled "(->) (,)" (symmetricLaws runFun genTPair), + labeled "(->) Either" (symmetricLaws runFun genTEither), + labeled "(->) These" (symmetricLaws runFun genTThese), + labeled "Op (,)" (symmetricLaws runOp genTPair), + labeled "Op Either" (symmetricLaws runOp genTEither), + labeled "Op These" (symmetricLaws runOp genTThese), + labeled "Star Maybe These" (symmetricLaws runStarMaybe genTThese), + labeled "Kleisli Maybe These" (symmetricLaws runKleisliMaybe genTThese) + ] + pure (and [gbifunctor, iso, associative, tensor, symmetric]) diff --git a/test/Data/Bifunctor/Monoidal/LawsSpec.hs b/test/Data/Bifunctor/Monoidal/LawsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Bifunctor/Monoidal/LawsSpec.hs @@ -0,0 +1,277 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Runs the exported "Data.Bifunctor.Monoidal.Laws" 'Laws' against +-- known-good instances. Covariant bifunctors (tuples, which exercise both +-- tensor positions with a full 'Eq') and profunctors (@('->')@, @'Star' 'Maybe'@, +-- @'Kleisli' 'Maybe'@, observed extensionally). +module Data.Bifunctor.Monoidal.LawsSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Arrow (Kleisli (..)) +import Control.Category.Tensor (Associative (assoc), Iso (bwd)) +import Data.Bifunctor (bimap) +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.Monoidal (Semigroupal (combine)) +import Data.Bifunctor.Monoidal.Laws (monoidalLaws, opSemigroupalLaws, profunctorMonoidalLaws) +import Data.Bifunctor.Product (Product (..)) +import Data.Bifunctor.Tannen (Tannen (..)) +import Data.Bifunctor.Wrapped (WrappedBifunctor (..)) +import Data.Functor.Const (Const (..)) +import Data.Functor.Contravariant (Op (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Product qualified as F +import Data.Profunctor (Forget (..), Star (..), lmap) +import Data.Semigroup (Arg (..)) +import Data.String (fromString) +import Data.Tagged (Tagged (..)) +import Data.These (These (..)) +import Data.Void (Void) +import Hedgehog (Gen, Group (..), Property, PropertyName, checkSequential, forAll, forAllWith, property, (===)) +import Hedgehog.Classes (Laws (..)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Prelude + +-------------------------------------------------------------------------------- + +genInt :: Gen Int +genInt = Gen.int (Range.linear (-100) 100) + +-- Covariant bifunctor generators. The @()@ leading components are the 'Monoid' +-- tags the @(,,)@ \/ @(,,,)@ instances carry. + +genPair :: Gen a -> Gen b -> Gen (a, b) +genPair ga gb = (,) <$> ga <*> gb + +genTriple :: Gen a -> Gen b -> Gen ((), a, b) +genTriple ga gb = (\a b -> ((), a, b)) <$> ga <*> gb + +genQuad :: Gen a -> Gen b -> Gen ((), (), a, b) +genQuad ga gb = (\a b -> ((), (), a, b)) <$> ga <*> gb + +genQuint :: Gen a -> Gen b -> Gen ((), (), (), a, b) +genQuint ga gb = (\a b -> ((), (), (), a, b)) <$> ga <*> gb + +genSext :: Gen a -> Gen b -> Gen ((), (), (), (), a, b) +genSext ga gb = (\a b -> ((), (), (), (), a, b)) <$> ga <*> gb + +genSept :: Gen a -> Gen b -> Gen ((), (), (), (), (), a, b) +genSept ga gb = (\a b -> ((), (), (), (), (), a, b)) <$> ga <*> gb + +-- 'Arg's 'Eq' compares only the first parameter, so this law test is weaker than +-- the others (it cannot observe the second-parameter handling). +genArg :: Gen a -> Gen b -> Gen (Arg a b) +genArg ga gb = Arg <$> ga <*> gb + +-- Profunctor observers and (opaque) value generators. + +runFun :: (a -> b) -> a -> Identity b +runFun f = Identity . f + +runStarMaybe :: Star Maybe a b -> a -> Maybe b +runStarMaybe = runStar + +runKleisliMaybe :: Kleisli Maybe a b -> a -> Maybe b +runKleisliMaybe = runKleisli + +genFun :: Gen (Int -> Int) +genFun = Gen.choice [(\n -> (+ n)) <$> genInt, (\n -> (n -)) <$> genInt, (\n -> (* n)) <$> genInt] + +genStar :: Gen (Star Maybe Int Int) +genStar = + Gen.choice + [ (\n -> Star (\x -> Just (x + n))) <$> genInt, + (\n -> Star (\x -> if even x then Just (x * n) else Nothing)) <$> genInt + ] + +-- A 'Product' of profunctors runs both components on the same input. + +runProductFun :: Product (->) (->) a b -> a -> F.Product Identity Identity b +runProductFun (Pair f g) a = F.Pair (Identity (f a)) (Identity (g a)) + +runProductFunStar :: Product (->) (Star Maybe) a b -> a -> F.Product Identity Maybe b +runProductFunStar (Pair f s) a = F.Pair (Identity (f a)) (runStar s a) + +genProductFun :: Gen (Product (->) (->) Int Int) +genProductFun = Pair <$> genFun <*> genFun + +genProductFunStar :: Gen (Product (->) (Star Maybe) Int Int) +genProductFunStar = Pair <$> genFun <*> genStar + +genKleisli :: Gen (Kleisli Maybe Int Int) +genKleisli = + Gen.choice + [ (\n -> Kleisli (\x -> Just (x + n))) <$> genInt, + (\n -> Kleisli (\x -> if even x then Just (x * n) else Nothing)) <$> genInt + ] + +-- Rank-2 tensor builders for the profunctors' contravariant-side inputs. + +genPairT :: Gen x -> Gen y -> Gen (x, y) +genPairT gx gy = (,) <$> gx <*> gy + +genConstB :: Gen a -> Gen b -> Gen (Const a b) +genConstB ga _ = Const <$> ga + +genTaggedB :: Gen a -> Gen b -> Gen (Tagged a b) +genTaggedB _ gb = Tagged <$> gb + +genProduct :: Gen a -> Gen b -> Gen (Product (,) (,) a b) +genProduct ga gb = Pair <$> genPair ga gb <*> genPair ga gb + +genThese :: Gen a -> Gen b -> Gen (These a b) +genThese ga gb = Gen.choice [This <$> ga, That <$> gb, These <$> ga <*> gb] + +genJokerMaybe :: Gen a -> Gen b -> Gen (Joker Maybe a b) +genJokerMaybe _ gb = Joker <$> Gen.maybe gb + +genClownMaybe :: Gen a -> Gen b -> Gen (Clown Maybe a b) +genClownMaybe ga _ = Clown <$> Gen.maybe ga + +genBiap :: Gen a -> Gen b -> Gen (Biap (,) a b) +genBiap ga gb = Biap <$> genPair ga gb + +genWrapped :: Gen a -> Gen b -> Gen (WrappedBifunctor (,) a b) +genWrapped ga gb = WrapBifunctor <$> genPair ga gb + +genFlip :: Gen a -> Gen b -> Gen (Flip (,) a b) +genFlip ga gb = Flip <$> genPair gb ga + +genTannen :: Gen a -> Gen b -> Gen (Tannen Identity Either a b) +genTannen ga gb = (Tannen . Identity) <$> genEitherT ga gb + +genBiff :: Gen a -> Gen b -> Gen (Biff (,) Maybe Maybe a b) +genBiff ga gb = Biff <$> genPair (Gen.maybe ga) (Gen.maybe gb) + +-- Ad-hoc witnesses for the 'Forget' colax split. The generic law cannot exercise +-- it (the split consumes profunctors at structured contravariant-argument types), +-- but at fixed 'Either' types every function factors through its branches, so the +-- split is testable by observation. Fixed at @Forget (Maybe Int)@. + +genBranch :: Gen (Int -> Maybe Int) +genBranch = + Gen.choice + [ (\n x -> Just (x + n)) <$> genInt, + (\n x -> if even x then Just (x * n) else Nothing) <$> genInt, + pure (const Nothing) + ] + +splitForget :: Forget (Maybe Int) (Either x x') (Either y y') -> (Forget (Maybe Int) x y, Forget (Maybe Int) x' y') +splitForget = getOp (combine @Op @Either @Either @(,)) + +combineForget :: (Forget (Maybe Int) x y, Forget (Maybe Int) x' y') -> Forget (Maybe Int) (Either x x') (Either y y') +combineForget = combine @(->) @Either @Either @(,) + +genEitherT :: Gen x -> Gen y -> Gen (Either x y) +genEitherT gx gy = Gen.choice [Left <$> gx, Right <$> gy] + +-- | Splices a sublibrary 'Laws' into the hedgehog 'Group', prefixing each of its +-- properties with the instance under test. +labeled :: String -> Laws -> [(PropertyName, Property)] +labeled prefix ls = [(fromString (prefix <> " " <> n), p) | (n, p) <- lawsProperties ls] + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = do + covariant <- + checkSequential $ + Group "Bifunctor monoidal laws (covariant)" $ + concat + [ labeled "(,)" (monoidalLaws @(,) @() @(,) @() genPair), + labeled "(,,) ()" (monoidalLaws @(,) @() @(,) @() genTriple), + labeled "(,,,) () ()" (monoidalLaws @(,) @() @(,) @() genQuad), + labeled "Product (,) (,)" (monoidalLaws @(,) @() @(,) @() genProduct) + ] + colax <- + checkSequential $ + Group "Bifunctor monoidal laws (colax Op)" $ + concat + [ labeled "(,)" (opSemigroupalLaws @(,) @(,) @(,) genPair genPairT genPairT), + labeled "Either" (opSemigroupalLaws @Either @Either @Either genEitherT genEitherT genEitherT), + labeled "(,,) ()" (opSemigroupalLaws @(,) @(,) @(,) genTriple genPairT genPairT), + labeled "(,,,) () ()" (opSemigroupalLaws @(,) @(,) @(,) genQuad genPairT genPairT), + labeled "(,,,,) () () ()" (opSemigroupalLaws @(,) @(,) @(,) genQuint genPairT genPairT), + labeled "(,,,,,) () () () ()" (opSemigroupalLaws @(,) @(,) @(,) genSext genPairT genPairT), + labeled "(,,,,,,) () () () () ()" (opSemigroupalLaws @(,) @(,) @(,) genSept genPairT genPairT), + labeled "Arg" (opSemigroupalLaws @(,) @(,) @(,) genArg genPairT genPairT), + labeled "Const" (opSemigroupalLaws @(,) @(,) @(,) genConstB genPairT genPairT), + labeled "Tagged" (opSemigroupalLaws @(,) @(,) @(,) genTaggedB genPairT genPairT), + labeled "Product (,) (,)" (opSemigroupalLaws @(,) @(,) @(,) genProduct genPairT genPairT), + labeled "Joker Maybe" (opSemigroupalLaws @(,) @These @(,) genJokerMaybe genPairT genThese), + labeled "Clown Maybe" (opSemigroupalLaws @These @(,) @(,) genClownMaybe genThese genPairT), + labeled "Biap (,)" (opSemigroupalLaws @(,) @(,) @(,) genBiap genPairT genPairT), + labeled "WrappedBifunctor (,)" (opSemigroupalLaws @(,) @(,) @(,) genWrapped genPairT genPairT), + labeled "Flip (,)" (opSemigroupalLaws @(,) @(,) @(,) genFlip genPairT genPairT), + labeled "Tannen Identity Either" (opSemigroupalLaws @Either @Either @Either genTannen genEitherT genEitherT), + labeled "Biff (,) Maybe Maybe" (opSemigroupalLaws @These @These @(,) genBiff genThese genThese) + ] + profunctor <- + checkSequential $ + Group "Bifunctor monoidal laws (profunctor)" $ + concat + [ labeled "(->) (,)" (profunctorMonoidalLaws @(,) @() @(,) @() runFun genFun genPairT), + labeled "(->) Either" (profunctorMonoidalLaws @Either @Void @Either @Void runFun genFun genEitherT), + labeled "Star Maybe (,)" (profunctorMonoidalLaws @(,) @() @(,) @() runStarMaybe genStar genPairT), + labeled "Kleisli Maybe (,)" (profunctorMonoidalLaws @(,) @() @(,) @() runKleisliMaybe genKleisli genPairT), + labeled "Product (->) (->) (,)" (profunctorMonoidalLaws @(,) @() @(,) @() runProductFun genProductFun genPairT), + labeled "Product (->) (->) Either" (profunctorMonoidalLaws @Either @Void @Either @Void runProductFun genProductFun genEitherT), + labeled "Product (->) (Star Maybe) (,)" (profunctorMonoidalLaws @(,) @() @(,) @() runProductFunStar genProductFunStar genPairT) + ] + forget <- + checkSequential $ + Group + "Bifunctor colax Op (Forget, ad-hoc)" + [ ( "split . combine = id", + property $ do + f <- forAllWith (const "") genBranch + g <- forAllWith (const "") genBranch + x <- forAll genInt + y <- forAll genInt + let (p1, p2) = splitForget (combineForget (Forget f, Forget g)) + (runForget p1 x, runForget p2 y) === (f x, g y) + ), + ( "combine . split = id", + property $ do + f <- forAllWith (const "") genBranch + g <- forAllWith (const "") genBranch + e <- forAll (genEitherT genInt genInt) + let h = either f g + runForget (combineForget (splitForget (Forget h))) e === h e + ), + ( "Coassociativity", + property $ do + f <- forAllWith (const "") genBranch + g <- forAllWith (const "") genBranch + k <- forAllWith (const "") genBranch + ia <- forAll genInt + ib <- forAll genInt + ic <- forAll genInt + let h = either f (either g k) :: Either Int (Either Int Int) -> Maybe Int + (pa, pbc) = splitForget (Forget h :: Forget (Maybe Int) (Either Int (Either Int Int)) (Either Int (Either Int Int))) + (pb, pc) = splitForget pbc + h' = h . bwd (assoc @(->) @Either) + (pab, pc') = splitForget (Forget h' :: Forget (Maybe Int) (Either (Either Int Int) Int) (Either (Either Int Int) Int)) + (pa', pb') = splitForget pab + (runForget pa ia, runForget pb ib, runForget pc ic) + === (runForget pa' ia, runForget pb' ib, runForget pc' ic) + ), + ( "Conaturality", + property $ do + f <- forAllWith (const "") genBranch + g <- forAllWith (const "") genBranch + x <- forAll genInt + y <- forAll genInt + let l = (+ 1) :: Int -> Int + h = either f g :: Either Int Int -> Maybe Int + (l1, l2) = splitForget (Forget (h . bimap l l) :: Forget (Maybe Int) (Either Int Int) (Either Int Int)) + (r1, r2) = splitForget (Forget h :: Forget (Maybe Int) (Either Int Int) (Either Int Int)) + (runForget l1 x, runForget l2 y) === (runForget (lmap l r1) x, runForget (lmap l r2) y) + ) + ] + pure (covariant && colax && profunctor && forget) diff --git a/test/Data/Bifunctor/Rank2/MonoidalSpec.hs b/test/Data/Bifunctor/Rank2/MonoidalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Bifunctor/Rank2/MonoidalSpec.hs @@ -0,0 +1,351 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Exercises the generically derived rank-2 'Monoidal' for bifunctor-interpreted +-- HKDs, at all three derivable instantiations: +-- +-- * covariant product: 'combine' agrees with the field-wise 'Pair'ing and +-- 'introduce' fills every field with the unit bifunctor @'Joker' 'Proxy'@; +-- * coproduct: 'combine' injects a whole record all-'L2' or all-'R2'; +-- * oplax product: 'combine' unzips a record of 'Pair's, and is inverse to the +-- covariant product 'combine'. +-- +-- The covariant product also gets a laws pass (associativity, both unit laws, +-- and naturality), stated through @kindly-functors@' rank-2 'bmap1' with +-- associators and unitors written inline. This doubles as an interop check that +-- 'combine' commutes with 'bmap1'. The associators/unitors would collapse into +-- the shared "Data.Bifunctor.Monoidal.Laws" machinery once the @Nat@-category +-- 'Control.Category.Tensor.Tensor' instances for 'Product' exist. +-- +-- A last group relates this class to "Data.Bifunctor.Rank2.Traversable". +-- 'Rank2.sequence' must preserve the product structure: sequencing a combined +-- record gives the 'Pair' of the component sequences, and sequencing the unit +-- record gives the unit. Only covariant interpretations are checked, because +-- 'Product' is 'Data.Bifunctor.Monoidal.Monoidal' only at 'Biapplicative' +-- components. +module Data.Bifunctor.Rank2.MonoidalSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Category.LawsSupport (genInt) +import Data.Bifunctor.Joker (Joker (..)) +import Data.Bifunctor.Product (Product (..)) +import Data.Bifunctor.Rank2.Monoidal (Monoidal, Semigroupal (..), Unital (..), gcombineSum, gsplitProduct) +import Data.Bifunctor.Rank2.Traversable qualified as Rank2 +import Data.Bifunctor.Sum (Sum (..)) +import Data.Functor.Const (Const (..)) +import Data.Functor.Contravariant (Op (..), getOp) +import Data.Kind (Type) +import Data.Proxy (Proxy (..)) +import Data.Void (Void, absurd) +import GHC.Generics (Generic, V1) +import Hedgehog (Gen, Group (..), Property, checkSequential, forAll, property, withTests, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Kindly (CategoricalFunctor (..), Nat (..), bmap1, runNat, type (~>)) +import Prelude hiding (map) + +-------------------------------------------------------------------------------- +-- Test types + +-- | A three-field record of bifunctor values. Exercises @K1@, @M1@, and nested +-- @:*:@. +data TestHKD p = TestHKD + { thFst :: p Int Bool, + thSnd :: p String Int, + thThd :: p Bool String + } + deriving stock (Generic) + +instance Semigroupal (->) Product (,) TestHKD + +instance Unital (->) (Joker Proxy) () TestHKD + +instance Monoidal (->) Product (Joker Proxy) (,) () TestHKD + +instance Semigroupal (->) Sum Either TestHKD where combine = gcombineSum + +instance Unital (->) (Joker V1) Void TestHKD where introduce = absurd + +instance Monoidal (->) Sum (Joker V1) Either Void TestHKD + +instance Semigroupal Op Product (,) TestHKD where combine = Op gsplitProduct + +instance Unital Op (Joker Proxy) () TestHKD where introduce = Op (const ()) + +instance Monoidal Op Product (Joker Proxy) (,) () TestHKD + +instance Rank2.Traversable TestHKD + +-- | 'TestHKD' as a @kindly-functors@ rank-2 functor, so the law properties can +-- map interpretations through it with 'bmap1'. The domain is the bifunctor +-- category, so the morphisms are nested 'Nat's. +instance CategoricalFunctor TestHKD where + type Dom TestHKD = (->) ~> ((->) ~> (->)) + type Cod TestHKD = (->) + map (Nat n) (TestHKD a b c) = TestHKD (runNat n a) (runNat n b) (runNat n c) + +deriving stock instance (Show (p Int Bool), Show (p String Int), Show (p Bool String)) => Show (TestHKD p) + +deriving stock instance (Eq (p Int Bool), Eq (p String Int), Eq (p Bool String)) => Eq (TestHKD p) + +-- | A nullary constructor. Exercises @U1@ and the unit path. +data EmptyHKD (p :: Type -> Type -> Type) = EmptyHKD + deriving stock (Generic, Show, Eq) + +instance Semigroupal (->) Product (,) EmptyHKD + +instance Unital (->) (Joker Proxy) () EmptyHKD + +instance Monoidal (->) Product (Joker Proxy) (,) () EmptyHKD + +instance Semigroupal (->) Sum Either EmptyHKD where combine = gcombineSum + +instance Unital (->) (Joker V1) Void EmptyHKD where introduce = absurd + +instance Monoidal (->) Sum (Joker V1) Either Void EmptyHKD + +-------------------------------------------------------------------------------- +-- Monomorphic call sites (fix @cat@, @tC@, @tD@ for the derived instances). + +combineHKD :: TestHKD p -> TestHKD q -> TestHKD (Product p q) +combineHKD x y = combine @(->) @Product @(,) (x, y) + +introduceHKD :: TestHKD (Joker Proxy) +introduceHKD = introduce @(->) @(Joker Proxy) @() () + +combineSumHKD :: Either (TestHKD p) (TestHKD q) -> TestHKD (Sum p q) +combineSumHKD = combine @(->) @Sum @Either + +splitHKD :: TestHKD (Product p q) -> (TestHKD p, TestHKD q) +splitHKD = getOp (combine @Op @Product @(,)) + +-- | Map a bifunctor natural transformation over every field, through kindly's +-- rank-2 functor interface. +mapHKD :: (forall x y. p x y -> q x y) -> TestHKD p -> TestHKD q +mapHKD n = bmap1 (Nat n) + +-- | The reference for the covariant product 'combine': field-wise 'Pair'. +refCombine :: TestHKD p -> TestHKD q -> TestHKD (Product p q) +refCombine (TestHKD a b c) (TestHKD a' b' c') = + TestHKD (Pair a a') (Pair b b') (Pair c c') + +-- | The reference for the coproduct 'combine': every field on one side. +refCombineSum :: Either (TestHKD p) (TestHKD q) -> TestHKD (Sum p q) +refCombineSum (Left (TestHKD a b c)) = TestHKD (L2 a) (L2 b) (L2 c) +refCombineSum (Right (TestHKD a b c)) = TestHKD (R2 a) (R2 b) (R2 c) + +-------------------------------------------------------------------------------- +-- Associators and unitors for the 'Product' tensor on the bifunctor category. +-- These stand in for the (as yet unwritten) @Nat@-category 'Tensor' instances. + +-- | 'Product'\'s action on morphisms of the bifunctor category. +prodNat :: + (forall x y. p x y -> p' x y) -> + (forall x y. q x y -> q' x y) -> + Product p q a b -> + Product p' q' a b +prodNat l r (Pair p q) = Pair (l p) (r q) + +-- | The associator of 'Product' on the bifunctor category. +assocProd :: Product p (Product q r) a b -> Product (Product p q) r a b +assocProd (Pair a (Pair b c)) = Pair (Pair a b) c + +-- | The right unitor: @'Joker' 'Proxy'@ is the unit of 'Product'. +runitProd :: Product p (Joker Proxy) a b -> p a b +runitProd (Pair a _) = a + +-- | The left unitor. +lunitProd :: Product (Joker Proxy) p a b -> p a b +lunitProd (Pair _ a) = a + +-------------------------------------------------------------------------------- +-- Natural transformations between the interpretations used by the laws. + +-- | Keep the first component, discard the second. +pairToConst :: (a, b) -> Const a b +pairToConst (a, _) = Const a + +-- | Inject the first component on the left. +pairToEither :: (a, b) -> Either a b +pairToEither (a, _) = Left a + +-------------------------------------------------------------------------------- +-- Generators + +genString :: Gen String +genString = Gen.string (Range.linear 0 5) Gen.alpha + +-- | Build a 'TestHKD' generator from a per-field wrapper. +genHKD :: (forall a b. Gen a -> Gen b -> Gen (p a b)) -> Gen (TestHKD p) +genHKD f = TestHKD <$> f genInt Gen.bool <*> f genString genInt <*> f Gen.bool genString + +genPairHKD :: Gen (TestHKD (,)) +genPairHKD = genHKD (\ga gb -> (,) <$> ga <*> gb) + +genEitherHKD :: Gen (TestHKD Either) +genEitherHKD = genHKD (\ga gb -> Gen.choice [Left <$> ga, Right <$> gb]) + +genConstHKD :: Gen (TestHKD Const) +genConstHKD = genHKD (\ga _ -> Const <$> ga) + +genProductHKD :: Gen (TestHKD (Product (,) Either)) +genProductHKD = + genHKD (\ga gb -> Pair <$> ((,) <$> ga <*> gb) <*> Gen.choice [Left <$> ga, Right <$> gb]) + +-- | A record of 'Pair's with 'Biapplicative' components, so 'Rank2.sequence' +-- applies at the 'Product' interpretation. +genPairConstHKD :: Gen (TestHKD (Product (,) Const)) +genPairConstHKD = + genHKD (\ga gb -> Pair <$> ((,) <$> ga <*> gb) <*> (Const <$> ga)) + +-------------------------------------------------------------------------------- +-- Covariant product: agreement with the reference + +-- | 'combine' agrees with the hand-written field-wise 'Pair'. +combineAgreesWithRef :: Property +combineAgreesWithRef = property $ do + x <- forAll genPairHKD + y <- forAll genEitherHKD + combineHKD x y === refCombine x y + +-- | 'combine' at a homogeneous interpretation also agrees with the reference. +combineAgreesWithRefHomogeneous :: Property +combineAgreesWithRefHomogeneous = property $ do + x <- forAll genPairHKD + y <- forAll genPairHKD + combineHKD x y === refCombine x y + +-- | 'introduce' fills every field with the unit bifunctor. +introduceIsAllUnit :: Property +introduceIsAllUnit = withTests 1 $ property $ do + introduceHKD === TestHKD (Joker Proxy) (Joker Proxy) (Joker Proxy) + +-------------------------------------------------------------------------------- +-- Covariant product: monoidal laws (via kindly's rank-2 'bmap1') + +-- | Naturality: 'combine' commutes with maps into either tensor position. +-- Doubles as the interop check that 'combine' commutes with 'bmap1'. +naturalityLaw :: Property +naturalityLaw = property $ do + x <- forAll genPairHKD + y <- forAll genPairHKD + mapHKD (prodNat pairToConst pairToEither) (combineHKD x y) + === combineHKD (mapHKD pairToConst x) (mapHKD pairToEither y) + +-- | Associativity: reassociating the domain 'Product' turns the right-nested +-- 'combine' into the left-nested one. +associativityLaw :: Property +associativityLaw = property $ do + x <- forAll genPairHKD + y <- forAll genEitherHKD + z <- forAll genConstHKD + mapHKD assocProd (combineHKD x (combineHKD y z)) + === combineHKD (combineHKD x y) z + +-- | Right unit: combining with @'introduce' ()@ and projecting recovers the record. +rightUnitLaw :: Property +rightUnitLaw = property $ do + x <- forAll genPairHKD + mapHKD runitProd (combineHKD x introduceHKD) === x + +-- | Left unit: the mirror of 'rightUnitLaw'. +leftUnitLaw :: Property +leftUnitLaw = property $ do + x <- forAll genPairHKD + mapHKD lunitProd (combineHKD introduceHKD x) === x + +-------------------------------------------------------------------------------- +-- Coproduct + +-- | Injecting on the left sends every field to 'L2'. +coproductInjectsLeft :: Property +coproductInjectsLeft = property $ do + x <- forAll genPairHKD + let e = Left x :: Either (TestHKD (,)) (TestHKD Either) + combineSumHKD e === refCombineSum e + +-- | Injecting on the right sends every field to 'R2'. +coproductInjectsRight :: Property +coproductInjectsRight = property $ do + y <- forAll genEitherHKD + let e = Right y :: Either (TestHKD (,)) (TestHKD Either) + combineSumHKD e === refCombineSum e + +-------------------------------------------------------------------------------- +-- Oplax product (split) + +-- | Split then combine is the identity (product iso, one direction). +splitAfterCombine :: Property +splitAfterCombine = property $ do + x <- forAll genPairHKD + y <- forAll genEitherHKD + splitHKD (combineHKD x y) === (x, y) + +-- | Combine then split is the identity (product iso, other direction). +combineAfterSplit :: Property +combineAfterSplit = property $ do + z <- forAll genProductHKD + uncurry combineHKD (splitHKD z) === z + +-------------------------------------------------------------------------------- +-- Field-less record + +-- | The field-less record is handled by the @U1@ path at every instantiation. +emptyRecord :: Property +emptyRecord = withTests 1 $ property $ do + combine @(->) @Product @(,) (EmptyHKD :: EmptyHKD (,), EmptyHKD :: EmptyHKD Either) === EmptyHKD + introduce @(->) @(Joker Proxy) @() () === (EmptyHKD :: EmptyHKD (Joker Proxy)) + combine @(->) @Sum @Either (Left EmptyHKD :: Either (EmptyHKD (,)) (EmptyHKD Either)) === EmptyHKD + +-------------------------------------------------------------------------------- +-- Coherence with Rank2.Traversable + +-- TODO: Check the profunctor interpretation too. That needs a +-- variance-agnostic 'Data.Bifunctor.Monoidal.Monoidal' instance for 'Product'. + +-- | Sequencing a combined record gives the 'Pair' of the component sequences. +sequencePreservesProduct :: Property +sequencePreservesProduct = property $ do + x <- forAll genPairHKD + y <- forAll genConstHKD + Rank2.sequence (combineHKD x y) === Pair (Rank2.sequence x) (Rank2.sequence y) + +-- | Sequencing the unit record gives the unit bifunctor. +sequencePreservesUnit :: Property +sequencePreservesUnit = withTests 1 $ property $ do + Rank2.sequence introduceHKD === Joker Proxy + +-- | Sequencing a record of 'Pair's agrees with splitting it first and +-- sequencing each half. +sequenceAgreesWithSplit :: Property +sequenceAgreesWithSplit = property $ do + z <- forAll genPairConstHKD + let (x, y) = splitHKD z + Rank2.sequence z === Pair (Rank2.sequence x) (Rank2.sequence y) + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = + checkSequential $ + Group + "Data.Bifunctor.Rank2.Monoidal" + [ ("combine agrees with reference ((,)/Either)", combineAgreesWithRef), + ("combine agrees with reference ((,))", combineAgreesWithRefHomogeneous), + ("introduce is all Joker Proxy", introduceIsAllUnit), + ("naturality (combine commutes with bmap1)", naturalityLaw), + ("associativity", associativityLaw), + ("right unit", rightUnitLaw), + ("left unit", leftUnitLaw), + ("coproduct injects left", coproductInjectsLeft), + ("coproduct injects right", coproductInjectsRight), + ("split . combine = id", splitAfterCombine), + ("combine . split = id", combineAfterSplit), + ("empty record at every instantiation", emptyRecord), + ("sequence preserves the product", sequencePreservesProduct), + ("sequence preserves the unit", sequencePreservesUnit), + ("sequence agrees with split", sequenceAgreesWithSplit) + ] diff --git a/test/Data/Bifunctor/Rank2/TraversableSpec.hs b/test/Data/Bifunctor/Rank2/TraversableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Bifunctor/Rank2/TraversableSpec.hs @@ -0,0 +1,141 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Exercises the generically derived rank-2 'Rank2.Traversable' for +-- bifunctor-interpreted HKDs. Sequencing a record of @p a b@ fields yields +-- @p (hkd 'Rank2.First') (hkd 'Rank2.Second')@, which must act field-wise. The +-- profunctor case (@(Op, (->))@) is checked against an applicative reference. +-- The covariant case (@((->), (->))@) is the 'Biapplicative' unzip. +module Data.Bifunctor.Rank2.TraversableSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Arrow (Kleisli (..)) +import Control.Category.LawsSupport (genInt) +import Data.Bifunctor.Rank2.Traversable qualified as Rank2 +import Data.Kind (Type) +import GHC.Generics (Generic) +import Hedgehog (Gen, Group (..), Property, checkSequential, forAll, property, withTests, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Prelude + +-------------------------------------------------------------------------------- +-- Test types + +-- | A three-field record of profunctor values. Exercises @K1@, @M1@, and +-- nested @:*:@. +data TestHKD p = TestHKD + { thFun :: p Int Bool, + thLen :: p String Int, + thFlag :: p Bool String + } + deriving stock (Generic) + deriving anyclass (Rank2.Traversable) + +deriving stock instance (Show (p Int Bool), Show (p String Int), Show (p Bool String)) => Show (TestHKD p) + +deriving stock instance (Eq (p Int Bool), Eq (p String Int), Eq (p Bool String)) => Eq (TestHKD p) + +-- | A nullary constructor. Exercises @U1@ and the 'introduce' path. +data EmptyHKD (p :: Type -> Type -> Type) = EmptyHKD + deriving stock (Generic, Show, Eq) + deriving anyclass (Rank2.Traversable) + +-------------------------------------------------------------------------------- +-- Generators + +genString :: Gen String +genString = Gen.string (Range.linear 0 5) Gen.alpha + +-- | A record of pairs, for the covariant @(,)@ (Biapplicative) instantiation. +genPairHKD :: Gen (TestHKD (,)) +genPairHKD = + TestHKD + <$> ((,) <$> genInt <*> Gen.bool) + <*> ((,) <$> genString <*> genInt) + <*> ((,) <$> Gen.bool <*> genString) + +-------------------------------------------------------------------------------- +-- Properties + +-- | Sequencing a record of functions gives a function between records that +-- applies each field pointwise. +functionActsFieldwise :: Property +functionActsFieldwise = property $ do + k <- forAll genInt + m <- forAll genInt + let hkd = TestHKD {thFun = \n -> n > k, thLen = \s -> length s + m, thFlag = \b -> if b then show k else show m} + run = Rank2.sequence hkd + a <- forAll genInt + s <- forAll genString + b <- forAll Gen.bool + run (TestHKD (Rank2.First a) (Rank2.First s) (Rank2.First b)) + === TestHKD (Rank2.Second (a > k)) (Rank2.Second (length s + m)) (Rank2.Second (if b then show k else show m)) + +-- | Sequencing a record of 'Kleisli' arrows combines the effects field-wise, +-- agreeing with the applicative reference. +kleisliAgrees :: Property +kleisliAgrees = property $ do + k <- forAll genInt + m <- forAll genInt + let f n = if n > k then Just (even n) else Nothing + g s = if length s > m then Just (length s) else Nothing + h b = if b then Just (show k) else Nothing + hkd = TestHKD (Kleisli f) (Kleisli g) (Kleisli h) + a <- forAll genInt + s <- forAll genString + b <- forAll Gen.bool + runKleisli (Rank2.sequence hkd) (TestHKD (Rank2.First a) (Rank2.First s) (Rank2.First b)) + === ((\x y z -> TestHKD (Rank2.Second x) (Rank2.Second y) (Rank2.Second z)) <$> f a <*> g s <*> h b) + +-- | At @Kleisli []@ the effect order is observable: 'Maybe' cannot tell a +-- flipped combine apart, but the cartesian product of multi-element lists +-- pins the left-to-right ordering against the applicative reference. +kleisliOrdersEffects :: Property +kleisliOrdersEffects = property $ do + k <- forAll genInt + let f n = [even n, n > k] + g s = [length s, length s + k] + h b = [show b, show (b, k)] + hkd = TestHKD (Kleisli f) (Kleisli g) (Kleisli h) + a <- forAll genInt + s <- forAll genString + b <- forAll Gen.bool + runKleisli (Rank2.sequence hkd) (TestHKD (Rank2.First a) (Rank2.First s) (Rank2.First b)) + === ((\x y z -> TestHKD (Rank2.Second x) (Rank2.Second y) (Rank2.Second z)) <$> f a <*> g s <*> h b) + +-- | At the covariant bifunctor @(,)@ sequencing is the 'Biapplicative' unzip: +-- a record of pairs splits into the record of first components and the record +-- of second components. +pairUnzips :: Property +pairUnzips = property $ do + hkd <- forAll genPairHKD + let TestHKD (a1, b1) (a2, b2) (a3, b3) = hkd + Rank2.sequence hkd + === ( TestHKD (Rank2.First a1) (Rank2.First a2) (Rank2.First a3), + TestHKD (Rank2.Second b1) (Rank2.Second b2) (Rank2.Second b3) + ) + +-- | A field-less record sequences to the unit of the profunctor via +-- 'introduce'. +emptySequencesToUnit :: Property +emptySequencesToUnit = withTests 1 $ property $ do + Rank2.sequence (EmptyHKD :: EmptyHKD (->)) EmptyHKD === EmptyHKD + runKleisli (Rank2.sequence (EmptyHKD :: EmptyHKD (Kleisli Maybe))) EmptyHKD === Just EmptyHKD + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = + checkSequential $ + Group + "Data.Bifunctor.Rank2.Traversable" + [ ("function sequencing acts field-wise", functionActsFieldwise), + ("Kleisli sequencing agrees with reference", kleisliAgrees), + ("Kleisli sequencing orders effects left-to-right", kleisliOrdersEffects), + ("record of pairs unzips (Biapplicative)", pairUnzips), + ("empty record sequences to unit", emptySequencesToUnit) + ] diff --git a/test/Data/Functor/Monoidal/GenericSpec.hs b/test/Data/Functor/Monoidal/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Functor/Monoidal/GenericSpec.hs @@ -0,0 +1,400 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Functor.Monoidal.GenericSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Applicative (liftA2) +import Data.Distributive (Distributive (..)) +import Data.Functor.Contravariant (Contravariant (..), Op (..), Predicate (..)) +import Data.Functor.Monoidal (Monoidal, Semigroupal (..), Unital (..)) +import Data.Functor.Monoidal.Generic (FromGeneric (..), FromRepresentable (..)) +import Data.Functor.Monoidal.Laws + ( contravariantMonoidalLaws, + monoidalLaws, + opSemigroupalLaws, + representableSplitLaws, + semigroupalLaws, + ) +import Data.Monoid (Sum (..)) +import Data.String (fromString) +import Data.These (These (..)) +import Data.Void (Void) +import Generics.Kind.TH (deriveGenericK) +import Hedgehog (Gen, Group (..), Property, PropertyName, checkSequential, forAll, property, (===)) +import Hedgehog.Classes (Laws (..)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Prelude + +-------------------------------------------------------------------------------- +-- Test types, one per rep shape + +-- | A nullary constructor. Exercises @U1@. +data Phantom a = Phantom deriving (Functor, Show, Eq) + +$(deriveGenericK ''Phantom) + +deriving via FromGeneric Phantom instance Semigroupal (->) (,) (,) Phantom + +deriving via FromGeneric Phantom instance Unital (->) () () Phantom + +deriving via FromGeneric Phantom instance Monoidal (->) (,) () (,) () Phantom + +-- | Two bare parameters. Exercises @Field Var0@ and @:*:@. Representable, so it +-- also has the coherent split. +data Two a = Two a a deriving (Functor, Show, Eq) + +$(deriveGenericK ''Two) + +instance Distributive Two where + distribute w = Two (fmap (\(Two a _) -> a) w) (fmap (\(Two _ b) -> b) w) + +deriving via FromGeneric Two instance Semigroupal (->) (,) (,) Two + +deriving via FromRepresentable Two instance Semigroupal Op (,) (,) Two + +deriving via FromGeneric Two instance Unital (->) () () Two + +deriving via FromGeneric Two instance Monoidal (->) (,) () (,) () Two + +-- | Sub-functor fields. Exercises @Field (Kon g :@: Var0)@ across three tensors. +data P a = P (Maybe a) [a] deriving (Functor, Show, Eq) + +$(deriveGenericK ''P) + +deriving via FromGeneric P instance Semigroupal (->) (,) (,) P + +deriving via FromGeneric P instance Semigroupal (->) Either (,) P + +deriving via FromGeneric P instance Semigroupal (->) These (,) P + +deriving via FromGeneric P instance Semigroupal Op (,) (,) P + +deriving via FromGeneric P instance Unital (->) () () P + +deriving via FromGeneric P instance Monoidal (->) (,) () (,) () P + +deriving via FromGeneric P instance Unital (->) Void () P + +deriving via FromGeneric P instance Monoidal (->) Either Void (,) () P + +-- | A constant 'Monoid' field. Exercises @Field (Kon c)@. +data W a = W String (Maybe a) deriving (Functor, Show, Eq) + +$(deriveGenericK ''W) + +deriving via FromGeneric W instance Semigroupal (->) (,) (,) W + +deriving via FromGeneric W instance Unital (->) () () W + +deriving via FromGeneric W instance Monoidal (->) (,) () (,) () W + +deriving via FromGeneric W instance Semigroupal (->) Either (,) W + +deriving via FromGeneric W instance Unital (->) Void () W + +deriving via FromGeneric W instance Monoidal (->) Either Void (,) () W + +-- | A nested functor field. Exercises @Field (Kon f :@: (Kon g :@: Var0))@. +data Nest a = Nest (Maybe [a]) deriving (Functor, Show, Eq) + +$(deriveGenericK ''Nest) + +deriving via FromGeneric Nest instance Semigroupal (->) (,) (,) Nest + +deriving via FromGeneric Nest instance Semigroupal Op (,) (,) Nest + +deriving via FromGeneric Nest instance Unital (->) () () Nest + +deriving via FromGeneric Nest instance Monoidal (->) (,) () (,) () Nest + +deriving via FromGeneric Nest instance Semigroupal (->) Either (,) Nest + +deriving via FromGeneric Nest instance Unital (->) Void () Nest + +deriving via FromGeneric Nest instance Monoidal (->) Either Void (,) () Nest + +-- | A record with named fields. Exercises the selector metadata. +data Rec a = Rec {recFst :: Maybe a, recSnd :: [a]} deriving (Functor, Show, Eq) + +$(deriveGenericK ''Rec) + +deriving via FromGeneric Rec instance Semigroupal (->) (,) (,) Rec + +deriving via FromGeneric Rec instance Unital (->) () () Rec + +deriving via FromGeneric Rec instance Monoidal (->) (,) () (,) () Rec + +-- | A mixed three-field product. Exercises @Var0@, @Kon g :@: Var0@, and +-- @Kon c@ together. +data Mix a = Mix a (Maybe a) (Sum Int) deriving (Functor, Show, Eq) + +$(deriveGenericK ''Mix) + +deriving via FromGeneric Mix instance Semigroupal (->) (,) (,) Mix + +deriving via FromGeneric Mix instance Unital (->) () () Mix + +deriving via FromGeneric Mix instance Monoidal (->) (,) () (,) () Mix + +-- | A sum of sub-functor fields. Combine is undefined. Has only the (total) +-- split. +data S a = SL (Maybe a) | SR [a] deriving (Functor, Show, Eq) + +$(deriveGenericK ''S) + +deriving via FromGeneric S instance Semigroupal Op (,) (,) S + +-- | A three-constructor sum mixing bare parameters and a nullary constructor. +data Sum3 a = A a | B a a | C deriving (Functor, Show, Eq) + +$(deriveGenericK ''Sum3) + +deriving via FromGeneric Sum3 instance Semigroupal Op (,) (,) Sum3 + +-- | A contravariant functor. Exercises the @Divisible@ leaf. +data TwoPreds a = TwoPreds (Predicate a) (Predicate a) + +$(deriveGenericK ''TwoPreds) + +deriving via FromGeneric TwoPreds instance Semigroupal (->) (,) (,) TwoPreds + +deriving via FromGeneric TwoPreds instance Unital (->) () () TwoPreds + +deriving via FromGeneric TwoPreds instance Monoidal (->) (,) () (,) () TwoPreds + +instance Contravariant TwoPreds where + contramap f (TwoPreds p q) = TwoPreds (contramap f p) (contramap f q) + +-- | A bare function field @a -> r@, with no named contravariant wrapper. +-- Exercises the function atom directly. The 'Monoid' codomain gives it the +-- @Op r@ (Divisible/Decidable) instances. +newtype Sink a = Sink (a -> [String]) + +$(deriveGenericK ''Sink) + +deriving via FromGeneric Sink instance Semigroupal (->) (,) (,) Sink + +deriving via FromGeneric Sink instance Semigroupal (->) Either (,) Sink + +deriving via FromGeneric Sink instance Unital (->) () () Sink + +deriving via FromGeneric Sink instance Unital (->) Void () Sink + +deriving via FromGeneric Sink instance Monoidal (->) (,) () (,) () Sink + +deriving via FromGeneric Sink instance Monoidal (->) Either Void (,) () Sink + +instance Contravariant Sink where + contramap f (Sink g) = Sink (g . f) + +runSink :: Sink a -> a -> [String] +runSink (Sink f) = f + +-------------------------------------------------------------------------------- +-- Generators + +genInt :: Gen Int +genInt = Gen.int (Range.linear (-100) 100) + +genPhantom :: Gen a -> Gen (Phantom a) +genPhantom _ = pure Phantom + +genTwo :: Gen a -> Gen (Two a) +genTwo g = Two <$> g <*> g + +genP :: Gen a -> Gen (P a) +genP g = P <$> Gen.maybe g <*> Gen.list (Range.linear 0 4) g + +genW :: Gen a -> Gen (W a) +genW g = W <$> Gen.string (Range.linear 0 3) Gen.alpha <*> Gen.maybe g + +genNest :: Gen a -> Gen (Nest a) +genNest g = Nest <$> Gen.maybe (Gen.list (Range.linear 0 3) g) + +genRec :: Gen a -> Gen (Rec a) +genRec g = Rec <$> Gen.maybe g <*> Gen.list (Range.linear 0 4) g + +genMix :: Gen a -> Gen (Mix a) +genMix g = Mix <$> g <*> Gen.maybe g <*> (Sum <$> genInt) + +genS :: Gen a -> Gen (S a) +genS g = Gen.choice [SL <$> Gen.maybe g, SR <$> Gen.list (Range.linear 0 4) g] + +genSum3 :: Gen a -> Gen (Sum3 a) +genSum3 g = Gen.choice [A <$> g, B <$> g <*> g, pure C] + +genPair :: Gen a -> Gen (a, a) +genPair g = (,) <$> g <*> g + +-- Rank-2 tensor builders, for the contravariant law observation points. +genPairT :: Gen a -> Gen b -> Gen (a, b) +genPairT ga gb = (,) <$> ga <*> gb + +genEitherT :: Gen a -> Gen b -> Gen (Either a b) +genEitherT ga gb = Gen.choice [Left <$> ga, Right <$> gb] + +genTwoPreds :: Gen (TwoPreds Int) +genTwoPreds = TwoPreds <$> genPredInt <*> genPredInt + where + genPredInt = (\n -> Predicate (> n)) <$> genInt + +genSink :: Gen (Sink Int) +genSink = (\n -> Sink (\x -> [show (x + n)])) <$> genInt + +-------------------------------------------------------------------------------- +-- Property laws + +-- | The standalone split is the functorial unzip. +splitLaw :: + forall f. + ( Semigroupal Op (,) (,) f, + Functor f, + forall a. (Eq a) => Eq (f a), + forall a. (Show a) => Show (f a) + ) => + (forall a. Gen a -> Gen (f a)) -> + Property +splitLaw genF = property $ do + s <- forAll (genF (genPair genInt)) + getOp (combine @Op @(,) @(,)) s === (fmap fst s, fmap snd s) + +-- | The derived combine agrees with the field-wise applicative combine. +referenceP :: Property +referenceP = property $ do + P ma la <- forAll (genP genInt) + P mb lb <- forAll (genP genInt) + combine @(->) @(,) @(,) (P ma la, P mb lb) + === P (liftA2 (,) ma mb) (liftA2 (,) la lb) + +-- | The contravariant combine divides its input across the two predicates. +contravariantTwoPreds :: Property +contravariantTwoPreds = property $ do + n1 <- forAll genInt + n2 <- forAll genInt + n3 <- forAll genInt + n4 <- forAll genInt + let TwoPreds f g = + combine @(->) @(,) @(,) + ( TwoPreds (Predicate (> n1)) (Predicate (> n2)), + TwoPreds (Predicate (> n3)) (Predicate (> n4)) + ) + a <- forAll genInt + b <- forAll genInt + getPredicate f (a, b) === (a > n1 && b > n3) + getPredicate g (a, b) === (a > n2 && b > n4) + +obsTwoPreds :: TwoPreds a -> a -> (Bool, Bool) +obsTwoPreds (TwoPreds p q) a = (getPredicate p a, getPredicate q a) + +-- | The function atom divides its input across the two sinks at the product +-- tensor. +sinkDivide :: Property +sinkDivide = property $ do + m <- forAll genInt + n <- forAll genInt + a <- forAll genInt + b <- forAll genInt + runSink (combine @(->) @(,) @(,) (Sink (\x -> [show (x + m)]), Sink (\x -> [show (x + n)]))) (a, b) + === [show (a + m), show (b + n)] + +-- | At the Either tensor the function atom chooses. +sinkChoose :: Property +sinkChoose = property $ do + m <- forAll genInt + n <- forAll genInt + a <- forAll genInt + let s = combine @(->) @Either @(,) (Sink (\x -> [show (x + m)]), Sink (\x -> [show (x + n)])) + runSink s (Left a) === [show (a + m)] + runSink s (Right a) === [show (a + n)] + +-------------------------------------------------------------------------------- +-- Concrete checks for the tensors the property laws do not cover + +check :: (Eq a, Show a) => String -> a -> a -> IO Bool +check name got want + | got == want = putStrLn ("ok " ++ name) >> pure True + | otherwise = putStrLn ("FAIL " ++ name ++ ": got " ++ show got ++ ", want " ++ show want) >> pure False + +-- | Splice a sublibrary 'Laws' into the hedgehog 'Group', prefixing each of its +-- properties with the instance under test. +labeled :: String -> Laws -> [(PropertyName, Property)] +labeled prefix ls = [(fromString (prefix <> " " <> n), p) | (n, p) <- lawsProperties ls] + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = do + u1 <- + check + "P (Either tensor)" + (combine @(->) @Either @(,) (P (Just 1) [1, 2], P (Just 3) [4])) + (P (Just (Left 1)) [Left 1, Left 2, Right 4] :: P (Either Int Int)) + u2 <- + check + "P (These tensor)" + (combine @(->) @These @(,) (P (Just 1) [1, 2], P (Just 3) [4])) + (P (Just (These 1 3)) [These 1 4, This 2] :: P (These Int Int)) + u3 <- + check + "Nest (nested combine)" + (combine @(->) @(,) @(,) (Nest (Just [1, 2]), Nest (Just [3, 4]))) + (Nest (Just [(1, 3), (1, 4), (2, 3), (2, 4)]) :: Nest (Int, Int)) + u4 <- + check + "P (introduce unit)" + (introduce @(->) @() @() () :: P ()) + (P (Just ()) [()]) + u5 <- + check + "P (introduce Void unit)" + (introduce @(->) @Void @() () :: P Void) + (P Nothing []) + props <- + checkSequential $ + Group "generic-deriving laws" $ + concat + [ -- Covariant Monoidal, product tensor. + labeled "Phantom (,)" (monoidalLaws @(,) @() genPhantom), + labeled "Two (,)" (monoidalLaws @(,) @() genTwo), + labeled "P (,)" (monoidalLaws @(,) @() genP), + labeled "W (,)" (monoidalLaws @(,) @() genW), + labeled "Nest (,)" (monoidalLaws @(,) @() genNest), + labeled "Rec (,)" (monoidalLaws @(,) @() genRec), + labeled "Mix (,)" (monoidalLaws @(,) @() genMix), + -- Covariant Monoidal, Either tensor. + labeled "P Either" (monoidalLaws @Either @Void genP), + labeled "W Either" (monoidalLaws @Either @Void genW), + labeled "Nest Either" (monoidalLaws @Either @Void genNest), + -- Covariant Semigroupal only, These tensor. + labeled "P These" (semigroupalLaws @These genP), + -- Contravariant Monoidal. + labeled "TwoPreds (,)" (contravariantMonoidalLaws @(,) @() genTwoPreds genPairT obsTwoPreds), + labeled "Sink (,)" (contravariantMonoidalLaws @(,) @() genSink genPairT runSink), + labeled "Sink Either" (contravariantMonoidalLaws @Either @Void genSink genEitherT runSink), + -- Op (comonoidal) split, at the '(,)' unzip these generic functors derive. + labeled "Two Op" (opSemigroupalLaws @(,) @(,) genTwo genPairT), + labeled "P Op" (opSemigroupalLaws @(,) @(,) genP genPairT), + labeled "Nest Op" (opSemigroupalLaws @(,) @(,) genNest genPairT), + labeled "S Op" (opSemigroupalLaws @(,) @(,) genS genPairT), + labeled "Sum3 Op" (opSemigroupalLaws @(,) @(,) genSum3 genPairT), + -- Op split / combine coherence, for the representable Two. + labeled "Two" (representableSplitLaws genTwo) + ] + <> [ -- Concrete checks the general laws do not capture. + ("reference P", referenceP), + ("contravariant divide TwoPreds", contravariantTwoPreds), + ("split unzip P", splitLaw @P genP), + ("split unzip Nest", splitLaw @Nest genNest), + ("split unzip S", splitLaw @S genS), + ("split unzip Sum3", splitLaw @Sum3 genSum3), + ("function atom divide Sink", sinkDivide), + ("function atom choose Sink", sinkChoose) + ] + pure (and [u1, u2, u3, u4, u5] && props) diff --git a/test/Data/Functor/Monoidal/LawsSpec.hs b/test/Data/Functor/Monoidal/LawsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Functor/Monoidal/LawsSpec.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Run the exported 'Laws' against known-good library instances, both +-- covariant ('Maybe', @[]@) and contravariant ('Predicate'). This exercises the +-- sublibrary's law statements end-to-end. It includes the variance-agnostic +-- 'Data.Functor.Product.Product' instance, law-checked at both variances from +-- the single delegating instance. @Product Maybe []@ is covariant and @Product +-- Predicate Predicate@ is contravariant. +module Data.Functor.Monoidal.LawsSpec (tests) where + +-------------------------------------------------------------------------------- + +import Data.Functor.Const (Const (..)) +import Data.Functor.Contravariant (Op (..), Predicate (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Monoidal (Semigroupal (..)) +import Data.Functor.Monoidal.Laws + ( contravariantMonoidalLaws, + monoidalLaws, + opSemigroupalLaws, + representableSplitLaws, + semigroupalLaws, + unitalLaws, + ) +import Data.Functor.Product (Product) +import Data.Functor.Product qualified as Product +import Data.Functor.Reverse (Reverse (..)) +import Data.Monoid (Sum (..)) +import Data.String (fromString) +import Data.These (These (..)) +import Data.Void (Void) +import GHC.Generics ((:*:) (..)) +import Hedgehog (Gen, Group (..), Property, PropertyName, checkSequential) +import Hedgehog.Classes (Laws (..), lawsCheck) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Prelude + +-------------------------------------------------------------------------------- + +genInt :: Gen Int +genInt = Gen.int (Range.linear (-100) 100) + +-- Covariant witnesses. + +genMaybe :: Gen a -> Gen (Maybe a) +genMaybe = Gen.maybe + +genList :: Gen a -> Gen [a] +genList = Gen.list (Range.linear 0 4) + +-- Contravariant witness. 'Predicate' is Divisible (at @(,)@) and Decidable (at +-- @Either@). It has no 'Eq' \/ 'Show', so it is observed by running it. + +genPredicate :: Gen (Predicate Int) +genPredicate = (\n -> Predicate (> n)) <$> genInt + +obsPredicate :: Predicate a -> a -> Bool +obsPredicate (Predicate p) = p + +genPairT :: Gen a -> Gen b -> Gen (a, b) +genPairT ga gb = (,) <$> ga <*> gb + +genEitherT :: Gen a -> Gen b -> Gen (Either a b) +genEitherT ga gb = Gen.choice [Left <$> ga, Right <$> gb] + +-- Op (comonoidal) witness: a pair functor whose split is the unzip. + +data Pair a = Pair a a deriving (Functor, Show, Eq) + +instance Semigroupal (->) (,) (,) Pair where + combine (Pair a b, Pair c d) = Pair (a, c) (b, d) + +instance Semigroupal Op (,) (,) Pair where + combine = Op (\(Pair (a, b) (c, d)) -> (Pair a c, Pair b d)) + +genPairF :: Gen a -> Gen (Pair a) +genPairF g = Pair <$> g <*> g + +-- Op witnesses at the other splits. @Semigroupal Op These (,) Maybe@ (the These +-- split, over 'genMaybe') and @Semigroupal Op Either Either Identity@. + +genThese :: Gen a -> Gen b -> Gen (These a b) +genThese ga gb = Gen.choice [This <$> ga, That <$> gb, These <$> ga <*> gb] + +genIdentity :: Gen a -> Gen (Identity a) +genIdentity = fmap Identity + +-- Product witnesses. The single variance-agnostic 'Product' instance, exercised +-- at both variances. It is covariant when its components are ('Maybe', @[]@), +-- compared with 'Eq'. It is contravariant when they are ('Predicate'), observed +-- through @obs@. + +genProductCov :: Gen a -> Gen (Product Maybe [] a) +genProductCov g = Product.Pair <$> genMaybe g <*> genList g + +genProductCon :: Gen (Product Predicate Predicate Int) +genProductCon = Product.Pair <$> genPredicate <*> genPredicate + +obsProductCon :: Product Predicate Predicate a -> a -> (Bool, Bool) +obsProductCon (Product.Pair p q) a = (obsPredicate p a, obsPredicate q a) + +-- Generic product ':*:' (componentwise, like Product), at both variances. + +genGenProdCov :: Gen a -> Gen ((Maybe :*: []) a) +genGenProdCov g = (:*:) <$> genMaybe g <*> genList g + +genGenProdCon :: Gen ((Predicate :*: Predicate) Int) +genGenProdCon = (:*:) <$> genPredicate <*> genPredicate + +obsGenProdCon :: (Predicate :*: Predicate) a -> a -> (Bool, Bool) +obsGenProdCon (p :*: q) a = (obsPredicate p a, obsPredicate q a) + +-- Phantom 'Const'. One instance for every tensor and both variances. Combine is +-- the underlying 'Semigroup'. Compared with 'Eq'. + +genConst :: Gen a -> Gen (Const (Sum Int) a) +genConst _ = Const . Sum <$> genInt + +-- Transparent wrapper 'Reverse' (inherits its component by coercion), both +-- variances. + +genReverseCov :: Gen a -> Gen (Reverse Maybe a) +genReverseCov g = Reverse <$> genMaybe g + +genReverseCon :: Gen (Reverse Predicate Int) +genReverseCon = Reverse <$> genPredicate + +obsReverseCon :: Reverse Predicate a -> a -> Bool +obsReverseCon (Reverse p) a = obsPredicate p a + +-------------------------------------------------------------------------------- + +-- | Splice a sublibrary 'Laws' into the hedgehog 'Group', prefixing each of its +-- properties with the instance under test. +labeled :: String -> Laws -> [(PropertyName, Property)] +labeled prefix ls = [(fromString (prefix <> " " <> n), p) | (n, p) <- lawsProperties ls] + +tests :: IO Bool +tests = do + cov <- + checkSequential $ + Group "Covariant" $ + concat + [ -- Covariant. + labeled "Maybe (,)" (monoidalLaws @(,) @() genMaybe), + labeled "List (,)" (monoidalLaws @(,) @() genList), + labeled "Maybe Either" (monoidalLaws @Either @Void genMaybe), + labeled "List Either" (semigroupalLaws @Either genList), + labeled "List (,)" (unitalLaws @(,) @() genList), + -- Product with covariant components. One delegating instance, both tensors. + labeled "Product (,)" (monoidalLaws @(,) @() genProductCov), + labeled "Product Either" (monoidalLaws @Either @Void genProductCov), + -- Generic product ':*:', phantom 'Const', and transparent wrapper 'Reverse'. + labeled ":*: (,)" (monoidalLaws @(,) @() genGenProdCov), + labeled ":*: Either" (monoidalLaws @Either @Void genGenProdCov), + labeled "Const (,)" (monoidalLaws @(,) @() genConst), + labeled "Const Either" (monoidalLaws @Either @Void genConst), + labeled "Reverse (,)" (monoidalLaws @(,) @() genReverseCov) + ] + con <- + checkSequential $ + Group "Contravariant" $ + concat + [ -- Contravariant. + labeled "Predicate (,)" (contravariantMonoidalLaws @(,) @() genPredicate genPairT obsPredicate), + labeled "Predicate Either" (contravariantMonoidalLaws @Either @Void genPredicate genEitherT obsPredicate), + -- Product with contravariant components. The same instance, other variance. + labeled "Product (,)" (contravariantMonoidalLaws @(,) @() genProductCon genPairT obsProductCon), + labeled "Product Either" (contravariantMonoidalLaws @Either @Void genProductCon genEitherT obsProductCon), + -- Generic product ':*:' and transparent wrapper 'Reverse', contravariant. + labeled ":*: (,)" (contravariantMonoidalLaws @(,) @() genGenProdCon genPairT obsGenProdCon), + labeled ":*: Either" (contravariantMonoidalLaws @Either @Void genGenProdCon genEitherT obsGenProdCon), + labeled "Reverse (,)" (contravariantMonoidalLaws @(,) @() genReverseCon genPairT obsReverseCon), + -- Op split, general in both tensors. '(,)' unzip (Pair), These unalign + -- (Maybe), Either coproduct split (Identity). + labeled "Pair (,)" (opSemigroupalLaws @(,) @(,) genPairF genPairT), + labeled "Maybe These" (opSemigroupalLaws @These @(,) genMaybe genThese), + labeled "Identity Either" (opSemigroupalLaws @Either @Either genIdentity genEitherT), + labeled "Pair" (representableSplitLaws genPairF) + ] + pure (and [cov, con]) diff --git a/test/Data/Functor/Rank2/MonoidalSpec.hs b/test/Data/Functor/Rank2/MonoidalSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Functor/Rank2/MonoidalSpec.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Exercises the generically derived rank-2 'Monoidal' for functor-interpreted +-- HKDs, at all three derivable instantiations: +-- +-- * covariant product (@barbies@' @ApplicativeB@): 'combine' agrees with the +-- field-wise 'Pair'ing (@bprod@) and 'introduce' fills every field with +-- 'Proxy' (@bpure Proxy@); +-- * coproduct: 'combine' injects a whole record all-'InL' or all-'InR'; +-- * oplax product: 'combine' unzips a record of 'Pair's, and is inverse to the +-- covariant product 'combine'. +-- +-- The covariant product also gets a laws pass (associativity, both unit laws, +-- and naturality), stated through @kindly-functors@' rank-2 'bmap1' with +-- associators and unitors written inline. This doubles as an interop check that +-- 'combine' commutes with 'bmap1'. The associators/unitors would collapse into +-- the shared "Data.Functor.Monoidal.Laws" machinery once the @Nat@-category +-- 'Control.Category.Tensor.Tensor' instances for 'Product' exist. +module Data.Functor.Rank2.MonoidalSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Category.LawsSupport (genInt) +import Data.Functor.Contravariant (Op (..), getOp) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Product (Product (..)) +import Data.Functor.Rank2.Monoidal (Monoidal, Semigroupal (..), Unital (..), gcombineSum, gcombineThese, gsplitProduct) +import Data.Functor.Sum (Sum (..)) +import Data.Functor.These (These1 (..)) +import Data.Kind (Type) +import Data.Maybe (listToMaybe, maybeToList) +import Data.Proxy (Proxy (..)) +import Data.These (These (..)) +import Data.Void (Void, absurd) +import GHC.Generics (Generic, V1) +import Hedgehog (Gen, Group (..), Property, checkSequential, forAll, property, withTests, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Kindly (CategoricalFunctor (..), Nat (..), bmap1, type (~>)) +import Prelude hiding (map) + +-------------------------------------------------------------------------------- +-- Test types + +-- | A three-field record. Exercises @K1@, @M1@, and nested @:*:@. +data TestHKD f = TestHKD + { thInt :: f Int, + thBool :: f Bool, + thString :: f String + } + deriving stock (Generic) + +instance Semigroupal (->) Product (,) TestHKD + +instance Unital (->) Proxy () TestHKD + +instance Monoidal (->) Product Proxy (,) () TestHKD + +instance Semigroupal (->) Sum Either TestHKD where combine = gcombineSum + +instance Unital (->) V1 Void TestHKD where introduce = absurd + +instance Monoidal (->) Sum V1 Either Void TestHKD + +instance Semigroupal (->) These1 These TestHKD where combine = gcombineThese + +instance Monoidal (->) These1 V1 These Void TestHKD + +instance Semigroupal Op Product (,) TestHKD where combine = Op gsplitProduct + +instance Unital Op Proxy () TestHKD where introduce = Op (const ()) + +instance Monoidal Op Product Proxy (,) () TestHKD + +-- | 'TestHKD' as a @kindly-functors@ rank-2 functor, so the law properties can +-- map interpretations through it with 'bmap1'. +instance CategoricalFunctor TestHKD where + type Dom TestHKD = (->) ~> (->) + type Cod TestHKD = (->) + map (Nat nt) (TestHKD a b c) = TestHKD (nt a) (nt b) (nt c) + +deriving stock instance (Show (f Int), Show (f Bool), Show (f String)) => Show (TestHKD f) + +deriving stock instance (Eq (f Int), Eq (f Bool), Eq (f String)) => Eq (TestHKD f) + +-- | A nullary constructor. Exercises @U1@ and the unit path. +data EmptyHKD (f :: Type -> Type) = EmptyHKD + deriving stock (Generic, Show, Eq) + +instance Semigroupal (->) Product (,) EmptyHKD + +instance Unital (->) Proxy () EmptyHKD + +instance Monoidal (->) Product Proxy (,) () EmptyHKD + +instance Semigroupal (->) Sum Either EmptyHKD where combine = gcombineSum + +instance Unital (->) V1 Void EmptyHKD where introduce = absurd + +instance Monoidal (->) Sum V1 Either Void EmptyHKD + +instance Semigroupal (->) These1 These EmptyHKD where combine = gcombineThese + +instance Monoidal (->) These1 V1 These Void EmptyHKD + +-------------------------------------------------------------------------------- +-- Monomorphic call sites (fix @cat@, @tC@, @tD@ for the derived instances). + +combineHKD :: TestHKD f -> TestHKD g -> TestHKD (Product f g) +combineHKD x y = combine @(->) @Product @(,) (x, y) + +introduceHKD :: TestHKD Proxy +introduceHKD = introduce @(->) @Proxy @() () + +combineSumHKD :: Either (TestHKD f) (TestHKD g) -> TestHKD (Sum f g) +combineSumHKD = combine @(->) @Sum @Either + +combineTheseHKD :: These (TestHKD f) (TestHKD g) -> TestHKD (These1 f g) +combineTheseHKD = combine @(->) @These1 @These + +splitHKD :: TestHKD (Product f g) -> (TestHKD f, TestHKD g) +splitHKD = getOp (combine @Op @Product @(,)) + +-- | The reference for the covariant product 'combine': field-wise 'Pair'. +refCombine :: TestHKD f -> TestHKD g -> TestHKD (Product f g) +refCombine (TestHKD a b c) (TestHKD a' b' c') = + TestHKD (Pair a a') (Pair b b') (Pair c c') + +-- | The reference for the coproduct 'combine': every field on one side. +refCombineSum :: Either (TestHKD f) (TestHKD g) -> TestHKD (Sum f g) +refCombineSum (Left (TestHKD a b c)) = TestHKD (InL a) (InL b) (InL c) +refCombineSum (Right (TestHKD a b c)) = TestHKD (InR a) (InR b) (InR c) + +-- | The reference for the These 'combine': every field follows the outer 'These'. +refCombineThese :: These (TestHKD f) (TestHKD g) -> TestHKD (These1 f g) +refCombineThese (This (TestHKD a b c)) = TestHKD (This1 a) (This1 b) (This1 c) +refCombineThese (That (TestHKD a b c)) = TestHKD (That1 a) (That1 b) (That1 c) +refCombineThese (These (TestHKD a b c) (TestHKD a' b' c')) = + TestHKD (These1 a a') (These1 b b') (These1 c c') + +-------------------------------------------------------------------------------- +-- Associators and unitors for the 'Product' tensor on the functor category. +-- These stand in for the (as yet unwritten) @Nat@-category 'Tensor' instances. + +-- | 'Product'\'s action on morphisms (the functor-category bifunctor). +prodNat :: + (forall x. f x -> f' x) -> + (forall x. g x -> g' x) -> + Product f g a -> + Product f' g' a +prodNat l r (Pair p q) = Pair (l p) (r q) + +-- | The associator of 'Product' on the functor category. +assocProd :: Product f (Product g h) a -> Product (Product f g) h a +assocProd (Pair a (Pair b c)) = Pair (Pair a b) c + +-- | The right unitor: 'Proxy' is the unit of 'Product'. +runitProd :: Product f Proxy a -> f a +runitProd (Pair a _) = a + +-- | The left unitor. +lunitProd :: Product Proxy f a -> f a +lunitProd (Pair _ a) = a + +-------------------------------------------------------------------------------- +-- Generators + +genString :: Gen String +genString = Gen.string (Range.linear 0 5) Gen.alpha + +-- | Build a 'TestHKD' generator from a per-field wrapper. +genHKD :: (forall a. Gen a -> Gen (f a)) -> Gen (TestHKD f) +genHKD f = TestHKD <$> f genInt <*> f Gen.bool <*> f genString + +genMaybeHKD :: Gen (TestHKD Maybe) +genMaybeHKD = genHKD Gen.maybe + +genListHKD :: Gen (TestHKD []) +genListHKD = genHKD (Gen.list (Range.linear 0 3)) + +genIdentityHKD :: Gen (TestHKD Identity) +genIdentityHKD = genHKD (fmap Identity) + +genProductHKD :: Gen (TestHKD (Product Maybe [])) +genProductHKD = genHKD (\g -> Pair <$> Gen.maybe g <*> Gen.list (Range.linear 0 3) g) + +-- | A 'These' generator that hits all three cases. +genTheseHKD :: Gen (These (TestHKD Maybe) (TestHKD [])) +genTheseHKD = + Gen.choice + [ This <$> genMaybeHKD, + That <$> genListHKD, + These <$> genMaybeHKD <*> genListHKD + ] + +-------------------------------------------------------------------------------- +-- Covariant product: agreement with the reference + +-- | 'combine' agrees with the hand-written field-wise 'Pair' (@bprod@). +combineAgreesWithRef :: Property +combineAgreesWithRef = property $ do + x <- forAll genMaybeHKD + y <- forAll genListHKD + combineHKD x y === refCombine x y + +-- | 'combine' at a homogeneous interpretation also agrees with the reference. +combineAgreesWithRefHomogeneous :: Property +combineAgreesWithRefHomogeneous = property $ do + x <- forAll genIdentityHKD + y <- forAll genIdentityHKD + combineHKD x y === refCombine x y + +-- | 'introduce' fills every field with 'Proxy' (@bpure Proxy@). +introduceIsAllProxy :: Property +introduceIsAllProxy = withTests 1 $ property $ do + introduceHKD === TestHKD Proxy Proxy Proxy + +-------------------------------------------------------------------------------- +-- Covariant product: monoidal laws (via kindly's rank-2 'bmap1') + +-- | Naturality: 'combine' commutes with maps into either tensor position. +-- Doubles as the interop check that 'combine' commutes with 'bmap1'. +naturalityLaw :: Property +naturalityLaw = property $ do + x <- forAll genMaybeHKD + y <- forAll genListHKD + bmap1 (prodNat maybeToList listToMaybe) (combineHKD x y) + === combineHKD (bmap1 maybeToList x) (bmap1 listToMaybe y) + +-- | Associativity: reassociating the domain 'Product' turns the right-nested +-- 'combine' into the left-nested one. +associativityLaw :: Property +associativityLaw = property $ do + x <- forAll genMaybeHKD + y <- forAll genListHKD + z <- forAll genIdentityHKD + bmap1 assocProd (combineHKD x (combineHKD y z)) + === combineHKD (combineHKD x y) z + +-- | Right unit: combining with @'introduce' ()@ and projecting recovers the record. +rightUnitLaw :: Property +rightUnitLaw = property $ do + x <- forAll genMaybeHKD + bmap1 runitProd (combineHKD x introduceHKD) === x + +-- | Left unit: the mirror of 'rightUnitLaw'. +leftUnitLaw :: Property +leftUnitLaw = property $ do + x <- forAll genMaybeHKD + bmap1 lunitProd (combineHKD introduceHKD x) === x + +-------------------------------------------------------------------------------- +-- Coproduct + +-- | Injecting on the left sends every field to 'InL'. +coproductInjectsLeft :: Property +coproductInjectsLeft = property $ do + x <- forAll genMaybeHKD + let e = Left x :: Either (TestHKD Maybe) (TestHKD []) + combineSumHKD e === refCombineSum e + +-- | Injecting on the right sends every field to 'InR'. +coproductInjectsRight :: Property +coproductInjectsRight = property $ do + y <- forAll genListHKD + let e = Right y :: Either (TestHKD Maybe) (TestHKD []) + combineSumHKD e === refCombineSum e + +-------------------------------------------------------------------------------- +-- These + +-- | 'combine' at the 'These1' tensor follows the outer 'These' field-wise, +-- across all three cases. +theseAgreesWithRef :: Property +theseAgreesWithRef = property $ do + e <- forAll genTheseHKD + combineTheseHKD e === refCombineThese e + +-------------------------------------------------------------------------------- +-- Oplax product (split) + +-- | Split then combine is the identity (product iso, one direction). +splitAfterCombine :: Property +splitAfterCombine = property $ do + x <- forAll genMaybeHKD + y <- forAll genListHKD + splitHKD (combineHKD x y) === (x, y) + +-- | Combine then split is the identity (product iso, other direction). +combineAfterSplit :: Property +combineAfterSplit = property $ do + z <- forAll genProductHKD + uncurry combineHKD (splitHKD z) === z + +-------------------------------------------------------------------------------- +-- Field-less record + +-- | The field-less record is handled by the @U1@ path at every instantiation. +emptyRecord :: Property +emptyRecord = withTests 1 $ property $ do + combine @(->) @Product @(,) (EmptyHKD :: EmptyHKD Maybe, EmptyHKD :: EmptyHKD []) === EmptyHKD + introduce @(->) @Proxy @() () === (EmptyHKD :: EmptyHKD Proxy) + combine @(->) @Sum @Either (Left EmptyHKD :: Either (EmptyHKD Maybe) (EmptyHKD [])) === EmptyHKD + combine @(->) @These1 @These (These EmptyHKD EmptyHKD :: These (EmptyHKD Maybe) (EmptyHKD [])) === EmptyHKD + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = + checkSequential $ + Group + "Data.Functor.Rank2.Monoidal" + [ ("combine agrees with reference (Maybe/[])", combineAgreesWithRef), + ("combine agrees with reference (Identity)", combineAgreesWithRefHomogeneous), + ("introduce is all Proxy", introduceIsAllProxy), + ("naturality (combine commutes with bmap1)", naturalityLaw), + ("associativity", associativityLaw), + ("right unit", rightUnitLaw), + ("left unit", leftUnitLaw), + ("coproduct injects left", coproductInjectsLeft), + ("coproduct injects right", coproductInjectsRight), + ("these follows outer These", theseAgreesWithRef), + ("split . combine = id", splitAfterCombine), + ("combine . split = id", combineAfterSplit), + ("empty record at every instantiation", emptyRecord) + ] diff --git a/test/Data/Functor/Rank2/TraversableSpec.hs b/test/Data/Functor/Rank2/TraversableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Functor/Rank2/TraversableSpec.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Exercises the generically derived rank-2 'Rank2.Traversable' for +-- functor-interpreted HKDs. At a covariant 'Applicative' interpretation +-- (@cat ~ (->)@) 'Rank2.sequence' must agree with the hand-written applicative +-- traversal, respect the 'Identity' law, and commute with applicative +-- homomorphisms. At a contravariant 'Predicate' interpretation (@cat ~ Op@, +-- 'Divisible') it must conjoin the field predicates. +module Data.Functor.Rank2.TraversableSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Category.LawsSupport (genInt) +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Contravariant (Predicate (..)) +import Data.Functor.Identity (Identity (..)) +import Data.Functor.Monoidal (Monoidal) +import Data.Functor.Rank2.Traversable qualified as Rank2 +import Data.Kind (Type) +import Data.Maybe (maybeToList) +import GHC.Generics (Generic) +import Hedgehog (Gen, Group (..), Property, checkSequential, forAll, property, withTests, (===)) +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import Kindly qualified +import Prelude + +-------------------------------------------------------------------------------- +-- Test types + +-- | A three-field record. Exercises @K1@, @M1@, and nested @:*:@. +data TestHKD f = TestHKD + { thInt :: f Int, + thBool :: f Bool, + thString :: f String + } + deriving stock (Generic) + deriving anyclass (Rank2.Traversable) + +deriving stock instance (Show (f Int), Show (f Bool), Show (f String)) => Show (TestHKD f) + +deriving stock instance (Eq (f Int), Eq (f Bool), Eq (f String)) => Eq (TestHKD f) + +-- | A nullary constructor. Exercises @U1@ and the 'introduce' path. +data EmptyHKD (f :: Type -> Type) = EmptyHKD + deriving stock (Generic, Show, Eq) + deriving anyclass (Rank2.Traversable) + +-- | The reference: sequencing an HKD through an 'Applicative' is the +-- field-wise applicative traversal, left to right. +refSequence :: (Applicative f) => TestHKD f -> f (TestHKD Identity) +refSequence (TestHKD a b c) = + (\x y z -> TestHKD (Identity x) (Identity y) (Identity z)) <$> a <*> b <*> c + +-------------------------------------------------------------------------------- +-- Generators + +genString :: Gen String +genString = Gen.string (Range.linear 0 5) Gen.alpha + +-- | Build a 'TestHKD' generator from a per-field wrapper. +genHKD :: (forall a. Gen a -> Gen (f a)) -> Gen (TestHKD f) +genHKD f = TestHKD <$> f genInt <*> f Gen.bool <*> f genString + +genIdentityHKD :: Gen (TestHKD Identity) +genIdentityHKD = genHKD (fmap Identity) + +genMaybeHKD :: Gen (TestHKD Maybe) +genMaybeHKD = genHKD Gen.maybe + +genListHKD :: Gen (TestHKD []) +genListHKD = genHKD (Gen.list (Range.linear 0 3)) + +genComposeHKD :: Gen (TestHKD (Compose Maybe [])) +genComposeHKD = genHKD (fmap Compose . Gen.maybe . Gen.list (Range.linear 0 3)) + +-------------------------------------------------------------------------------- +-- Properties + +-- | Sequencing at 'Identity' is 'Identity'. +identityLaw :: Property +identityLaw = property $ do + hkd <- forAll genIdentityHKD + Rank2.sequence hkd === Identity hkd + +-- | Agreement with the reference traversal at a given interpretation. +agreesWithRef :: + ( Applicative f, + Kindly.Functor (->) f, + Monoidal (->) (,) () (,) () f, + Show (f Int), + Show (f Bool), + Show (f String), + Eq (f (TestHKD Identity)), + Show (f (TestHKD Identity)) + ) => + Gen (TestHKD f) -> + Property +agreesWithRef gen = property $ do + hkd <- forAll gen + Rank2.sequence hkd === refSequence hkd + +-- | 'maybeToList' is an applicative homomorphism, so sequencing must commute +-- with it (naturality). +naturality :: Property +naturality = property $ do + hkd <- forAll genMaybeHKD + let hoist (TestHKD a b c) = TestHKD (maybeToList a) (maybeToList b) (maybeToList c) + maybeToList (Rank2.sequence hkd) === Rank2.sequence (hoist hkd) + +-- | A field-less record sequences to 'pure' via 'introduce'. +emptySequencesToPure :: Property +emptySequencesToPure = withTests 1 $ property $ do + Rank2.sequence (EmptyHKD :: EmptyHKD Maybe) === Just EmptyHKD + Rank2.sequence (EmptyHKD :: EmptyHKD []) === [EmptyHKD] + +-------------------------------------------------------------------------------- +-- Contravariant interpretation + +-- | The reference for the contravariant 'Predicate' interpretation: sequencing +-- a record of per-field predicates through 'Divisible' conjoins them, so the +-- whole record passes iff every field's predicate passes on its own value. +refPredicate :: TestHKD Predicate -> Predicate (TestHKD Identity) +refPredicate (TestHKD pInt pBool pString) = + Predicate $ \(TestHKD (Identity i) (Identity b) (Identity s)) -> + getPredicate pInt i && getPredicate pBool b && getPredicate pString s + +-- | 'Rank2.sequence' at the contravariant 'Predicate' interpretation +-- (@cat ~ Op@, 'Divisible') must agree with the conjunction reference. +-- Predicates have no 'Eq', so they are compared extensionally by observing +-- them on a generated record. The predicate parameters are generated (rather +-- than the predicates themselves) so 'forAll' has something to show. +agreesWithRefPredicate :: Property +agreesWithRefPredicate = property $ do + n <- forAll genInt + b <- forAll Gen.bool + k <- forAll (Gen.int (Range.linear 0 5)) + input <- forAll genIdentityHKD + let preds = TestHKD (Predicate (< n)) (Predicate (== b)) (Predicate ((<= k) . length)) + getPredicate (Rank2.sequence preds) input === getPredicate (refPredicate preds) input + +-- | A field-less record sequences to 'conquer', the always-true predicate. +emptyPredicateIsConquer :: Property +emptyPredicateIsConquer = withTests 1 $ property $ do + getPredicate (Rank2.sequence (EmptyHKD :: EmptyHKD Predicate)) EmptyHKD === True + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = + checkSequential $ + Group + "Data.Functor.Rank2.Traversable" + [ ("identity law", identityLaw), + ("agrees with reference (Maybe)", agreesWithRef genMaybeHKD), + ("agrees with reference ([])", agreesWithRef genListHKD), + ("agrees with reference (Compose Maybe [])", agreesWithRef genComposeHKD), + ("naturality of maybeToList", naturality), + ("empty record sequences to pure", emptySequencesToPure), + ("agrees with reference (Predicate)", agreesWithRefPredicate), + ("empty record is conquer (Predicate)", emptyPredicateIsConquer) + ] diff --git a/test/Data/Trifunctor/Rank2/TraversableSpec.hs b/test/Data/Trifunctor/Rank2/TraversableSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Trifunctor/Rank2/TraversableSpec.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Exercises the generically derived rank-2 'Rank2.Traversable' for +-- trifunctor-interpreted HKDs. No monoidal trifunctor instances ship with the +-- library yet, so the spec defines 'Shear', a minimal inhabitant of +-- @'Kindly.Trifunctor' (->) 'Op' (->)@ that is monoidal with respect to +-- tupling. Sequencing a record of @p a b c@ fields yields +-- @p (hkd 'Rank2.First') (hkd 'Rank2.Second') (hkd 'Rank2.Third')@, which +-- must act field-wise. +module Data.Trifunctor.Rank2.TraversableSpec (tests) where + +-------------------------------------------------------------------------------- + +import Control.Category.LawsSupport (genInt) +import Data.Functor.Contravariant (Op (..)) +import Data.Kind (Type) +import Data.Trifunctor.Monoidal (Monoidal, Semigroupal (..), Unital (..)) +import Data.Trifunctor.Rank2.Traversable qualified as Rank2 +import GHC.Generics (Generic) +import Hedgehog (Group (..), Property, checkSequential, forAll, property, withTests, (===)) +import Hedgehog.Gen qualified as Gen +import Kindly (CategoricalFunctor (..), Nat (..), type (~>)) +import Prelude + +-------------------------------------------------------------------------------- + +-- | The minimal trifunctor of variance @(covariant, contravariant, covariant)@ +-- that is monoidal with respect to tupling: consume a @b@, produce an @a@ and +-- a @c@. +type Shear :: Type -> Type -> Type -> Type +newtype Shear a b c = Shear {runShear :: b -> (a, c)} + +instance Functor (Shear a b) where + fmap :: (c -> c') -> Shear a b c -> Shear a b c' + fmap f (Shear g) = Shear (fmap f . g) + +instance CategoricalFunctor (Shear a b) where + type Dom (Shear a b) = (->) + type Cod (Shear a b) = (->) + + map :: (c -> c') -> Shear a b c -> Shear a b c' + map = fmap + +instance CategoricalFunctor (Shear a) where + type Dom (Shear a) = Op + type Cod (Shear a) = (->) ~> (->) + + map :: Op b b' -> ((->) ~> (->)) (Shear a b) (Shear a b') + map (Op f) = Nat (\(Shear g) -> Shear (g . f)) + +instance CategoricalFunctor Shear where + type Dom Shear = (->) + type Cod Shear = Op ~> (->) ~> (->) + + map :: (a -> a') -> (Op ~> (->) ~> (->)) (Shear a) (Shear a') + map f = Nat (Nat (\(Shear g) -> Shear (\b -> let (x, c) = g b in (f x, c)))) + +instance Semigroupal (->) (,) (,) (,) (,) Shear where + combine :: (Shear x y z, Shear x' y' z') -> Shear (x, x') (y, y') (z, z') + combine (Shear f, Shear g) = Shear $ \(y, y') -> + let (x, z) = f y + (x', z') = g y' + in ((x, x'), (z, z')) + +instance Unital (->) () () () () Shear where + introduce :: () -> Shear () () () + introduce () = Shear (\() -> ((), ())) + +instance Monoidal (->) (,) () (,) () (,) () (,) () Shear + +-------------------------------------------------------------------------------- +-- Test types + +-- | A three-field record of trifunctor values. Exercises @K1@, @M1@, and +-- nested @:*:@. +data TestHKD p = TestHKD + { thOne :: p Int Bool Char, + thTwo :: p String Int Bool, + thThree :: p Bool Char Int + } + deriving stock (Generic) + deriving anyclass (Rank2.Traversable) + +deriving stock instance (Show (p Int Bool Char), Show (p String Int Bool), Show (p Bool Char Int)) => Show (TestHKD p) + +deriving stock instance (Eq (p Int Bool Char), Eq (p String Int Bool), Eq (p Bool Char Int)) => Eq (TestHKD p) + +-- | A nullary constructor. Exercises @U1@ and the 'introduce' path. +data EmptyHKD (p :: Type -> Type -> Type -> Type) = EmptyHKD + deriving stock (Generic, Show, Eq) + deriving anyclass (Rank2.Traversable) + +-------------------------------------------------------------------------------- +-- Properties + +-- | Sequencing a record of shears gives a shear between records that applies +-- each field pointwise, splitting the 'Rank2.Second' inputs into +-- 'Rank2.First' and 'Rank2.Third' outputs. +shearActsFieldwise :: Property +shearActsFieldwise = property $ do + n <- forAll genInt + m <- forAll genInt + let f b = (n + fromEnum b, if b then 'T' else 'F') + g i = (show (i + m), even i) + h c = (c > 'j', fromEnum c + m) + hkd = TestHKD (Shear f) (Shear g) (Shear h) + b <- forAll Gen.bool + i <- forAll genInt + c <- forAll Gen.alpha + let (firsts, thirds) = runShear (Rank2.sequence hkd) (TestHKD (Rank2.Second b) (Rank2.Second i) (Rank2.Second c)) + firsts === TestHKD (Rank2.First (fst (f b))) (Rank2.First (fst (g i))) (Rank2.First (fst (h c))) + thirds === TestHKD (Rank2.Third (snd (f b))) (Rank2.Third (snd (g i))) (Rank2.Third (snd (h c))) + +-- | A field-less record sequences to the unit shear via 'introduce'. +emptySequencesToUnit :: Property +emptySequencesToUnit = withTests 1 $ property $ do + runShear (Rank2.sequence (EmptyHKD :: EmptyHKD Shear)) EmptyHKD === (EmptyHKD, EmptyHKD) + +-------------------------------------------------------------------------------- + +tests :: IO Bool +tests = + checkSequential $ + Group + "Data.Trifunctor.Rank2.Traversable" + [ ("shear sequencing acts field-wise", shearActsFieldwise), + ("empty record sequences to unit", emptySequencesToUnit) + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,36 @@ +-- | Test driver. Runs the generic-deriving suite, the rank-2 traversable +-- specs, and the laws sublibrary self-test, and fails if any does. +module Main (main) where + +import Control.Category.CartesianSpec qualified as CartesianSpec +import Control.Category.TensorSpec qualified as TensorSpec +import Control.Monad (unless) +import Data.Bifunctor.Monoidal.LawsSpec qualified as BifunctorLawsSpec +import Data.Bifunctor.Rank2.MonoidalSpec qualified as BifunctorMonoidalSpec +import Data.Bifunctor.Rank2.TraversableSpec qualified as BifunctorTraversableSpec +import Data.Functor.Monoidal.GenericSpec qualified as GenericSpec +import Data.Functor.Monoidal.LawsSpec qualified as LawsSpec +import Data.Functor.Rank2.MonoidalSpec qualified as FunctorMonoidalSpec +import Data.Functor.Rank2.TraversableSpec qualified as FunctorTraversableSpec +import Data.Trifunctor.Rank2.TraversableSpec qualified as TrifunctorTraversableSpec +import System.Exit (exitFailure) +import Prelude + +-------------------------------------------------------------------------------- + +main :: IO () +main = do + results <- + sequence + [ putStrLn "=== Control.Category.Tensor laws ===" *> TensorSpec.tests, + putStrLn "=== Control.Category.Cartesian laws ===" *> CartesianSpec.tests, + putStrLn "=== bifunctor monoidal laws ===" *> BifunctorLawsSpec.tests, + putStrLn "=== generic deriving ===" *> GenericSpec.tests, + putStrLn "=== rank-2 traversable ===" *> FunctorTraversableSpec.tests, + putStrLn "=== rank-2 monoidal ===" *> FunctorMonoidalSpec.tests, + BifunctorMonoidalSpec.tests, + BifunctorTraversableSpec.tests, + TrifunctorTraversableSpec.tests, + putStrLn "=== laws sublibrary self-test ===" *> LawsSpec.tests + ] + unless (and results) exitFailure