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

import Prelude hiding (return)
import Data.Square
import Data.Profunctor
import qualified Control.Monad as M

-- |
-- > +-----+
-- > |     |
-- > |  R  |
-- > |  v  |
-- > +--m--+
return :: Monad m => Square '[] '[] '[] '[m]
return :: forall (m :: * -> *). Monad m => Square '[] '[] '[] '[m]
return = 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 (m :: * -> *) a. Monad m => a -> m a
M.return forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

-- |
-- > +--m--+
-- > |  v  |
-- > m>-B  |
-- > |  v  |
-- > +--m--+
--
-- `(>>=)` as a square (or to be precise its flipped version `(=<<)`)
--
-- Left identity law:
--
-- > +-----+
-- > |  R  |     +-----+
-- > |  v  |     |     |
-- > m>-B  | === m>-\  |
-- > |  v  |     |  v  |
-- > +--m--+     +--m--+
--
-- Right identity law:
--
-- > +---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-+
bind :: Monad m => Square '[Star m] '[] '[m] '[m]
bind :: forall (m :: * -> *). Monad m => Square '[Star m] '[] '[m] '[m]
bind = 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 (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) d (c :: k). Star f d c -> d -> f c
runStar)

-- |
-- > +-m-m-+
-- > | v v |
-- > | \-@ |
-- > |   v |
-- > +---m-+
--
-- > join = toRight ||| bind
join :: Monad m => Square '[] '[] '[m, m] '[m]
join :: forall (m :: * -> *). Monad m => Square '[] '[] '[m, m] '[m]
join = forall (f :: * -> *). Functor f => Square '[] '[Star f] '[f] '[]
toRight forall (rs :: [* -> * -> *]) (fs :: [* -> *]) (gs :: [* -> *])
       (hs :: [* -> *]) (is :: [* -> *]) (ps :: [* -> * -> *])
       (qs :: [* -> * -> *]).
(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)
||| forall (m :: * -> *). Monad m => Square '[Star m] '[] '[m] '[m]
bind

-- |
-- > +-----+
-- > m>-\  |
-- > m>-@  |
-- > |  \->m
-- > +-----+
--
-- Kleisli composition `(M.>=>)`
--
-- > (>=>) = fromLeft === bind === toRight
(>=>) :: Monad m => Square '[Star m, Star m] '[Star m] '[] '[]
>=> :: forall (m :: * -> *).
Monad m =>
Square '[Star m, Star m] '[Star m] '[] '[]
(>=>) = forall (f :: * -> *). Square '[Star f] '[] '[] '[f]
fromLeft forall (ps :: [* -> * -> *]) (qs :: [* -> * -> *])
       (ss :: [* -> * -> *]) (fs :: [* -> *]) (gs :: [* -> *])
       (rs :: [* -> * -> *]) (hs :: [* -> *]).
(IsPList ps, IsPList qs, Profunctor (PList qs),
 Profunctor (PList ss)) =>
Square ps qs fs gs
-> Square rs ss gs hs -> Square (ps ++ rs) (qs ++ ss) fs hs
=== forall (m :: * -> *). Monad m => Square '[Star m] '[] '[m] '[m]
bind forall (ps :: [* -> * -> *]) (qs :: [* -> * -> *])
       (ss :: [* -> * -> *]) (fs :: [* -> *]) (gs :: [* -> *])
       (rs :: [* -> * -> *]) (hs :: [* -> *]).
(IsPList ps, IsPList qs, Profunctor (PList qs),
 Profunctor (PList ss)) =>
Square ps qs fs gs
-> Square rs ss gs hs -> Square (ps ++ rs) (qs ++ ss) fs hs
=== forall (f :: * -> *). Functor f => Square '[] '[Star f] '[f] '[]
toRight