-- | This module provides a variant of the standard
-- 'Control.Arrow.Arrow' type class with a different
-- 'Control.Arrow.arr' method so that it can be implemented for signal
-- functions in Rattus.

module Rattus.Arrow where

import Prelude hiding (id)
import Rattus.Primitives
import Control.Category

-- | Variant of the standard 'Control.Arrow.Arrow' type class with a
-- different 'Control.Arrow.arr' method so that it can be implemented
-- for signal functions in Rattus.
class Category a => Arrow a where
    {-# MINIMAL arrBox, (first | (***)) #-}

    -- | Lift a function to an arrow. It is here the definition of the
    -- 'Arrow' class differs from the standard one. The function to be
    -- lifted has to be boxed.
    -- 
    arrBox :: Box (b -> c) -> a b c

    -- | Send the first component of the input through the argument
    --   arrow, and copy the rest unchanged to the output.
    first :: a b c -> a (b,d) (c,d)
    first = (a b c -> a d d -> a (b, d) (c, d)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a d d
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)

    -- | A mirror image of 'first'.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    second :: a b c -> a (d,b) (d,c)
    second = (a d d
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id a d d -> a b c -> a (d, b) (d, c)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
***)

    -- | Split the input between the two argument arrows and combine
    --   their output.  Note that this is in general not a functor.
    (***) :: a b c -> a b' c' -> a (b,b') (c,c')
    a b c
f *** a b' c'
g = a b c -> a (b, b') (c, b')
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b c
f a (b, b') (c, b') -> a (c, b') (c, c') -> a (b, b') (c, c')
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((c, b') -> (b', c)) -> a (c, b') (b', c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (c, b') -> (b', c)
forall b a. (b, a) -> (a, b)
swap a (c, b') (b', c) -> a (b', c) (c, c') -> a (c, b') (c, c')
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a b' c' -> a (b', c) (c', c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b' c'
g a (b', c) (c', c) -> a (c', c) (c, c') -> a (b', c) (c, c')
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((c', c) -> (c, c')) -> a (c', c) (c, c')
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (c', c) -> (c, c')
forall b a. (b, a) -> (a, b)
swap
      where swap :: (b, a) -> (a, b)
swap ~(b
x,a
y) = (a
y,b
x)

    -- | Fanout: send the input to both argument arrows and combine
    --   their output.
    --
    --   The default definition may be overridden with a more efficient
    --   version if desired.
    (&&&) :: a b c -> a b c' -> a b (c,c')
    a b c
f &&& a b c'
g = (b -> (b, b)) -> a b (b, b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\b
b -> (b
b,b
b)) a b (b, b) -> a (b, b) (c, c') -> a b (c, c')
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> a b c
f a b c -> a b c' -> a (b, b) (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** a b c'
g


-- | This combinator is subject to the same restrictions as the 'box'
-- primitive of Rattus. That is,
--
-- >   Γ☐ ⊢ t :: b -> c
-- > --------------------
-- >  Γ ⊢ arr t :: a b c
--
-- where Γ☐ is obtained from Γ by removing ✓ and any variables @x ::
-- 𝜏@, where 𝜏 is not a stable type.

arr :: Arrow a => (b -> c) -> a b c
arr :: (b -> c) -> a b c
arr b -> c
f = Box (b -> c) -> a b c
forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox ((b -> c) -> Box (b -> c)
forall a. a -> Box a
box b -> c
f)

-- | The identity arrow, which plays the role of 'return' in arrow notation.
returnA :: Arrow a => a b b
returnA :: a b b
returnA = Box (b -> b) -> a b b
forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox ((b -> b) -> Box (b -> b)
forall a. a -> Box a
box b -> b
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)