{-# 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