-
Notifications
You must be signed in to change notification settings - Fork 28
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
Showing
7 changed files
with
177 additions
and
6 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters