module Main where

import Control.Monad.Exception.Asynchronous
   (Exceptional(Exceptional), force, pure, throwMonoid, broken, result, exception, )
import Control.Monad (mplus, )
import Data.Monoid (Monoid, mappend, mempty, )


convert :: [Either String a] -> Exceptional String [a]
convert =
   emconcat .
   map (force . either throwMonoid (pure . (:[])))

emconcat :: Monoid a => [Exceptional e a] -> Exceptional e a
emconcat =
   force .
   foldr
      (\(Exceptional e a) ~(Exceptional es as) ->
          Exceptional (mplus e es) (mappend a as))
      (pure mempty)

econcat :: [Exceptional e a] -> Exceptional e [a]
econcat =
   force .
   foldr
      (\(Exceptional e a) ~(Exceptional es as) ->
          Exceptional (mplus e es) (a:as))
      (pure [])

convert0 :: [Either String a] -> Exceptional String [a]
convert0 =
   force .
   -- not quite mconcat, because we need lazy matching on the right operand
   foldr
      (\a b -> mappend a (force b))
      (pure []) .
   map (either throwMonoid (pure . (:[])))

convert1 :: [Either String a] -> Exceptional String [a]
convert1 =
   force .
   foldr
      (\ea -> force .
         either (mappend . throwMonoid) (\entry -> fmap (entry:)) ea)
      (pure [])

-- the String argument prevents caching and thus a space-leak
infinite :: String -> [Either String Integer]
infinite msg =
   map Right (iterate (1+) 0) ++ [Left msg]

-- the String argument prevents caching and thus a space-leak
infiniteExc :: String -> [Exceptional String Integer]
infiniteExc msg =
   map (Exceptional Nothing) (iterate (1+) 0) ++ [broken msg 0]

skip :: [a] -> [a]
skip = map head . iterate (drop 1000)

spaceLeak0 :: IO ()
spaceLeak0 =
   let r  = convert $ infinite "bla"
       e  = exception r
       xs = result r
   in  do mapM_ print $ skip xs
          print e

spaceLeak1 :: IO ()
spaceLeak1 =
   let Exceptional e xs = convert $ infinite "bla"
   in  do mapM_ print $ skip xs
          print e

spaceLeak2 :: IO ()
spaceLeak2 =
   let Exceptional e xs = econcat $ infiniteExc "bla"
   in  do mapM_ print $ skip xs
          print e

noSpaceLeak0 :: IO ()
noSpaceLeak0 =
   let r  = convert $ infinite "bla"
       _e = exception r
       xs = result r
   in  mapM_ print $ skip xs

noSpaceLeak1 :: IO ()
noSpaceLeak1 =
   let Exceptional _e xs = convert $ infinite "bla"
   in  mapM_ print $ skip xs

{-
ee-test +RTS -M32m -c30 -RTS
-}
main :: IO ()
main = spaceLeak2