Clean up some more, remove some half-baked effects

bench/Core.hs

@@ -10,7 +10,7 @@ import Criterion (bench, bgroup, whnf)
 import Criterion.Main (defaultMain)
 
 import Control.Monad.Freer (Member, Eff, run, send)
-import Control.Monad.Freer.Internal (Eff(E, Val), decomp, qApp, tsingleton)
+import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)
 import Control.Monad.Freer.Error (runError, throwError)
 import Control.Monad.Freer.State (get, put, runState)
 import Control.Monad.Freer.StateRW (ask, tell, runStateR)
@@ -24,7 +24,7 @@ import qualified Control.Eff.State.Lazy as EE
 --------------------------------------------------------------------------------
 
 oneGet :: Int -> (Int, Int)
-oneGet = run . runState get
+oneGet n = run (runState n get)
 
 oneGetMTL :: Int -> (Int, Int)
 oneGetMTL = MTL.runState MTL.get
@@ -33,11 +33,11 @@ oneGetEE :: Int -> (Int, Int)
 oneGetEE n = EE.run $ EE.runState n EE.get
 
 countDown :: Int -> (Int, Int)
-countDown start = run (runState go start)
+countDown start = run (runState start go)
   where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
 
 countDownRW :: Int -> (Int, Int)
-countDownRW start = run (runStateR go start)
+countDownRW start = run (runStateR start go)
   where go = ask >>= (\n -> if n <= 0 then pure n else tell (n-1) >> go)
 
 countDownMTL :: Int -> (Int, Int)
@@ -52,7 +52,7 @@ countDownEE start = EE.run $ EE.runState start go
                        -- Exception + State --
 --------------------------------------------------------------------------------
 countDownExc :: Int -> Either String (Int,Int)
-countDownExc start = run $ runError (runState go start)
+countDownExc start = run $ runError (runState start go)
   where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)
 
 countDownExcMTL :: Int -> Either String (Int,Int)

examples/src/Console.hs

