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

import Prelude hiding (traverse, sequence)
import Data.Square
import Data.Bifunctor.Biff
import Data.Profunctor
import qualified Data.Traversable as T

-- |
-- > +--t--+
-- > |  v  |
-- > f>-T->f
-- > |  v  |
-- > +--t--+
--
-- `traverse` as a square.
--
-- Naturality law:
--
-- > +-----t--+     +--t-----+
-- > |     v  |     |  v     |
-- > f>-@->T->g === f>-T->@->g
-- > |     v  |     |  v     |
-- > +-----t--+     +--t-----+
--
-- Identity law:
--
-- > +--t--+     +--t--+
-- > |  v  |     |  |  |
-- > |  T  | === |  v  |
-- > |  v  |     |  |  |
-- > +--t--+     +--t--+
--
-- Composition law:
--
-- > +--t--+     +--t--+
-- > |  v  |     |  v  |
-- > f>-T->f     f>\|/>f
-- > |  v  | === |  T  |
-- > g>-T->g     g>/|\>g
-- > |  v  |     |  v  |
-- > +--t--+     +--t--+
--
-- > traverse = (fromLeft ||| funId) === sequence === (funId ||| toRight)
traverse :: (Traversable t, Applicative f) => Square '[Star f] '[Star f] '[t] '[t]
traverse :: forall (t :: * -> *) (f :: * -> *).
(Traversable t, Applicative f) =>
Square '[Star f] '[Star f] '[t] '[t]
traverse = 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 {k} (f :: k -> *) d (c :: k). (d -> f c) -> Star f d c
Star forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
T.traverse 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)

-- |
-- > +-f-t---+
-- > | v v   |
-- > | \-@-\ |
-- > |   v v |
-- > +---t-f-+
--
-- @sequence = toRight ||| traverse ||| fromLeft@
sequence :: (Traversable t, Applicative f) => Square '[] '[] '[f, t] '[t, f]
sequence :: forall (t :: * -> *) (f :: * -> *).
(Traversable t, Applicative f) =>
Square '[] '[] '[f, t] '[t, f]
sequence = 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 (t :: * -> *) (f :: * -> *).
(Traversable t, Applicative f) =>
Square '[Star f] '[Star f] '[t] '[t]
traverse 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 (f :: * -> *). Square '[Star f] '[] '[] '[f]
fromLeft

-- | > mapAccumL :: ((s, a) -> (s, b)) -> (s, t a) -> (s, t b)
mapAccumL :: Traversable t => Square '[Biff (->) ((,) s) ((,) s)] '[Biff (->) ((,) s) ((,) s)] '[t] '[t]
mapAccumL :: forall (t :: * -> *) s.
Traversable t =>
Square
  '[Biff (->) ((,) s) ((,) s)] '[Biff (->) ((,) s) ((,) s)] '[t] '[t]
mapAccumL = 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 {k} {k1} {k2} {k3} (p :: k -> k1 -> *) (f :: k2 -> k)
       (g :: k3 -> k1) (a :: k2) (b :: k3).
p (f a) (g b) -> Biff p f g a b
Biff forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
T.mapAccumL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} {k3} {k4} (p :: k1 -> k2 -> *) (f :: k3 -> k1)
       (g :: k4 -> k2) (a :: k3) (b :: k4).
Biff p f g a b -> p (f a) (g b)
runBiff)

-- | > mapAccumR :: ((s, a) -> (s, b)) -> (s, t a) -> (s, t b)
mapAccumR :: Traversable t => Square '[Biff (->) ((,) s) ((,) s)] '[Biff (->) ((,) s) ((,) s)] '[t] '[t]
mapAccumR :: forall (t :: * -> *) s.
Traversable t =>
Square
  '[Biff (->) ((,) s) ((,) s)] '[Biff (->) ((,) s) ((,) s)] '[t] '[t]
mapAccumR = 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 {k} {k1} {k2} {k3} (p :: k -> k1 -> *) (f :: k2 -> k)
       (g :: k3 -> k1) (a :: k2) (b :: k3).
p (f a) (g b) -> Biff p f g a b
Biff forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
T.mapAccumR forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k1} {k2} {k3} {k4} (p :: k1 -> k2 -> *) (f :: k3 -> k1)
       (g :: k4 -> k2) (a :: k3) (b :: k4).
Biff p f g a b -> p (f a) (g b)
runBiff)