Church-encoded Fresh carrier

ChangeLog.md

@@ -6,6 +6,8 @@
 
 - Adds a church-encoded `Writer` carrier in `Control.Carrier.Writer.Church`. ([#369](https://github.com/fused-effects/fused-effects/pull/369))
 
+- Adds a church-encoded `Fresh` carrier in `Control.Carrier.Fresh.Church`. ([#373](https://github.com/fused-effects/fused-effects/pull/373))
+
 - Defines `Algebra` instances for `Control.Monad.Trans.Maybe.MaybeT`, `Control.Monad.Trans.RWS.CPS`, and `Control.Monad.Trans.Writer.CPS`. ([#366](https://github.com/fused-effects/fused-effects/pull/366))
 
 - Adds `evalEmpty` and `execEmpty` handlers for the `Empty` carriers as conveniences for using `empty` to signal early returns. ([#371](https://github.com/fused-effects/fused-effects/pull/371))

fused-effects.cabal

@@ -53,6 +53,7 @@ library
     Control.Carrier.Error.Church
     Control.Carrier.Error.Either
     Control.Carrier.Fail.Either
+    Control.Carrier.Fresh.Church
     Control.Carrier.Fresh.Strict
     Control.Carrier.Interpret
     Control.Carrier.Lift

src/Control/Carrier/Fresh/Church.hs

@@ -0,0 +1,66 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | A church-encoded carrier for a 'Fresh' effect, providing access to a monotonically increasing stream of 'Int' values.
+--
+-- @since 1.1.0.0
+module Control.Carrier.Fresh.Church
+( -- * Fresh carrier
+  runFresh
+, evalFresh
+, FreshC(FreshC)
+  -- * Fresh effect
+, module Control.Effect.Fresh
+) where
+
+import Control.Algebra
+import Control.Applicative (Alternative)
+import Control.Carrier.State.Church
+import Control.Effect.Fresh
+import Control.Monad (MonadPlus)
+import Control.Monad.Fail as Fail
+import Control.Monad.Fix
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+
+-- | Run a 'Fresh' effect counting up from 0.
+--
+-- @
+-- 'runFresh' k n ('pure' a) = k n a
+-- @
+-- @
+-- 'runFresh' k n 'fresh' = k (n '+' 1) n
+-- @
+--
+-- @since 1.1.0.0
+runFresh :: (Int -> a -> m b) -> Int -> FreshC m a -> m b
+runFresh k n = runState k n . runFreshC
+{-# INLINE runFresh #-}
+
+-- | Run a 'Fresh' effect counting up from an initial value, and forgetting the final value.
+--
+-- @
+-- 'evalFresh' n ('pure' a) = 'pure' a
+-- @
+-- @
+-- 'evalFresh' n 'fresh' = 'pure' n
+-- @
+--
+-- @since 1.1.0.0
+evalFresh :: Applicative m => Int -> FreshC m a -> m a
+evalFresh n = evalState n . runFreshC
+{-# INLINE evalFresh #-}
+
+-- | @since 1.1.0.0
+newtype FreshC m a = FreshC { runFreshC :: StateC Int m a }
+  deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)
+
+instance Algebra sig m => Algebra (Fresh :+: sig) (FreshC m) where
+  alg hdl sig ctx = FreshC $ case sig of
+    L Fresh -> state $ \ i -> (i + 1, i <$ ctx)
+    R other -> alg (runFreshC . hdl) (R other) ctx
+  {-# INLINE alg #-}

src/Control/Carrier/Fresh/Strict.hs

@@ -18,10 +18,10 @@ module Control.Carrier.Fresh.Strict
 ) where
 
 import Control.Algebra
-import Control.Applicative (Alternative(..))
+import Control.Applicative (Alternative)
 import Control.Carrier.State.Strict
 import Control.Effect.Fresh
-import Control.Monad (MonadPlus(..))
+import Control.Monad (MonadPlus)
 import Control.Monad.Fail as Fail
 import Control.Monad.Fix
 import Control.Monad.IO.Class
@@ -60,7 +60,7 @@ newtype FreshC m a = FreshC { runFreshC :: StateC Int m a }
   deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadPlus, MonadTrans)
 
 instance Algebra sig m => Algebra (Fresh :+: sig) (FreshC m) where
-  alg hdl sig ctx = case sig of
-    L Fresh -> FreshC (gets (<$ ctx) <* modify (+ (1 :: Int)))
-    R other -> FreshC (alg (runFreshC . hdl) (R other) ctx)
+  alg hdl sig ctx = FreshC $ case sig of
+    L Fresh -> state $ \ i -> (i + 1, i <$ ctx)
+    R other -> alg (runFreshC . hdl) (R other) ctx
   {-# INLINE alg #-}

src/Control/Effect/Fresh.hs

@@ -4,8 +4,8 @@
 
 Predefined carriers:
 
-* "Control.Carrier.Fresh.Strict".
-
+* "Control.Carrier.Fresh.Church"
+* "Control.Carrier.Fresh.Strict"
 -}
 module Control.Effect.Fresh
 ( -- * Fresh effect

test/Fresh.hs

@@ -8,7 +8,8 @@ module Fresh
 , test
 ) where
 
-import qualified Control.Carrier.Fresh.Strict as FreshC
+import qualified Control.Carrier.Fresh.Church as C.Church
+import qualified Control.Carrier.Fresh.Strict as C.Strict
 import           Control.Effect.Fresh
 import           Gen
 import qualified Hedgehog.Range as R
@@ -19,11 +20,16 @@ import           Test.Tasty.Hedgehog
 
 tests :: TestTree
 tests = testGroup "Fresh"
-  [ testGroup "FreshC" $
+  [ testGroup "FreshC (Church)" $
     [ testMonad
     , testMonadFix
     , testFresh
-    ] >>= ($ runC FreshC.runFresh)
+    ] >>= ($ runC (C.Church.runFresh (curry pure)))
+  , testGroup "FreshC (Strict)" $
+    [ testMonad
+    , testMonadFix
+    , testFresh
+    ] >>= ($ runC C.Strict.runFresh)
   ] where
   testMonad    run = Monad.test    (m gen (\ _ _ -> [])) a b c initial run
   testMonadFix run = MonadFix.test (m gen (\ _ _ -> [])) a b   initial run