@@ -49,7 +49,7 @@ runConsole = runM . interpretM (\case
 -------------------------------------------------------------------------------
 runConsolePure :: [String] -> Eff '[Console] w -> [String]
 runConsolePure inputs req = snd . fst $
-    run (runWriter (runState (runError (reinterpret3 go req)) inputs))
+    run (runWriter (runState inputs (runError (reinterpret3 go req))))
   where
     go :: Console v -> Eff '[Error (), State [String], Writer [String]] v
     go (PutStrLn msg) = tell [msg]
@@ -78,7 +78,7 @@ runConsolePureM
   -> Eff effs (Maybe w, [String], [String])
 runConsolePureM inputs req = do
     ((x, inputs'), output) <- reinterpret3 go req
-      & runError & flip runState inputs & runWriter
+      & runError & runState inputs & runWriter
     pure (either (const Nothing) Just x, inputs', output)
   where
     go :: Console v

examples/src/Cut.hs

@@ -1,33 +0,0 @@
-module Cut () where
-
--- import Control.Monad.Freer.Cut
-
-
-{-
--- The signature is inferred
-tcut1 :: (Member Choose r, Member (Error CutFalse) r) => Eff r Int
-tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`
-         ((cutfalse `mplus'` return 4) `mplus'`
-          return 5)
-
-tcut1r = run . makeChoice $ call tcut1
--- [1,2]
-
-tcut2 = return (1::Int) `mplus'`
-         call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'`
-               return 4)
-       `mplus'` return 5
-
--- Here we see nested call. It poses no problems...
-tcut2r = run . makeChoice $ call tcut2
--- [1,2,5]
-
--- More nested calls
-tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse)
-tcut3r = run . makeChoice $ call tcut3
--- [1,2,1,2,5]
-
-tcut4 = call tcut1 `mplus'`  (tcut2 `mplus'` cutfalse)
-tcut4r = run . makeChoice $ call tcut4
--- [1,2,1,2,5]
--}

examples/src/Fresh.hs

@@ -9,7 +9,7 @@ import Control.Monad.Freer.Trace (runTrace, trace)
 -- Fresh 0
 -- Fresh 1
 traceFresh :: IO ()
-traceFresh = runTrace $ flip evalFresh 0 $ do
+traceFresh = runTrace $ evalFresh 0 $ do
   n <- fresh
   trace $ "Fresh " ++ show n
   n' <- fresh

examples/src/Main.hs

@@ -17,7 +17,6 @@ import Console
   , runConsoleM
   )
 import Coroutine ()
-import Cut ()
 import Fresh ()
 import Trace ()
 

examples/src/Trace.hs

@@ -27,7 +27,7 @@ mapMdebug f (h:t) = do
   pure (h':t')
 
 tMd :: IO [Int]
-tMd = runTrace $ runReader (mapMdebug f [1..5]) (10::Int)
+tMd = runTrace $ runReader (10::Int) (mapMdebug f [1..5])
  where f x = (+) <$> ask <*> pure x
 {-
 mapMdebug: 1
@@ -40,10 +40,10 @@ mapMdebug: 5
 
 -- duplicate layers
 tdup :: IO ()
-tdup = runTrace $ runReader m (10::Int)
+tdup = runTrace $ runReader (10::Int) m
  where
  m = do
-     runReader tr (20::Int)
+     runReader (20::Int) tr
      tr
  tr = do
       v <- ask

src/Control/Monad/Freer.hs

@@ -70,18 +70,21 @@ import Control.Monad.Freer.Internal
 -- transformation from some effect @eff@ to some effectful computation with
 -- effects @effs@, produces a natural transformation from @'Eff' (eff ': effs)@
 -- to @'Eff' effs@.
-interpret :: (eff ~> Eff effs) -> Eff (eff ': effs) ~> Eff effs
+interpret :: forall eff effs. (eff ~> Eff effs) -> Eff (eff ': effs) ~> Eff effs
 interpret f = interpretWith (\e -> (f e >>=))
+{-# INLINE interpret #-}
 
 -- | Like 'interpret', but instead of handling the effect, allows responding to
 -- the effect while leaving it unhandled.
-interpose :: Member eff effs => (eff ~> Eff effs) -> Eff effs ~> Eff effs
+interpose :: forall eff effs. Member eff effs => (eff ~> Eff effs) -> Eff effs ~> Eff effs
 interpose f = interposeWith (\e -> (f e >>=))
+{-# INLINE interpose #-}
 
 -- | Like 'interpret', but instead of removing the interpreted effect @f@,
 -- reencodes it in some new effect @g@.
-reinterpret :: (f ~> Eff (g ': effs)) -> Eff (f ': effs) ~> Eff (g ': effs)
+reinterpret :: forall f g effs. (f ~> Eff (g ': effs)) -> Eff (f ': effs) ~> Eff (g ': effs)
 reinterpret f = replaceRelay pure (\e -> (f e >>=))
+{-# INLINE reinterpret #-}
 
 -- | Like 'reinterpret', but encodes the @f@ effect in /two/ new effects instead
 -- of just one.
@@ -89,6 +92,7 @@ reinterpret2
   :: forall f g h effs
    . (f ~> Eff (g ': h ': effs)) -> Eff (f ': effs) ~> Eff (g ': h ': effs)
 reinterpret2 = reinterpretN @[g, h]
+{-# INLINE reinterpret2 #-}
 
 -- | Like 'reinterpret', but encodes the @f@ effect in /three/ new effects
 -- instead of just one.
@@ -97,6 +101,7 @@ reinterpret3
    . (f ~> Eff (g ': h ': i ': effs))
   -> Eff (f ': effs) ~> Eff (g ': h ': i ': effs)
 reinterpret3 = reinterpretN @[g, h, i]
+{-# INLINE reinterpret3 #-}
 
 -- | Like 'interpret', 'reinterpret', 'reinterpret2', and 'reinterpret3', but
 -- allows the result to have any number of additional effects instead of simply
@@ -107,6 +112,7 @@ reinterpretN
   :: forall gs f effs. Weakens gs
   => (f ~> Eff (gs :++: effs)) -> Eff (f ': effs) ~> Eff (gs :++: effs)
 reinterpretN f = replaceRelayN @gs pure (\e -> (f e >>=))
+{-# INLINE reinterpretN #-}
 
 -- | Runs an effect by translating it into another effect. This is effectively a
 -- more restricted form of 'reinterpret', since both produce a natural
@@ -121,8 +127,9 @@ reinterpretN f = replaceRelayN @gs pure (\e -> (f e >>=))
 -- @
 -- 'translate' f = 'reinterpret' ('send' . f)
 -- @
-translate :: (f ~> g) -> Eff (f ': effs) ~> Eff (g ': effs)
+translate :: forall f g effs. (f ~> g) -> Eff (f ': effs) ~> Eff (g ': effs)
 translate f = reinterpret (send . f)
+{-# INLINE translate #-}
 
 -- | Like 'interpret', this function runs an effect without introducing another
 -- one. Like 'translate', this function runs an effect by translating it into
@@ -134,9 +141,11 @@ translate f = reinterpret (send . f)
 -- 'interpretM' f = 'interpret' ('sendM' . f)
 -- @
 interpretM
-  :: (Monad m, LastMember m effs)
+  :: forall eff effs m
+   . (Monad m, LastMember m effs)
   => (eff ~> m) -> Eff (eff ': effs) ~> Eff effs
 interpretM f = interpret (sendM . f)
+{-# INLINE interpretM #-}
 
 -- | A highly general way of handling an effect. Like 'interpret', but
 -- explicitly passes the /continuation/, a function of type @v -> 'Eff' effs b@,
@@ -150,10 +159,12 @@ interpretM f = interpret (sendM . f)
 -- 'interpret' f = 'interpretWith' (\e -> (f e '>>='))
 -- @
 interpretWith
-  :: (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)
+  :: forall eff effs b
+   . (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)
   -> Eff (eff ': effs) b
   -> Eff effs b
 interpretWith = handleRelay pure
+{-# INLINE interpretWith #-}
 
 -- | Combines the interposition behavior of 'interpose' with the
 -- continuation-passing capabilities of 'interpretWith'.
@@ -162,8 +173,10 @@ interpretWith = handleRelay pure
 -- 'interpose' f = 'interposeWith' (\e -> (f e '>>='))
 -- @
 interposeWith
-  :: Member eff effs
+  :: forall eff effs b
+   . Member eff effs
   => (forall v. eff v -> (v -> Eff effs b) -> Eff effs b)
   -> Eff effs b
   -> Eff effs b
 interposeWith = Internal.interpose pure
+{-# INLINE interposeWith #-}

src/Control/Monad/Freer/Cut.hs

@@ -1,46 +0,0 @@
--- |
--- Module:       Control.Monad.Freer.Cut
--- Description:  An implementation of logical Cut.
--- Copyright:    (c) 2016 Allele Dev; 2017 Ixperta Solutions s.r.o.; 2017 Alexis King
--- License:      BSD3
--- Maintainer:   ixcom-core@ixperta.com
--- Stability:    broken
--- Portability:  GHC specific language extensions.
---
--- Composable handler for logical Cut effects. Implemented in terms of 'Error'
--- effect.
---
--- Using <http://okmij.org/ftp/Haskell/extensible/Eff1.hs> as a starting point.
-module Control.Monad.Freer.Cut
-  ( CutFalse(..)
-  , cutFalse
-  -- , call
-  ) where
-
--- import Control.Monad
-import Control.Monad.Freer.Error (Error, throwError)
-import Control.Monad.Freer.Internal (Eff, Member)
-
-data CutFalse = CutFalse
--- data Choose a b = Choose [a] b
-
--- | Implementation of logical Cut using Error effects.
-cutFalse :: Member (Error CutFalse) r => Eff r a
-cutFalse = throwError CutFalse
-
-{-
-call :: Member (Error CutFalse) r => Eff (Error CutFalse ': r) a -> Eff r a
-call m = loop [] m where
- loop jq (Val x) = return x `mplus` next jq          -- (C2)
- loop jq (E u q) = case decomp u of
-    Right (Error CutFalse) -> mzero  -- drop jq (F2)
-    Left u -> check jq u
-
- check jq u | Just (Choose [] _) <- prj u  = next jq  -- (C1)
- check jq u | Just (Choose [x] k) <- prj u = loop jq (k x)  -- (C3), optim
- check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3)
- check jq u = send (\k -> fmap k u) >>= loop jq      -- (C4)
-
- next []    = mzero
- next (h:t) = loop t h
--}

src/Control/Monad/Freer/Error.hs

@@ -19,36 +19,36 @@ module Control.Monad.Freer.Error
   , handleError
   ) where
 
-import Control.Monad.Freer.Internal (Eff, Member, handleRelay, interpose, send)
-
---------------------------------------------------------------------------------
-                           -- Exceptions --
---------------------------------------------------------------------------------
+import Control.Monad.Freer (Eff, Member, interposeWith, interpretWith, send)
+import Control.Monad.Freer.Internal (handleRelay)
 
 -- | Exceptions of the type @e :: *@ with no resumption.
-newtype Error e a = Error e
+newtype Error e r where
+  Error :: e -> Error e r
 
 -- | Throws an error carrying information of type @e :: *@.
-throwError :: Member (Error e) effs => e -> Eff effs a
+throwError :: forall e effs a. Member (Error e) effs => e -> Eff effs a
 throwError e = send (Error e)
 
 -- | Handler for exception effects. If there are no exceptions thrown, returns
 -- 'Right'. If exceptions are thrown and not handled, returns 'Left', while
 -- interrupting the execution of any other effect handlers.
-runError :: Eff (Error e ': effs) a -> Eff effs (Either e a)
-runError = handleRelay (pure . Right) (\(Error e) _k -> pure (Left e))
+runError :: forall e effs a. Eff (Error e ': effs) a -> Eff effs (Either e a)
+runError = handleRelay (pure . Right) (\(Error e) _ -> pure (Left e))
 
 -- | A catcher for Exceptions. Handlers are allowed to rethrow exceptions.
 catchError
-  :: Member (Error e) effs
+  :: forall e effs a
+   . Member (Error e) effs
   => Eff effs a
   -> (e -> Eff effs a)
   -> Eff effs a
-catchError m handle = interpose pure (\(Error e) _ -> handle e) m
+catchError m handle = interposeWith (\(Error e) _ -> handle e) m
 
 -- | A catcher for Exceptions. Handlers are /not/ allowed to rethrow exceptions.
 handleError
-  :: Eff (Error e ': effs) a
+  :: forall e effs a
+   . Eff (Error e ': effs) a
   -> (e -> Eff effs a)
   -> Eff effs a
-handleError m handle = handleRelay pure (\(Error e) _ -> handle e) m
+handleError m handle = interpretWith (\(Error e) _ -> handle e) m

src/Control/Monad/Freer/Fresh.hs

@@ -17,13 +17,12 @@ module Control.Monad.Freer.Fresh
   , fresh
   , runFresh
   , evalFresh
-  , runFresh'
   ) where
 
 import Control.Monad.Freer.Internal (Eff, Member, handleRelayS, send)
 
 -- | Fresh effect model.
-data Fresh a where
+data Fresh r where
   Fresh :: Fresh Int
 
 -- | Request a fresh effect.
@@ -32,18 +31,11 @@ fresh = send Fresh
 
 -- | Handler for 'Fresh' effects, with an 'Int' for a starting value. The
 -- return value includes the next fresh value.
-runFresh :: Eff (Fresh ': effs) a -> Int -> Eff effs (a, Int)
-runFresh m s =
-  handleRelayS s (\s' a -> pure (a, s')) (\s' Fresh k -> (k $! s' + 1) s') m
+runFresh :: Int -> Eff (Fresh ': effs) a -> Eff effs (a, Int)
+runFresh s =
+  handleRelayS s (\s' a -> pure (a, s')) (\s' Fresh k -> (k $! s' + 1) s')
 
 -- | Handler for 'Fresh' effects, with an 'Int' for a starting value. Discards
 -- the next fresh value.
-evalFresh :: Eff (Fresh ': effs) a -> Int -> Eff effs a
-evalFresh = ((fst <$>) .) . runFresh
-
--- | Backward compatibility alias for 'evalFresh'.
-runFresh' :: Eff (Fresh ': effs) a -> Int -> Eff effs a
-runFresh' = evalFresh
-{-# DEPRECATED runFresh'
-    "Use `evalFresh` instead, this function will be removed in next release."
-  #-}
+evalFresh :: Int -> Eff (Fresh ': effs) a -> Eff effs a
+evalFresh s = fmap fst . runFresh s

src/Control/Monad/Freer/Internal.hs

@@ -10,8 +10,6 @@
 -- TODO: Remove once GHC can deduce the decidability of this instance.
 {-# LANGUAGE UndecidableInstances #-}
 
-
-
 -- |
 -- Module:       Control.Monad.Freer.Internal
 -- Description:  Mechanisms to make effects work.
@@ -60,6 +58,7 @@ module Control.Monad.Freer.Internal
   , handleRelay
   , handleRelayS
   , interpose
+  , interposeS
   , replaceRelay
   , replaceRelayS
   , replaceRelayN
@@ -139,6 +138,7 @@ instance (MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where
 -- | Send a request and wait for a reply.
 send :: Member eff effs => eff a -> Eff effs a
 send t = E (inj t) (tsingleton Val)
+{-# INLINE send #-}
 
 -- | Identical to 'send', but specialized to the final effect in @effs@ to
 -- assist type inference. This is useful for running actions in a monad
@@ -187,6 +187,7 @@ replaceRelayS s' pure' bind = loop s'
         Left  u -> E (weaken u) (tsingleton (k s))
       where
         k s'' x = loop s'' $ qApp q x
+{-# INLINE replaceRelayS #-}
 
 -- | Interpret an effect by transforming it into another effect on top of the
 -- stack. The primary use case of this function is allow interpreters to be
@@ -205,6 +206,7 @@ replaceRelay pure' bind = loop
         Left  u -> E (weaken u) (tsingleton k)
       where
         k = qComp q loop
+{-# INLINE replaceRelay #-}
 
 replaceRelayN
   :: forall gs t a effs w
@@ -223,6 +225,7 @@ replaceRelayN pure' bind = loop
       where
         k :: Arr (gs :++: effs) b w
         k = qComp q loop
+{-# INLINE replaceRelayN #-}
 
 -- | Given a request, either handle it or relay it.
 handleRelay
@@ -241,6 +244,7 @@ handleRelay ret h = loop
         Left  u -> E u (tsingleton k)
       where
         k = qComp q loop
+{-# INLINE handleRelay #-}
 
 -- | Parameterized 'handleRelay'. Allows sending along some state of type
 -- @s :: *@ to be handled for the target effect, or relayed to a handler that
@@ -262,6 +266,7 @@ handleRelayS s' ret h = loop s'
         Left  u -> E u (tsingleton (k s))
       where
         k s'' x = loop s'' $ qApp q x
+{-# INLINE handleRelayS #-}
 
 -- | Intercept the request and possibly reply to it, but leave it unhandled.
 interpose
@@ -278,6 +283,26 @@ interpose ret h = loop
         _      -> E u (tsingleton k)
       where
         k = qComp q loop
+{-# INLINE interpose #-}
+
+-- | Like 'interpose', but with support for an explicit state to help implement
+-- the interpreter.
+interposeS
+  :: Member eff effs
+  => s
+  -> (s -> a -> Eff effs b)
+  -> (forall v. s -> eff v -> (s -> Arr effs v b) -> Eff effs b)
+  -> Eff effs a
+  -> Eff effs b
+interposeS s' ret h = loop s'
+  where
+    loop s (Val x) = ret s x
+    loop s (E u q) = case prj u of
+        Just x -> h s x k
+        _      -> E u (tsingleton (k s))
+      where
+        k s'' x = loop s'' $ qApp q x
+{-# INLINE interposeS #-}
 
 -- | Embeds a less-constrained 'Eff' into a more-constrained one. Analogous to
 -- MTL's 'lift'.
@@ -286,6 +311,7 @@ raise = loop
   where
     loop (Val x) = pure x
     loop (E u q) = E (weaken u) . tsingleton $ qComp q loop
+{-# INLINE raise #-}
 
 --------------------------------------------------------------------------------
                     -- Nondeterministic Choice --

src/Control/Monad/Freer/NonDet.hs

@@ -1,5 +1,3 @@
-{-# LANGUAGE TypeFamilies #-}
-
 -- |
 -- Module:       Control.Monad.Freer.NonDet
 -- Description:  Non deterministic effects
@@ -20,9 +18,9 @@ import Control.Applicative (Alternative, (<|>), empty)
 import Control.Monad (msum)
 
 import Control.Monad.Freer.Internal
-  ( Eff(E, Val)
+  ( Eff(..)
   , Member
-  , NonDet(MPlus, MZero)
+  , NonDet(..)
   , handleRelay
   , prj
   , qApp

src/Control/Monad/Freer/Reader.hs

@@ -30,51 +30,43 @@ module Control.Monad.Freer.Reader
     -- $localExample
   ) where
 
-import Control.Monad.Freer.Internal
-  ( Arr
-  , Eff
-  , Member
-  , handleRelay
-  , interpose
-  , send
-  )
+import Control.Monad.Freer (Eff, Member, interpose, interpret, send)
 
 -- | Represents shared immutable environment of type @(e :: *)@ which is made
 -- available to effectful computation.
-data Reader e a where
-  Reader :: Reader e e
+data Reader r a where
+  Ask :: Reader r r
 
 -- | Request a value of the environment.
-ask :: Member (Reader e) effs => Eff effs e
-ask = send Reader
+ask :: forall r effs. Member (Reader r) effs => Eff effs r
+ask = send Ask
 
 -- | Request a value of the environment, and apply as selector\/projection
 -- function to it.
 asks
-  :: Member (Reader e) effs
-  => (e -> a)
+  :: forall r effs a
+   . Member (Reader r) effs
+  => (r -> a)
   -- ^ The selector\/projection function to be applied to the environment.
   -> Eff effs a
 asks f = f <$> ask
 
 -- | Handler for 'Reader' effects.
-runReader :: Eff (Reader e ': effs) a -> e -> Eff effs a
-runReader m e = handleRelay pure (\Reader k -> k e) m
+runReader :: forall r effs a. r -> Eff (Reader r ': effs) a -> Eff effs a
+runReader r = interpret (\Ask -> pure r)
 
 -- | Locally rebind the value in the dynamic environment.
 --
 -- This function is like a relay; it is both an admin for 'Reader' requests,
 -- and a requestor of them.
 local
-  :: forall e a effs. Member (Reader e) effs
-  => (e -> e)
+  :: forall r effs a. Member (Reader r) effs
+  => (r -> r)
   -> Eff effs a
   -> Eff effs a
 local f m = do
-  e <- f <$> ask
-  let h :: Reader e v -> Arr effs v a -> Eff effs a
-      h Reader k = k e
-  interpose pure h m
+  r <- asks f
+  interpose @(Reader r) (\Ask -> pure r) m
 
 -- $simpleReaderExample
 --
@@ -93,7 +85,7 @@ local f m = do
 -- >
 -- > -- Returns True if the "count" variable contains correct bindings size.
 -- > isCountCorrect :: Bindings -> Bool
--- > isCountCorrect bindings = run $ runReader calc_isCountCorrect bindings
+-- > isCountCorrect bindings = run $ runReader bindings calc_isCountCorrect
 -- >
 -- > -- The Reader effect, which implements this complicated check.
 -- > calc_isCountCorrect :: Eff '[Reader Bindings] Bool
@@ -138,8 +130,8 @@ local f m = do
 -- >
 -- > main :: IO ()
 -- > main = do
--- >     let s = "12345";
--- >     let modifiedLen = run $ runReader calculateModifiedContentLen s;
--- >     let len = run $ runReader calculateContentLen s ;
+-- >   let s = "12345"
+-- >   let modifiedLen = run $ runReader s calculateModifiedContentLen
+-- >   let len = run $ runReader s calculateContentLen
 -- >   putStrLn $ "Modified 's' length: " ++ (show modifiedLen)
 -- >   putStrLn $ "Original 's' length: " ++ (show len)

src/Control/Monad/Freer/State.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+
 -- |
 -- Module:       Control.Monad.Freer.State
 -- Description:  State effects, for state-carrying computations.
@@ -33,73 +35,75 @@ module Control.Monad.Freer.State
 
     -- * State Utilities
   , transactionState
+  , transactionState'
   ) where
 
 import Data.Proxy (Proxy)
 
-import Control.Monad.Freer.Internal
-  ( Eff(E, Val)
-  , Member
-  , Union
-  , decomp
-  , prj
-  , qApp
-  , qComp
-  , send
-  , tsingleton
-  )
-
---------------------------------------------------------------------------------
-                         -- State, strict --
---------------------------------------------------------------------------------
+import Control.Monad.Freer (Eff, Member, send)
+import Control.Monad.Freer.Internal (Arr, handleRelayS, interposeS)
 
 -- | Strict 'State' effects: one can either 'Get' values or 'Put' them.
-data State s a where
+data State s r where
   Get :: State s s
   Put :: !s -> State s ()
 
 -- | Retrieve the current value of the state of type @s :: *@.
-get :: Member (State s) effs => Eff effs s
+get :: forall s effs. Member (State s) effs => Eff effs s
 get = send Get
 
 -- | Set the current state to a specified value of type @s :: *@.
-put :: Member (State s) effs => s -> Eff effs ()
+put :: forall s effs. Member (State s) effs => s -> Eff effs ()
 put s = send (Put s)
 
 -- | Modify the current state of type @s :: *@ using provided function
 -- @(s -> s)@.
-modify :: Member (State s) effs => (s -> s) -> Eff effs ()
+modify :: forall s effs. Member (State s) effs => (s -> s) -> Eff effs ()
 modify f = fmap f get >>= put
 
 -- | Handler for 'State' effects.
-runState :: Eff (State s ': effs) a -> s -> Eff effs (a, s)
-runState (Val x) s = return (x, s)
-runState (E u q) s = case decomp u of
-  Right Get      -> runState (qApp q s) s
-  Right (Put s') -> runState (qApp q ()) s'
-  Left  u'       -> E u' (tsingleton (\x -> runState (qApp q x) s))
+runState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs (a, s)
+runState s0 = handleRelayS s0 (\s x -> pure (x, s)) $ \s x k -> case x of
+  Get -> k s s
+  Put s' -> k s' ()
 
 -- | Run a 'State' effect, returning only the final state.
-execState :: Eff (State s ': effs) a -> s -> Eff effs s
-execState st s = snd <$> runState st s
+execState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs s
+execState s = fmap snd . runState s
 
 -- | Run a State effect, discarding the final state.
-evalState :: Eff (State s ': effs) a -> s -> Eff effs a
-evalState st s = fst <$> runState st s
+evalState :: forall s effs a. s -> Eff (State s ': effs) a -> Eff effs a
+evalState s = fmap fst . runState s
 
 -- | An encapsulated State handler, for transactional semantics. The global
 -- state is updated only if the 'transactionState' finished successfully.
+--
+-- GHC cannot infer the @s@ type parameter for this function, so it must be
+-- specified explicitly with @TypeApplications@. Alternatively, it can be
+-- specified by supplying a 'Proxy' to 'transactionState''.
 transactionState
+  :: forall s effs a
+   . Member (State s) effs
+  => Eff effs a
+  -> Eff effs a
+transactionState m = do
+    s0 <- get @s
+    (x, s) <- interposeS s0 (\s x -> pure (x, s)) handle m
+    put s
+    pure x
+  where
+    handle :: s -> State s v -> (s -> Arr effs v b) -> Eff effs b
+    handle s x k = case x of
+      Get -> k s s
+      Put s' -> k s' ()
+
+-- | Like 'transactionState', but @s@ is specified by providing a 'Proxy'
+-- instead of requiring @TypeApplications@.
+transactionState'
   :: forall s effs a
    . Member (State s) effs
   => Proxy s
   -> Eff effs a
   -> Eff effs a
-transactionState _ m = do s <- get; loop s m
-  where
-    loop :: s -> Eff effs a -> Eff effs a
-    loop s (Val x)                = put s >> return x
-    loop s (E (u :: Union r b) q) = case prj u :: Maybe (State s b) of
-      Just Get      -> loop s (qApp q s)
-      Just (Put s') -> loop s'(qApp q ())
-      _             -> E u (tsingleton k) where k = qComp q (loop s)
+transactionState' _ = transactionState @s
+{-# INLINE transactionState' #-}

src/Control/Monad/Freer/StateRW.hs

@@ -25,15 +25,12 @@ import Control.Monad.Freer.Writer (Writer(..), tell)
 import Control.Monad.Freer.Internal (Eff(..), decomp, qComp, tsingleton)
 
 -- | State handler, using 'Reader' and 'Writer' effects.
-runStateR :: Eff (Writer s ': Reader s ': effs) a -> s -> Eff effs (a, s)
-runStateR m s = loop s m
-  where
-    loop :: s -> Eff (Writer s ': Reader s ': effs) a -> Eff effs (a, s)
-    loop s' (Val x) = return (x, s')
-    loop s' (E u q) = case decomp u of
-        Right (Writer o) -> k o ()
+runStateR :: s -> Eff (Writer s ': Reader s ': effs) a -> Eff effs (a, s)
+runStateR s' (Val x) = return (x, s')
+runStateR s' (E u q) = case decomp u of
+    Right (Tell o) -> k o ()
     Left  u'  -> case decomp u' of
-          Right Reader -> k s' s'
+      Right Ask -> k s' s'
       Left u'' -> E u'' (tsingleton (k s'))
   where
-        k s'' = qComp q (loop s'')
+    k s'' = qComp q (runStateR s'')

src/Control/Monad/Freer/Writer.hs

@@ -24,14 +24,14 @@ import Data.Monoid ((<>))
 import Control.Monad.Freer.Internal (Eff, Member, handleRelay, send)
 
 -- | Writer effects - send outputs to an effect environment.
-data Writer w a where
-  Writer :: w -> Writer w ()
+data Writer w r where
+  Tell :: w -> Writer w ()
 
 -- | Send a change to the attached environment.
-tell :: Member (Writer w) effs => w -> Eff effs ()
-tell w = send $ Writer w
+tell :: forall w effs. Member (Writer w) effs => w -> Eff effs ()
+tell w = send (Tell w)
 
 -- | Simple handler for 'Writer' effects.
-runWriter :: Monoid w => Eff (Writer w ': effs) a -> Eff effs (a, w)
-runWriter = handleRelay (\a -> pure (a, mempty)) $ \(Writer w) k ->
+runWriter :: forall w effs a. Monoid w => Eff (Writer w ': effs) a -> Eff effs (a, w)
+runWriter = handleRelay (\a -> pure (a, mempty)) $ \(Tell w) k ->
   second (w <>) <$> k ()

tests/Tests/Coroutine.hs

@@ -34,7 +34,7 @@ countOddDuoPrefix list = count list 0
     count _          n = n
 
 runTestCoroutine :: [Int] -> Int
-runTestCoroutine list = snd . run $ runState effTestCoroutine 0
+runTestCoroutine list = snd . run $ runState 0 effTestCoroutine
   where
     testCoroutine :: Members '[Yield () Int, State Int] r => Eff r ()
     testCoroutine = do

tests/Tests/Exception.hs

@@ -49,19 +49,19 @@ tes1 :: (Members '[State Int, Error String] r) => Eff r b
 tes1 = incr >> throwError "exc"
 
 ter1 :: (Either String Int, Int)
-ter1 = run $ runState (runError tes1) (1 :: Int)
+ter1 = run $ runState (1 :: Int) (runError tes1)
 
 ter2 :: Either String (String, Int)
-ter2 = run $ runError (runState tes1 (1 :: Int))
+ter2 = run $ runError (runState (1 :: Int) tes1)
 
 teCatch :: Member (Error String) r => Eff r a -> Eff r String
 teCatch m = (m >> pure "done") `catchError` \e -> pure (e :: String)
 
 ter3 :: (Either String String, Int)
-ter3 = run $ runState (runError (teCatch tes1)) (1 :: Int)
+ter3 = run $ runState (1 :: Int) (runError (teCatch tes1))
 
 ter4 :: Either String (String, Int)
-ter4 = run $ runError (runState (teCatch tes1) (1 :: Int))
+ter4 = run $ runError (runState (1 :: Int) (teCatch tes1))
 
 -- | The example from the paper.
 newtype TooBig = TooBig Int
@@ -79,11 +79,11 @@ runErrBig :: Eff (Error TooBig ': r) a -> Eff r (Either TooBig a)
 runErrBig = runError
 
 ex2rr :: Either TooBig Int
-ex2rr = run $ runReader (runErrBig (ex2 ask)) (5 :: Int)
+ex2rr = run $ runReader (5 :: Int) (runErrBig (ex2 ask))
 
 ex2rr1 :: Either TooBig Int
-ex2rr1 = run $ runReader (runErrBig (ex2 ask)) (7 :: Int)
+ex2rr1 = run $ runReader (7 :: Int) (runErrBig (ex2 ask))
 
 -- | Different order of handlers (layers).
 ex2rr2 :: Either TooBig Int
-ex2rr2 = run $ runErrBig (runReader (ex2 ask) (7 :: Int))
+ex2rr2 = run $ runErrBig (runReader (7 :: Int) (ex2 ask))

tests/Tests/Fresh.hs

@@ -18,7 +18,7 @@ tests = testGroup "Fresh tests"
   ]
 
 makeFresh :: Int -> Eff r Int
-makeFresh n = fst <$> runFresh (last <$> replicateM n fresh) 0
+makeFresh n = fst <$> runFresh 0 (last <$> replicateM n fresh)
 
 testFresh :: Int -> Int
 testFresh = run . makeFresh

tests/Tests/Reader.hs

@@ -20,7 +20,7 @@ tests = testGroup "Reader tests"
                             -- Examples --
 --------------------------------------------------------------------------------
 testReader :: Int -> Int -> Int
-testReader n x = run . flip runReader n $ (+) <$> ask <*> pure x
+testReader n x = run . runReader n $ (+) <$> ask <*> pure x
 
 {-
 t1rr' = run t1
@@ -29,7 +29,7 @@ t1rr' = run t1
 -}
 
 testMultiReader :: Integer -> Int -> Integer
-testMultiReader i = run . flip runReader i . runReader t2
+testMultiReader i j = run . runReader i $ runReader j t2
   where
     t2 = do
       v1 <- ask
@@ -44,7 +44,7 @@ t2rrr1' = run $ runReader (runReader t2 (20 :: Float)) (10 :: Float)
 -}
 
 testLocal :: Int -> Int -> Int
-testLocal env inc = run $ runReader t3 env
+testLocal env inc = run $ runReader env t3
   where
     t3 = (+) <$> t1 <*> local (+ inc) t1
     t1 = (+) <$> ask <*> pure (1 :: Int)

tests/Tests/State.hs

@@ -30,17 +30,17 @@ tests = testGroup "State tests"
   ]
 
 testPutGet :: Int -> Int -> (Int, Int)
-testPutGet n start = run $ runState go start
+testPutGet n start = run $ runState start go
   where
     go = put n >> get
 
 testPutGetRW :: Int -> Int -> (Int, Int)
-testPutGetRW n start = run $ runStateR go start
+testPutGetRW n start = run $ runStateR start go
   where
     go = tell n >> ask
 
 testPutGetPutGetPlus :: Int -> Int -> Int -> (Int, Int)
-testPutGetPutGetPlus p1 p2 start = run $ runState go start
+testPutGetPutGetPlus p1 p2 start = run $ runState start go
   where
     go = do
       put p1
@@ -50,7 +50,7 @@ testPutGetPutGetPlus p1 p2 start = run $ runState go start
       pure (x + y)
 
 testPutGetPutGetPlusRW :: Int -> Int -> Int -> (Int, Int)
-testPutGetPutGetPlusRW p1 p2 start = run $ runStateR go start
+testPutGetPutGetPlusRW p1 p2 start = run $ runStateR start go
   where
     go = do
       tell p1
@@ -60,13 +60,13 @@ testPutGetPutGetPlusRW p1 p2 start = run $ runStateR go start
       pure (x+y)
 
 testGetStart :: Int -> (Int, Int)
-testGetStart = run . runState get
+testGetStart = run . flip runState get
 
 testGetStartRW :: Int -> (Int, Int)
-testGetStartRW = run . runStateR ask
+testGetStartRW = run . flip runStateR ask
 
 testEvalState :: Int -> Int
-testEvalState = run . evalState go
+testEvalState = run . flip evalState go
   where
     go = do
       x <- get
@@ -75,4 +75,4 @@ testEvalState = run . evalState go
       pure x
 
 testExecState :: Int -> Int
-testExecState n = run $ execState (put n) 0
+testExecState n = run $ execState 0 (put n)