[Haskell-cafe] Space leak whilst implementing streams

[ephemeral.elusive at gmail.com]

Hello,

I have been using arrows to implement stream processors. At first, I
tried using the implementation presented in John Hughes' AFP arrows
lectures. However, this appeared to have a space leak in its
implementation of the left operator for ArrowChoice.

I found a way to remove this space leak, however, I do not really
understand why there was a space leak in the first place. I would
really appreciate any light that could be shed on this.

Below I include the AFP implementation (SF) and a modified
implementation that no longer has the space leak (SF'). I am using ghc
6.4.2.

Many thanks.



import Control.Arrow
import Data.Maybe


main  = test
test  = print (runSF  p (repeat 1))
test' = print (runSF' p (repeat (Just 1)))

-- heap profile appears to grow linearly for test, but not test'
p :: ArrowChoice a => a Int (Either Int Int)
p = arr Right >>> left (arr id)


newtype SF a b = SF {runSF :: [a] -> [b]}

instance Arrow SF where
  arr f
      = SF (map f)
  SF f >>> SF g
      = SF (f >>> g)
  first (SF f)
      = SF (unzip >>> first f >>> uncurry zip)

instance ArrowChoice SF where
  left (SF f)
      = SF (\xs -> combine xs (f [y | Left y <- xs]))
        where combine (Left _:xs)  (z:zs) = Left z :combine xs zs
              combine (Right r:xs) zs     = Right r:combine xs zs
              combine []           _      = []


-- SF' does not exhibit the space leak
newtype SF' a b = SF' {runSF' :: [Maybe a] -> [Maybe b]}

instance Arrow SF' where
  arr f
      = SF' (map (maybe Nothing (Just . f)))
  SF' f >>> SF' g
      = SF' (f >>> g)
  first (SF' f)
      = SF' (maybe_unzip >>> first f >>> uncurry maybe_zip)
        where maybe_unzip = foldr mu ([],[])
                  where mu Nothing      ~(xs,ys) = (Nothing:xs, Nothing: ys)
                        mu (Just (x,y)) ~(xs,ys) = (Just x:xs, Just y: ys)

              maybe_zip = zipWith mz
                  where mz (Just x) (Just y) = Just (x,y)
                        mz Nothing  Nothing  = Nothing

instance ArrowChoice SF' where
  left (SF' f)
      = SF' (\xs -> xs `combined` f (map drop_right xs))
        where combined = zipWith merge_left

              drop_right Nothing          = Nothing
              drop_right (Just (Left l))  = Just l
              drop_right (Just (Right _)) = Nothing

              merge_left Nothing          Nothing  = Nothing
              merge_left (Just (Left _))  (Just x) = Just (Left x)
              merge_left (Just (Right r)) Nothing  = Just (Right r)