mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-10-26 10:58:34 +03:00
Forklift interpretations (#128)
This PR provides a single function withLowerToIO, which runs a desired Sem r effect all the way down to IO, without needing to know the natural transformation beforehand. It does it by running the desired code in a new thread, and shipping all of the unhandled effects back to the main thread. The main thread turns into an event loop for the duration of the withLowerToIO block.
This commit is contained in:
parent
585aeb1224
commit
2654d35066
@ -24,6 +24,8 @@ dependencies:
|
||||
- th-abstraction >= 0.3.1.0 && < 0.4
|
||||
- transformers >= 0.5.2.0 && < 0.6
|
||||
- first-class-families >= 0.5.0.0 && < 0.6
|
||||
- unagi-chan >= 0.4.0.0 && < 0.5
|
||||
- async >= 2.2 && < 3
|
||||
|
||||
default-extensions:
|
||||
- DataKinds
|
||||
@ -90,7 +92,7 @@ tests:
|
||||
- hspec-discover >= 2.0
|
||||
dependencies:
|
||||
- polysemy
|
||||
- inspection-testing >= 0.4.2.1 && < 0.5
|
||||
- inspection-testing >= 0.4.2 && < 0.5
|
||||
- hspec >= 2.6.0 && < 3
|
||||
- doctest >= 0.16.0.1 && < 0.17
|
||||
|
||||
|
@ -43,7 +43,7 @@ tests:
|
||||
- polysemy-plugin
|
||||
- hspec >= 2.6.0 && < 3
|
||||
- should-not-typecheck >= 2.1.0 && < 3
|
||||
- inspection-testing >= 0.4.2.1 && < 0.5
|
||||
- inspection-testing >= 0.4.2 && < 0.5
|
||||
|
||||
default-extensions:
|
||||
- DataKinds
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 67eaa9259909a5401e1bbdf179fc3263ec3b57afd9951ae709d347f390e9c541
|
||||
-- hash: d6541c6630b0beeaad870e361e1382face77df6d5864cd4b9b098d9b87697121
|
||||
|
||||
name: polysemy-plugin
|
||||
version: 0.2.1.0
|
||||
@ -71,7 +71,7 @@ test-suite polysemy-plugin-test
|
||||
, ghc >=8.4.4 && <9
|
||||
, ghc-tcplugins-extra >=0.3 && <0.4
|
||||
, hspec >=2.6.0 && <3
|
||||
, inspection-testing >=0.4.2.1 && <0.5
|
||||
, inspection-testing >=0.4.2 && <0.5
|
||||
, polysemy
|
||||
, polysemy-plugin
|
||||
, should-not-typecheck >=2.1.0 && <3
|
||||
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 3bb11d1562f0640e892b918e3de6086196562200410a660b14851704b64175a0
|
||||
-- hash: 3f07038fea02ea788ded67449bf361c83a48d3773798a68f15b6b03ac8032e2d
|
||||
|
||||
name: polysemy
|
||||
version: 0.4.0.0
|
||||
@ -47,6 +47,7 @@ library
|
||||
Polysemy.Internal.Combinators
|
||||
Polysemy.Internal.CustomErrors
|
||||
Polysemy.Internal.Fixpoint
|
||||
Polysemy.Internal.Forklift
|
||||
Polysemy.Internal.Kind
|
||||
Polysemy.Internal.Lift
|
||||
Polysemy.Internal.NonDet
|
||||
@ -69,7 +70,8 @@ library
|
||||
default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base >=4.9 && <5
|
||||
async >=2.2 && <3
|
||||
, base >=4.9 && <5
|
||||
, containers >=0.5 && <0.7
|
||||
, first-class-families >=0.5.0.0 && <0.6
|
||||
, mtl >=2.2.2 && <3
|
||||
@ -77,6 +79,7 @@ library
|
||||
, template-haskell >=2.12.0.0 && <3
|
||||
, th-abstraction >=0.3.1.0 && <0.4
|
||||
, transformers >=0.5.2.0 && <0.6
|
||||
, unagi-chan >=0.4.0.0 && <0.5
|
||||
if impl(ghc < 8.6)
|
||||
default-extensions: MonadFailDesugaring TypeInType
|
||||
if flag(dump-core)
|
||||
@ -112,18 +115,20 @@ test-suite polysemy-test
|
||||
build-tool-depends:
|
||||
hspec-discover:hspec-discover >=2.0
|
||||
build-depends:
|
||||
base >=4.9 && <5
|
||||
async >=2.2 && <3
|
||||
, base >=4.9 && <5
|
||||
, containers >=0.5 && <0.7
|
||||
, doctest >=0.16.0.1 && <0.17
|
||||
, first-class-families >=0.5.0.0 && <0.6
|
||||
, hspec >=2.6.0 && <3
|
||||
, inspection-testing >=0.4.2.1 && <0.5
|
||||
, inspection-testing >=0.4.2 && <0.5
|
||||
, mtl >=2.2.2 && <3
|
||||
, polysemy
|
||||
, syb >=0.7 && <0.8
|
||||
, template-haskell >=2.12.0.0 && <3
|
||||
, th-abstraction >=0.3.1.0 && <0.4
|
||||
, transformers >=0.5.2.0 && <0.6
|
||||
, unagi-chan >=0.4.0.0 && <0.5
|
||||
if impl(ghc < 8.6)
|
||||
default-extensions: MonadFailDesugaring TypeInType
|
||||
default-language: Haskell2010
|
||||
@ -138,7 +143,8 @@ benchmark polysemy-bench
|
||||
bench
|
||||
default-extensions: DataKinds DeriveFunctor FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UnicodeSyntax
|
||||
build-depends:
|
||||
base >=4.9 && <5
|
||||
async >=2.2 && <3
|
||||
, base >=4.9 && <5
|
||||
, containers >=0.5 && <0.7
|
||||
, criterion
|
||||
, first-class-families >=0.5.0.0 && <0.6
|
||||
@ -150,6 +156,7 @@ benchmark polysemy-bench
|
||||
, template-haskell >=2.12.0.0 && <3
|
||||
, th-abstraction >=0.3.1.0 && <0.4
|
||||
, transformers >=0.5.2.0 && <0.6
|
||||
, unagi-chan >=0.4.0.0 && <0.5
|
||||
if impl(ghc < 8.6)
|
||||
default-extensions: MonadFailDesugaring TypeInType
|
||||
default-language: Haskell2010
|
||||
|
@ -3,6 +3,7 @@ module Polysemy
|
||||
Sem ()
|
||||
, Member
|
||||
, Members
|
||||
, LastMember
|
||||
|
||||
-- * Running Sem
|
||||
, run
|
||||
@ -120,4 +121,5 @@ import Polysemy.Internal.Combinators
|
||||
import Polysemy.Internal.Kind
|
||||
import Polysemy.Internal.TH.Effect
|
||||
import Polysemy.Internal.Tactics
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
|
93
src/Polysemy/Internal/Forklift.hs
Normal file
93
src/Polysemy/Internal/Forklift.hs
Normal file
@ -0,0 +1,93 @@
|
||||
{-# LANGUAGE NumDecimals #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Polysemy.Internal.Forklift where
|
||||
|
||||
import qualified Control.Concurrent.Async as A
|
||||
import Control.Concurrent.Chan.Unagi
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import Polysemy
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A promise for interpreting an effect of the union @r@ in another thread.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
data Forklift r = forall a. Forklift
|
||||
{ responseMVar :: MVar (Sem '[Lift IO] a)
|
||||
, request :: Union r (Sem r) a
|
||||
}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A strategy for automatically interpreting an entire stack of effects by
|
||||
-- just shipping them off to some other interpretation context.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
runViaForklift
|
||||
:: LastMember (Lift IO) r
|
||||
=> InChan (Forklift r)
|
||||
-> Sem r a
|
||||
-> Sem '[Lift IO] a
|
||||
runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do
|
||||
case decompLast u of
|
||||
Left x -> usingSem k $ join $ sendM $ do
|
||||
mvar <- newEmptyMVar
|
||||
writeChan chan $ Forklift mvar x
|
||||
takeMVar mvar
|
||||
Right y -> k $ hoist (runViaForklift_b chan) y
|
||||
{-# INLINE runViaForklift #-}
|
||||
|
||||
|
||||
runViaForklift_b
|
||||
:: LastMember (Lift IO) r
|
||||
=> InChan (Forklift r)
|
||||
-> Sem r a
|
||||
-> Sem '[Lift IO] a
|
||||
runViaForklift_b = runViaForklift
|
||||
{-# NOINLINE runViaForklift_b #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an effect stack all the way down to 'IO' by running it in a new
|
||||
-- thread, and temporarily turning the current thread into an event poll.
|
||||
--
|
||||
-- This function creates a thread, and so should be compiled with @-threaded@.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
withLowerToIO
|
||||
:: LastMember (Lift IO) r
|
||||
=> ((forall x. Sem r x -> IO x) -> IO () -> IO a)
|
||||
-- ^ A lambda that takes the lowering function, and a finalizing 'IO'
|
||||
-- action to mark a the forked thread as being complete. The finalizing
|
||||
-- action need not be called.
|
||||
-> Sem r a
|
||||
withLowerToIO action = do
|
||||
(inchan, outchan) <- sendM newChan
|
||||
signal <- sendM newEmptyMVar
|
||||
|
||||
res <- sendM $ A.async $ do
|
||||
a <- action (runM . runViaForklift inchan)
|
||||
(putMVar signal ())
|
||||
putMVar signal ()
|
||||
pure a
|
||||
|
||||
let me = do
|
||||
raced <- sendM $ A.race (takeMVar signal) $ readChan outchan
|
||||
case raced of
|
||||
Left () -> sendM $ A.wait res
|
||||
Right (Forklift mvar req) -> do
|
||||
resp <- liftSem req
|
||||
sendM $ putMVar mvar $ pure resp
|
||||
me_b
|
||||
{-# INLINE me #-}
|
||||
|
||||
me_b = me
|
||||
{-# NOINLINE me_b #-}
|
||||
|
||||
me
|
||||
|
@ -4,9 +4,13 @@ import Data.Kind
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The kind of effects.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
type Effect = (Type -> Type) -> Type -> Type
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The kind of effect rows.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
type EffectRow = [Effect]
|
||||
|
||||
|
@ -1,11 +1,13 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE StrictData #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE UndecidableSuperClasses #-}
|
||||
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
@ -27,8 +29,10 @@ module Polysemy.Internal.Union
|
||||
-- * Witnesses
|
||||
, SNat (..)
|
||||
, Nat (..)
|
||||
, LastMember (..)
|
||||
) where
|
||||
|
||||
import Data.Bifunctor
|
||||
import Control.Monad
|
||||
import Data.Functor.Compose
|
||||
import Data.Functor.Identity
|
||||
@ -105,13 +109,17 @@ hoist f' (Union w (Yo e s nt f v)) = Union w $ Yo e s (f' . nt) f v
|
||||
type Member e r = Member' e r
|
||||
|
||||
type Member' e r =
|
||||
( Find r e
|
||||
, e ~ IndexOf r (Found r e)
|
||||
( MemberNoError e r
|
||||
#ifndef NO_ERROR_MESSAGES
|
||||
, Break (AmbiguousSend r e) (IndexOf r (Found r e))
|
||||
#endif
|
||||
)
|
||||
|
||||
type MemberNoError e r =
|
||||
( Find r e
|
||||
, e ~ IndexOf r (Found r e)
|
||||
)
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The kind of type-level natural numbers.
|
||||
@ -189,11 +197,12 @@ absurdU = absurdU
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Weaken a 'Union' so it is capable of storing a new sort of effect.
|
||||
weaken :: Union r m a -> Union (e ': r) m a
|
||||
weaken :: forall e r m a. Union r m a -> Union (e ': r) m a
|
||||
weaken (Union n a) = Union (SS n) a
|
||||
{-# INLINE weaken #-}
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Lift an effect @e@ into a 'Union' capable of holding it.
|
||||
inj :: forall r e a m. (Functor m , Member e r) => e m a -> Union r m a
|
||||
@ -233,3 +242,20 @@ decompCoerce (Union p a) =
|
||||
{-# INLINE decompCoerce #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A proof that @end@ is the last effect in the row.
|
||||
--
|
||||
-- TODO(sandy): @since
|
||||
class MemberNoError end r => LastMember end r | r -> end where
|
||||
decompLast
|
||||
:: Union r m a
|
||||
-> Either (Union r m a) (Union '[end] m a)
|
||||
|
||||
instance {-# OVERLAPPABLE #-} (LastMember end r, MemberNoError end (eff ': r))
|
||||
=> LastMember end (eff ': r) where
|
||||
decompLast (Union SZ u) = Left $ Union SZ u
|
||||
decompLast (Union (SS n) u) = first weaken $ decompLast $ Union n u
|
||||
|
||||
instance LastMember end '[end] where
|
||||
decompLast = Right
|
||||
|
||||
|
@ -13,4 +13,5 @@ extra-deps:
|
||||
- inspection-testing-0.4.2
|
||||
- monadLib-3.9
|
||||
- th-abstraction-0.3.1.0
|
||||
- unagi-chan-0.4.1.0
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user