packages feed

monoidal-functors (empty) → 0.1.0.0

raw patch · 14 files changed

+898/−0 lines, 14 filesdep +basedep +bifunctorsdep +comonadsetup-changed

Dependencies added: base, bifunctors, comonad, contravariant, profunctors, semigroupoids, tagged, these

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for monoidal-functors++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,7 @@+Copyright © 2021 Solomon Bothwell and Asad Saeeduddin++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ monoidal-functors.cabal view
@@ -0,0 +1,70 @@+cabal-version:       2.4+name:                monoidal-functors+category:            Control, Categories+version:             0.1.0.0+license:             MIT+license-file:        LICENSE+author:              Solomon Bothwell & Asad Saeeduddin+maintainer:          ssbothwell@gmail.com+stability:           experimental+homepage:            http://github.com/ssbothwell/monoidal-functors+build-type:          Simple+extra-source-files:  CHANGELOG.md+description:+  A typeclass hierarchy for monoidal functors.++library+  build-depends:+      base           >= 4.12    && < 5+    -- , base-orphans  ^>= 0.8.4+    , bifunctors+    , comonad+    , contravariant+    , profunctors+    , semigroupoids+    , tagged+    , these+    -- , transformers  ^>= 0.5++  exposed-modules:+    Control.Category.Tensor+    Data.Bifunctor.BiInvariant+    Data.Bifunctor.Module+    Data.Bifunctor.Monoidal+    Data.Bifunctor.Monoidal.Specialized+    Data.Functor.Invariant+    Data.Functor.Module+    Data.Functor.Monoidal+    Data.Trifunctor.Module+    Data.Trifunctor.Monoidal++  ghc-options: -Wall -O2 -Wno-trustworthy-safe -Wno-star-is-type++  if impl(ghc >= 9.0)+    -- these flags may abort compilation with GHC-8.10+    -- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/3295+    ghc-options: -Winferred-safe-imports -Wmissing-safe-haskell-mode++  hs-source-dirs:  src++  default-language: Haskell2010++  default-extensions: ConstraintKinds+                      DeriveFunctor+                      DerivingVia+                      FunctionalDependencies+                      FlexibleInstances+                      FlexibleContexts+                      GeneralizedNewtypeDeriving+                      InstanceSigs+                      KindSignatures+                      LambdaCase+                      MultiParamTypeClasses+                      NoImplicitPrelude+                      QuantifiedConstraints+                      RankNTypes+                      ScopedTypeVariables+                      StandaloneDeriving+                      TypeApplications+                      TypeOperators+                      UndecidableInstances
+ src/Control/Category/Tensor.hs view
@@ -0,0 +1,220 @@+{-# LANGUAGE MonoLocalBinds #-}+module Control.Category.Tensor where++import Prelude hiding (id)+import Control.Applicative+import Control.Category (Category, id)+import Data.Biapplicative+import Data.Functor.Contravariant+import Data.Profunctor+import Data.These+import Data.Void++{-++| Tensor | Unit |++--------|------++| Either | Void |+|  (,)   |  ()  |+| These  | Void |++tensor = monoidal structure =+    category+  + bifunctor on that category `t`+  + unit object in that category `i`+  + isomorphisms in that category `t i a <-> a`, `t a i <-> a`, `t a (t b c) <-> t (t a b) c`+  + some equalities++monoidal functor = a functor that goes between the underlying+categories of two different monoidal structure, and has a pair of+operations `t2 (f a) (f b) -> f (t1 a b)` and `i2 -> f i1`++-}++class (Category cat1, Category cat2) => GBifunctor cat1 cat2 r t | t r -> cat1 cat2 where+  gbimap :: a `cat1` b -> c `cat2` d -> t a c `r` t b d++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 GBifunctor (->) (->) (->) (,) where+  gbimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)+  gbimap f g = bimap f g++instance GBifunctor (->) (->) (->) Either where+  gbimap :: (a -> b) -> (c -> d) -> Either a c -> Either b d+  gbimap f g = bimap f g++instance GBifunctor (->) (->) (->) These where+  gbimap :: (a -> b) -> (c -> d) -> These a c -> These b d+  gbimap f g = bimap f g++instance GBifunctor (Star Maybe) (Star Maybe) (Star Maybe) These where+  gbimap :: Star Maybe a b -> Star Maybe c d -> Star Maybe (These a c) (These b d)+  gbimap (Star f) (Star g) =+    Star $ \case+      This a -> This <$> f a+      That c -> That <$> g c+      These a c -> liftA2 These (f a) (g c)++grmap :: GBifunctor cat1 cat2 r t => c `cat2` d -> t a c `r` t a d+grmap = gbimap id++glmap :: GBifunctor cat1 cat2 r t => a `cat1` b -> t a c `r` t b c+glmap = flip gbimap id++data Iso cat a b = Iso { fwd :: a `cat` b, bwd :: b `cat` a }++class (Category cat, GBifunctor cat cat cat t) => Associative t cat where+  assoc :: Iso cat (a `t` (b `t` c)) ((a `t` b) `t` c)++instance Associative t (->) => Associative t Op where+  assoc :: Iso Op (t a (t b c)) (t (t a b) c)+  assoc = Iso+    { fwd = Op $ bwd assoc+    , bwd = Op $ fwd assoc+    }++instance (Monad m, Associative t (->), GBifunctor (Star m) (Star m) (Star m) t) => Associative t (Star m) where+  assoc :: Iso (Star m) (t a (t b c)) (t (t a b) c)+  assoc = Iso+    { fwd = (`rmap` id) (fwd assoc)+    , bwd = (`rmap` id) (bwd assoc)+    }++instance Associative (,) (->) where+  assoc :: Iso (->) (a, (b, c)) ((a, b), c)+  assoc = Iso+    { fwd = \(a, (b, c)) -> ((a, b), c)+    , bwd = \((a, b), c) -> (a, (b, c))+    }++instance Associative Either (->) where+  assoc :: Iso (->) (Either a (Either b c)) (Either (Either a b) c)+  assoc = Iso+    { fwd = either (Left . Left) (either (Left . Right) Right)+    , bwd = either (fmap Left) (Right . Right)+    }++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)+    }++class Associative t cat => Tensor t i cat | t -> i where+  lunit :: Iso cat (t i a) a+  runit :: Iso cat (t a i) a++instance (Tensor t i (->)) => Tensor t i Op where+  lunit :: Iso Op (t i a) a+  lunit = Iso+    { fwd = Op $ bwd lunit+    , bwd = Op $ fwd lunit+    }++  runit :: Iso Op (t a i) a+  runit = Iso+    { fwd = Op $ bwd runit+    , bwd = Op $ fwd runit+    }++instance (Monad m, Tensor t i (->), Associative t (Star m)) => Tensor t i (Star m) where+  lunit :: Iso (Star m) (t i a) a+  lunit = Iso+    { fwd = (`rmap` id) (fwd lunit)+    , bwd = (`rmap` id) (bwd lunit)+    }++  runit = Iso+    { fwd = (`rmap` id) (fwd runit)+    , bwd = (`rmap` id) (bwd runit)+    }++instance Tensor (,) () (->) where+  lunit :: Iso (->) ((), a) a+  lunit = Iso+    { fwd = snd+    , bwd = bipure ()+    }++  runit :: Iso (->) (a, ()) a+  runit = Iso+    { fwd = fst+    , bwd = (`bipure` ())+    }++instance Tensor Either Void (->) where+  lunit :: Iso (->) (Either Void a) a+  lunit = Iso+     { fwd = either absurd id+     , bwd = pure+     }++  runit :: Iso (->) (Either a Void) a+  runit = Iso+    { fwd = either id absurd+    , bwd = Left+    }++instance Tensor These Void (->) where+  lunit :: Iso (->) (These Void a) a+  lunit = Iso+    { fwd = these absurd id (\ _ x -> x)+    , bwd = That+    }++  runit :: Iso (->) (These a Void) a+  runit = Iso+    { fwd = these id absurd const+    , bwd = This+    }++class Associative t cat => Symmetric t cat where+  swap :: t a b `cat` t b a++instance (Symmetric t (->)) => Symmetric t Op where+  swap :: Op (t a b) (t b a)+  swap = Op swap++instance (Monad m, Symmetric t (->), Associative t (Star m)) => Symmetric t (Star m) where+  swap :: Star m (t a b) (t b a)+  swap = Star $ pure . swap++instance Symmetric (,) (->) where+  swap :: (a, b) -> (b, a)+  swap (a, b) = (b, a)++instance Symmetric Either (->) where+  swap :: Either a b -> Either b a+  swap = either Right Left++instance Symmetric These (->) where+  swap :: These a b -> These b a+  swap = these That This (flip These)++class (Symmetric t cat, Tensor t i cat) => Cartesian t i cat | i -> t, t -> i where+  diagonal :: a `cat` t a a+  terminal :: a `cat` i++instance Cartesian (,) () (->) where+  diagonal :: a -> (a , a)+  diagonal = dup++  terminal :: a -> ()+  terminal = const ()++instance Cartesian Either Void Op where+  diagonal :: Op a (Either a a)+  diagonal = Op merge++  terminal :: Op a Void+  terminal = Op absurd++dup :: a -> (a, a)+dup a = (a, a)++merge :: Either a a -> a+merge = either id id
+ src/Data/Bifunctor/BiInvariant.hs view
@@ -0,0 +1,122 @@+module Data.Bifunctor.BiInvariant where++import Prelude+import Control.Arrow+import Control.Comonad+import Data.Bifunctor+import Data.Bifunctor.Biap+import Data.Bifunctor.Biff+import Data.Bifunctor.Clown+import Data.Bifunctor.Flip+import Data.Bifunctor.Tannen+import Data.Bifunctor.Joker+import Data.Bifunctor.Sum+import Data.Bifunctor.Product+import Data.Bifunctor.Wrapped+import Data.Coerce+import Data.Functor.Const+import Data.Functor.Contravariant+import Data.Kind+import Data.Profunctor+import Data.Profunctor.Cayley+import Data.Profunctor.Composition+import Data.Profunctor.Choice+import Data.Profunctor.Closed+import Data.Profunctor.Mapping+import Data.Profunctor.Ran+import Data.Profunctor.Strong+import Data.Profunctor.Traversing+import Data.Profunctor.Yoneda+import Data.Semigroup (Arg)+import Data.Tagged+import Data.These+import GHC.Generics (K1)+++class BiInvariant p where+  biinvmap :: (a' -> a) -> (a -> a') -> (b' -> b) -> (b -> b') -> p a b -> p a' b'++-- BiInvariant witnesses an Isomorphism+data Iso a b = Iso (a -> b) (b -> a)+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')++newtype FromProfunctor p a b = FromProfunctor { runPro :: p a b}++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++newtype FromBifunctor p a b = FromBifunctor { runBi :: p a b }++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++newtype FromContra f a = FromContra { runContra :: f a }++instance Contravariant f => Contravariant (FromContra f) where+  contramap f = FromContra . contramap f . runContra++newtype FromFunctor f a = FromFunctor { runFunctor :: f a }+  deriving Functor++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)++deriving via (FromProfunctor (->))                    instance BiInvariant (->)+deriving via (FromProfunctor (Biff p f g))           instance (Profunctor p, Functor f, Functor g) => BiInvariant (Biff (FromProfunctor p) f g)+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 (Clown f :: * -> * -> *))  instance Contravariant f => BiInvariant (Clown (FromContra f) :: * -> * -> *)+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 (CofreeTraversing p))   instance Profunctor p => BiInvariant (CofreeTraversing p)+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 (Cotambara p))          instance BiInvariant (Cotambara p)+deriving via (FromProfunctor (CotambaraSum p))       instance BiInvariant (CotambaraSum p)+deriving via (FromProfunctor (Coyoneda p))           instance BiInvariant (Coyoneda p)+deriving via (FromProfunctor (Environment p))        instance BiInvariant (Environment p)+deriving via (FromProfunctor (Forget r :: * -> * -> *)) instance BiInvariant (Forget r :: * -> * -> *)+deriving via (FromProfunctor (FreeMapping p))        instance BiInvariant (FreeMapping p)+deriving via (FromProfunctor (FreeTraversing p))     instance BiInvariant (FreeTraversing p)+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 (Pastro p))             instance BiInvariant (Pastro p)+deriving via (FromProfunctor (PastroSum p))          instance BiInvariant (PastroSum p)+deriving via (FromProfunctor (Procompose p q))       instance (Profunctor p, Profunctor q) => BiInvariant (Procompose p q)+deriving via (FromProfunctor (Product p q))          instance (Profunctor p, Profunctor q) => BiInvariant (Product (FromProfunctor p) (FromProfunctor q))+deriving via (FromProfunctor (Ran p q))              instance (Profunctor p, Profunctor q) => BiInvariant (Ran p q)+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 (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 (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 (Yoneda p))             instance BiInvariant (Yoneda p)++deriving via (FromBifunctor ((,,) x1))                 instance BiInvariant ((,,) x1)+deriving via (FromBifunctor ((,,,) x1 x2))             instance BiInvariant ((,,,) x1 x2)+deriving via (FromBifunctor ((,,,,) x1 x2 x3))         instance BiInvariant ((,,,,) x1 x2 x3)+deriving via (FromBifunctor ((,,,,,) x1 x2 x3 x4))     instance BiInvariant ((,,,,,) x1 x2 x3 x4)+deriving via (FromBifunctor ((,,,,,,) x1 x2 x3 x4 x5)) instance BiInvariant ((,,,,,,) x1 x2 x3 x4 x5)+deriving via (FromBifunctor (,))                       instance BiInvariant (,)+deriving via (FromBifunctor (Arg))                     instance BiInvariant (Arg)+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 (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 (Joker f :: * -> * -> *))     instance Functor f => BiInvariant (Joker (FromFunctor f) :: * -> * -> *)+deriving via (FromBifunctor (K1 i :: * -> * -> *))        instance BiInvariant (K1 i :: * -> * -> *)+deriving via (FromBifunctor (Product p q))             instance (Bifunctor p, Bifunctor q) => BiInvariant (Product (FromBifunctor p) (FromBifunctor q))+deriving via (FromBifunctor (Sum p q))                 instance (Bifunctor p, Bifunctor q) => BiInvariant (Sum (FromBifunctor p) (FromBifunctor q))+deriving via (FromBifunctor (Tannen f q))              instance (Functor f, Coercible1 f, Bifunctor q) => BiInvariant (Tannen (FromFunctor f) (FromBifunctor q))+deriving via (FromBifunctor (These))                   instance BiInvariant (These)+deriving via (FromBifunctor (WrappedBifunctor p))      instance Bifunctor p => BiInvariant (WrappedBifunctor p)
+ src/Data/Bifunctor/Module.hs view
@@ -0,0 +1,11 @@+module Data.Bifunctor.Module where++class LeftModule cat t1 t2 f where+  lstrength :: cat (f a b) (f (t1 a x) (t2 b x))++-- Strong is LeftModule (->) (,) (,)++class RightModule cat t1 t2 f where+  rstrength :: cat (f a b) (f (t1 x a) (t2 x b))++class (LeftModule cat t1 t2 f, RightModule cat t1 t2 f) => Bimodule cat t1 t2 f
+ src/Data/Bifunctor/Monoidal.hs view
@@ -0,0 +1,215 @@+module Data.Bifunctor.Monoidal where++import Prelude hiding ((.), id)+import Control.Applicative+import Control.Category+import Control.Category.Tensor+import Data.Biapplicative+import Data.Bifunctor.Clown+import Data.Bifunctor.Joker+import Data.Profunctor+import Data.Semigroupoid+import Data.These+import Data.Void++class (Associative t1 cat, Associative t2 cat, Associative to cat) => Semigroupal cat t1 t2 to f where+  combine :: cat (to (f x y) (f x' y')) (f (t1 x x') (t2 y y'))++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 =+  --   let fwd' = fwd assoc+  --       bwd' = bwd assoc+  --   in second swap . swap . fwd' . swap . first (bwd' . first swap) . fwd'++instance Semigroupal (->) Either Either Either (,) where+  combine :: Either (x, y) (x', y') -> (Either x x', Either y y')+  combine = either (bimap Left Left) (bimap Right Right)++instance Semigroupal (->) Either Either Either Either where+  combine :: Either (Either x y) (Either x' y') -> Either (Either x x') (Either y y')+  combine = either (bimap Left Left) (bimap Right Right)++instance Semigroupal (->) Either (,) (,) Either where+  combine :: (Either x y, Either x' y') -> Either (Either x x') (y, y')+  combine = \case+    (Left x, Left _) -> Left $ Left x+    (Left x, Right _) -> Left $ Left x+    (Right _, Left x') -> Left $ Right x'+    (Right y, Right y') -> Right (y, y')++instance Semigroupal (->) These (,) (,) Either where+  combine :: (Either x y, Either x' y') -> Either (These x x') (y, y')+  combine = \case+    (Left x, Left x') -> Left $ These x x'+    (Left x, Right _) -> Left $ This x+    (Right _, Left x') -> Left $ That x'+    (Right y, Right y') -> Right (y, y')++instance Semigroupal (->) (,) (,) (,) (->) where+  combine :: (x -> y, x' -> y') -> (x, x') -> (y, y')+  combine fs = uncurry bimap fs++instance Semigroupal (->) Either Either (,) (->) where+  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+  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+  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+  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+  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+  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 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+  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 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'++instance Semigroupal (->) Either Either (,) (Forget (f r)) where+  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+  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+  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'++class Unital cat i1 i2 io f where+  introduce :: cat io (f i1 i2)++instance (Profunctor p, Category p) => Unital (->) () () () (StrongCategory p) where+  introduce :: () -> StrongCategory p () ()+  introduce () = StrongCategory id++instance Unital (->) () () () (,) where+  introduce :: () -> ((), ())+  introduce = dup++instance Unital (->) Void Void Void (,) where+  introduce :: Void -> (Void, Void)+  introduce = absurd++instance Unital (->) Void Void Void Either where+  introduce :: Void -> Either Void Void+  introduce = bwd runit++instance Unital (->) Void () () Either where+  introduce :: () -> Either Void ()+  introduce = Right++instance Unital (->) () () () (->) where+  introduce :: () -> () -> ()+  introduce () () = ()++instance Unital (->) Void Void Void (->) where+  introduce :: Void -> Void -> Void+  introduce = absurd++instance (Unital (->) Void Void () (->)) where+  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+  introduce :: () -> Joker f Void Void+  introduce () = Joker empty++instance Unital (->) Void Void Void (Joker f) where+  introduce :: Void -> Joker f Void Void+  introduce = absurd++instance Applicative f => Unital (->) () () () (Star f) where+  introduce :: () -> Star f () ()+  introduce () = Star pure++instance Unital (->) Void Void () (Star f) where+  introduce :: () -> Star f Void Void+  introduce () = Star absurd++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+  introduce :: () -> Star f () Void+  introduce () = Star $ const empty++class (Tensor t1 i1 cat+      , Tensor t2 i2 cat+      , Tensor to io cat+      , Semigroupal cat t1 t2 to f+      , Unital cat i1 i2 io f+      ) => Monoidal cat t1 i1 t2 i2 to io f++instance (Strong p, Semigroupoid p, Category p) => Monoidal (->) (,) () (,) () (,) () (StrongCategory p)+instance Monoidal (->) (,) () (,) () (,) () (,)+instance Monoidal (->) Either Void Either Void Either Void (,)+instance Monoidal (->) Either Void Either Void Either Void Either+instance Monoidal (->) Either Void (,) () (,) () Either+instance Monoidal (->) These Void (,) () (,) () Either+instance Monoidal (->) (,) () (,) () (,) () (->)+instance Monoidal (->) Either Void Either Void (,) () (->)+instance Applicative f => Monoidal (->) (,) () (,) () (,) () (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 Applicative f => Monoidal (->) (,) () (,) () (,) () (Star f)+instance Functor f => Monoidal (->) Either Void Either Void (,) () (Star f)+instance Alternative f => Monoidal (->) Either Void Either Void Either Void (Star f)+instance Alternative f => Monoidal (->) (,) () Either Void (,) () (Star f)++newtype StrongCategory p a b = StrongCategory (p a b)+  deriving (Functor, Applicative, Monad, Profunctor, Category)++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)++instance (Strong p, Semigroupoid p) => Semigroupal (->) (,) (,) (,) (StrongCategory p) where+  combine :: (StrongCategory p x y, StrongCategory p x' y') -> StrongCategory p (x, x') (y, y')+  combine (StrongCategory pxy, StrongCategory pxy') = StrongCategory $ first' pxy `o` second' pxy'
+ src/Data/Bifunctor/Monoidal/Specialized.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TupleSections #-}+module Data.Bifunctor.Monoidal.Specialized where++import Prelude hiding ((&&), (||))++import Control.Category.Tensor+import Data.Bifunctor.Monoidal+import Data.Functor.Contravariant+import Data.Profunctor+import Data.Void++mux :: Semigroupal (->) (,) (,) (,) p => p a b -> p c d -> p (a, c) (b, d)+mux = curry combine++infixr 5 &&++(&&) :: Semigroupal (->) (,) (,) (,) p => p a b -> p c d -> p (a, c) (b, d)+(&&) = mux++zip :: (Profunctor p, Semigroupal (->) (,) (,) (,) p) => p x a -> p x b -> p x (a, b)+zip pxa pxb = lmap dup $ pxa && pxb++demux :: Semigroupal (->) Either Either (,) p => p a b -> p c d -> p (Either a c) (Either b d)+demux = curry combine++infixr 4 ||++(||) :: Semigroupal (->) Either Either (,) p => p a b -> p c d -> p (Either a c) (Either b d)+(||) = demux+++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++switch :: Semigroupal (->) (,) Either (,) p => p a b -> p c d -> p (a, c) (Either b d)+switch = curry combine++infixr 5 &|++(&|) :: Semigroupal (->) (,) Either (,) p => p a b -> p c d -> p (a, c) (Either b d)+(&|) = switch++union :: Profunctor p => Semigroupal (->) (,) Either (,) p => p x a -> p x b -> p x (Either a b)+union pxa pxb = lmap dup $ pxa &| pxb++divide :: (Profunctor p, Semigroupal (->) (,) Either (,) p) => p a x -> p b x -> p (a, b) x+divide pxa pxb = rmap merge $ pxa &| pxb++splice :: Semigroupal (->) Either (,) (,) p => p a b -> p c d -> p (Either a c) (b, d)+splice = curry combine++infix 5 |&++(|&) :: 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)+diverge = combine++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++zig :: (Profunctor p, Semigroupal (->) (,) t Either p) => Either (p x a) (p x b) -> p x (t a b)+zig = lmap dup . combine++zag :: (Profunctor p, Semigroupal (->) t Either Either p) => Either (p a x) (p b x) -> p (t a b) x+zag = rmap merge . combine++ultrafirst :: (Profunctor p, Semigroupal (->) (,) (,) Either p) => p a b -> p (a, x) (b, y)+ultrafirst = zag . Left . zig . Left++ultrasecond :: (Profunctor p, Semigroupal (->) (,) (,) Either p) => p a b -> p (x, a) (y, b)+ultrasecond = zag . Right . zig . Right++ultraleft :: (Profunctor p, Semigroupal (->) Either Either Either p) => p a b -> p (Either a x) (Either b y)+ultraleft = zag . Left . zig . Left++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)+comux = getOp combine++undivide :: forall p x a b. Profunctor p => Semigroupal Op (,) (,) (,) p => p (a, b) x -> (p a x, p b x)+undivide = comux . rmap dup++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)+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 = 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 = coswitch . rmap dup++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 = getOp combine++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+ppure = dimap ((),) snd $ first' (introduce () :: p () ())++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+poly = dimap (const ()) absurd $ introduce ()++mono :: forall p. Unital (->) Void () () p => p Void ()+mono = introduce ()
+ src/Data/Functor/Invariant.hs view
@@ -0,0 +1,45 @@+module Data.Functor.Invariant where++import Prelude+import Control.Applicative (ZipList)+import Data.Functor.Contravariant+import Data.Functor.Compose+import Data.Functor.Identity+import Data.Functor.Sum+import Data.Functor.Product+import Data.List.NonEmpty (NonEmpty)++class Invariant f where+  invmap :: (a -> a') -> (a' -> a) -> f a -> f a'++-- Invariant witnesses an Isomorphism+data Iso a b = Iso (a -> b) (b -> a)++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 }++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+  invmap :: (a -> a') -> (a' -> a) -> FromContra f a -> FromContra f a'+  invmap _ g = FromContra . contramap g . runContra++deriving via FromFunctor Identity           instance Invariant Identity+deriving via FromFunctor (Compose f g)      instance (Functor f, Functor g) => Invariant (Compose f g)+deriving via FromFunctor []                 instance Invariant []+deriving via FromFunctor ZipList            instance Invariant ZipList+deriving via FromFunctor NonEmpty           instance Invariant NonEmpty+deriving via FromFunctor Maybe              instance Invariant Maybe+deriving via FromFunctor (Either e)         instance Invariant (Either e)+deriving via FromFunctor IO                 instance Invariant IO+deriving via FromFunctor (Sum f g)          instance (Functor f, Functor g) => Invariant (Sum f g)+deriving via FromFunctor (Product f g)      instance (Functor f, Functor g) => Invariant (Product f g)+deriving via (FromFunctor ((,) x1))         instance Invariant ((,) x1)+deriving via (FromFunctor ((,,) x1 x2))     instance Invariant ((,,) x1 x2)+deriving via (FromFunctor ((,,,) x1 x2 x3)) instance Invariant ((,,,) x1 x2 x3)
+ src/Data/Functor/Module.hs view
@@ -0,0 +1,9 @@+module Data.Functor.Module where++class LeftModule cat t1 f where+  lstrength :: f a `cat` f (t1 a x)++class RightModule cat t1 f where+  rstrength :: f a `cat` f (t1 x a)++class (LeftModule cat t1 f, RightModule cat t1 f) => Bimodule cat t1 f
+ src/Data/Functor/Monoidal.hs view
@@ -0,0 +1,41 @@+module Data.Functor.Monoidal where++import Prelude+import Control.Applicative+import Control.Category.Tensor+import Data.Void++class (Associative t1 cat, Associative t0 cat) => Semigroupal cat t1 t0 f where+  combine :: (f x `t0` f x') `cat` f (x `t1` x')++class Unital cat i1 i0 f where+  introduce :: i0 `cat` f i1++class ( Tensor t1 i1 cat+      , Tensor t0 i0 cat+      , Semigroupal cat t1 t0 f+      , Unital cat i1 i0 f+      ) => Monoidal cat t1 i1 t0 i0 f++-- TODO: Should we create an Apply class?+instance Applicative f => Semigroupal (->) (,) (,) f where+  combine :: (f x, f x') -> f (x, x')+  combine = uncurry (liftA2 (,))++instance Applicative f => Unital (->) () () f where+  introduce :: () -> f ()+  introduce = pure++instance Applicative f => Monoidal (->) (,) () (,) () f++-- TODO: Should we create an Alt class?+instance Alternative f => Semigroupal (->) Either (,) f where+  combine :: (f x, f x') -> f (Either x x')+  combine (fx, fx') = fmap Left fx <|> fmap Right fx'++-- TODO: Should we create a Plus class?+instance Alternative f => Unital (->) Void () f where+  introduce :: () -> f Void+  introduce () = empty++instance Alternative f => Monoidal (->) Either Void (,) () f
+ src/Data/Trifunctor/Module.hs view
@@ -0,0 +1,10 @@+module Data.Trifunctor.Module where+++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 RightModule cat t1 t2 t3 f where+  rstrength :: cat (f a b c) (f (t1 x a) (t2 x b) (t3 x c))++class (LeftModule cat t1 t2 t3 f, RightModule cat t1 t2 t3 f) => Bimodule cat t1 t2 t3 f
+ src/Data/Trifunctor/Monoidal.hs view
@@ -0,0 +1,23 @@+module Data.Trifunctor.Monoidal where++import Control.Category.Tensor++class+  ( Associative t1 cat+  , Associative t2 cat+  , Associative t3 cat+  , Associative to cat+  ) => Semigroupal cat t1 t2 t3 to f where+  combine :: to (f x y z) (f x' y' z') `cat` f (t1 x x') (t2 y y') (t3 z z')++class Unital cat i1 i2 i3 o f where+  introduce :: o `cat` f i1 i2 i3++class+  ( Tensor t1 i1 cat+  , Tensor t2 i2 cat+  , Tensor t3 i3 cat+  , Tensor to io cat+  , Semigroupal cat t1 t2 t3 to f+  , Unital cat i1 i2 i3 io f+  ) => Monoidal cat t1 i1 t2 i2 t3 i3 to io f