-- | 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 = (forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** 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 = (forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id 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 = forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b c
f forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr forall {b} {a}. (b, a) -> (a, b)
swap forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first a b' c'
g forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr 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 = forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\b
b -> (b
b,b
b)) 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 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 :: forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> c
f = forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox (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 :: forall (a :: * -> * -> *) b. Arrow a => a b b
returnA = forall (a :: * -> * -> *) b c. Arrow a => Box (b -> c) -> a b c
arrBox (forall a. a -> Box a
box forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id)