{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Arrow.Square
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  sjoerd@w3future.com
--
-----------------------------------------------------------------------------
module Control.Arrow.Square where

import Data.Square
import Data.Profunctor
import Data.Profunctor.Composition
import Data.Profunctor.Composition.List
import qualified Control.Arrow as A

-- |
-- > +-----+
-- > |     |
-- > |  @--a
-- > |     |
-- > +-----+
arr :: (A.Arrow a, Profunctor a) => Square '[] '[a] '[] '[]
arr :: forall (a :: * -> * -> *).
(Arrow a, Profunctor a) =>
Square '[] '[a] '[] '[]
arr = forall (ps :: [* -> * -> *]) (qs :: [* -> * -> *]) (fs :: [* -> *])
       (gs :: [* -> *]).
(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 forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr

-- |
-- > +-----+
-- > a--\  |
-- > |  @--a
-- > a--/  |
-- > +-----+
(>>>) :: (A.Arrow a, Profunctor a) => Square '[a, a] '[a] '[] '[]
>>> :: forall (a :: * -> * -> *).
(Arrow a, Profunctor a) =>
Square '[a, a] '[a] '[] '[]
(>>>) = forall (ps :: [* -> * -> *]) (qs :: [* -> * -> *]) (fs :: [* -> *])
       (gs :: [* -> *]).
(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 (\(Procompose a x b
q a a x
p) -> a a x
p forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
A.>>> a x b
q)

-- |
-- > +-_⊗d-+
-- > |  v  |
-- > a--@--a
-- > |  v  |
-- > +-_⊗d-+
second :: (A.Arrow a, Profunctor a) => Square '[a] '[a] '[(,) d] '[(,) d]
second :: forall (a :: * -> * -> *) d.
(Arrow a, Profunctor a) =>
Square '[a] '[a] '[(,) d] '[(,) d]
second = forall (ps :: [* -> * -> *]) (qs :: [* -> * -> *]) (fs :: [* -> *])
       (gs :: [* -> *]).
(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 forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
A.second

-- |
-- > H²-⊗--H
-- > |  v  |
-- > a²-@--a
-- > |  v  |
-- > H²-⊗--H
(***) :: A.Arrow a => Square21 '[a] '[a] '[a] (,) (,)
*** :: forall (a :: * -> * -> *).
Arrow a =>
Square21 '[a] '[a] '[a] (,) (,)
(***) = forall a b c d (p :: a -> b -> *) (q :: c -> d -> *) (f :: a -> c)
       (g :: b -> d).
(forall (a :: a) (b :: b). p a b -> q (f a) (g b))
-> SquareNT p q f g
Square forall a b. (a -> b) -> a -> b
$ \(P p a1 b1
p1 :**: P p a2 b2
p2) -> forall (a :: * -> * -> *) a b. a a b -> PList '[a] a b
P (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr forall {a} {b} (f :: a -> b -> *) (a :: a) (b :: b).
f a b -> UncurryF f '(a, b)
UncurryF forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
A.<<< p a1 b1
p1 forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
A.*** p a2 b2
p2 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
A.<<< forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr forall {a} {b} (f :: a -> b -> *) (a :: a) (b :: b).
UncurryF f '(a, b) -> f a b
curryF)

-- |
-- > +-_⊕d-+
-- > |  v  |
-- > a--@--a
-- > |  v  |
-- > +-_⊕d-+
right :: (A.ArrowChoice a, Profunctor a) => Square '[a] '[a] '[Either d] '[Either d]
right :: forall (a :: * -> * -> *) d.
(ArrowChoice a, Profunctor a) =>
Square '[a] '[a] '[Either d] '[Either d]
right = forall (ps :: [* -> * -> *]) (qs :: [* -> * -> *]) (fs :: [* -> *])
       (gs :: [* -> *]).
(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 forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either d b) (Either d c)
A.right

-- |
-- > H²-⊕--H
-- > |  v  |
-- > a²-@--a
-- > |  v  |
-- > H²-⊕--H
(+++) :: A.ArrowChoice a => Square21 '[a] '[a] '[a] Either Either
+++ :: forall (a :: * -> * -> *).
ArrowChoice a =>
Square21 '[a] '[a] '[a] Either Either
(+++) = forall a b c d (p :: a -> b -> *) (q :: c -> d -> *) (f :: a -> c)
       (g :: b -> d).
(forall (a :: a) (b :: b). p a b -> q (f a) (g b))
-> SquareNT p q f g
Square forall a b. (a -> b) -> a -> b
$ \(P p a1 b1
p1 :**: P p a2 b2
p2) -> forall (a :: * -> * -> *) a b. a a b -> PList '[a] a b
P (forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr forall {a} {b} (f :: a -> b -> *) (a :: a) (b :: b).
f a b -> UncurryF f '(a, b)
UncurryF forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
A.<<< p a1 b1
p1 forall (a :: * -> * -> *) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
A.+++ p a2 b2
p2 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
A.<<< forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
A.arr forall {a} {b} (f :: a -> b -> *) (a :: a) (b :: b).
UncurryF f '(a, b) -> f a b
curryF)