Prevent possibility of mixing functions for different dispatch types (#49)

* Prevent possibility of mixing functions for different dispatch types

* Rename Rep to EffectR

* Turn DataR into a data family

* Fix doctest with GHC 9.2.1

* HandlerR -> Handler, EffectR -> EffectRep, DataR -> StaticRep

* Safer unsafeConsEnv

* Better haddock

* Rename *Data operations to *StaticRep

* Haddock adjustment

* More haddock adjustments

* One more haddock adjustment
This commit is contained in:
Andrzej Rybczak 2022-01-07 20:28:19 +01:00 committed by GitHub
parent 310c1f9bf8
commit 109d441656
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
30 changed files with 361 additions and 180 deletions

View File

@ -228,11 +228,11 @@ jobs:
- name: doctest
run: |
cd ${PKGDIR_effectful} || false
doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
cd ${PKGDIR_effectful_core} || false
doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators src
cd ${PKGDIR_effectful_core} || false
doctest -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils
doctest -XHaskell2010 -XBangPatterns -XConstraintKinds -XDataKinds -XDeriveFunctor -XDeriveGeneric -XFlexibleContexts -XFlexibleInstances -XGADTs -XGeneralizedNewtypeDeriving -XLambdaCase -XMultiParamTypeClasses -XNoStarIsType -XRankNTypes -XRecordWildCards -XRoleAnnotations -XScopedTypeVariables -XStandaloneDeriving -XTupleSections -XTypeApplications -XTypeFamilies -XTypeOperators utils
- name: cabal check
run: |
cd ${PKGDIR_effectful} || false

View File

@ -13,6 +13,7 @@ run_doctest() {
pushd "${1}"
doctest \
"${2}" \
-XHaskell2010 \
-XBangPatterns \
-XConstraintKinds \
-XDataKinds \

View File

@ -4,6 +4,8 @@ module Effectful
-- ** Effect constraints
, Effect
, Dispatch(..)
, DispatchOf
, (:>)
-- * Running the 'Eff' monad

View File

@ -44,17 +44,19 @@ import Effectful.Internal.Monad
-- | Interpret an effect.
interpret
:: EffectHandler e es
:: DispatchOf e ~ 'Dynamic
=> EffectHandler e es
-- ^ The effect handler.
-> Eff (e : es) a
-> Eff es a
interpret handler m = unsafeEff $ \es -> do
les <- forkEnv es
(`unEff` es) $ runHandler (HandlerA les handler) m
(`unEff` es) $ runHandler (Handler les handler) m
-- | Interpret an effect using other effects.
reinterpret
:: (Eff handlerEs a -> Eff es b)
:: DispatchOf e ~ 'Dynamic
=> (Eff handlerEs a -> Eff es b)
-- ^ Introduction of effects encapsulated within the handler.
-> EffectHandler e handlerEs
-- ^ The effect handler.
@ -63,7 +65,7 @@ reinterpret
reinterpret runHandlerEs handler m = unsafeEff $ \es -> do
les0 <- forkEnv es
(`unEff` les0) . runHandlerEs . unsafeEff $ \les -> do
(`unEff` es) $ runHandler (HandlerA les handler) m
(`unEff` es) $ runHandler (Handler les handler) m
----------------------------------------
-- Unlifts
@ -163,6 +165,7 @@ withLiftMap !_ k = unsafeEff $ \es -> do
-- >>> :{
-- data Fork :: Effect where
-- ForkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> Fork m ThreadId
-- type instance DispatchOf Fork = 'Dynamic
-- :}
--
-- >>> :{

View File

@ -1,18 +1,18 @@
module Effectful.Dispatch.Static
( -- * Low level API
DataA(..)
StaticRep
-- ** Extending the environment
, runData
, evalData
, execData
, runStaticRep
, evalStaticRep
, execStaticRep
-- ** Data retrieval and update
, getData
, putData
, stateData
, stateDataM
, localData
, getStaticRep
, putStaticRep
, stateStaticRep
, stateStaticRepM
, localStaticRep
-- ** Unlifts
, seqUnliftIO
@ -30,6 +30,9 @@ module Effectful.Dispatch.Static
, Relinker(..)
, noRelinker
-- ** Representation of effects
, EffectRep
-- ** Operations
, emptyEnv
, cloneEnv

View File

@ -91,8 +91,10 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | Provide the ability to handle errors of type @e@.
newtype Error e :: Effect where
Error :: ErrorId -> Error e m r
data Error e :: Effect
type instance DispatchOf (Error e) = 'Static
newtype instance StaticRep (Error e) = Error ErrorId
-- | Handle errors of type @e@.
runError
@ -102,7 +104,7 @@ runError
runError m = unsafeEff $ \es0 -> mask $ \release -> do
eid <- newErrorId
size0 <- sizeEnv es0
es <- unsafeConsEnv (DataA (Error @e eid)) noRelinker es0
es <- unsafeConsEnv (Error @e eid) noRelinker es0
r <- tryErrorIO release eid es `onException` unsafeTailEnv size0 es
unsafeTailEnv size0 es
pure r
@ -119,7 +121,7 @@ throwError
-- ^ The error.
-> Eff es a
throwError e = unsafeEff $ \es -> do
DataA (Error eid) <- getEnv @(Error e) es
Error eid <- getEnv @(Error e) es
throwIO $ ErrorEx eid callStack e
-- | Handle an error of type @e@.
@ -131,7 +133,7 @@ catchError
-- ^ A handler for errors in the inner computation.
-> Eff es a
catchError m handler = unsafeEff $ \es -> do
DataA (Error eid) <- getEnv @(Error e) es
Error eid <- getEnv @(Error e) es
size <- sizeEnv es
catchErrorIO eid (unEff m es) $ \cs e -> do
checkSizeEnv size es

View File

@ -16,6 +16,8 @@ data Error e :: Effect where
ThrowError :: e -> Error e m a
CatchError :: m a -> (E.CallStack -> e -> m a) -> Error e m a
type instance DispatchOf (Error e) = 'Dynamic
runError
:: Typeable e
=> Eff (Error e : es) a

View File

@ -29,14 +29,14 @@ module Effectful.Internal.Env
, checkSizeEnv
-- ** Extending and shrinking
, unsafeConsEnv
, veryUnsafeConsEnv
, unsafeTailEnv
-- ** Data retrieval and update
, getEnv
, putEnv
, stateEnv
, modifyEnv
, unsafeGetEnv
, unsafePutEnv
, unsafeStateEnv
, unsafeModifyEnv
) where
import Control.Monad
@ -167,11 +167,11 @@ newForkId (ForkIdGen ref) = do
-- the environment.
newtype Relinker :: (Effect -> Type) -> Effect -> Type where
Relinker
:: ((forall es. Env es -> IO (Env es)) -> adapter e -> IO (adapter e))
-> Relinker adapter e
:: ((forall es. Env es -> IO (Env es)) -> rep e -> IO (rep e))
-> Relinker rep e
-- | A dummy 'Relinker' that does nothing.
noRelinker :: Relinker adapter e
noRelinker :: Relinker rep e
noRelinker = Relinker $ \_ -> pure
----------------------------------------
@ -356,11 +356,15 @@ checkSizeEnv k (Env (Forks _ baseIx lref _) _ _) = do
-- | Extend the environment with a new data type (in place).
--
-- This function is __highly unsafe__ because it renders the input 'Env'
-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not
-- checked anywhere.
unsafeConsEnv :: adapter e -> Relinker adapter e -> Env es -> IO (Env (e : es))
unsafeConsEnv e f (Env fork gref gen) = case fork of
-- This function is __highly unsafe__ because:
--
-- - The @rep@ type variable is unrestricted, so it's possible to put in a
-- different data type than the one retrieved later.
--
-- - It renders the input 'Env' unusable until the corresponding 'unsafeTailEnv'
-- call is made, but it's not checked anywhere.
veryUnsafeConsEnv :: rep e -> Relinker rep e -> Env es -> IO (Env (e : es))
veryUnsafeConsEnv e f (Env fork gref gen) = case fork of
NoFork -> do
extendEnvRef gref
pure $ Env NoFork gref gen
@ -390,7 +394,7 @@ unsafeConsEnv e f (Env fork gref gen) = case fork of
doubleCapacity :: Int -> Int
doubleCapacity n = max 1 n * 2
{-# NOINLINE unsafeConsEnv #-}
{-# NOINLINE veryUnsafeConsEnv #-}
-- | Shrink the environment by one data type (in place). Makes sure the size of
-- the environment is as expected.
@ -417,43 +421,63 @@ unsafeTailEnv len (Env fork gref _) = case fork of
-- Data retrieval and update
-- | Extract a specific data type from the environment.
getEnv
:: forall e adapter es. e :> es
--
-- This function is __unsafe__ because @rep@ is unrestricted, so it's possible
-- to retrieve a different data type that was put in.
--
-- For a safe variant see 'Effectful.Dispatch.Static.getEnv'.
unsafeGetEnv
:: forall e rep es. e :> es
=> Env es
-> IO (adapter e)
getEnv env = do
-> IO (rep e)
unsafeGetEnv env = do
Location i es <- getLocation (reifyIndex @e @es) env
fromAny <$> readSmallArray es i
-- | Replace the data type in the environment with a new value (in place).
putEnv
:: forall e adapter es. e :> es
--
-- This function is __unsafe__ because @rep@ is unrestricted, so it's possible
-- to retrieve a different data type that was put in.
--
-- For a safe variant see 'Effectful.Dispatch.Static.putEnv'.
unsafePutEnv
:: forall e rep es. e :> es
=> Env es
-> adapter e
-> rep e
-> IO ()
putEnv env e = do
unsafePutEnv env e = do
Location i es <- getLocation (reifyIndex @e @es) env
e `seq` writeSmallArray es i (toAny e)
-- | Modify the data type in the environment (in place) and return a value.
stateEnv
:: forall e adapter es a. e :> es
--
-- This function is __unsafe__ because @rep@ is unrestricted, so it's possible
-- to retrieve a different data type that was put in.
--
-- For a safe variant see 'Effectful.Dispatch.Static.stateEnv'.
unsafeStateEnv
:: forall e rep es a. e :> es
=> Env es
-> (adapter e -> (a, adapter e))
-> (rep e -> (a, rep e))
-> IO a
stateEnv env f = do
unsafeStateEnv env f = do
Location i es <- getLocation (reifyIndex @e @es) env
(a, e) <- f . fromAny <$> readSmallArray es i
e `seq` writeSmallArray es i (toAny e)
pure a
-- | Modify the data type in the environment (in place).
modifyEnv
:: forall e adapter es. e :> es
--
-- This function is __unsafe__ because @rep@ is unrestricted, so it's possible
-- to retrieve a different data type that was put in.
--
-- For a safe variant see 'Effectful.Dispatch.Static.modifyEnv'.
unsafeModifyEnv
:: forall e rep es. e :> es
=> Env es
-> (adapter e -> adapter e)
-> (rep e -> rep e)
-> IO ()
modifyEnv env f = do
unsafeModifyEnv env f = do
Location i es <- getLocation (reifyIndex @e @es) env
e <- f . fromAny <$> readSmallArray es i
e `seq` writeSmallArray es i (toAny e)

View File

@ -1,3 +1,4 @@
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-noncanonical-monad-instances #-}
{-# OPTIONS_HADDOCK not-home #-}
@ -40,23 +41,35 @@ module Effectful.Internal.Monad
-- * Effects
-- * Dispatch
, Dispatch(..)
, DispatchOf
, EffectRep
-- ** Dynamic dispatch
, EffectHandler
, LocalEnv(..)
, HandlerA(..)
, Handler(..)
, runHandler
, send
-- ** Static dispatch
, DataA(..)
, runData
, evalData
, execData
, getData
, putData
, stateData
, stateDataM
, localData
, StaticRep
, runStaticRep
, evalStaticRep
, execStaticRep
, getStaticRep
, putStaticRep
, stateStaticRep
, stateStaticRepM
, localStaticRep
-- *** Primitive operations
, unsafeConsEnv
, getEnv
, putEnv
, stateEnv
, modifyEnv
) where
import Control.Applicative (liftA2)
@ -145,12 +158,12 @@ unsafeEff_ m = unsafeEff $ \_ -> m
-- | Get the current 'UnliftStrategy'.
unliftStrategy :: IOE :> es => Eff es UnliftStrategy
unliftStrategy = do
DataA (IOE unlift) <- getData
IOE unlift <- getStaticRep
pure unlift
-- | Locally override the 'UnliftStrategy' with the given value.
withUnliftStrategy :: IOE :> es => UnliftStrategy -> Eff es a -> Eff es a
withUnliftStrategy unlift = localData $ \_ -> DataA (IOE unlift)
withUnliftStrategy unlift = localStaticRep $ \_ -> IOE unlift
-- | Create an unlifting function with the current 'UnliftStrategy'.
--
@ -252,6 +265,8 @@ instance C.MonadMask (Eff es) where
data Fail :: Effect where
Fail :: String -> Fail m a
type instance DispatchOf Fail = 'Dynamic
instance Fail :> es => MonadFail (Eff es) where
fail = send . Fail
@ -259,14 +274,16 @@ instance Fail :> es => MonadFail (Eff es) where
-- IO
-- | Run arbitrary 'IO' computations via 'MonadIO' or 'MonadUnliftIO'.
newtype IOE :: Effect where
IOE :: UnliftStrategy -> IOE m r
data IOE :: Effect
type instance DispatchOf IOE = 'Static
newtype instance StaticRep IOE = IOE UnliftStrategy
-- | Run an 'Eff' computation with side effects.
--
-- For running pure computations see 'runPureEff'.
runEff :: Eff '[IOE] a -> IO a
runEff m = unEff (evalData (DataA (IOE SeqUnlift)) m) =<< emptyEnv
runEff m = unEff (evalStaticRep (IOE SeqUnlift) m) =<< emptyEnv
instance IOE :> es => MonadIO (Eff es) where
liftIO = unsafeEff_
@ -291,17 +308,34 @@ instance IOE :> es => MonadBaseControl IO (Eff es) where
-- Primitive
-- | Provide the ability to perform primitive state-transformer actions.
data Prim :: Effect where
Prim :: Prim m r
data Prim :: Effect
type instance DispatchOf Prim = 'Static
data instance StaticRep Prim = Prim
-- | Run an 'Eff' computation with primitive state-transformer actions.
runPrim :: IOE :> es => Eff (Prim : es) a -> Eff es a
runPrim = evalData (DataA Prim)
runPrim = evalStaticRep Prim
instance Prim :> es => PrimMonad (Eff es) where
type PrimState (Eff es) = RealWorld
primitive = unsafeEff_ . IO
----------------------------------------
-- Dispatch
-- | A type of dispatch. For more information consult the documentation in
-- "Effectful.Dispatch.Dynamic" and "Effectful.Dispatch.Static".
data Dispatch = Dynamic | Static
-- | Dispatch types of effects.
type family DispatchOf (e :: Effect) :: Dispatch
-- | Internal representations of effects.
type family EffectRep (d :: Dispatch) = (r :: Effect -> Type) | r -> d where
EffectRep 'Dynamic = Handler
EffectRep 'Static = StaticRep
----------------------------------------
-- Dynamic dispatch
@ -325,91 +359,157 @@ type EffectHandler e es
-- ^ The effect performed in the local environment.
-> Eff es a
-- | An adapter for dynamically dispatched effects.
--
-- Represents the effect handler bundled with its environment.
data HandlerA :: Effect -> Type where
HandlerA :: !(Env es) -> !(EffectHandler e es) -> HandlerA e
-- | An internal representation of dynamically dispatched effects, i.e. the
-- effect handler bundled with its environment.
data Handler :: Effect -> Type where
Handler :: !(Env es) -> !(EffectHandler e es) -> Handler e
-- | Run a dynamically dispatched effect with the given handler.
runHandler :: HandlerA e -> Eff (e : es) a -> Eff es a
runHandler :: DispatchOf e ~ 'Dynamic => Handler e -> Eff (e : es) a -> Eff es a
runHandler e m = unsafeEff $ \es0 -> do
size0 <- sizeEnv es0
E.bracket (unsafeConsEnv e relinker es0)
(unsafeTailEnv size0)
(\es -> unEff m es)
where
relinker :: Relinker HandlerA e
relinker = Relinker $ \relink (HandlerA handlerEs handle) -> do
relinker :: Relinker Handler e
relinker = Relinker $ \relink (Handler handlerEs handle) -> do
newHandlerEs <- relink handlerEs
pure $ HandlerA newHandlerEs handle
pure $ Handler newHandlerEs handle
-- | Send an operation of the given effect to its handler for execution.
send :: (HasCallStack, e :> es) => e (Eff es) a -> Eff es a
send :: (HasCallStack, DispatchOf e ~ 'Dynamic, e :> es) => e (Eff es) a -> Eff es a
send op = unsafeEff $ \es -> do
HandlerA handlerEs handle <- getEnv es
Handler handlerEs handle <- getEnv es
unEff (handle (LocalEnv es) op) handlerEs
----------------------------------------
-- Static dispatch
-- | An adapter for statically dispatched effects.
--
-- Represents an arbitrary data type with the appropriate number of phantom type
-- parameters.
newtype DataA :: Effect -> Type where
DataA :: (forall m r. e m r) -> DataA e
-- | Internal representations of statically dispatched effects.
data family StaticRep (e :: Effect) :: Type
-- | Run a statically dispatched effect with the given initial state and return
-- the final value along with the final state.
runData :: DataA e -> Eff (e : es) a -> Eff es (a, DataA e)
runData e0 m = unsafeEff $ \es0 -> do
-- | Run a statically dispatched effect with the given initial representation
-- and return the final value along with the final representation.
runStaticRep
:: DispatchOf e ~ 'Static
=> StaticRep e -- ^ The initial representation.
-> Eff (e : es) a
-> Eff es (a, StaticRep e)
runStaticRep e0 m = unsafeEff $ \es0 -> do
size0 <- sizeEnv es0
E.bracket (unsafeConsEnv e0 noRelinker es0)
(unsafeTailEnv size0)
(\es -> (,) <$> unEff m es <*> getEnv es)
-- | Run a statically dispatched effect with the given initial state and return
-- the final value, discarding the final state.
evalData :: DataA e -> Eff (e : es) a -> Eff es a
evalData e m = unsafeEff $ \es0 -> do
-- | Run a statically dispatched effect with the given initial representation
-- and return the final value, discarding the final representation.
evalStaticRep
:: DispatchOf e ~ 'Static
=> StaticRep e -- ^ The initial representation.
-> Eff (e : es) a
-> Eff es a
evalStaticRep e m = unsafeEff $ \es0 -> do
size0 <- sizeEnv es0
E.bracket (unsafeConsEnv e noRelinker es0)
(unsafeTailEnv size0)
(\es -> unEff m es)
-- | Run a statically dispatched effect with the given initial state and return
-- the final state, discarding the final value.
execData :: DataA e -> Eff (e : es) a -> Eff es (DataA e)
execData e0 m = unsafeEff $ \es0 -> do
-- | Run a statically dispatched effect with the given initial representation
-- and return the final representation, discarding the final value.
execStaticRep
:: DispatchOf e ~ 'Static
=> StaticRep e -- ^ The initial representation.
-> Eff (e : es) a
-> Eff es (StaticRep e)
execStaticRep e0 m = unsafeEff $ \es0 -> do
size0 <- sizeEnv es0
E.bracket (unsafeConsEnv e0 noRelinker es0)
(unsafeTailEnv size0)
(\es -> unEff m es *> getEnv es)
-- | Fetch the current state of the effect.
getData :: e :> es => Eff es (DataA e)
getData = unsafeEff $ \es -> getEnv es
-- | Fetch the current representation of the effect.
getStaticRep :: (DispatchOf e ~ 'Static, e :> es) => Eff es (StaticRep e)
getStaticRep = unsafeEff $ \es -> getEnv es
-- | Set the current state of the effect to the given value.
putData :: e :> es => DataA e -> Eff es ()
putData e = unsafeEff $ \es -> putEnv es e
-- | Set the current representation of the effect to the given value.
putStaticRep :: (DispatchOf e ~ 'Static, e :> es) => StaticRep e -> Eff es ()
putStaticRep s = unsafeEff $ \es -> putEnv es s
-- | Apply the function to the current state of the effect and return a value.
stateData :: e :> es => (DataA e -> (a, DataA e)) -> Eff es a
stateData f = unsafeEff $ \es -> stateEnv es f
-- | Apply the monadic function to the current state of the effect and return a
-- | Apply the function to the current representation of the effect and return a
-- value.
stateDataM :: e :> es => (DataA e -> Eff es (a, DataA e)) -> Eff es a
stateDataM f = unsafeEff $ \es -> E.mask $ \release -> do
(a, e) <- (\e -> release $ unEff (f e) es) =<< getEnv es
putEnv es e
stateStaticRep
:: (DispatchOf e ~ 'Static, e :> es)
=> (StaticRep e -> (a, StaticRep e))
-- ^ The function to modify the representation.
-> Eff es a
stateStaticRep f = unsafeEff $ \es -> stateEnv es f
-- | Apply the monadic function to the current representation of the effect and
-- return a value.
stateStaticRepM
:: (DispatchOf e ~ 'Static, e :> es)
=> (StaticRep e -> Eff es (a, StaticRep e))
-- ^ The function to modify the representation.
-> Eff es a
stateStaticRepM f = unsafeEff $ \es -> E.mask $ \release -> do
(a, s) <- (\s0 -> release $ unEff (f s0) es) =<< getEnv es
putEnv es s
pure a
-- | Execute a computation with a temporarily modified state of the effect.
localData :: e :> es => (DataA e -> DataA e) -> Eff es a -> Eff es a
localData f m = unsafeEff $ \es -> do
E.bracket (stateEnv es $ \e -> (e, f e))
(\e -> putEnv es e)
-- | Execute a computation with a temporarily modified representation of the
-- effect.
localStaticRep
:: (DispatchOf e ~ 'Static, e :> es)
=> (StaticRep e -> StaticRep e)
-- ^ The function to temporarily modify the representation.
-> Eff es a
-> Eff es a
localStaticRep f m = unsafeEff $ \es -> do
E.bracket (stateEnv es $ \s -> (s, f s))
(\s -> putEnv es s)
(\_ -> unEff m es)
----------------------------------------
-- Safer interface for Env
-- | Extend the environment with a new effect (in place).
--
-- This function is __highly unsafe__ because it renders the input 'Env'
-- unusable until the corresponding 'unsafeTailEnv' call is made, but it's not
-- checked anywhere.
unsafeConsEnv
:: EffectRep (DispatchOf e) e
-- ^ The representation of the effect.
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
unsafeConsEnv = veryUnsafeConsEnv
-- | Extract a specific representation of the effect from the environment.
getEnv :: e :> es => Env es -> IO (EffectRep (DispatchOf e) e)
getEnv = unsafeGetEnv
-- | Replace the representation of the effect in the environment with a new
-- value (in place).
putEnv :: e :> es => Env es -> EffectRep (DispatchOf e) e -> IO ()
putEnv = unsafePutEnv
-- | Modify the representation of the effect in the environment (in place) and
-- return a value.
stateEnv
:: e :> es
=> Env es
-> (EffectRep (DispatchOf e) e -> (a, EffectRep (DispatchOf e) e))
-- ^ The function to modify the representation.
-> IO a
stateEnv = unsafeStateEnv
-- | Modify the representation of the effect in the environment (in place).
modifyEnv
:: e :> es
=> Env es
-> (EffectRep (DispatchOf e) e -> EffectRep (DispatchOf e) e)
-- ^ The function to modify the representation.
-> IO ()
modifyEnv = unsafeModifyEnv

View File

@ -5,6 +5,8 @@ module Effectful.Monad
-- ** Effect constraints
, Effect
, Dispatch(..)
, DispatchOf
, (:>)
-- * Arbitrary I/O

View File

@ -12,20 +12,22 @@ import Effectful.Monad
-- | Provide access to a strict (WHNF), thread local, read only value of type
-- @r@.
newtype Reader r :: Effect where
Reader :: r -> Reader r m a
data Reader r :: Effect
type instance DispatchOf (Reader r) = 'Static
newtype instance StaticRep (Reader r) = Reader r
-- | Run a 'Reader' effect with the given initial environment.
runReader
:: r -- ^ An initial environment.
-> Eff (Reader r : es) a
-> Eff es a
runReader r = evalData (DataA (Reader r))
runReader r = evalStaticRep (Reader r)
-- | Fetch the value of the environment.
ask :: Reader r :> es => Eff es r
ask = do
DataA (Reader r) <- getData
Reader r <- getStaticRep
pure r
-- | Retrieve a function of the current environment.
@ -46,4 +48,4 @@ local
=> (r -> r) -- ^ The function to modify the environment.
-> Eff es a
-> Eff es a
local f = localData $ \(DataA (Reader r)) -> DataA (Reader (f r))
local f = localStaticRep $ \(Reader r) -> Reader (f r)

View File

@ -14,6 +14,8 @@ data Reader r :: Effect where
Ask :: Reader r m r
Local :: (r -> r) -> m a -> Reader r m a
type instance DispatchOf (Reader r) = 'Dynamic
runReader :: r -> Eff (Reader r : es) a -> Eff es a
runReader r = reinterpret (R.runReader r) $ \env -> \case
Ask -> R.ask

View File

@ -34,6 +34,8 @@ data State s :: Effect where
State :: (s -> (a, s)) -> State s m a
StateM :: (s -> m (a, s)) -> State s m a
type instance DispatchOf (State s) = 'Dynamic
----------------------------------------
-- Local

View File

@ -42,8 +42,10 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | Provide access to a strict (WHNF), thread local, mutable value of type @s@.
newtype State s :: Effect where
State :: s -> State s m r
data State s :: Effect
type instance DispatchOf (State s) = 'Static
newtype instance StaticRep (State s) = State s
-- | Run a 'State' effect with the given initial state and return the final
-- value along with the final state.
@ -52,7 +54,7 @@ runState
-> Eff (State s : es) a
-> Eff es (a, s)
runState s0 m = do
(a, DataA (State s)) <- runData (DataA (State s0)) m
(a, State s) <- runStaticRep (State s0) m
pure (a, s)
-- | Run a 'State' effect with the given initial state and return the final
@ -61,7 +63,7 @@ evalState
:: s -- ^ An initial state.
-> Eff (State s : es) a
-> Eff es a -- ^ A return value.
evalState s = evalData (DataA (State s))
evalState s = evalStaticRep (State s)
-- | Run a 'State' effect with the given initial state and return the final
-- state, discarding the final value.
@ -70,13 +72,13 @@ execState
-> Eff (State s : es) a
-> Eff es s
execState s0 m = do
DataA (State s) <- execData (DataA (State s0)) m
State s <- execStaticRep (State s0) m
pure s
-- | Fetch the current value of the state.
get :: State s :> es => Eff es s
get = do
DataA (State s) <- getData
State s <- getStaticRep
pure s
-- | Get a function of the current state.
@ -90,14 +92,14 @@ gets f = f <$> get
-- | Set the current state to the given value.
put :: State s :> es => s -> Eff es ()
put s = putData (DataA (State s))
put s = putStaticRep (State s)
-- | Apply the function to the current state and return a value.
state
:: State s :> es
=> (s -> (a, s)) -- ^ The function to modify the state.
-> Eff es a
state f = stateData $ \(DataA (State s0)) -> let (a, s) = f s0 in (a, DataA (State s))
state f = stateStaticRep $ \(State s0) -> let (a, s) = f s0 in (a, State s)
-- | Apply the function to the current state.
--
@ -113,9 +115,9 @@ stateM
:: State s :> es
=> (s -> Eff es (a, s)) -- ^ The function to modify the state.
-> Eff es a
stateM f = stateDataM $ \(DataA (State s0)) -> do
stateM f = stateStaticRepM $ \(State s0) -> do
(a, s) <- f s0
pure (a, DataA (State s))
pure (a, State s)
-- | Apply the monadic function to the current state.
--

View File

@ -44,15 +44,17 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | Provide access to a strict (WHNF), shared, mutable value of type @s@.
newtype State s :: Effect where
State :: MVar s -> State s m r
data State s :: Effect
type instance DispatchOf (State s) = 'Static
newtype instance StaticRep (State s) = State (MVar s)
-- | Run a 'State' effect with the given initial state and return the final
-- value along with the final state.
runState :: s -> Eff (State s : es) a -> Eff es (a, s)
runState s m = do
v <- unsafeEff_ $ newMVar s
a <- evalData (DataA (State v)) m
a <- evalStaticRep (State v) m
(a, ) <$> unsafeEff_ (readMVar v)
-- | Run a 'State' effect with the given initial state and return the final
@ -60,20 +62,20 @@ runState s m = do
evalState :: s -> Eff (State s : es) a -> Eff es a
evalState s m = do
v <- unsafeEff_ $ newMVar s
evalData (DataA (State v)) m
evalStaticRep (State v) m
-- | Run a 'State' effect with the given initial state and return the final
-- state, discarding the final value.
execState :: s -> Eff (State s : es) a -> Eff es s
execState s m = do
v <- unsafeEff_ $ newMVar s
_ <- evalData (DataA (State v)) m
_ <- evalStaticRep (State v) m
unsafeEff_ $ readMVar v
-- | Fetch the current value of the state.
get :: State s :> es => Eff es s
get = unsafeEff $ \es -> do
DataA (State v) <- getEnv es
State v <- getEnv es
readMVar v
-- | Get a function of the current state.
@ -85,7 +87,7 @@ gets f = f <$> get
-- | Set the current state to the given value.
put :: State s :> es => s -> Eff es ()
put s = unsafeEff $ \es -> do
DataA (State v) <- getEnv es
State v <- getEnv es
modifyMVar_ v $ \_ -> s `seq` pure s
-- | Apply the function to the current state and return a value.
@ -93,7 +95,7 @@ put s = unsafeEff $ \es -> do
-- /Note:/ this function gets an exclusive access to the state for its duration.
state :: State s :> es => (s -> (a, s)) -> Eff es a
state f = unsafeEff $ \es -> do
DataA (State v) <- getEnv es
State v <- getEnv es
modifyMVar v $ \s0 -> let (a, s) = f s0 in s `seq` pure (s, a)
-- | Apply the function to the current state.
@ -109,7 +111,7 @@ modify f = state (\s -> ((), f s))
-- /Note:/ this function gets an exclusive access to the state for its duration.
stateM :: State s :> es => (s -> Eff es (a, s)) -> Eff es a
stateM f = unsafeEff $ \es -> do
DataA (State v) <- getEnv es
State v <- getEnv es
modifyMVar v $ \s0 -> do
(a, s) <- unEff (f s0) es
s `seq` pure (s, a)

View File

@ -24,6 +24,8 @@ data Writer w :: Effect where
Tell :: w -> Writer w m ()
Listen :: m a -> Writer w m (a, w)
type instance DispatchOf (Writer w) = 'Dynamic
----------------------------------------
-- Local

View File

@ -31,26 +31,28 @@ import Effectful.Monad
-- | Provide access to a strict (WHNF), thread local, write only value of type
-- @w@.
newtype Writer w :: Effect where
Writer :: w -> Writer w m r
data Writer w :: Effect
type instance DispatchOf (Writer w) = 'Static
newtype instance StaticRep (Writer w) = Writer w
-- | Run a 'Writer' effect and return the final value along with the final
-- output.
runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
runWriter m = do
(a, DataA (Writer w)) <- runData (DataA (Writer mempty)) m
(a, Writer w) <- runStaticRep (Writer mempty) m
pure (a, w)
-- | Run a 'Writer' effect and return the final output, discarding the final
-- value.
execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
execWriter m = do
DataA (Writer w) <- execData (DataA (Writer mempty)) m
Writer w <- execStaticRep (Writer mempty) m
pure w
-- | Append the given output to the overall output of the 'Writer'.
tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))
tell w = stateStaticRep $ \(Writer w0) -> ((), Writer (w0 <> w))
-- | Execute an action and append its output to the overall output of the
-- 'Writer'.
@ -71,13 +73,13 @@ tell w = stateData $ \(DataA (Writer w0)) -> ((), DataA (Writer (w0 <> w)))
-- "Hi there!"
listen :: (Writer w :> es, Monoid w) => Eff es a -> Eff es (a, w)
listen m = unsafeEff $ \es -> mask $ \restore -> do
w0 <- stateEnv es $ \(DataA (Writer w)) -> (w, DataA (Writer mempty))
w0 <- stateEnv es $ \(Writer w) -> (w, Writer mempty)
a <- restore (unEff m es) `onException` merge es w0
(a, ) <$> merge es w0
where
merge es w0 =
-- If an exception is thrown, restore w0 and keep parts of w1.
stateEnv es $ \(DataA (Writer w1)) -> (w1, DataA (Writer (w0 <> w1)))
stateEnv es $ \(Writer w1) -> (w1, Writer (w0 <> w1))
-- | Execute an action and append its output to the overall output of the
-- 'Writer', then return the final value along with a function of the recorded

View File

@ -31,15 +31,17 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | Provide access to a strict (WHNF), shared, write only value of type @w@.
newtype Writer w :: Effect where
Writer :: MVar w -> Writer w m r
data Writer w :: Effect
type instance DispatchOf (Writer w) = 'Static
newtype instance StaticRep (Writer w) = Writer (MVar w)
-- | Run a 'Writer' effect and return the final value along with the final
-- output.
runWriter :: Monoid w => Eff (Writer w : es) a -> Eff es (a, w)
runWriter m = do
v <- unsafeEff_ $ newMVar mempty
a <- evalData (DataA (Writer v)) m
a <- evalStaticRep (Writer v) m
(a, ) <$> unsafeEff_ (readMVar v)
-- | Run a 'Writer' effect and return the final output, discarding the final
@ -47,13 +49,13 @@ runWriter m = do
execWriter :: Monoid w => Eff (Writer w : es) a -> Eff es w
execWriter m = do
v <- unsafeEff_ $ newMVar mempty
_ <- evalData (DataA (Writer v)) m
_ <- evalStaticRep (Writer v) m
unsafeEff_ $ readMVar v
-- | Append the given output to the overall output of the 'Writer'.
tell :: (Writer w :> es, Monoid w) => w -> Eff es ()
tell w1 = unsafeEff $ \es -> do
DataA (Writer v) <- getEnv es
Writer v <- getEnv es
modifyMVar_ v $ \w0 -> let w = w0 <> w1 in w `seq` pure w
-- | Execute an action and append its output to the overall output of the
@ -81,14 +83,14 @@ listen m = unsafeEff $ \es -> do
uninterruptibleMask $ \restore -> do
v1 <- newMVar mempty
-- Replace thread local MVar with a fresh one for isolated listening.
v0 <- stateEnv es $ \(DataA (Writer v)) -> (v, DataA (Writer v1))
v0 <- stateEnv es $ \(Writer v) -> (v, Writer v1)
a <- restore (unEff m es) `onException` merge es v0 v1
(a, ) <$> merge es v0 v1
where
-- Merge results accumulated in the local MVar with the mainline. If an
-- exception was received while listening, merge results recorded so far.
merge es v0 v1 = do
putEnv es $ DataA (Writer v0)
putEnv es $ Writer v0
w1 <- readMVar v1
modifyMVar_ v0 $ \w0 -> let w = w0 <> w1 in w `seq` pure w
pure w1

View File

@ -57,6 +57,8 @@ op = pure 1
data Fork :: Effect where
ForkWithUnmask :: ((forall a. m a -> m a) -> m r) -> Fork m (Async r)
type instance DispatchOf Fork = 'Dynamic
-- | Uses 'localUnliftIO' and 'withLiftMapIO'.
runFork1 :: IOE :> es => Eff (Fork : es) a -> Eff es a
runFork1 = interpret $ \env -> \case

View File

@ -77,6 +77,8 @@ ref_calculateFileSizes files = do
data Effectful_File :: E.Effect where
Effectful_tryFileSize :: FilePath -> Effectful_File m (Maybe Int)
type instance E.DispatchOf Effectful_File = 'E.Dynamic
effectful_tryFileSize :: Effectful_File E.:> es => FilePath -> E.Eff es (Maybe Int)
effectful_tryFileSize = E.send . Effectful_tryFileSize
@ -87,6 +89,8 @@ effectful_runFile = E.interpret \_ -> \case
data Effectful_Logging :: E.Effect where
Effectful_logMsg :: String -> Effectful_Logging m ()
type instance E.DispatchOf Effectful_Logging = 'E.Dynamic
effectful_logMsg :: Effectful_Logging E.:> es => String -> E.Eff es ()
effectful_logMsg = E.send . Effectful_logMsg

View File

@ -22,6 +22,8 @@ data FileSystem :: Effect where
ReadFile :: FilePath -> FileSystem m String
WriteFile :: FilePath -> String -> FileSystem m ()
type instance DispatchOf FileSystem = 'Dynamic
--- | File system error.
newtype FsError = FsError String

View File

@ -67,12 +67,14 @@ import Effectful.Monad
-- in the parent thread because the value is thread local, but in the second
-- example they are, because the value is shared.
--
data Concurrent :: Effect where
Concurrent :: Concurrent m r
data Concurrent :: Effect
type instance DispatchOf Concurrent = 'Static
data instance StaticRep Concurrent = Concurrent
-- | Run the 'Concurrent' effect.
runConcurrent :: IOE :> es => Eff (Concurrent : es) a -> Eff es a
runConcurrent = evalData (DataA Concurrent)
runConcurrent = evalStaticRep Concurrent
-- $setup
-- >>> import Effectful.Concurrent

View File

@ -23,12 +23,14 @@ import Effectful.Dispatch.Static hiding (getEnv)
import Effectful.Monad
-- | An effect for querying and modifying the system environment.
data Environment :: Effect where
Environment :: Environment m r
data Environment :: Effect
type instance DispatchOf Environment = 'Static
data instance StaticRep Environment = Environment
-- | Run the 'Environment' effect.
runEnvironment :: IOE :> es => Eff (Environment : es) a -> Eff es a
runEnvironment = evalData (DataA Environment)
runEnvironment = evalStaticRep Environment
-- | Lifted 'E.getArgs'.
getArgs :: Environment :> es => Eff es [String]

View File

@ -7,9 +7,11 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | An effect for interacting with the filesystem.
data FileSystem :: Effect where
FileSystem :: FileSystem m r
data FileSystem :: Effect
type instance DispatchOf FileSystem = 'Static
data instance StaticRep FileSystem = FileSystem
-- | Run the 'FileSystem' effect.
runFileSystem :: IOE :> es => Eff (FileSystem : es) a -> Eff es a
runFileSystem = evalData (DataA FileSystem)
runFileSystem = evalStaticRep FileSystem

View File

@ -54,11 +54,13 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | An effect for running child processes using the @process@ library.
data Process :: Effect where
Process :: Process m r
data Process :: Effect
type instance DispatchOf Process = 'Static
data instance StaticRep Process = Process
runProcess :: IOE :> es => Eff (Process : es) a -> Eff es a
runProcess = evalData (DataA Process)
runProcess = evalStaticRep Process
----------------------------------------
-- Running sub-processes

View File

@ -28,8 +28,10 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | Data tag for a resource effect.
newtype Resource :: Effect where
Resource :: R.InternalState -> Resource m r
data Resource :: Effect
type instance DispatchOf Resource = 'Static
newtype instance StaticRep Resource = Resource R.InternalState
-- | Run the resource effect.
runResource :: IOE :> es => Eff (Resource : es) a -> Eff es a
@ -37,7 +39,7 @@ runResource m = unsafeEff $ \es0 -> do
size0 <- sizeEnv es0
istate <- R.createInternalState
mask $ \restore -> do
es <- unsafeConsEnv (DataA (Resource istate)) noRelinker es0
es <- unsafeConsEnv (Resource istate) noRelinker es0
a <- restore (unEff m es) `catch` \e -> do
unsafeTailEnv size0 es
RI.stateCleanupChecked (Just e) istate
@ -52,18 +54,18 @@ runResource m = unsafeEff $ \es0 -> do
-- | Get the 'R.InternalState' of the current 'Resource' effect.
getInternalState :: Resource :> es => Eff es R.InternalState
getInternalState = do
DataA (Resource istate) <- getData
Resource istate <- getStaticRep
pure istate
-- | Run the 'Resource' effect with existing 'R.InternalState'.
--
-- /Note:/ the 'R.InternalState' will not be closed at the end.
runInternalState :: R.InternalState -> Eff (Resource : es) a -> Eff es a
runInternalState istate = evalData (DataA (Resource istate))
runInternalState istate = evalStaticRep (Resource istate)
----------------------------------------
-- Orphan instance
instance (IOE :> es, Resource :> es) => R.MonadResource (Eff es) where
liftResourceT (RI.ResourceT m) = unsafeEff $ \es -> do
getEnv es >>= \(DataA (Resource istate)) -> m istate
getEnv es >>= \(Resource istate) -> m istate

View File

@ -14,12 +14,14 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | An effect for interacting with temporary files.
data Temporary :: Effect where
Temporary :: Temporary m r
data Temporary :: Effect
type instance DispatchOf Temporary = 'Static
data instance StaticRep Temporary = Temporary
-- | Run the 'Temporary' effect.
runTemporary :: IOE :> es => Eff (Temporary : es) a -> Eff es a
runTemporary = evalData (DataA Temporary)
runTemporary = evalStaticRep Temporary
-- | Lifted 'T.withSystemTempFile'.
withSystemTempFile

View File

@ -10,12 +10,14 @@ import Effectful.Dispatch.Static
import Effectful.Monad
-- | An effect for timing out computations.
data Timeout :: Effect where
Timeout :: Timeout m r
data Timeout :: Effect
type instance DispatchOf Timeout = 'Static
data instance StaticRep Timeout = Timeout
-- | Run the 'Timeout' effect.
runTimeout :: IOE :> es => Eff (Timeout : es) a -> Eff es a
runTimeout = evalData (DataA Timeout)
runTimeout = evalStaticRep Timeout
-- | Lifted 'T.timeout'.
timeout

View File

@ -26,6 +26,8 @@ test_errorFromInterpret = runEff $ do
data NestedErr :: Effect where
NestedErr :: NestedErr m ()
type instance DispatchOf NestedErr = 'Dynamic
nestedErr :: (HasCallStack, NestedErr :> es) => Eff es ()
nestedErr = send NestedErr

View File

@ -105,6 +105,8 @@ data HasInt :: Effect where
GetInt :: HasInt m Int
PutInt :: Int -> HasInt m ()
type instance DispatchOf HasInt = 'Dynamic
getInt :: HasInt :> es => Eff es Int
getInt = send GetInt