many layered transformers vs. many "effects"

test.hs

{-#LANGUAGE TypeOperators, BangPatterns, DataKinds, FlexibleContexts, GADTs #-}
module Main (main) where
import Control.Monad.Freer
import Control.Monad.Freer.Internal
import qualified Control.Monad.Freer.State as FS

import Control.Monad
import qualified  Control.Monad.Trans.State.Strict as MTL

import Streaming hiding (run)
import qualified Streaming.Prelude as S
import qualified Streaming.Internal as S

import Streaming.Extensible 
import qualified Pipes as P
import qualified Pipes.Prelude as P
import GHC.Magic

--                   layers
--           one         two        three     four
-- streaming 0m0.354s    0m0.937s   0m1.782s	0m2.139s
-- freer     0m0.590s    0m1.283s   0m3.594s	0m5.891s
-- pipes     0m0.432s    0m1.353s   0m3.910s	0m5.444s


main = ssstream
-- ------------------------------------------------------------
-- thee programs summing over a succession of yields
-- ------------------------------------------------------------


stream_ = print $ runIdentity 
                $ S.fold (+) (0::Int) id 
                $ replicateM_ 10000000 $ S.yield (1::Int) 
-- real	0m0.354s

freer_ = print $ run 
               $ fold (+) (0::Int) 
               $ replicateM_ 10000000 $ yield (1::Int)
-- real	0m0.590s

pipe_ :: IO ()
pipe_ = print $ runIdentity 
              $ P.fold (+) (0::Int) id 
              $ replicateM_ 10000000 $ P.yield (1::Int)
-- real	0m0.432s


-- ------------------------------------------------------------
-- threee programs summing over two layers of yielding
-- ------------------------------------------------------------


stream = print $ runIdentity 
               $ S.fold (+) (0::Double) id
               $ S.fold (+) (0::Int) id 
               $ replicateM_ 10000000 $ do
                    S.yield (1::Int)
                    lift (S.yield (1::Double))
-- 1.0e7 :> (10000000 :> ())
-- real	0m0.937s


freer = print $ run 
              $ fold (+) (0::Double) 
              $ fold (+) (0::Int) 
              $ replicateM_ 10000000 $ do 
                   yield (1::Int)
                   yield (1::Double)
-- (1.0e7,(10000000,()))
-- real	0m1.283s


pipe :: IO ()
pipe = print $ runIdentity 
             $ P.fold' (+) (0::Double) id 
             $ P.sum 
             $ replicateM_ 10000000 $ do 
                 P.yield (1::Int)
                 lift (P.yield (1::Double))
-- (1.0e7,10000000)
-- real	0m1.353s


-- ------------------------------------------------------------------
-- three programs modifying state and summing over two kinds of yield 
-- ------------------------------------------------------------------


sstream = print $ runIdentity 
                $ flip MTL.runStateT (0::Int) 
                $ S.sum 
                $ S.sum 
                $ replicateM_ 10000000 $ do
                    S.yield (1::Int)
                    lift $ S.yield (1::Double)
                    lift $ lift $ do 
                      n <- MTL.get 
                      MTL.put $! n + 1
-- (1.0e7 :> (10000000 :> ()),10000000)
-- real	0m1.782s

sfreer = print $ run 
               $ flip FS.runState (0::Int) 
               $ fold (+) (0::Double) 
               $ fold (+) (0::Int) 
               $ replicateM_ 10000000 $
                    do yield (1::Int)
                       yield (1::Double)
                       n <- FS.get
                       FS.put $! (n+1 :: Int)

-- ((1.0e7,(10000000,())),10000000)
-- real  0m3.594s

spipe :: IO ()
spipe = print $ runIdentity 
              $ flip MTL.runStateT (0::Int) 
              $ P.fold' (+) (0::Double) id 
              $ P.fold' (+) (0::Int) id 
              $ replicateM_ 10000000 $ do
                 P.yield (1::Int)
                 lift $ P.yield (1::Double)
                 lift $ lift $ do 
                    n <- MTL.get 
                    MTL.put $! n + 1
-- ((1.0e7,10000000),10000000)
-- real	0m3.910s

-- -----------------------------------------------------------------------
-- three programs modifying two states and summing over two kinds of yield 
-- -----------------------------------------------------------------------

ssstream =   print
             $ runIdentity
             $ flip MTL.runStateT (0::Double)
             $ flip MTL.runStateT (0::Int) 
             $ S.fold (+) (0::Double) id 
             $ S.fold (+) (0::Int) id 
             $ replicateM_ 10000000 $ do
                    S.yield (1::Int)
                    lift $ S.yield (1::Double)
                    lift $ lift $ do 
                      n <- MTL.get 
                      lift $ do 
                        m <- MTL.get
                        MTL.put $! (m+1::Double) 
                      MTL.put $! (n + 1::Int)

ssfreer = print $ run 
                $ flip FS.runState (0::Int) 
                $ flip FS.runState (0::Double) 
                $ fold (+) (0::Double) 
                $ fold (+) (0::Int) 
                $ replicateM_ 10000000 $
                    do yield (1::Int)
                       yield (1::Double)
                       n <- FS.get
                       FS.put $! (n+1 :: Int)
                       m <- FS.get
                       FS.put $! (m+1 :: Double)
 
sspipe :: IO ()
sspipe = print  $ runIdentity 
               $ flip MTL.runStateT (0::Double)
               $ flip MTL.runStateT (0::Int) 
               $ P.fold' (+) (0::Double) id 
               $ P.fold' (+) (0::Int) id 
               $ replicateM_ 10000000 $ do
                  P.yield (1::Int)
                  lift $ P.yield (1::Double)
                  lift $ lift $ do 
                     n <- MTL.get 
                     lift $ do 
                       m <- MTL.get
                       MTL.put $! (m+1::Double) 
                     MTL.put $! n + 1
                  
-- -------------------------------------------------------------
-- implementations
-- -------------------------------------------------------------

-- ----------      
-- freer help
-- ----------
fold :: (s -> a -> s) -> s -> Eff (Of a ': fs) r -> Eff fs (s,r)
fold op seed = handleRelayS 
    seed 
    (\s r -> return (s,r)) 
    (\s (a :> r) go ->
       let !s' = op s a
       in go s' r )
       

yield :: Member (Of a) r => a -> Eff r ()
yield x = send (x :> ())