-- |
-- Module: Language.KURE.Combinators.Arrow
-- Copyright: (c) 2012--2021 The University of Kansas
-- License: BSD3
--
-- Maintainer: Neil Sculthorpe <neil.sculthorpe@ntu.ac.uk>
-- Stability: beta
-- Portability: ghc
--
-- This module provides some utility arrow routing combinators.

module Language.KURE.Combinators.Arrow
           ( -- * Arrow Routing
             -- | The names 'result' and 'argument' are taken from Conal Elliott's semantic editor combinators.
             --   <http://conal.net/blog/posts/semantic-editor-combinators>
             result
           , argument
           , toFst
           , toSnd
           , swap
           , fork
           , forkFirst
           , forkSecond
           , constant
           , serialise
           , parallelise
) where

import Prelude hiding (id, foldr)

import Control.Category hiding ((.))
import Control.Arrow

import Data.Foldable

------------------------------------------------------------------------------------------

-- | Apply a pure function to the result of an arrow.
result :: Arrow bi => (b -> c) -> bi a b -> bi a c
result :: (b -> c) -> bi a b -> bi a c
result b -> c
f bi a b
a = bi a b
a bi a b -> (b -> c) -> bi a c
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ b -> c
f
{-# INLINE result #-}

-- | Apply a pure function to the argument to an arrow.
argument :: Arrow bi => (a -> b) -> bi b c -> bi a c
argument :: (a -> b) -> bi b c -> bi a c
argument a -> b
f bi b c
a = a -> b
f (a -> b) -> bi b c -> bi a c
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> bi b c
a
{-# INLINE argument #-}

-- | Apply an arrow to the first element of a pair, discarding the second element.
toFst :: Arrow bi => bi a b -> bi (a,x) b
toFst :: bi a b -> bi (a, x) b
toFst bi a b
f = (a, x) -> a
forall a b. (a, b) -> a
fst ((a, x) -> a) -> bi a b -> bi (a, x) b
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> bi a b
f
{-# INLINE toFst #-}

-- | Apply an arrow to the second element of a pair, discarding the first element.
toSnd :: Arrow bi => bi a b -> bi (x,a) b
toSnd :: bi a b -> bi (x, a) b
toSnd bi a b
f = (x, a) -> a
forall a b. (a, b) -> b
snd ((x, a) -> a) -> bi a b -> bi (x, a) b
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> bi a b
f
{-# INLINE toSnd #-}

-- | A pure arrow that swaps the elements of a pair.
swap :: Arrow bi => bi (a,b) (b,a)
swap :: bi (a, b) (b, a)
swap = ((a, b) -> (b, a)) -> bi (a, b) (b, a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\(a
a,b
b) -> (b
b,a
a))
{-# INLINE swap #-}

-- | A pure arrow that duplicates its argument.
fork :: Arrow bi => bi a (a,a)
fork :: bi a (a, a)
fork = (a -> (a, a)) -> bi a (a, a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\a
a -> (a
a,a
a))
{-# INLINE fork #-}

-- | Tag the result of an arrow with its argument.
forkFirst :: Arrow bi => bi a b -> bi a (b,a)
forkFirst :: bi a b -> bi a (b, a)
forkFirst bi a b
sf = bi a (a, a)
forall (bi :: * -> * -> *) a. Arrow bi => bi a (a, a)
fork bi a (a, a) -> bi (a, a) (b, a) -> bi a (b, a)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> bi a b -> bi (a, a) (b, a)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first bi a b
sf
{-# INLINE forkFirst #-}

-- | Tag the result of an arrow with its argument.
forkSecond :: Arrow bi => bi a b -> bi a (a,b)
forkSecond :: bi a b -> bi a (a, b)
forkSecond bi a b
sf = bi a (a, a)
forall (bi :: * -> * -> *) a. Arrow bi => bi a (a, a)
fork bi a (a, a) -> bi (a, a) (a, b) -> bi a (a, b)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> bi a b -> bi (a, a) (a, b)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second bi a b
sf
{-# INLINE forkSecond #-}

-- | An arrow with a constant result.
constant :: Arrow bi => b -> bi a b
constant :: b -> bi a b
constant = (a -> b) -> bi a b
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr ((a -> b) -> bi a b) -> (b -> a -> b) -> b -> bi a b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a -> b
forall a b. a -> b -> a
const
{-# INLINE constant #-}

-------------------------------------------------------------------------------

-- | Sequence (from left to right) a collection of 'Category's.
serialise :: (Foldable f, Category bi) => f (bi a a) -> bi a a
serialise :: f (bi a a) -> bi a a
serialise = (bi a a -> bi a a -> bi a a) -> bi a a -> f (bi a a) -> bi a a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr bi a a -> bi a a -> bi a a
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) bi a a
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id
{-# INLINE serialise #-}

-- | Apply a collection of arrows to the same input, combining their results in a monoid.
parallelise :: (Foldable f, Arrow bi, Monoid b) => f (bi a b) -> bi a b
parallelise :: f (bi a b) -> bi a b
parallelise = (bi a b -> bi a b -> bi a b) -> bi a b -> f (bi a b) -> bi a b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ bi a b
f bi a b
g -> (bi a b
f bi a b -> bi a b -> bi a (b, b)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& bi a b
g) bi a (b, b) -> ((b, b) -> b) -> bi a b
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> (c -> d) -> a b d
>>^ (b -> b -> b) -> (b, b) -> b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> b -> b
forall a. Monoid a => a -> a -> a
mappend) (b -> bi a b
forall (bi :: * -> * -> *) b a. Arrow bi => b -> bi a b
constant b
forall a. Monoid a => a
mempty)
{-# INLINE parallelise #-}

-------------------------------------------------------------------------------