it is so FAST

bench/countDown.hs

@@ -126,8 +126,7 @@ main :: IO ()
 main =
   defaultMain [
     bgroup "Countdown Bench" [
-        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,7 +23,7 @@ dependencies:
 - base >= 4.7 && < 5
 - transformers
 - mtl
-- template-haskell
+# - ghc-lib
 
 flags:
   dump-core:

src/Control/Monad/Discount.hs

@@ -104,26 +104,33 @@ interpret f (Freer m) = m $ \u ->
     Right y -> f y
 {-# INLINE interpret #-}
 
-
 stateful
-    :: forall e s r a
+    :: forall s r a e
      . Effect e
-    => (∀ x. e (StateT s (Eff r)) x -> StateT s (Eff r) x)
+    => (∀ x. e (Eff (e ': 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
+stateful f s (Freer m) = Freer $ \k ->
+  fmap swap $ flip S.runStateT s $ 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
+          k . fmap swap
+            . weave (s', ()) (uncurry $ stateful' f)
+            $ x
+        Right y -> S.mapStateT (usingFreer k) $ f y
 {-# INLINE stateful #-}
 
+stateful'
+    :: forall s r a e
+     . Effect e
+    => (∀ x. e (Eff (e ': r)) x -> StateT s (Eff r) x)
+    -> s
+    -> Eff (e ': r) a
+    -> Eff r (s, a)
+stateful' = stateful
+{-# NOINLINE stateful' #-}
+
 
 reinterpret
     :: Effect f

src/Recursively.hs

@@ -0,0 +1,18 @@
+module Recursively where
+
+-- import Plugins
+
+
+-- plugin :: Plugin
+-- plugin = defaultPlugin {
+--     installCoreToDos = install
+--   }
+
+-- install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
+-- install _option todos = do
+--   return $ CoreDoPluginPass "Peel and unroll loops" (BindsToBindsPluginPass pass)
+--          : todos
+
+
+-- pass :: [CoreBind] -> CoreM [CoreBind]
+-- pass = _

src/TRYAGAIN.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving  #-}
+{-# LANGUAGE TemplateHaskell     #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE UnicodeSyntax       #-}
@@ -19,8 +20,8 @@
 
 module TRYAGAIN where
 
-import Data.Tuple
-import Control.Monad.Discount
+import           Control.Monad.Discount
+import qualified Control.Monad.Trans.Except as E
 import qualified Control.Monad.Trans.State.Strict as S
 
 
@@ -60,40 +61,6 @@ 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 = stateful $ \case
@@ -102,60 +69,25 @@ runState = stateful $ \case
 {-# INLINE runState #-}
 
 
-
--- runRelayS
---     :: ∀ s e a r
---      . (∀ x. s -> x -> Eff r (s, x))
---     -> (∀ x. e (Eff (e ': r)) (s -> Eff r (s, x))
---           -> s
---           -> Eff r (s, x))
---     -> s
---     -> Eff (e ': r) a
---     -> Eff r (s, a)
--- runRelayS pure' bind' = flip go
---   where
---     go :: Eff (e ': r) x -> s -> Eff r (s, x)
---     go = runEff (flip pure') $ \u ->
---       case decomp u of
---         Left x  -> \s' ->
---           join . liftEff
---                $ fmap (uncurry (flip id))
---                $ weave (s', ()) (uncurry $ flip go) x
---         Right eff -> bind' eff
--- {-# INLINE runRelayS #-}
-
-
--- runError :: Eff (Error e ': r) a -> Eff r (Either e a)
--- runError = runEff (pure . Right) $ \u ->
---   case decomp u of
---     Left x  -> join
---              . liftEff
---              . fmap (either (pure . Left) id)
---              $ weave (Right ()) (either (pure . Left) runError) x
---     Right (Throw e) -> pure $ Left e
---     Right (Catch try handle k) -> do
---       ma <- runError try
---       case ma of
---         Right a -> k a
---         Left e -> do
---           ma' <- runError $ handle e
---           case ma' of
---             Left e' -> pure (Left e')
---             Right a -> k a
--- {-# INLINE runError #-}
-
-
-
--- main :: IO ()
--- main = (print =<<) $ runM $ runState "1" $ runError @Bool $ runState True $ do
---   put "2"
---   catch
---     do
---       sendM $ putStrLn "hello"
---       put False
---       throw True
---     \(_ :: Bool) -> do
---       sendM $ putStrLn "caught"
+runError :: Eff (Error e ': r) a -> Eff r (Either e a)
+runError (Freer m) = Freer $ \k -> E.runExceptT $ m $ \u ->
+  case decomp u of
+    Left x -> E.ExceptT $ k $ weave (Right ()) (either (pure . Left) runError') x
+    Right (Throw e) -> E.throwE e
+    Right (Catch try handle kt) -> E.ExceptT $ do
+      let zonk = usingFreer k . runError'
+      ma <- zonk try
+      case ma of
+        Right a -> pure . Right $ kt a
+        Left e -> do
+          ma' <- zonk $ handle e
+          case ma' of
+            Left e' -> pure $ Left e'
+            Right a -> pure . Right $ kt a
+{-# INLINE runError #-}
 
 
+runError' :: Eff (Error e ': r) a -> Eff r (Either e a)
+runError' = runError
+{-# NOINLINE runError' #-}
 

src/Wtf.hs

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

stack.yaml

@@ -6,4 +6,5 @@ packages:
 extra-deps:
 - dump-core-0.1.3.2
 - monadLib-3.9
+- ghc-lib-0.20190204
 

test/Spec.hs

@@ -1,10 +1,14 @@
-{-# LANGUAGE DataKinds       #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE BlockArguments   #-}
+{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE TypeApplications #-}
 
 import Test.Inspection
 import Control.Monad.Discount
 import Data.OpenUnion
 import TRYAGAIN hiding (main)
+import qualified Control.Monad.Trans.State.Strict as S
+import qualified Control.Monad.Trans.Except as E
 
 
 main :: IO ()
@@ -19,8 +23,17 @@ go = do
        send $ Put (n-1) ()
        go
 
+tryIt :: Either Bool String
+tryIt = run . runError @Bool $ do
+  catch @Bool
+    do
+      throw False
+    \_ -> pure "hello"
+
 countDown :: Int -> Int
 countDown start = fst $ run $ runState start go
 
-inspect $ 'countDown `hasNoType` ''SNat
+inspect $ 'countDown `hasNoType`  ''SNat
+inspect $ 'countDown `doesNotUse` ''S.StateT
+inspect $ 'tryIt     `doesNotUse` ''E.ExceptT