Clean up some more, remove some half-baked effects

This commit is contained in:
Alexis King 2017-12-06 15:46:15 -08:00
parent e89ed8911f
commit 207be8e9d7
21 changed files with 185 additions and 243 deletions

View File

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

View File

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

View File

@ -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]
-}

View File

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

View File

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

View File

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

View File

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

View File

@ -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
-}

View File

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

View File

@ -17,13 +17,12 @@ module Control.Monad.Freer.Fresh
, fresh , fresh
, runFresh , runFresh
, evalFresh , evalFresh
, runFresh'
) where ) where
import Control.Monad.Freer.Internal (Eff, Member, handleRelayS, send) import Control.Monad.Freer.Internal (Eff, Member, handleRelayS, send)
-- | Fresh effect model. -- | Fresh effect model.
data Fresh a where data Fresh r where
Fresh :: Fresh Int Fresh :: Fresh Int
-- | Request a fresh effect. -- | Request a fresh effect.
@ -32,18 +31,11 @@ fresh = send Fresh
-- | Handler for 'Fresh' effects, with an 'Int' for a starting value. The -- | Handler for 'Fresh' effects, with an 'Int' for a starting value. The
-- return value includes the next fresh value. -- return value includes the next fresh value.
runFresh :: Eff (Fresh ': effs) a -> Int -> Eff effs (a, Int) runFresh :: Int -> Eff (Fresh ': effs) a -> Eff effs (a, Int)
runFresh m s = runFresh s =
handleRelayS s (\s' a -> pure (a, s')) (\s' Fresh k -> (k $! s' + 1) s') m 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 -- | Handler for 'Fresh' effects, with an 'Int' for a starting value. Discards
-- the next fresh value. -- the next fresh value.
evalFresh :: Eff (Fresh ': effs) a -> Int -> Eff effs a evalFresh :: Int -> Eff (Fresh ': effs) a -> Eff effs a
evalFresh = ((fst <$>) .) . runFresh evalFresh s = fmap fst . runFresh s
-- | 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."
#-}

View File

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

View File

@ -1,5 +1,3 @@
{-# LANGUAGE TypeFamilies #-}
-- | -- |
-- Module: Control.Monad.Freer.NonDet -- Module: Control.Monad.Freer.NonDet
-- Description: Non deterministic effects -- Description: Non deterministic effects
@ -20,9 +18,9 @@ import Control.Applicative (Alternative, (<|>), empty)
import Control.Monad (msum) import Control.Monad (msum)
import Control.Monad.Freer.Internal import Control.Monad.Freer.Internal
( Eff(E, Val) ( Eff(..)
, Member , Member
, NonDet(MPlus, MZero) , NonDet(..)
, handleRelay , handleRelay
, prj , prj
, qApp , qApp
@ -32,9 +30,9 @@ import Control.Monad.Freer.Internal
-- | A handler for nondeterminstic effects. -- | A handler for nondeterminstic effects.
makeChoiceA makeChoiceA
:: Alternative f :: Alternative f
=> Eff (NonDet ': effs) a => Eff (NonDet ': effs) a
-> Eff effs (f a) -> Eff effs (f a)
makeChoiceA = handleRelay (pure . pure) $ \m k -> makeChoiceA = handleRelay (pure . pure) $ \m k ->
case m of case m of
MZero -> pure empty MZero -> pure empty

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -18,7 +18,7 @@ tests = testGroup "Fresh tests"
] ]
makeFresh :: Int -> Eff r Int 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 :: Int -> Int
testFresh = run . makeFresh testFresh = run . makeFresh

View File

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

View File

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