squares 0.0.1 → 0.1
raw patch · 14 files changed
+433/−80 lines, 14 filesdep +adjunctionsdep +comonaddep +distributivedep ~base
Dependencies added: adjunctions, comonad, distributive
Dependency ranges changed: base
Files
- CHANGELOG.md +11/−0
- squares.cabal +15/−3
- src/Control/Arrow/Square.hs +9/−9
- src/Control/Comonad/Square.hs +85/−0
- src/Control/Monad/Square.hs +31/−29
- src/Data/Distributive/Square.hs +35/−0
- src/Data/Foldable/Square.hs +26/−0
- src/Data/Functor/Adjunction/Square.hs +57/−0
- src/Data/Functor/Compose/List.hs +24/−7
- src/Data/Functor/Rep/Square.hs +30/−0
- src/Data/Functor/Square.hs +53/−0
- src/Data/Profunctor/Composition/List.hs +26/−7
- src/Data/Profunctor/Square.hs +4/−7
- src/Data/Square.hs +27/−18
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Revision history for squares +## 0.1++* `mkSquare` works for all functions of the right shape+* Added `runSquare`, the inverse of `mkSquare`.+* Added `Data.Functor.Square`+* Added `Data.Foldable.Square`+* Added `Data.Distributive.Square`+* Added `Data.Functor.Rep.Square`+* Added `Data.Functor.Adjunction.Square`+* Added `Control.Comonad.Square`+ ## 0.0.1 -- 2020-05-23 * Included README.
squares.cabal view
@@ -1,9 +1,11 @@ cabal-version: >=1.10 name: squares-version: 0.0.1+version: 0.1 synopsis: The double category of Hask functors and profunctors-description: A library for working with natural transformations of type @forall a b. p a b -> q (f a) (g b)@.+description: A library for working with natural transformations of type+ .+ @forall a b. p a b -> q (f a) (g b)@ homepage: https://github.com/sjoerdvisscher/squares bug-reports: https://github.com/sjoerdvisscher/squares/issues license: BSD3@@ -22,10 +24,20 @@ Data.Functor.Compose.List Data.Profunctor.Composition.List Control.Arrow.Square+ Control.Comonad.Square Control.Monad.Square+ Data.Distributive.Square+ Data.Foldable.Square+ Data.Functor.Square Data.Profunctor.Square Data.Traversable.Square- build-depends: base == 4.*, profunctors == 5.*+ Data.Functor.Adjunction.Square+ Data.Functor.Rep.Square+ build-depends: base >= 4.8 && < 5+ , profunctors == 5.*+ , distributive == 0.6.*+ , adjunctions == 4.*+ , comonad == 5.* hs-source-dirs: src default-language: Haskell2010
src/Control/Arrow/Square.hs view
@@ -10,8 +10,8 @@ module Control.Arrow.Square where import Data.Square-import Data.Functor.Compose.List import Data.Profunctor+import Data.Profunctor.Composition import Data.Profunctor.Composition.List import qualified Control.Arrow as A @@ -21,8 +21,8 @@ -- > | @--a -- > | | -- > +-----+-arr :: A.Arrow a => Square '[] '[a] '[] '[]-arr = Square (P . A.arr . dimap unId Id . unHom)+arr :: (A.Arrow a, Profunctor a) => Square '[] '[a] '[] '[]+arr = mkSquare A.arr -- | -- > +-----+@@ -30,8 +30,8 @@ -- > | @--a -- > a--/ | -- > +-----+-(>>>) :: A.Arrow a => Square '[a, a] '[a] '[] '[]-(>>>) = Square (\(PComp p (P q)) -> P (A.arr Id A.<<< q A.<<< p A.<<< A.arr unId))+(>>>) :: (A.Arrow a, Profunctor a) => Square '[a, a] '[a] '[] '[]+(>>>) = mkSquare (\(Procompose q p) -> p A.>>> q) -- | -- > +-_⊗d-+@@ -39,8 +39,8 @@ -- > a--@--a -- > | v | -- > +-_⊗d-+-second :: A.Arrow a => Square '[a] '[a] '[(,) d] '[(,) d]-second = Square (P . (A.>>> A.arr F) . (A.<<< A.arr unF) . A.second . unP)+second :: (A.Arrow a, Profunctor a) => Square '[a] '[a] '[(,) d] '[(,) d]+second = mkSquare A.second -- | -- > H²-⊗--H@@ -57,8 +57,8 @@ -- > a--@--a -- > | v | -- > +-_⊕d-+-right :: A.ArrowChoice a => Square '[a] '[a] '[Either d] '[Either d]-right = Square (P . (A.>>> A.arr F) . (A.<<< A.arr unF) . A.right . unP)+right :: (A.ArrowChoice a, Profunctor a) => Square '[a] '[a] '[Either d] '[Either d]+right = mkSquare A.right -- | -- > H²-⊕--H
+ src/Control/Comonad/Square.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Control.Comonad.Square+-- License : BSD-style (see the file LICENSE)+-- Maintainer : sjoerd@w3future.com+--+-----------------------------------------------------------------------------+module Control.Comonad.Square where++import Data.Square+import Data.Profunctor+import qualified Control.Comonad as W++-- |+-- > +--w--++-- > | v |+-- > | X |+-- > | |+-- > +-----++extract :: W.Comonad w => Square '[] '[] '[w] '[]+extract = mkSquare (. W.extract)++-- |+-- > +--w--++-- > | v |+-- > w<-E |+-- > | v |+-- > +--w--++--+-- `W.extend` as a square+--+-- Right identity law:+--+-- > +--w--++-- > | v | +--w--++-- > w<-E | | v |+-- > | v | === w<-/ |+-- > | X | | |+-- > +-----+ +-----++--+-- Left identity law:+--+-- > +---w-++-- > | v | +--w--++-- > | /-E | | | |+-- > | v | | === | v |+-- > | X v | | | |+-- > +---w-+ +--w--++--+-- Associativity law:+--+-- > +--w--+ +---w-++-- > | v | | v |+-- > w<-E | | /-E |+-- > | v | === w<E | |+-- > w<-E | | | | |+-- > | v | w</ v |+-- > +--w--+ +---w-++extend :: W.Comonad w => Square '[Costar w] '[] '[w] '[w]+extend = mkSquare (W.extend . runCostar)++-- |+-- > +---w-++-- > | v |+-- > | /-@ |+-- > | v v |+-- > +-w-w-++--+-- > duplicate = fromRight ||| extend+duplicate :: W.Comonad w => Square '[] '[] '[w] '[w, w]+duplicate = fromRight ||| extend++-- |+-- > +-----++-- > | /-<w+-- > w<-@ |+-- > w<-/ |+-- > +-----++--+-- Cokleisli composition `(W.<=<)`+--+-- > (<=<) = fromRight === extend === toLeft+(<=<) :: W.Comonad w => Square '[Costar w, Costar w] '[Costar w] '[] '[]+(<=<) = fromRight === extend === toLeft
src/Control/Monad/Square.hs view
@@ -11,17 +11,16 @@ import Prelude hiding (return) import Data.Square import Data.Profunctor-import Data.Profunctor.Square import qualified Control.Monad as M -- | -- > +-----+ -- > | |--- > | R->m--- > | |--- > +-----+-return :: Monad m => Square '[] '[Star m] '[] '[]-return = toHom ||| proNat (Star . (M.return .))+-- > | R |+-- > | v |+-- > +--m--++return :: Monad m => Square '[] '[] '[] '[m]+return = mkSquare (M.return .) -- | -- > +--m--+@@ -30,36 +29,37 @@ -- > | v | -- > +--m--+ ----- `(>>=)`+-- `(>>=)` as a square (or to be precise its flipped version `(=<<)`) -- -- Left identity law: ----- > +-------+--- > | R>-\ + +-----+--- > | v | | |--- > m>---B | === m>-\ |--- > | v | | v |--- > +----m--+ +--m--++-- > +-----++-- > | R | +-----++-- > | v | | |+-- > m>-B | === m>-\ |+-- > | v | | v |+-- > +--m--+ +--m--+ -- -- Right identity law: ----- > +----m--+ +--m--+--- > | v | | | |--- > | R>-B | === | v |--- > | v | | | |--- > +----m--+ +--m--++-- > +---m-++-- > | R v | +--m--++-- > | v | | | | |+-- > | \-B | === | v |+-- > | v | | | |+-- > +---m-+ +--m--+ -- -- Associativity law: ----- > +--m--+ +-----m--+--- > | v | m>-\ v |--- > m>-B | | v | |--- > | v | === m>-B | |--- > m>-B | | \->B |--- > | v | | v |--- > +--m--+ +-----m--++-- > +--m--+ +---m-++-- > | v | m>\ v |+-- > m>-B | | v | |+-- > | v | === m>B | |+-- > m>-B | | \-B |+-- > | v | | v |+-- > +--m--+ +---m-+ bind :: Monad m => Square '[Star m] '[] '[m] '[m]-bind = mkSquare (flip (>>=) . runStar) ||| fromHom+bind = mkSquare (flip (>>=) . runStar) -- | -- > +-m-m-+@@ -68,7 +68,7 @@ -- > | v | -- > +---m-+ ----- @join = toRight ||| bind@+-- > join = toRight ||| bind join :: Monad m => Square '[] '[] '[m, m] '[m] join = toRight ||| bind @@ -80,5 +80,7 @@ -- > +-----+ -- -- Kleisli composition `(M.>=>)`-kleisli :: Monad m => Square '[Star m, Star m] '[Star m] '[] '[]-kleisli = fromLeft === bind === toRight+--+-- > (>=>) = fromLeft === bind === toRight+(>=>) :: Monad m => Square '[Star m, Star m] '[Star m] '[] '[]+(>=>) = fromLeft === bind === toRight
+ src/Data/Distributive/Square.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Distributive.Square+-- License : BSD-style (see the file LICENSE)+-- Maintainer : sjoerd@w3future.com+--+-----------------------------------------------------------------------------+module Data.Distributive.Square where++import Data.Square+import Data.Profunctor+import qualified Data.Distributive as D++-- |+-- > +--t--++-- > | v |+-- > f<-@-<f+-- > | v |+-- > +--t--++--+-- @cotraverse = (funId ||| fromRight) === distribute === (toLeft ||| funId)@+cotraverse :: (D.Distributive t, Functor f) => Square '[Costar f] '[Costar f] '[t] '[t]+cotraverse = mkSquare (Costar . D.cotraverse . runCostar)++-- |+-- > +---t-f-++-- > | v v |+-- > | /-@-/ |+-- > | v v |+-- > +-f-t---++--+-- @distribute = fromRight ||| cotraverse ||| toLeft@+distribute :: (D.Distributive t, Functor f) => Square '[] '[] '[t, f] '[f, t]+distribute = fromRight ||| cotraverse ||| toLeft
+ src/Data/Foldable/Square.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Foldable.Square+-- License : BSD-style (see the file LICENSE)+-- Maintainer : sjoerd@w3future.com+--+-----------------------------------------------------------------------------+module Data.Foldable.Square where++import Data.Square+import Data.Profunctor+import Data.Functor.Compose.List+import qualified Data.Foldable as F++-- |+-- > +--f--++-- > | v |+-- > !m-@-!m+-- > | ? |+-- > +--?--++--+-- `F.foldMap` as a square. Note that because `Forget` ignores its output parameter,+-- this square can have any list of functors as output type.+foldMap :: (Foldable f, Monoid m, IsFList gs) => Square '[Forget m] '[Forget m] '[f] gs+foldMap = mkSquare (Forget . F.foldMap . runForget)
+ src/Data/Functor/Adjunction/Square.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Adjunction.Square+-- License : BSD-style (see the file LICENSE)+-- Maintainer : sjoerd@w3future.com+--+-----------------------------------------------------------------------------+module Data.Functor.Adjunction.Square where++import Data.Square+import Data.Profunctor+import qualified Data.Functor.Adjunction as A++-- |+-- > +-----++-- > | |+-- > f<-@->g+-- > | |+-- > +-----++--+-- > leftAdjunct = unit === (toLeft ||| toRight)+leftAdjunct :: A.Adjunction f g => Square '[Costar f] '[Star g] '[] '[]+leftAdjunct = mkSquare (Star . A.leftAdjunct . runCostar)++-- |+-- > +-----++-- > | |+-- > g>-@-<f+-- > | |+-- > +-----++--+-- > rightAdjunct = (fromLeft ||| fromRight) === counit+rightAdjunct :: A.Adjunction f g => Square '[Star g] '[Costar f] '[] '[]+rightAdjunct = mkSquare (Costar . A.rightAdjunct . runStar)++-- |+-- > +-----++-- > | |+-- > | /@\ |+-- > | v v |+-- > +-f-g-++--+-- > unit = fromRight ||| leftAdj ||| fromLeft+unit :: A.Adjunction f g => Square '[] '[] '[] '[f, g]+unit = mkSquare (A.unit .)++-- |+-- > +-g-f-++-- > | v v |+-- > | \@/ |+-- > | |+-- > +-----++--+-- > counit = toRight ||| rightAdjoint ||| toLeft+counit :: A.Adjunction f g => Square '[] '[] '[g, f] '[]+counit = mkSquare (. A.counit)
src/Data/Functor/Compose/List.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -32,24 +33,40 @@ instance (Functor f, Functor (FList (g ': gs))) => Functor (FList (f ': g ': gs)) where fmap f = FComp . fmap (fmap f) . unFComp +-- | Calculate the simplified type of the composition of a list of functors.+type family PlainF (fs :: [* -> *]) (a :: *) :: *+type instance PlainF '[] a = a+type instance PlainF (f ': fs) a = PlainF fs (f a) --- | Combining and splitting nested `FList`s.-class FAppend f where- fappend :: Functor (FList g) => FList g (FList f a) -> FList (f ++ g) a- funappend :: Functor (FList g) => FList (f ++ g) a -> FList g (FList f a)-instance FAppend '[] where+-- | Functions for working with `FList`s.+class IsFList fs where+ -- | Combine 2 nested `FList`s into one `FList`.+ fappend :: Functor (FList gs) => FList gs (FList fs a) -> FList (fs ++ gs) a+ -- | Split one `FList` into 2 nested `FList`s.+ funappend :: Functor (FList gs) => FList (fs ++ gs) a -> FList gs (FList fs a)+ -- | Convert an `FList` to its simplified form.+ toPlainF :: FList fs a -> PlainF fs a+ -- | Create an `FList` from its simplified form.+ fromPlainF :: PlainF fs a -> FList fs a+instance IsFList '[] where fappend = fmap unId funappend = fmap Id-instance FAppend '[f] where+ toPlainF (Id a) = a+ fromPlainF a = Id a+instance IsFList '[f] where fappend (Id fa) = F (unF fa) fappend f@F{} = FComp $ fmap unF f fappend f@FComp{} = FComp $ fmap unF f funappend fa@F{} = Id fa funappend (FComp fga@F{}) = fmap F fga funappend (FComp fga@FComp{}) = fmap F fga-instance (Functor f, FAppend (g ': gs)) => FAppend (f ': g ': gs) where+ toPlainF (F fa) = fa+ fromPlainF fa = F fa+instance IsFList (g ': gs) => IsFList (f ': g ': gs) where fappend = FComp . fappend . fmap unFComp funappend = fmap FComp . funappend . unFComp+ toPlainF (FComp fgs) = toPlainF fgs+ fromPlainF fgs = FComp (fromPlainF fgs) -- | Natural transformations between two functors. (Why is this still not in base??)
+ src/Data/Functor/Rep/Square.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Rep.Square+-- License : BSD-style (see the file LICENSE)+-- Maintainer : sjoerd@w3future.com+--+-----------------------------------------------------------------------------+module Data.Functor.Rep.Square where++import Data.Square+import qualified Data.Functor.Rep as R++-- |+-- > +-k→_-++-- > | v |+-- > | @ |+-- > | v |+-- > +--f--++tabulate :: R.Representable f => Square '[] '[] '[(->) (R.Rep f)] '[f]+tabulate = funNat R.tabulate++-- |+-- > +--f--++-- > | v |+-- > | @ |+-- > | v |+-- > +-k→_-++index :: R.Representable f => Square '[] '[] '[f] '[(->) (R.Rep f)]+index = funNat R.index
+ src/Data/Functor/Square.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Functor.Square+-- License : BSD-style (see the file LICENSE)+-- Maintainer : sjoerd@w3future.com+--+-----------------------------------------------------------------------------+module Data.Functor.Square where++import Data.Square+import Data.Functor.Identity+import Data.Functor.Compose++-- * Squares for @Identity@++-- |+-- > +--I--++-- > | v |+-- > | @ |+-- > | |+-- > +-----++fromIdentity :: Square '[] '[] '[Identity] '[]+fromIdentity = mkSquare (. runIdentity)++-- |+-- > +-----++-- > | |+-- > | @ |+-- > | v |+-- > +--I--++toIdentity :: Square '[] '[] '[] '[Identity]+toIdentity = mkSquare (Identity .)++-- * Squares for `Compose`++-- |+-- > +-g.f-++-- > | v |+-- > | /@\ |+-- > | v v |+-- > +-f-g-++fromCompose :: (Functor f, Functor g) => Square '[] '[] '[Compose g f] '[f, g]+fromCompose = mkSquare ((. getCompose) . fmap . fmap)++-- |+-- > +-f-g-++-- > | v v |+-- > | \@/ |+-- > | v |+-- > +-g.f-++toCompose :: (Functor f, Functor g) => Square '[] '[] '[f, g] '[Compose g f]+toCompose = mkSquare ((Compose .) . fmap . fmap)
src/Data/Profunctor/Composition/List.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-}@@ -30,19 +31,37 @@ instance (Profunctor p, Profunctor (PList (q ': qs))) => Profunctor (PList (p ': q ': qs)) where dimap l r (PComp p ps) = PComp (lmap l p) (rmap r ps) --- | Combining and splitting nested `PList`s.-class PAppend p where- pappend :: Profunctor (PList q) => Procompose (PList q) (PList p) a b -> PList (p ++ q) a b- punappend :: PList (p ++ q) a b -> Procompose (PList q) (PList p) a b-instance PAppend '[] where+-- | Calculate the simplified type of the composition of a list of profunctors.+type family PlainP (ps :: [* -> * -> *]) :: * -> * -> *+type instance PlainP '[] = (->)+type instance PlainP '[p] = p+type instance PlainP (p ': q ': qs) = Procompose (PlainP (q ': qs)) p++-- | Functions for working with `PList`s.+class IsPList ps where+ -- | Combine 2 nested `PList`s into one `PList`.+ pappend :: Profunctor (PList qs) => Procompose (PList qs) (PList ps) :-> PList (ps ++ qs)+ -- | Split one `PList` into 2 nested `PList`s.+ punappend :: PList (ps ++ qs) :-> Procompose (PList qs) (PList ps)+ -- | Convert a `PList` to its simplified form.+ toPlainP :: PList ps :-> PlainP ps+ -- | Create a `PList` from its simplified form.+ fromPlainP :: PlainP ps :-> PList ps+instance IsPList '[] where pappend (Procompose q (Hom f)) = lmap f q punappend q = Procompose q (Hom id)-instance Profunctor p => PAppend '[p] where+ toPlainP (Hom f) = f+ fromPlainP f = Hom f+instance Profunctor p => IsPList '[p] where pappend (Procompose (Hom f) (P p)) = P (rmap f p) pappend (Procompose q@P{} (P p)) = PComp p q pappend (Procompose q@PComp{} (P p)) = PComp p q punappend p@P{} = Procompose (Hom id) p punappend (PComp p qs) = Procompose qs (P p)-instance (Profunctor p, PAppend (q ': qs)) => PAppend (p ': q ': qs) where+ toPlainP (P p) = p+ fromPlainP p = P p+instance IsPList (q ': qs) => IsPList (p ': q ': qs) where pappend (Procompose q (PComp p ps)) = PComp p (pappend (Procompose q ps)) punappend (PComp p pq) = case punappend pq of Procompose q ps -> Procompose q (PComp p ps)+ toPlainP (PComp p pq) = Procompose (toPlainP pq) p+ fromPlainP (Procompose pq p) = PComp p (fromPlainP pq)
src/Data/Profunctor/Square.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} ----------------------------------------------------------------------------- -- |@@ -10,8 +9,6 @@ module Data.Profunctor.Square where import Data.Square-import Data.Functor.Compose.List-import Data.Profunctor.Composition.List import qualified Data.Profunctor as P import Data.Profunctor.Composition @@ -62,7 +59,7 @@ -- > | | -- > +-----+ fromHom :: Square '[(->)] '[] '[] '[]-fromHom = Square (Hom . P.dimap unId Id . unP)+fromHom = mkSquare id -- | -- > +-----+@@ -71,7 +68,7 @@ -- > | | -- > +-----+ toHom :: Square '[] '[(->)] '[] '[]-toHom = Square (P . P.dimap unId Id . unHom)+toHom = mkSquare id -- * Squares for `Procompose` @@ -82,7 +79,7 @@ -- > | \-q -- > +-----+ fromProcompose :: (P.Profunctor p, P.Profunctor q) => Square '[Procompose q p] '[p, q] '[] '[]-fromProcompose = Square ((\(Procompose q p) -> PComp (P.lmap unId p) (P (P.rmap Id q))) . unP)+fromProcompose = mkSquare id -- | -- > +-----+@@ -91,4 +88,4 @@ -- > q-/ | -- > +-----+ toProcompose :: (P.Profunctor p, P.Profunctor q) => Square '[p, q] '[Procompose q p] '[] '[]-toProcompose = Square (P . (\(PComp p (P q)) -> Procompose (P.rmap Id q) (P.lmap unId p)))+toProcompose = mkSquare id
src/Data/Square.hs view
@@ -45,7 +45,7 @@ -- -- The empty square is the identity transformation. emptySquare :: Square '[] '[] '[] '[]-emptySquare = Square (dimap unId Id)+emptySquare = mkSquare id -- | -- > +-----+@@ -61,7 +61,7 @@ -- Note that `emptySquare` is `proId` for the profunctor @(->)@. -- We don't draw a line for @(->)@ because it is the identity for profunctor composition. proId :: Profunctor p => Square '[p] '[p] '[] '[]-proId = Square (dimap unId Id)+proId = mkSquare id -- | -- > +--f--+@@ -77,7 +77,7 @@ -- -- We don't draw lines for the identity functor, because it is the identity for functor composition. funId :: Functor f => Square '[] '[] '[f] '[f]-funId = Square (Hom . fmap . unHom)+funId = mkSquare fmap -- | -- > +--f--+@@ -93,7 +93,7 @@ -- @forall a. f a -> g a@. The type above you get when `fmap`ping before or after. -- (It doesn't matter which, because of naturality!) funNat :: (Functor f, Functor g) => (f ~> g) -> Square '[] '[] '[f] '[g]-funNat n = Square (Hom . dimap unF F . (.) n . fmap . unHom)+funNat n = mkSquare ((n .) . fmap) -- | -- > +-----+@@ -106,7 +106,7 @@ -- -- Natural transformations between profunctors. proNat :: (Profunctor p, Profunctor q) => (p :-> q) -> Square '[p] '[q] '[] '[]-proNat n = Square (P . dimap unId Id . n . unP)+proNat n = mkSquare n -- | -- > +--f--+@@ -135,11 +135,20 @@ -- > PList '[p, q, r] a b ~ (p a x, q x y, r y b) type Square ps qs fs gs = SquareNT (PList ps) (PList qs) (FList fs) (FList gs) --- | A helper function to add the wrappers needed for `PList` and `FList`,--- if the square has exactly one (pro)functor on each side (which is common).-mkSquare :: Profunctor q => (forall a b. p a b -> q (f a) (g b)) -> Square '[p] '[q] '[f] '[g]-mkSquare f = Square (P . dimap unF F . f . unP)+-- | A helper function to add the wrappers needed for `PList` and `FList`.+mkSquare+ :: (IsPList ps, IsPList qs, IsFList fs, IsFList gs, Profunctor (PList qs))+ => (forall a b. PlainP ps a b -> PlainP qs (PlainF fs a) (PlainF gs b))+ -> Square ps qs fs gs -- ^+mkSquare n = Square (dimap toPlainF fromPlainF . dimap toPlainP fromPlainP n) +-- | A helper function to remove the wrappers needed for `PList` and `FList`.+runSquare+ :: (IsPList ps, IsPList qs, IsFList fs, IsFList gs, Profunctor (PList qs))+ => Square ps qs fs gs+ -> PlainP ps a b -> PlainP qs (PlainF fs a) (PlainF gs b) -- ^+runSquare (Square n) = dimap fromPlainP toPlainP (dimap fromPlainF toPlainF . n)+ -- | -- > +--f--+ +--h--+ +--f--h--+ -- > | v | | v | | v v |@@ -150,7 +159,7 @@ -- Horizontal composition of squares. `proId` is the identity of `(|||)`. -- This is regular function composition of the underlying functions. infixl 6 |||-(|||) :: (Profunctor (PList rs), FAppend fs, FAppend gs, Functor (FList hs), Functor (FList is))+(|||) :: (Profunctor (PList rs), IsFList fs, IsFList gs, Functor (FList hs), Functor (FList is)) => Square ps qs fs gs -> Square qs rs hs is -> Square ps rs (fs ++ hs) (gs ++ is) -- ^ Square pq ||| Square qr = Square (dimap funappend fappend . qr . pq) @@ -169,7 +178,7 @@ -- -- Vertical composition of squares. `funId` is the identity of `(===)`. infixl 5 ===-(===) :: (PAppend ps, PAppend qs, Profunctor (PList ss))+(===) :: (IsPList ps, IsPList qs, Profunctor (PList ss)) => Square ps qs fs gs -> Square rs ss gs hs -> Square (ps ++ rs) (qs ++ ss) fs hs -- ^ Square pq === Square rs = Square (\pr -> case punappend pr of P.Procompose r p -> pappend (P.Procompose (rs r) (pq p))) @@ -189,7 +198,7 @@ -- -- A functor @f@ can be bent to the right to become the profunctor @`Star` f@. toRight :: Functor f => Square '[] '[Star f] '[f] '[]-toRight = Square (P . Star . (. unF) . fmap . (Id .) . unHom)+toRight = mkSquare (Star . fmap) -- | -- > +--f--+@@ -199,8 +208,8 @@ -- > +-----+ -- -- A functor @f@ can be bent to the left to become the profunctor @`Costar` f@.-toLeft :: Square '[Costar f] '[] '[f] '[]-toLeft = Square (Hom . dimap unF Id . runCostar . unP)+toLeft :: Functor f => Square '[Costar f] '[] '[f] '[]+toLeft = mkSquare runCostar -- | -- > +-----+@@ -211,7 +220,7 @@ -- -- The profunctor @`Costar` f@ can be bent down to become the functor @f@ again. fromRight :: Functor f => Square '[] '[Costar f] '[] '[f]-fromRight = Square (P . Costar . (F .) . fmap . (. unId) . unHom)+fromRight = mkSquare (Costar . fmap) -- | -- > +-----+@@ -221,8 +230,8 @@ -- > +--f--+ -- -- The profunctor @`Star` f@ can be bent down to become the functor @f@ again.-fromLeft :: Square '[Star f] '[] '[] '[f]-fromLeft = Square (Hom . dimap unId F . runStar . unP)+fromLeft :: Functor f => Square '[Star f] '[] '[] '[f]+fromLeft = mkSquare runStar -- | -- > +-----+@@ -326,7 +335,7 @@ -- > | v | -- > 1--b--H ---type Square01 q a b = SquareNT Unit (PList q) (ValueF a) (ValueF b)+type Square01 qs a b = SquareNT Unit (PList qs) (ValueF a) (ValueF b) -- | The boring profunctor from and to the unit category. data Unit a b where