Add Effectful.Provider.List (#194)

This commit is contained in:
Andrzej Rybczak 2023-12-05 00:56:10 +01:00 committed by GitHub
parent 87955a807e
commit 02ce340d05
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 177 additions and 6 deletions

View File

@ -1,5 +1,6 @@
# effectful-core-2.3.0.2 (2023-??-??)
# effectful-core-2.3.1.0 (????-??-??)
* Remove inaccurate information from the `Show` instance of `ErrorWrapper`.
* Add `Effectful.Provider.List`, generalization of `Effectful.Provider`.
# effectful-core-2.3.0.1 (2023-11-13)
* Prevent internal functions from appending call stack frames to handlers.

View File

@ -1,7 +1,7 @@
cabal-version: 2.4
build-type: Simple
name: effectful-core
version: 2.3.0.2
version: 2.3.1.0
license: BSD-3-Clause
license-file: LICENSE
category: Control
@ -90,6 +90,7 @@ library
Effectful.NonDet
Effectful.Prim
Effectful.Provider
Effectful.Provider.List
Effectful.Reader.Dynamic
Effectful.Reader.Static
Effectful.State.Dynamic

View File

@ -12,6 +12,8 @@ module Effectful.Internal.Effect
, Subset(..)
, KnownPrefix(..)
, IsUnknownSuffixOf
, type (++)
, KnownEffects(..)
-- * Re-exports
, Type
@ -116,3 +118,22 @@ instance {-# INCOHERENT #-} KnownPrefix es where
class (xs :: [Effect]) `IsUnknownSuffixOf` (es :: [Effect])
instance {-# INCOHERENT #-} xs ~ es => xs `IsUnknownSuffixOf` es
instance xs `IsUnknownSuffixOf` es => xs `IsUnknownSuffixOf` (e : es)
----
-- | Append two type-level lists together.
type family (xs :: [Effect]) ++ (ys :: [Effect]) :: [Effect] where
'[] ++ ys = ys
(x : xs) ++ ys = x : xs ++ ys
infixr 5 ++
-- | Calculate length of a list of known effects.
class KnownEffects (es :: [Effect]) where
knownEffectsLength :: Int
instance KnownEffects es => KnownEffects (e : es) where
knownEffectsLength = 1 + knownEffectsLength @es
instance KnownEffects '[] where
knownEffectsLength = 0

View File

@ -192,8 +192,7 @@ copyRef (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do
error "storages do not match"
let size = sizeofPrimArray refs0 - offset
mrefs <- newPrimArray (size + 2)
copyPrimArray mrefs 0 hrefs hoffset 2
copyPrimArray mrefs 2 refs0 offset size
writePrimArray mrefs 0 $ indexPrimArray hrefs hoffset
writePrimArray mrefs 1 $ indexPrimArray hrefs (hoffset + 1)
refs <- unsafeFreezePrimArray mrefs
pure $ Env 0 refs storage

View File

@ -0,0 +1,144 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
-- | Turn a handler of multiple effects into an effectful operation.
--
-- Generalization of "Effectful.Provider".
module Effectful.Provider.List
( -- * Effect
ProviderList
, ProviderList_
-- ** Handlers
, runProviderList
, runProviderList_
-- ** Operations
, provideList
, provideList_
, provideListWith
, provideListWith_
-- * Misc
, type (++)
, KnownEffects
) where
import Control.Monad
import Data.Coerce
import Data.Functor.Identity
import Data.Primitive.PrimArray
import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive
import Effectful.Internal.Effect
import Effectful.Internal.Env (Env(..))
import Effectful.Internal.Utils
-- | Provide a way to run a handler of multiple @effects@ with a given @input@.
--
-- /Note:/ @f@ can be used to alter the return type of the handler. If that's
-- unnecessary, use 'ProviderList_'.
data ProviderList (effects :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect
-- | A restricted variant of 'ProviderList' with unchanged return type of the
-- handler.
type ProviderList_ effs input = ProviderList effs input Identity
type instance DispatchOf (ProviderList effs input f) = Static NoSideEffects
data instance StaticRep (ProviderList effs input f) where
ProviderList
:: KnownEffects effs
=> !(Env handlerEs)
-> !(forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (ProviderList effs input f)
-- | Run the 'ProviderList' effect with a given handler.
runProviderList
:: KnownEffects effs
=> (forall r. input -> Eff (effs ++ es) r -> Eff es (f r))
-- ^ The handler.
-> Eff (ProviderList effs input f : es) a
-> Eff es a
runProviderList run m = unsafeEff $ \es0 -> do
inlineBracket
(consEnv (ProviderList es0 run) relinkProviderList es0)
unconsEnv
(\es -> unEff m es)
-- | Run the 'Provider' effect with a given handler that doesn't change its
-- return type.
runProviderList_
:: KnownEffects effs
=> (forall r. input -> Eff (effs ++ es) r -> Eff es r)
-- ^ The handler.
-> Eff (ProviderList_ effs input : es) a
-> Eff es a
runProviderList_ run = runProviderList $ \input -> coerce . run input
-- | Run the handler.
provideList
:: forall effs f es a
. ProviderList effs () f :> es
=> Eff (effs ++ es) a
-> Eff es (f a)
provideList = provideListWith @effs ()
-- | Run the handler with unchanged return type.
provideList_
:: forall effs es a
. ProviderList_ effs () :> es
=> Eff (effs ++ es) a
-> Eff es a
provideList_ = provideListWith_ @effs ()
-- | Run the handler with a given input.
provideListWith
:: forall effs input f es a
. ProviderList effs input f :> es
=> input
-- ^ The input to the handler.
-> Eff (effs ++ es) a
-> Eff es (f a)
provideListWith input action = unsafeEff $ \es -> do
ProviderList (handlerEs :: Env handlerEs) run <- getEnv @(ProviderList effs input f) es
(`unEff` handlerEs) . run input . unsafeEff $ \eHandlerEs -> do
unEff action =<< copyRefs @effs @handlerEs eHandlerEs es
-- | Run the handler that doesn't change its return type with a given input.
provideListWith_
:: forall effs input es a
. ProviderList_ effs input :> es
=> input
-- ^ The input to the handler.
-> Eff (effs ++ es) a
-> Eff es a
provideListWith_ input = adapt . provideListWith @effs input
where
adapt :: Eff es (Identity a) -> Eff es a
adapt = coerce
----------------------------------------
-- Helpers
relinkProviderList :: Relinker StaticRep (ProviderList e input f)
relinkProviderList = Relinker $ \relink (ProviderList handlerEs run) -> do
newHandlerEs <- relink handlerEs
pure $ ProviderList newHandlerEs run
copyRefs
:: forall effs handlerEs es
. KnownEffects effs
=> Env (effs ++ handlerEs)
-> Env es
-> IO (Env (effs ++ es))
copyRefs (Env hoffset hrefs hstorage) (Env offset refs0 storage) = do
when (hstorage /= storage) $ do
error "storages do not match"
let size = sizeofPrimArray refs0 - offset
effsSize = 2 * knownEffectsLength @effs
mrefs <- newPrimArray (size + effsSize)
copyPrimArray mrefs 0 hrefs hoffset effsSize
copyPrimArray mrefs effsSize refs0 offset size
refs <- unsafeFreezePrimArray mrefs
pure $ Env 0 refs storage

View File

@ -1,3 +1,7 @@
# effectful-2.3.1.0 (????-??-??)
* Remove inaccurate information from the `Show` instance of `ErrorWrapper`.
* Add `Effectful.Provider.List`, generalization of `Effectful.Provider`.
# effectful-2.3.0.0 (2023-09-13)
* Deprecate `withConcEffToIO`.
* Make `withEffToIO` take an explicit unlifting strategy for the sake of

View File

@ -1,7 +1,7 @@
cabal-version: 2.4
build-type: Simple
name: effectful
version: 2.3.0.0
version: 2.3.1.0
license: BSD-3-Clause
license-file: LICENSE
category: Control
@ -68,7 +68,7 @@ library
, async >= 2.2.2
, bytestring >= 0.10
, directory >= 1.3.2
, effectful-core >= 2.3.0.0 && < 2.3.1.0
, effectful-core >= 2.3.1.0 && < 2.3.2.0
, process >= 1.6.9
, time >= 1.9.2
@ -112,6 +112,7 @@ library
, Effectful.NonDet
, Effectful.Prim
, Effectful.Provider
, Effectful.Provider.List
, Effectful.Reader.Dynamic
, Effectful.Reader.Static
, Effectful.State.Dynamic