{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{- |
This module is an attempt to simplify the use of arrow combinators.
If I have @f :: arrow a b@,
then subsequent arrows can only access the @b@,
but often I also want to access the @a@.
Thus I often write

> f &&& arr id :: arrow a (b,a)  .

If I repeat this, it yields

> g &&& arr id <<< f &&& arr id :: arrow a (c,(b,a))
> h &&& arr id <<< g &&& arr id <<< f &&& arr id :: arrow a (d,(c,(b,a)))  .

However accessing the particular inputs of type @d@, @c@, @b@
from within @h@ and @g@ is cumbersome.
Thus I wrote a little support for this style of arrow programming.
First I use @HList@ instead of nested pairs.
Using type level Peano numbers and reverse @HList@ index access
I can use the same expression (say @listen x@) in both @g@ and @h@
although in both contexts they refer to different @HLists@.
E.g. @g@ expects the @b@ input at the @HList@ head,
whereas @h@ gets it one position later.
-}
module Control.Arrow.Monad where

import qualified Data.HList as HL
import qualified Data.HList.HArray as HA
import qualified Data.HList.FakePrelude as HN

import Control.Arrow (Arrow, arr, (&&&), (<<<), (^<<), )


infixl 1 >>>=

{- |
This @bind@-like operator allows you to a share an interim arrow result
between various following arrow inputs.

Instead of

> mix <<<  id &&& delay  <<< lowpass

you can write

> (\x -> HL.hCons x HL.hNil) ^>>
> ((HL.hHead ^>> lowpass) >>>= \x ->
>      mix <<<  listen x &&& (delay <<< listen x))
-}
(>>>=) ::
   (Arrow arrow, HA.HLength list n) =>
   arrow list a ->
   (n -> arrow (HL.HCons a list) b) ->
   arrow list b
(>>>=) x k =
   let len :: (HA.HLength list n) => arrow list a -> list -> n
       len _ = HA.hLength
   in  k (len x undefined) <<< uncurry HL.HCons ^<< (x &&& arr id)


infixr 1 =<<<

(=<<<) ::
   (Arrow arrow, HA.HLength list n) =>
   (n -> arrow (HL.HCons a list) b) ->
   arrow list a ->
   arrow list b
(=<<<) = flip (>>>=)


class (HL.HNat x, HL.HNat y, HL.HNat z) => HAdd x y z
         | x y -> z, x z -> y {- , y z -> x -} where

instance (HL.HNat x) => HAdd HN.HZero x x where
instance (HAdd x y z) => HAdd (HN.HSucc x) y (HN.HSucc z) where

listen ::
   (Arrow arrow,
    HA.HLength list len, HAdd n m len, HA.HLookupByHNat m list a) =>
   n -> arrow list a
listen =
   let aux ::
          (HA.HLength list len, HAdd n m len, HA.HLookupByHNat m list a) =>
          m -> n -> list -> a
       aux m _ = HA.hLookupByHNat m
   in  arr . aux undefined