An example of a non-trivial Arrow, for cdsmith

StreamProc.hs

{-# LANGUAGE TypeOperators #-}
module StreamProc where

import Prelude hiding ((.), id, const)
import Control.Category
import Control.Arrow
import Control.Applicative

const :: (Arrow (~>)) => a -> (b ~> a)
const x = arr (\_ -> x)

newtype StreamProc a b = SP { stepSP :: a -> (b, StreamProc a b) }

runStream sp (x:xs) = let (r,sp') = stepSP sp x
                          (rs,sp'') = runStream sp' xs
                      in (r:rs, sp'')


instance Category StreamProc where
    id = SP $ \x -> (x, id)
    SP g . SP f = SP $ \x -> let (y, f') = f x
                                 (z, g') = g y
                             in (z, g' . f')

instance Arrow StreamProc where
    arr f = SP $ \x -> (f x, arr f)
    SP f &&& SP g = SP $ \x -> let (y1,f') = f x
                                   (y2,g') = g x
                               in ((y1,y2), f' &&& g')
    f *** g = f . arr fst &&& g . arr snd
    first f = f *** id
    second g = id *** g

instance Functor (StreamProc r) where
    fmap f = (arr f .)

instance Applicative (StreamProc r) where
    pure = const
    f <*> x = f &&& x >>> arr (uncurry ($))


instance ArrowChoice StreamProc where
    SP f ||| SP g = SP $ \e -> case e of
                                   Left l  -> second (||| SP g) $ f l
                                   Right r -> second (SP f |||) $ g r
    f +++ g = arr Left . f ||| arr Right . g
    left f = f +++ id
    right g = id +++ g


instance ArrowLoop StreamProc where
    loop (SP f) = SP $ \x -> let ((y, z), f') = f (x, z)
                             in (y, loop f')

-- ArrowApply can be defined, but you don't really want to

-- Alternative, ArrowZero, and ArrowPlus don't really work here,
-- but would be easy if the processor has a "halt" state


delay n z sp | n <= 0    = sp
             | otherwise = SP $ \_ -> (z, delay (n - 1) z sp)

foldlSP f z = SP $ \x -> let z' = f x z
                         in (z', foldlSP f z')

sumSP = foldlSP (+)

diffSP z = SP $ \x -> (z - x, diffSP x)