mirror of
https://github.com/lexi-lambda/freer-simple.git
synced 2024-12-23 14:12:45 +03:00
Clean up some more, remove some half-baked effects
This commit is contained in:
Alexis King
parent
e89ed8911f
commit
207be8e9d7
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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]
|
||||
-}
|
||||
@ -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
|
||||
|
||||
@ -17,7 +17,6 @@ import Console
|
||||
, runConsoleM
|
||||
)
|
||||
import Coroutine ()
|
||||
import Cut ()
|
||||
import Fresh ()
|
||||
import Trace ()
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 #-}
|
||||
|
||||
@ -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
|
||||
-}
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 --
|
||||
|
||||
@ -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
|
||||
@ -32,9 +30,9 @@ import Control.Monad.Freer.Internal
|
||||
|
||||
-- | A handler for nondeterminstic effects.
|
||||
makeChoiceA
|
||||
:: Alternative f
|
||||
=> Eff (NonDet ': effs) a
|
||||
-> Eff effs (f a)
|
||||
:: Alternative f
|
||||
=> Eff (NonDet ': effs) a
|
||||
-> Eff effs (f a)
|
||||
makeChoiceA = handleRelay (pure . pure) $ \m k ->
|
||||
case m of
|
||||
MZero -> pure empty
|
||||
|
||||
@ -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,14 +85,14 @@ 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
|
||||
-- > calc_isCountCorrect = do
|
||||
-- > count <- asks (lookupVar "count")
|
||||
-- > bindings <- (ask :: Eff '[Reader Bindings] Bindings)
|
||||
-- > return (count == (Map.size bindings))
|
||||
-- > count <- asks (lookupVar "count")
|
||||
-- > bindings <- (ask :: Eff '[Reader Bindings] Bindings)
|
||||
-- > return (count == (Map.size bindings))
|
||||
-- >
|
||||
-- > -- The selector function to use with 'asks'.
|
||||
-- > -- Returns value of the variable with specified name.
|
||||
@ -112,8 +104,8 @@ local f m = do
|
||||
-- >
|
||||
-- > main :: IO ()
|
||||
-- > main = putStrLn
|
||||
-- > $ "Count is correct for bindings " ++ show sampleBindings ++ ": "
|
||||
-- > ++ show (isCountCorrect sampleBindings)
|
||||
-- > $ "Count is correct for bindings " ++ show sampleBindings ++ ": "
|
||||
-- > ++ show (isCountCorrect sampleBindings)
|
||||
|
||||
-- $localExample
|
||||
--
|
||||
@ -129,8 +121,8 @@ local f m = do
|
||||
-- >
|
||||
-- > calculateContentLen :: Eff '[Reader String] Int
|
||||
-- > calculateContentLen = do
|
||||
-- > content <- (ask :: Eff '[Reader String] String)
|
||||
-- > return (length content)
|
||||
-- > content <- (ask :: Eff '[Reader String] String)
|
||||
-- > return (length content)
|
||||
-- >
|
||||
-- > -- Calls calculateContentLen after adding a prefix to the Reader content.
|
||||
-- > calculateModifiedContentLen :: Eff '[Reader String] Int
|
||||
@ -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 ;
|
||||
-- > putStrLn $ "Modified 's' length: " ++ (show modifiedLen)
|
||||
-- > putStrLn $ "Original 's' length: " ++ (show len)
|
||||
-- > 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)
|
||||
|
||||
@ -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' #-}
|
||||
|
||||
@ -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
|
||||
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 Ask -> k s' s'
|
||||
Left u'' -> E u'' (tsingleton (k s'))
|
||||
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 ()
|
||||
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'')
|
||||
k s'' = qComp q (runStateR s'')
|
||||
|
||||
@ -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 ()
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user