ArrowLoop instance for Hughes' StreamProcessor

arrowloop-streamprocessor.hs

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


data StreamProcessor a b =
    Put b (StreamProcessor a b) | Get (a -> StreamProcessor a b)

instance Category StreamProcessor where
    id = arr id
    (Put b sp2) . sp1 = Put b (sp1 >>> sp2)
    (Get f) . (Put b sp1) = sp1 >>> f b
    (Get f2) . (Get f1) = Get $ \a -> f1 a >>> Get f2
    
instance Arrow StreamProcessor where
    arr f = Get $ \a -> Put (f a) (arr f)

    first f = bypass [] [] f where
        bypass [] ds (Get f) = Get $
            \(b, d) -> bypass [] (ds ++ [d]) (f b)
        bypass (b : bs) [] (Get f) = bypass bs [] (f b)
        bypass bs [] (Put c sp) = Get $
            \(b, d) -> Put (c, d) (bypass (bs ++ [b]) [] sp)
        bypass [] (d : ds) (Put c sp) = Put (c, d) (bypass [] ds sp)

instance ArrowLoop StreamProcessor where
    loop sp = collect [] sp where
        collect cs (Put (b, c) sp) = Put b (collect (cs ++ [c]) sp)
        collect (c:cs) (Get f) = Get $ \a -> collect cs $ f (a, c)
        collect [] firstSP@(Get _) = collectFuture [] firstSP
        
        collectFuture allInp firstSP = nextProcessor where
            (_, _, nextProcessor) = peek allInp 0 firstSP
            
            peek [] _ (Get _) =
                ( repeat undefined, False, Get $ \a ->
                    collectFuture (allInp ++ [a]) firstSP )
                    
            peek (a:as) cn (Get f) =
                let (c:cs, fulfiled, next) = peek as (cn - 1) (f (a, c))
                in (cs, fulfiled, next)
            
            peek as cn (Put (b, c) rest) =
                if cn + 1 >= 0
                then ([c], True, Put b $ loop rest)
                else case peek as (cn + 1) rest of
                    (cs, True, next) -> (cs ++ [c], True, Put b next)
                    (cs, False, next) -> (cs, False, next)


runningTotal = loop $ Put (0, 0) addNext
    where addNext = Get $ \(x, t) -> Put (t + x, t + x) addNext

plus10 = loop step where
    step = Get $ \(x, c) -> Put (c, x + 10) step

reverse2 = loop step where
    step = Get $ \(x1, c1) -> Get $ \(x2, c2) ->
            Put (c2, x1) $ Put (c1, x2) step

reverse3 = loop step where
    step = Get $ \(x1, c1) -> Get $ \(x2, c2) -> Get $ \(x3, c3) ->
            Put (c3, x1) $ Put (c2, x2) $ Put (c1, x3) step

recursive = loop step where
    step = Get $ \(x1, f1) -> Get $ \(x2, f2) ->
            Put ((+) x1, \x -> f2 x) $
            Put (f1, (+) x2) step

pairSum = loop step where
    step = Get $ \(x1, c1) -> Get $ \(x2, c2) -> Put (c1+c2, x1) $
            Get $ \(x3, c3) -> Put (c1+c3, x2) $ Put (c2+c3, x3) step

mixedProfiDefi = loop step where
    step = Get $ \(x1, c1) -> Put (c1, x1) $
            Put (0, 0) $ Get $ \_ -> step

runSP (Put b sp) as = b : runSP sp as
runSP (Get _) [] = []
runSP (Get f) (a:as) = runSP (f a) as

main = do
    print $ runSP runningTotal [1, 2, 3, 4]
    print $ runSP plus10 [1, 2, 3]
    print $ runSP reverse2 [1, 2, 3, 4, 5, 6]
    print $ runSP reverse3 [1, 2, 3, 4, 5, 6]
    print $ (runSP recursive [1, 2]) <*> [10, 20]
    print $ runSP reverse3 [1, 2, 3, 4, 5, 6]
    print $ runSP pairSum [1, 2, 3, 4, 5, 6]
    print $ runSP mixedProfiDefi [1, 2, 3, 4, 5, 6]