whoa. optimize away the pain

bench/countDown.hs

@@ -126,8 +126,8 @@ main :: IO ()
 main =
   defaultMain [
     bgroup "Countdown Bench" [
-        -- bench "faster"            $ whnf TFTF.countDownFast 10000
+        bench "faster"            $ whnf TFTF.countDownFast 10000
-        bench "discount"          $ whnf TFTF.countDown 10000
+      , bench "discount"          $ whnf TFTF.countDown 10000
       , bench "freer-simple"      $ whnf countDown 10000
       , bench "mtl"               $ whnf countDownMTL 10000
     ]

package.yaml

@@ -23,12 +23,12 @@ dependencies:
 - base >= 4.7 && < 5
 - transformers
 - mtl
-- free
+- template-haskell
 
 flags:
   dump-core:
     description: Dump HTML for the core generated by GHC during compilation
-    default:     True
+    default:     False
     manual:      True
 
 library:

src/Control/Monad/Discount.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE MonoLocalBinds      #-}
 {-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE UnicodeSyntax       #-}
@@ -17,124 +18,59 @@ module Control.Monad.Discount
   , prj
   ) where
 
+import Data.Functor.Identity
+import Data.Tuple
 import Data.OpenUnion
 import Control.Monad.Discount.Effect
 import Control.Monad (join)
 import Control.Monad.Discount.Lift
+import qualified Control.Monad.Trans.State.Strict as S
+import Control.Monad.Trans.State.Strict (StateT)
 
+type Eff r = Freer (Union r)
 
-type Eff r = F (Union r)
+newtype Freer f a = Freer
-
+  { runFreer
-
+        :: ∀ m
-newtype F f a = F
+         . Monad m
-  { runF
+        => (∀ x. f (Freer f) x -> m x)
-        :: ∀ r
+        -> m a
-         . (a -> r)
-        -> (f (F f) r -> r)
-        -> r
   }
 
+usingFreer :: Monad m => (∀ x. f (Freer f) x -> m x) -> Freer f a -> m a
+usingFreer k m = runFreer m k
+{-# INLINE usingFreer #-}
 
-instance Functor (F f) where
+
-  fmap f (F g) = F (\kp -> g (kp . f))
+instance Functor (Freer f) where
+  fmap f (Freer m) = Freer $ \k -> fmap f $ m k
   {-# INLINE fmap #-}
 
 
-instance Applicative (F f) where
+instance Applicative (Freer f) where
-  pure a = F (\kp _ -> kp a)
+  pure a = Freer $ const $ pure a
   {-# INLINE pure #-}
-  F f <*> F g = F (\kp kf -> f (\a -> g (kp . a) kf) kf)
+
+  Freer f <*> Freer a = Freer $ \k -> f k <*> a k
   {-# INLINE (<*>) #-}
 
 
-instance Monad (F f) where
+instance Monad (Freer f) where
   return = pure
   {-# INLINE return #-}
-  F m >>= f = F (\kp kf -> m (\a -> runF (f a) kp kf) kf)
+
+  Freer ma >>= f = Freer $ \k -> do
+    z <- ma k
+    runFreer (f z) k
   {-# INLINE (>>=) #-}
 
-
+liftEff :: f (Freer f) a -> Freer f a
-runEff :: (a -> r) -> (f (F f) r -> r) -> F f a -> r
+liftEff u = Freer $ \k -> k u
-runEff kp kf e = runF e kp kf
-{-# INLINE runEff #-}
-
-
-liftEff :: Union r (Eff r) a -> Eff r a
-liftEff u = F $ \kp kf -> kf $ fmap kp u
 {-# INLINE liftEff #-}
 
-
+hoistEff :: (∀ x. f (Freer f) x -> g (Freer g) x) -> Freer f a -> Freer g a
-raise :: Eff r a -> Eff (e ': r) a
+hoistEff nat (Freer m) = Freer $ \k -> m $ \u -> k $ nat u
-raise = runEff pure $ join . liftEff . hoist raise . weaken
+{-# INLINE hoistEff #-}
-{-# INLINE raise #-}
-
-
-interpret
-    :: (∀ x. e (Eff (e ': r)) (Eff r x) -> Eff r x)
-    -> Eff (e ': r) a
-    -> Eff r a
-interpret f = runEff pure $ \u ->
-  case decomp u of
-    Left x -> join . liftEff $ hoist (interpret f) x
-    Right eff -> f eff
-{-# INLINE interpret #-}
-
-
-interpose
-    :: Member e r
-    => (∀ x. e (Eff r) x -> Eff r x)
-    -> Eff r a
-    -> Eff r a
-interpose f = runEff pure $ \u ->
-  join $ case prj u of
-    Just x  -> f x
-    Nothing -> liftEff u
-{-# INLINE interpose #-}
-
-
-subsume
-    :: (Member e r, Effect e)
-    => Eff (e ': r) a
-    -> Eff r a
-subsume = interpret $ join . send . hoist subsume
-{-# INLINE subsume #-}
-
-
-reinterpret
-    :: Effect f
-    => (∀ x. f (Eff (g ': r)) x -> Eff (g ': r) x)
-    -> Eff (f ': r) a
-    -> Eff (g ': r) a
-reinterpret f = runEff pure $ \u ->
-  join $ case decomp u of
-    Left  x -> liftEff $ weaken $ hoist (reinterpret f) x
-    Right y -> f $ hoist (reinterpret f) $ y
-{-# INLINE reinterpret #-}
-
-
--- TODO(sandy): does this have the right semantics for INSIDE MONADS?
-translate
-    :: ( Effect f
-       , Effect g
-       )
-    => (∀ x. f (Eff (f ': r)) x -> g (Eff (g ': r)) x)
-    -> Eff (f ': r) a
-    -> Eff (g ': r) a
-translate f = runEff pure $ \u ->
-  join $ case decomp u of
-    Left  x -> liftEff $ weaken $ hoist (translate f) x
-    Right y -> send $ f y
-{-# INLINE translate #-}
-
-
-runM :: Monad m => Eff '[Lift m] a -> m a
-runM e = runF e pure $ join . unLift . extract
-{-# INLINE runM #-}
-
-
-run :: Eff '[] a -> a
-run = runEff id $ error "lol"
-{-# INLINE run #-}
 
 
 send :: Member e r => e (Eff r) a -> Eff r a
@@ -143,6 +79,60 @@ send = liftEff . inj
 
 
 sendM :: Member (Lift m) r => m a -> Eff r a
-sendM = liftEff . inj . Lift
+sendM = send . Lift
 {-# INLINE sendM #-}
 
+
+run :: Eff '[] a -> a
+run (Freer m) = runIdentity $ m $ \u -> error "absurd"
+{-# INLINE run #-}
+
+
+runM :: Monad m => Eff '[Lift m] a -> m a
+runM (Freer m) = m $ \u -> error "absurd"
+{-# INLINE runM #-}
+
+
+interpret
+    :: Effect e
+    => (∀ x. e (Eff (e ': r)) x -> Eff r x)
+    -> Eff (e ': r) a
+    -> Eff r a
+interpret f (Freer m) = m $ \u ->
+  case decomp u of
+    Left  x -> liftEff $ hoist (interpret f) x
+    Right y -> f y
+{-# INLINE interpret #-}
+
+
+stateful
+    :: forall e s r a
+     . Effect e
+    => (∀ x. e (StateT s (Eff r)) x -> StateT s (Eff r) x)
+    -> s
+    -> Eff (e ': r) a
+    -> Eff r (s, a)
+stateful f s = \e -> fmap swap $ S.runStateT (go e) s
+  where
+    go :: Eff (e ': r) x -> StateT s (Eff r) x
+    go (Freer m) = m $ \u ->
+      case decomp u of
+        Left x -> S.StateT $ \s' ->
+          liftEff . fmap swap
+                  . weave (s', ()) (uncurry $ stateful f)
+                  $ x
+        Right y -> f $ hoist go y
+{-# INLINE stateful #-}
+
+
+reinterpret
+    :: Effect f
+    => (∀ x. f (Eff (g ': r)) x -> Eff (g ': r) x)
+    -> Eff (f ': r) a
+    -> Eff (g ': r) a
+reinterpret f (Freer m) = m $ \u ->
+  case decomp u of
+    Left  x -> liftEff $ weaken $ hoist (reinterpret f) x
+    Right y -> f $ hoist (reinterpret f) $ y
+{-# INLINE reinterpret #-}
+

src/Data/OpenUnion.hs

@@ -17,15 +17,7 @@
 {-# LANGUAGE UndecidableInstances  #-}
 {-# OPTIONS_GHC -Wall              #-}
 
-module Data.OpenUnion
+module Data.OpenUnion where
-  ( Member
-  , inj
-  , weaken
-  , Union (..)
-  , decomp
-  , extract
-  , prj
-  ) where
 
 import Control.Monad.Discount.Effect
 import Data.Typeable

src/TRYAGAIN.hs

@@ -19,8 +19,9 @@
 
 module TRYAGAIN where
 
+import Data.Tuple
 import Control.Monad.Discount
-import Control.Monad
+import qualified Control.Monad.Trans.State.Strict as S
 
 
 data State s m a
@@ -59,68 +60,102 @@ throw = send . Throw
 catch :: Member (Error e) r => Eff r a -> (e -> Eff r a) -> Eff r a
 catch try handle = send $ Catch try handle id
 
+runStateFast
+    :: forall s r a
+     . s
+    -> Eff (State s ': r) a
+    -> Eff r (s, a)
+runStateFast sz fm = go sz fm
+  where
+    go s (Freer m) = Freer $ \k ->
+      fmap swap $ flip S.runStateT s $ m $ \u ->
+        case decomp u of
+            Left x -> S.StateT $ \s' ->
+              k . fmap swap
+                . weave (s', ()) (uncurry runStateFast')
+                $ x
+            Right (Get k2) -> fmap k2 S.get
+            Right (Put s' k2) -> S.put s' >> pure k2
+{-# INLINE runStateFast #-}
+
+runStateFast'
+    :: forall s r a
+     . s
+    -> Eff (State s ': r) a
+    -> Eff r (s, a)
+runStateFast' s (Freer m) = Freer $ \k ->
+  fmap swap $ flip S.runStateT s $ m $ \u ->
+    case decomp u of
+        Left x -> S.StateT $ \s' ->
+          k . fmap swap
+            . weave (s', ()) (uncurry runStateFast)
+            $ x
+        Right (Get k2) -> fmap k2 S.get
+        Right (Put s' k2) -> S.put s' >> pure k2
+{-# INLINE runStateFast' #-}
+
 
 runState :: s -> Eff (State s ': r) a -> Eff r (s, a)
-runState = runRelayS (\s x -> pure (s, x)) $ \case
+runState = stateful $ \case
-  Get k   -> \s -> k s s
+  Get k   -> fmap k S.get
-  Put s k -> const $ k s
+  Put s k -> S.put s >> pure k
 {-# INLINE runState #-}
 
 
 
-runRelayS
+-- runRelayS
-    :: ∀ s e a r
+--     :: ∀ s e a r
-     . (∀ x. s -> x -> Eff r (s, x))
+--      . (∀ x. s -> x -> Eff r (s, x))
-    -> (∀ x. e (Eff (e ': r)) (s -> Eff r (s, x))
+--     -> (∀ x. e (Eff (e ': r)) (s -> Eff r (s, x))
-          -> s
+--           -> s
-          -> Eff r (s, x))
+--           -> Eff r (s, x))
-    -> s
+--     -> s
-    -> Eff (e ': r) a
+--     -> Eff (e ': r) a
-    -> Eff r (s, a)
+--     -> Eff r (s, a)
-runRelayS pure' bind' = flip go
+-- runRelayS pure' bind' = flip go
-  where
+--   where
-    go :: Eff (e ': r) x -> s -> Eff r (s, x)
+--     go :: Eff (e ': r) x -> s -> Eff r (s, x)
-    go = runEff (flip pure') $ \u ->
+--     go = runEff (flip pure') $ \u ->
-      case decomp u of
+--       case decomp u of
-        Left x  -> \s' ->
+--         Left x  -> \s' ->
-          join . liftEff
+--           join . liftEff
-               $ fmap (uncurry (flip id))
+--                $ fmap (uncurry (flip id))
-               $ weave (s', ()) (uncurry $ flip go) x
+--                $ weave (s', ()) (uncurry $ flip go) x
-        Right eff -> bind' eff
+--         Right eff -> bind' eff
-{-# INLINE runRelayS #-}
+-- {-# INLINE runRelayS #-}
 
 
-runError :: Eff (Error e ': r) a -> Eff r (Either e a)
+-- runError :: Eff (Error e ': r) a -> Eff r (Either e a)
-runError = runEff (pure . Right) $ \u ->
+-- runError = runEff (pure . Right) $ \u ->
-  case decomp u of
+--   case decomp u of
-    Left x  -> join
+--     Left x  -> join
-             . liftEff
+--              . liftEff
-             . fmap (either (pure . Left) id)
+--              . fmap (either (pure . Left) id)
-             $ weave (Right ()) (either (pure . Left) runError) x
+--              $ weave (Right ()) (either (pure . Left) runError) x
-    Right (Throw e) -> pure $ Left e
+--     Right (Throw e) -> pure $ Left e
-    Right (Catch try handle k) -> do
+--     Right (Catch try handle k) -> do
-      ma <- runError try
+--       ma <- runError try
-      case ma of
+--       case ma of
-        Right a -> k a
+--         Right a -> k a
-        Left e -> do
+--         Left e -> do
-          ma' <- runError $ handle e
+--           ma' <- runError $ handle e
-          case ma' of
+--           case ma' of
-            Left e' -> pure (Left e')
+--             Left e' -> pure (Left e')
-            Right a -> k a
+--             Right a -> k a
-{-# INLINE runError #-}
+-- {-# INLINE runError #-}
 
 
 
-main :: IO ()
+-- main :: IO ()
-main = (print =<<) $ runM $ runState "1" $ runError @Bool $ runState True $ do
+-- main = (print =<<) $ runM $ runState "1" $ runError @Bool $ runState True $ do
-  put "2"
+--   put "2"
-  catch
+--   catch
-    do
+--     do
-      sendM $ putStrLn "hello"
+--       sendM $ putStrLn "hello"
-      put False
+--       put False
-      throw True
+--       throw True
-    \(_ :: Bool) -> do
+--     \(_ :: Bool) -> do
-      sendM $ putStrLn "caught"
+--       sendM $ putStrLn "caught"
 
 
 

src/Wtf.hs

@@ -18,3 +18,6 @@ go = do
 countDown :: Int -> Int
 countDown start = fst $ run $ runState start go
 
+countDownFast :: Int -> Int
+countDownFast start = fst $ run $ runStateFast start go
+