mirror of
https://github.com/polysemy-research/polysemy.git
synced 2024-11-23 00:26:52 +03:00
Remove lowering functions and forklift (#438)
* Remove forklift * Remove lowerResource * Changelog * changelog * Remove (@) * Update documentation * Remove the ancient benchmarks * Remove fixpoint lowerings
This commit is contained in:
Sandy Maguire
GitHub
parent
3f965b7947
commit
6ece463ea8
12
ChangeLog.md
12
ChangeLog.md
@ -6,9 +6,21 @@
|
||||
|
||||
- Removed `Polysemy.View`
|
||||
- Removed `Polysemy.Law`
|
||||
- Removed `(@)` and `(@@)` from `Polysemy`
|
||||
- Removed `withLowerToIO` from `Polysemy`. Use `withWeavingToFinal` instead.
|
||||
- Removed `asyncToIO` and `lowerAsync` from `Polysemy.Async`. Use
|
||||
`asyncToIOFinal` instead.
|
||||
- Removed `lowerEmbedded` from `Polysemy.IO`. Use `embedToMonadIO` instead.
|
||||
- Removed `lowerError` from `Polysemy.Error`. Use `errorToIOFinal` instead.
|
||||
- Removed `resourceToIO` and `lowerResource` from `Polysemy.Resource`. Use
|
||||
`resourceToIOFinal` instead.
|
||||
- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use
|
||||
`fixpointToFinal` instead.
|
||||
|
||||
### Other Changes
|
||||
|
||||
- Exposed `send` from `Polysemy`.
|
||||
|
||||
## 1.7.1.0 (2021-11-23)
|
||||
|
||||
### Other Changes
|
||||
|
||||
@ -1,64 +0,0 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
{-# OPTIONS_GHC -fwarn-all-missed-specializations #-}
|
||||
|
||||
module Poly where
|
||||
|
||||
import Polysemy
|
||||
import Polysemy.Error
|
||||
import Polysemy.Resource
|
||||
import Polysemy.State
|
||||
import Polysemy.Input
|
||||
import Polysemy.Output
|
||||
|
||||
|
||||
slowBeforeSpecialization :: Member (State Int) r => Sem r Int
|
||||
slowBeforeSpecialization = do
|
||||
n <- get
|
||||
if n <= 0
|
||||
then pure n
|
||||
else do
|
||||
put $ n - 1
|
||||
slowBeforeSpecialization
|
||||
|
||||
{-# SPECIALIZE slowBeforeSpecialization :: Sem '[State Int] Int #-}
|
||||
|
||||
|
||||
countDown :: Int -> Int
|
||||
countDown s =
|
||||
fst . run . runState s $ slowBeforeSpecialization
|
||||
|
||||
prog
|
||||
:: Sem '[ State Bool
|
||||
, Error Bool
|
||||
, Resource
|
||||
, Embed IO
|
||||
] Bool
|
||||
prog = catch @Bool (throw True) (pure . not)
|
||||
|
||||
zoinks :: IO (Either Bool Bool)
|
||||
zoinks = fmap (fmap snd)
|
||||
. (runM .@ lowerResource .@@ lowerError)
|
||||
. runState False
|
||||
$ prog
|
||||
|
||||
data Console m a where
|
||||
ReadLine :: Console m String
|
||||
WriteLine :: String -> Console m ()
|
||||
|
||||
makeSem ''Console
|
||||
|
||||
runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a)
|
||||
runConsoleBoring inputs
|
||||
= runOutputMonoid (:[])
|
||||
. runInputList inputs
|
||||
. reinterpret2
|
||||
(\case
|
||||
ReadLine -> maybe "" id <$> input
|
||||
WriteLine msg -> output msg
|
||||
)
|
||||
|
||||
@ -1,133 +0,0 @@
|
||||
{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-}
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad (replicateM_)
|
||||
|
||||
import qualified Control.Monad.Except as MTL
|
||||
import qualified Control.Monad.State as MTL
|
||||
import qualified Control.Monad.Free as Free
|
||||
|
||||
import Criterion (bench, bgroup, whnf)
|
||||
import Criterion.Main (defaultMain)
|
||||
|
||||
import Control.Monad.Freer (Member, Eff, run, send)
|
||||
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 qualified Poly as P
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- State Benchmarks --
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
oneGet :: Int -> (Int, Int)
|
||||
oneGet n = run (runState n get)
|
||||
|
||||
oneGetMTL :: Int -> (Int, Int)
|
||||
oneGetMTL = MTL.runState MTL.get
|
||||
|
||||
countDown :: Int -> (Int, Int)
|
||||
countDown start = run (runState start go)
|
||||
where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)
|
||||
|
||||
countDownMTL :: Int -> (Int, Int)
|
||||
countDownMTL = MTL.runState go
|
||||
where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Exception + State --
|
||||
--------------------------------------------------------------------------------
|
||||
countDownExc :: Int -> Either String (Int,Int)
|
||||
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)
|
||||
countDownExcMTL = MTL.runStateT go
|
||||
where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Freer: Interpreter --
|
||||
--------------------------------------------------------------------------------
|
||||
data Http out where
|
||||
Open :: String -> Http ()
|
||||
Close :: Http ()
|
||||
Post :: String -> Http String
|
||||
Get :: Http String
|
||||
|
||||
open' :: Member Http r => String -> Eff r ()
|
||||
open' = send . Open
|
||||
|
||||
close' :: Member Http r => Eff r ()
|
||||
close' = send Close
|
||||
|
||||
post' :: Member Http r => String -> Eff r String
|
||||
post' = send . Post
|
||||
|
||||
get' :: Member Http r => Eff r String
|
||||
get' = send Get
|
||||
|
||||
runHttp :: Eff (Http ': r) w -> Eff r w
|
||||
runHttp (Val x) = pure x
|
||||
runHttp (E u q) = case decomp u of
|
||||
Right (Open _) -> runHttp (qApp q ())
|
||||
Right Close -> runHttp (qApp q ())
|
||||
Right (Post d) -> runHttp (qApp q d)
|
||||
Right Get -> runHttp (qApp q "")
|
||||
Left u' -> E u' (tsingleton (runHttp . qApp q ))
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Free: Interpreter --
|
||||
--------------------------------------------------------------------------------
|
||||
data FHttpT x
|
||||
= FOpen String x
|
||||
| FClose x
|
||||
| FPost String (String -> x)
|
||||
| FGet (String -> x)
|
||||
deriving Functor
|
||||
|
||||
type FHttp = Free.Free FHttpT
|
||||
|
||||
fopen' :: String -> FHttp ()
|
||||
fopen' s = Free.liftF $ FOpen s ()
|
||||
|
||||
fclose' :: FHttp ()
|
||||
fclose' = Free.liftF $ FClose ()
|
||||
|
||||
fpost' :: String -> FHttp String
|
||||
fpost' s = Free.liftF $ FPost s id
|
||||
|
||||
fget' :: FHttp String
|
||||
fget' = Free.liftF $ FGet id
|
||||
|
||||
runFHttp :: FHttp a -> Maybe a
|
||||
runFHttp (Free.Pure x) = pure x
|
||||
runFHttp (Free.Free (FOpen _ n)) = runFHttp n
|
||||
runFHttp (Free.Free (FClose n)) = runFHttp n
|
||||
runFHttp (Free.Free (FPost s n)) = pure s >>= runFHttp . n
|
||||
runFHttp (Free.Free (FGet n)) = pure "" >>= runFHttp . n
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- Benchmark Suite --
|
||||
--------------------------------------------------------------------------------
|
||||
prog :: Member Http r => Eff r ()
|
||||
prog = open' "cats" >> get' >> post' "cats" >> close'
|
||||
|
||||
prog' :: FHttp ()
|
||||
prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'
|
||||
|
||||
p :: Member Http r => Int -> Eff r ()
|
||||
p count = open' "cats" >> replicateM_ count (get' >> post' "cats") >> close'
|
||||
|
||||
p' :: Int -> FHttp ()
|
||||
p' count = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
defaultMain [
|
||||
bgroup "Countdown Bench" [
|
||||
bench "discount" $ whnf P.countDown 10000
|
||||
, bench "freer-simple" $ whnf countDown 10000
|
||||
, bench "mtl" $ whnf countDownMTL 10000
|
||||
]
|
||||
]
|
||||
10
package.yaml
10
package.yaml
@ -100,13 +100,3 @@ tests:
|
||||
generated-other-modules:
|
||||
- Build_doctests
|
||||
|
||||
benchmarks:
|
||||
polysemy-bench:
|
||||
source-dirs: bench
|
||||
main: countDown.hs
|
||||
dependencies:
|
||||
- criterion
|
||||
- free
|
||||
- freer-simple
|
||||
- mtl
|
||||
- polysemy
|
||||
|
||||
@ -56,7 +56,6 @@ library
|
||||
Polysemy.Internal.CustomErrors
|
||||
Polysemy.Internal.CustomErrors.Redefined
|
||||
Polysemy.Internal.Fixpoint
|
||||
Polysemy.Internal.Forklift
|
||||
Polysemy.Internal.Index
|
||||
Polysemy.Internal.Kind
|
||||
Polysemy.Internal.NonDet
|
||||
@ -130,7 +129,6 @@ test-suite polysemy-test
|
||||
main-is: Main.hs
|
||||
other-modules:
|
||||
AlternativeSpec
|
||||
AsyncSpec
|
||||
BracketSpec
|
||||
DoctestSpec
|
||||
ErrorSpec
|
||||
@ -139,7 +137,6 @@ test-suite polysemy-test
|
||||
FixpointSpec
|
||||
FusionSpec
|
||||
HigherOrderSpec
|
||||
InspectorSpec
|
||||
InterceptSpec
|
||||
KnownRowSpec
|
||||
OutputSpec
|
||||
@ -192,48 +189,3 @@ test-suite polysemy-test
|
||||
MonadFailDesugaring
|
||||
TypeInType
|
||||
default-language: Haskell2010
|
||||
|
||||
benchmark polysemy-bench
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: countDown.hs
|
||||
other-modules:
|
||||
Poly
|
||||
Paths_polysemy
|
||||
hs-source-dirs:
|
||||
bench
|
||||
default-extensions:
|
||||
DataKinds
|
||||
DeriveFunctor
|
||||
FlexibleContexts
|
||||
GADTs
|
||||
LambdaCase
|
||||
PolyKinds
|
||||
RankNTypes
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
TypeApplications
|
||||
TypeOperators
|
||||
TypeFamilies
|
||||
UnicodeSyntax
|
||||
build-depends:
|
||||
async >=2.2 && <3
|
||||
, base >=4.9 && <5
|
||||
, containers >=0.5 && <0.7
|
||||
, criterion
|
||||
, first-class-families >=0.5.0.0 && <0.9
|
||||
, free
|
||||
, freer-simple
|
||||
, mtl
|
||||
, polysemy
|
||||
, stm ==2.*
|
||||
, syb ==0.7.*
|
||||
, template-haskell >=2.12.0.0 && <3
|
||||
, th-abstraction >=0.3.1.0 && <0.5
|
||||
, transformers >=0.5.2.0 && <0.6
|
||||
, type-errors >=0.2.0.0
|
||||
, unagi-chan >=0.4.0.0 && <0.5
|
||||
if impl(ghc < 8.6)
|
||||
default-extensions:
|
||||
MonadFailDesugaring
|
||||
TypeInType
|
||||
default-language: Haskell2010
|
||||
|
||||
@ -120,17 +120,10 @@ module Polysemy
|
||||
, reinterpret2H
|
||||
, reinterpret3H
|
||||
|
||||
-- * Combinators for Interpreting Directly to IO
|
||||
, withLowerToIO
|
||||
|
||||
-- * Kind Synonyms
|
||||
, Effect
|
||||
, EffectRow
|
||||
|
||||
-- * Composing IO-based Interpreters
|
||||
, (.@)
|
||||
, (.@@)
|
||||
|
||||
-- * Tactics
|
||||
-- | Higher-order effects need to explicitly thread /other effects'/ state
|
||||
-- through themselves. Tactics are a domain-specific language for describing
|
||||
@ -155,7 +148,6 @@ module Polysemy
|
||||
import Polysemy.Final
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Combinators
|
||||
import Polysemy.Internal.Forklift
|
||||
import Polysemy.Internal.Kind
|
||||
import Polysemy.Internal.Tactics
|
||||
import Polysemy.Internal.TH.Effect
|
||||
|
||||
@ -13,9 +13,7 @@ module Polysemy.Async
|
||||
, sequenceConcurrently
|
||||
|
||||
-- * Interpretations
|
||||
, asyncToIO
|
||||
, asyncToIOFinal
|
||||
, lowerAsync
|
||||
) where
|
||||
|
||||
import qualified Control.Concurrent.Async as A
|
||||
@ -48,43 +46,6 @@ sequenceConcurrently :: forall t r a. (Traversable t, Member Async r) =>
|
||||
sequenceConcurrently t = traverse async t >>= traverse await
|
||||
{-# INLINABLE sequenceConcurrently #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A more flexible --- though less performant ---
|
||||
-- version of 'asyncToIOFinal'.
|
||||
--
|
||||
-- This function is capable of running 'Async' effects anywhere within an
|
||||
-- effect stack, without relying on 'Final' to lower it into 'IO'.
|
||||
-- Notably, this means that 'Polysemy.State.State' effects will be consistent
|
||||
-- in the presence of 'Async'.
|
||||
--
|
||||
-- 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions
|
||||
-- of other effects interpreted after 'Async'.
|
||||
-- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.
|
||||
--
|
||||
-- Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters
|
||||
-- after the interpreter for 'Async'.
|
||||
-- (Pure interpreters are interpreters that aren't expressed in terms of
|
||||
-- another effect or monad; for example, 'Polysemy.State.runState'.)
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
asyncToIO
|
||||
:: Member (Embed IO) r
|
||||
=> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
asyncToIO m = withLowerToIO $ \lower _ -> lower $
|
||||
interpretH
|
||||
( \case
|
||||
Async a -> do
|
||||
ma <- runT a
|
||||
ins <- getInspectorT
|
||||
fa <- embed $ A.async $ lower $ asyncToIO ma
|
||||
pureT $ inspect ins <$> fa
|
||||
|
||||
Await a -> pureT =<< embed (A.wait a)
|
||||
Cancel a -> pureT =<< embed (A.cancel a)
|
||||
) m
|
||||
{-# INLINE asyncToIO #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Async' effect in terms of 'A.async' through final 'IO'.
|
||||
--
|
||||
@ -92,16 +53,6 @@ asyncToIO m = withLowerToIO $ \lower _ -> lower $
|
||||
-- will have local state semantics in regards to 'Async' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
--
|
||||
-- Notably, unlike 'asyncToIO', this is not consistent with
|
||||
-- 'Polysemy.State.State' unless 'Polysemy.State.runStateIORef' is used.
|
||||
-- State that seems like it should be threaded globally throughout 'Async'
|
||||
-- /will not be./
|
||||
--
|
||||
-- Use 'asyncToIO' instead if you need to run
|
||||
-- pure, stateful interpreters after the interpreter for 'Async'.
|
||||
-- (Pure interpreters are interpreters that aren't expressed in terms of
|
||||
-- another effect or monad; for example, 'Polysemy.State.runState'.)
|
||||
--
|
||||
-- @since 1.2.0.0
|
||||
asyncToIOFinal :: Member (Final IO) r
|
||||
=> Sem (Async ': r) a
|
||||
@ -115,27 +66,3 @@ asyncToIOFinal = interpretFinal $ \case
|
||||
Cancel a -> liftS (A.cancel a)
|
||||
{-# INLINE asyncToIOFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Async' effect in terms of 'A.async'.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
lowerAsync
|
||||
:: Member (Embed IO) r
|
||||
=> (forall x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
|
||||
-- some combination of 'runM' and other interpreters composed via '.@'.
|
||||
-> Sem (Async ': r) a
|
||||
-> Sem r a
|
||||
lowerAsync lower m = interpretH
|
||||
( \case
|
||||
Async a -> do
|
||||
ma <- runT a
|
||||
ins <- getInspectorT
|
||||
fa <- embed $ A.async $ lower $ lowerAsync lower ma
|
||||
pureT $ inspect ins <$> fa
|
||||
|
||||
Await a -> pureT =<< embed (A.wait a)
|
||||
Cancel a -> pureT =<< embed (A.cancel a)
|
||||
) m
|
||||
{-# INLINE lowerAsync #-}
|
||||
{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}
|
||||
|
||||
@ -23,13 +23,11 @@ module Polysemy.Error
|
||||
, runError
|
||||
, mapError
|
||||
, errorToIOFinal
|
||||
, lowerError
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
import Control.Monad
|
||||
import qualified Control.Monad.Trans.Except as E
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Typeable
|
||||
import Polysemy
|
||||
import Polysemy.Final
|
||||
@ -152,16 +150,16 @@ note _ (Just a) = pure a
|
||||
{-# INLINABLE note #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@)
|
||||
-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type
|
||||
-- @e@ was @'throw'@n and its value is @ex@.
|
||||
-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@)
|
||||
-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type
|
||||
-- @e@ was @'throw'@n and its value is @ex@.
|
||||
try :: Member (Error e) r => Sem r a -> Sem r (Either e a)
|
||||
try m = catch (Right <$> m) (return . Left)
|
||||
{-# INLINABLE try #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A variant of @'try'@ that takes an exception predicate to select which exceptions
|
||||
-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate,
|
||||
-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate,
|
||||
-- it is re-@'throw'@n.
|
||||
tryJust :: Member (Error e) r => (e -> Maybe b) -> Sem r a -> Sem r (Either b a)
|
||||
tryJust f m = do
|
||||
@ -174,10 +172,10 @@ tryJust f m = do
|
||||
{-# INLINABLE tryJust #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument
|
||||
-- which is an exception predicate, a function which selects which type of exceptions
|
||||
-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument
|
||||
-- which is an exception predicate, a function which selects which type of exceptions
|
||||
-- we're interested in.
|
||||
catchJust :: Member (Error e) r
|
||||
catchJust :: Member (Error e) r
|
||||
=> (e -> Maybe b) -- ^ Predicate to select exceptions
|
||||
-> Sem r a -- ^ Computation to run
|
||||
-> (b -> Sem r a) -- ^ Handler
|
||||
@ -295,45 +293,3 @@ runErrorAsExcFinal = interpretFinal $ \case
|
||||
h' (unwrapExc se <$ s)
|
||||
{-# INLINE runErrorAsExcFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is
|
||||
-- significantly faster than 'runError', at the cost of being less flexible.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
lowerError
|
||||
:: ( Typeable e
|
||||
, Member (Embed IO) r
|
||||
)
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is
|
||||
-- likely some combination of 'runM' and other interpreters composed via
|
||||
-- '.@'.
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r (Either e a)
|
||||
lowerError lower
|
||||
= embed
|
||||
. fmap (first unwrapExc)
|
||||
. X.try
|
||||
. (lower .@ runErrorAsExc)
|
||||
{-# INLINE lowerError #-}
|
||||
{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}
|
||||
|
||||
|
||||
-- TODO(sandy): Can we use the new withLowerToIO machinery for this?
|
||||
runErrorAsExc
|
||||
:: forall e r a. ( Typeable e
|
||||
, Member (Embed IO) r
|
||||
)
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-> Sem (Error e ': r) a
|
||||
-> Sem r a
|
||||
runErrorAsExc lower = interpretH $ \case
|
||||
Throw e -> embed $ X.throwIO $ WrappedExc e
|
||||
Catch main handle -> do
|
||||
is <- getInitialStateT
|
||||
m <- runT main
|
||||
h <- bindT handle
|
||||
let runIt = lower . runErrorAsExc lower
|
||||
embed $ X.catch (runIt m) $ \(se :: WrappedExc e) ->
|
||||
runIt $ h $ unwrapExc se <$ is
|
||||
{-# INLINE runErrorAsExc #-}
|
||||
|
||||
@ -73,45 +73,3 @@ fixpointToFinal = interpretFinal @m $
|
||||
fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s
|
||||
{-# INLINE fixpointToFinal #-}
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect purely.
|
||||
--
|
||||
-- __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'.
|
||||
runFixpoint
|
||||
:: (∀ x. Sem r x -> x)
|
||||
-> Sem (Fixpoint ': r) a
|
||||
-> Sem r a
|
||||
runFixpoint lower = interpretH $ \case
|
||||
Fixpoint mf -> do
|
||||
c <- bindT mf
|
||||
s <- getInitialStateT
|
||||
ins <- getInspectorT
|
||||
pure $ fix $ \fa ->
|
||||
lower . runFixpoint lower . c $
|
||||
fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s
|
||||
{-# INLINE runFixpoint #-}
|
||||
{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \
|
||||
\'Data.Functor.Identity.Identity' instead" #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.
|
||||
--
|
||||
-- __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'.
|
||||
runFixpointM
|
||||
:: ( MonadFix m
|
||||
, Member (Embed m) r
|
||||
)
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-> Sem (Fixpoint ': r) a
|
||||
-> Sem r a
|
||||
runFixpointM lower = interpretH $ \case
|
||||
Fixpoint mf -> do
|
||||
c <- bindT mf
|
||||
s <- getInitialStateT
|
||||
ins <- getInspectorT
|
||||
embed $ mfix $ \fa ->
|
||||
lower . runFixpointM lower . c $
|
||||
fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s
|
||||
{-# INLINE runFixpointM #-}
|
||||
{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}
|
||||
|
||||
@ -3,14 +3,11 @@
|
||||
module Polysemy.IO
|
||||
( -- * Interpretations
|
||||
embedToMonadIO
|
||||
, lowerEmbedded
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Polysemy
|
||||
import Polysemy.Embed
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
@ -44,29 +41,3 @@ embedToMonadIO
|
||||
embedToMonadIO = runEmbedded $ liftIO @m
|
||||
{-# INLINE embedToMonadIO #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Given some @'MonadIO' m@, interpret all @'Embed' m@ actions in that monad
|
||||
-- at once. This is useful for interpreting effects like databases, which use
|
||||
-- their own monad for describing actions.
|
||||
--
|
||||
-- This function creates a thread, and so should be compiled with @-threaded@.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
lowerEmbedded
|
||||
:: ( MonadIO m
|
||||
, Member (Embed IO) r
|
||||
)
|
||||
=> (forall x. m x -> IO x) -- ^ The means of running this monad.
|
||||
-> Sem (Embed m ': r) a
|
||||
-> Sem r a
|
||||
lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->
|
||||
run_m $ m $ \u ->
|
||||
case decomp u of
|
||||
Left x -> liftIO
|
||||
. lower
|
||||
. liftSem
|
||||
$ hoist (lowerEmbedded run_m) x
|
||||
|
||||
Right (Weaving (Embed wd) s _ y _) ->
|
||||
y <$> ((<$ s) <$> wd)
|
||||
|
||||
@ -37,8 +37,6 @@ module Polysemy.Internal
|
||||
, Append
|
||||
, InterpreterFor
|
||||
, InterpretersFor
|
||||
, (.@)
|
||||
, (.@@)
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
@ -654,65 +652,3 @@ type InterpreterFor e r = ∀ a. Sem (e ': r) a -> Sem r a
|
||||
-- @since 1.5.0.0
|
||||
type InterpretersFor es r = ∀ a. Sem (Append es r) a -> Sem r a
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Some interpreters need to be able to lower down to the base monad (often
|
||||
-- 'IO') in order to function properly --- some good examples of this are
|
||||
-- 'Polysemy.Error.lowerError' and 'Polysemy.Resource.lowerResource'.
|
||||
--
|
||||
-- However, these interpreters don't compose particularly nicely; for example,
|
||||
-- to run 'Polysemy.Resource.lowerResource', you must write:
|
||||
--
|
||||
-- @
|
||||
-- runM . lowerError runM
|
||||
-- @
|
||||
--
|
||||
-- Notice that 'runM' is duplicated in two places here. The situation gets
|
||||
-- exponentially worse the more intepreters you have that need to run in this
|
||||
-- pattern.
|
||||
--
|
||||
-- Instead, '.@' performs the composition we'd like. The above can be written as
|
||||
--
|
||||
-- @
|
||||
-- (runM .@ lowerError)
|
||||
-- @
|
||||
--
|
||||
-- The parentheses here are important; without them you'll run into operator
|
||||
-- precedence errors.
|
||||
--
|
||||
-- __Warning:__ This combinator will __duplicate work__ that is intended to be
|
||||
-- just for initialization. This can result in rather surprising behavior. For
|
||||
-- a version of '.@' that won't duplicate work, see the @.\@!@ operator in
|
||||
-- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>.
|
||||
--
|
||||
-- Interpreters using 'Polysemy.Final' may be composed normally, and
|
||||
-- avoid the work duplication issue. For that reason, you're encouraged to use
|
||||
-- @-'Polysemy.Final'@ interpreters instead of @lower-@ interpreters whenever
|
||||
-- possible.
|
||||
(.@)
|
||||
:: Monad m
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-- ^ The lowering function, likely 'runM'.
|
||||
-> (∀ y. (∀ x. Sem r x -> m x)
|
||||
-> Sem (e ': r) y
|
||||
-> Sem r y)
|
||||
-> Sem (e ': r) z
|
||||
-> m z
|
||||
f .@ g = f . g f
|
||||
infixl 8 .@
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Like '.@', but for interpreters which change the resulting type --- eg.
|
||||
-- 'Polysemy.Error.lowerError'.
|
||||
(.@@)
|
||||
:: Monad m
|
||||
=> (∀ x. Sem r x -> m x)
|
||||
-- ^ The lowering function, likely 'runM'.
|
||||
-> (∀ y. (∀ x. Sem r x -> m x)
|
||||
-> Sem (e ': r) y
|
||||
-> Sem r (f y))
|
||||
-> Sem (e ': r) z
|
||||
-> m (f z)
|
||||
f .@@ g = f . g f
|
||||
infixl 8 .@@
|
||||
|
||||
@ -1,87 +0,0 @@
|
||||
{-# LANGUAGE NumDecimals #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_HADDOCK not-home #-}
|
||||
|
||||
module Polysemy.Internal.Forklift where
|
||||
|
||||
import qualified Control.Concurrent.Async as A
|
||||
import Control.Concurrent.Chan.Unagi
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Exception
|
||||
import Polysemy.Internal
|
||||
import Polysemy.Internal.Union
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A promise for interpreting an effect of the union @r@ in another thread.
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
data Forklift r = forall a. Forklift
|
||||
{ responseMVar :: MVar 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.
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
runViaForklift
|
||||
:: Member (Embed IO) r
|
||||
=> InChan (Forklift r)
|
||||
-> Sem r a
|
||||
-> IO a
|
||||
runViaForklift chan = usingSem $ \u -> do
|
||||
case prj u of
|
||||
Just (Weaving (Embed m) s _ ex _) ->
|
||||
ex . (<$ s) <$> m
|
||||
_ -> do
|
||||
mvar <- newEmptyMVar
|
||||
writeChan chan $ Forklift mvar u
|
||||
takeMVar mvar
|
||||
{-# INLINE runViaForklift #-}
|
||||
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | 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@.
|
||||
--
|
||||
-- @since 0.5.0.0
|
||||
withLowerToIO
|
||||
:: Member (Embed 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) <- embed newChan
|
||||
signal <- embed newEmptyMVar
|
||||
|
||||
res <- embed $ A.async $ do
|
||||
a <- action (runViaForklift inchan)
|
||||
(putMVar signal ())
|
||||
`finally` (putMVar signal ())
|
||||
pure a
|
||||
|
||||
let me = do
|
||||
raced <- embed $ A.race (takeMVar signal) $ readChan outchan
|
||||
case raced of
|
||||
Left () -> embed $ A.wait res
|
||||
Right (Forklift mvar req) -> do
|
||||
resp <- liftSem req
|
||||
embed $ putMVar mvar $ resp
|
||||
me_b
|
||||
{-# INLINE me #-}
|
||||
|
||||
me_b = me
|
||||
{-# NOINLINE me_b #-}
|
||||
|
||||
me
|
||||
|
||||
@ -14,8 +14,6 @@ module Polysemy.Resource
|
||||
-- * Interpretations
|
||||
, runResource
|
||||
, resourceToIOFinal
|
||||
, resourceToIO
|
||||
, lowerResource
|
||||
) where
|
||||
|
||||
import qualified Control.Exception as X
|
||||
@ -96,16 +94,6 @@ onException act end = bracketOnError (pure ()) (const end) (const act)
|
||||
-- will have local state semantics in regards to 'Resource' effects
|
||||
-- interpreted this way. See 'Final'.
|
||||
--
|
||||
-- Notably, unlike 'resourceToIO', this is not consistent with
|
||||
-- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used.
|
||||
-- State that seems like it should be threaded globally throughout 'bracket's
|
||||
-- /will not be./
|
||||
--
|
||||
-- Use 'resourceToIO' instead if you need to run
|
||||
-- pure, stateful interpreters after the interpreter for 'Resource'.
|
||||
-- (Pure interpreters are interpreters that aren't expressed in terms of
|
||||
-- another effect or monad; for example, 'Polysemy.State.runState'.)
|
||||
--
|
||||
-- @since 1.2.0.0
|
||||
resourceToIOFinal :: Member (Final IO) r
|
||||
=> Sem (Resource ': r) a
|
||||
@ -138,42 +126,6 @@ resourceToIOFinal = interpretFinal $ \case
|
||||
{-# INLINE resourceToIOFinal #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Resource' effect in terms of 'X.bracket'.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
lowerResource
|
||||
:: ∀ r a
|
||||
. Member (Embed IO) r
|
||||
=> (∀ x. Sem r x -> IO x)
|
||||
-- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely
|
||||
-- some combination of 'runM' and other interpreters composed via '.@'.
|
||||
-> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
lowerResource finish = interpretH $ \case
|
||||
Bracket alloc dealloc use -> do
|
||||
a <- runT alloc
|
||||
d <- bindT dealloc
|
||||
u <- bindT use
|
||||
|
||||
let run_it :: Sem (Resource ': r) x -> IO x
|
||||
run_it = finish .@ lowerResource
|
||||
|
||||
embed $ X.bracket (run_it a) (run_it . d) (run_it . u)
|
||||
|
||||
BracketOnError alloc dealloc use -> do
|
||||
a <- runT alloc
|
||||
d <- bindT dealloc
|
||||
u <- bindT use
|
||||
|
||||
let run_it :: Sem (Resource ': r) x -> IO x
|
||||
run_it = finish .@ lowerResource
|
||||
|
||||
embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)
|
||||
{-# INLINE lowerResource #-}
|
||||
{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | Run a 'Resource' effect purely.
|
||||
--
|
||||
@ -212,62 +164,3 @@ runResource = interpretH $ \case
|
||||
pure result
|
||||
{-# INLINE runResource #-}
|
||||
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- | A more flexible --- though less safe --- version of 'resourceToIOFinal'
|
||||
--
|
||||
-- This function is capable of running 'Resource' effects anywhere within an
|
||||
-- effect stack, without relying on an explicit function to lower it into 'IO'.
|
||||
-- Notably, this means that 'Polysemy.State.State' effects will be consistent
|
||||
-- in the presence of 'Resource'.
|
||||
--
|
||||
-- ResourceToIO' is safe whenever you're concerned about exceptions thrown
|
||||
-- by effects _already handled_ in your effect stack, or in 'IO' code run
|
||||
-- directly inside of 'bracket'. It is not safe against exceptions thrown
|
||||
-- explicitly at the main thread. If this is not safe enough for your use-case,
|
||||
-- use 'resourceToIOFinal' instead.
|
||||
--
|
||||
-- This function creates a thread, and so should be compiled with @-threaded@.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
resourceToIO
|
||||
:: forall r a
|
||||
. Member (Embed IO) r
|
||||
=> Sem (Resource ': r) a
|
||||
-> Sem r a
|
||||
resourceToIO = interpretH $ \case
|
||||
Bracket a b c -> do
|
||||
ma <- runT a
|
||||
mb <- bindT b
|
||||
mc <- bindT c
|
||||
|
||||
withLowerToIO $ \lower finish -> do
|
||||
let done :: Sem (Resource ': r) x -> IO x
|
||||
done = lower . raise . resourceToIO
|
||||
X.bracket
|
||||
(done ma)
|
||||
(\x -> done (mb x) >> finish)
|
||||
(done . mc)
|
||||
|
||||
BracketOnError a b c -> do
|
||||
ins <- getInspectorT
|
||||
ma <- runT a
|
||||
mb <- bindT b
|
||||
mc <- bindT c
|
||||
|
||||
withLowerToIO $ \lower finish -> do
|
||||
let done :: Sem (Resource ': r) x -> IO x
|
||||
done = lower . raise . resourceToIO
|
||||
X.bracketOnError
|
||||
(done ma)
|
||||
(\x -> done (mb x) >> finish)
|
||||
(\x -> do
|
||||
result <- done $ mc x
|
||||
case inspect ins result of
|
||||
Just _ -> pure result
|
||||
Nothing -> do
|
||||
_ <- done $ mb x
|
||||
pure result
|
||||
)
|
||||
{-# INLINE resourceToIO #-}
|
||||
|
||||
|
||||
@ -1,47 +0,0 @@
|
||||
{-# LANGUAGE NumDecimals #-}
|
||||
|
||||
module AsyncSpec where
|
||||
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import Polysemy
|
||||
import Polysemy.Async
|
||||
import Polysemy.State
|
||||
import Polysemy.Trace
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = describe "async" $ do
|
||||
it "should thread state and not lock" $ do
|
||||
(ts, (s, r)) <- runM
|
||||
. runTraceList
|
||||
. runState "hello"
|
||||
. asyncToIO $ do
|
||||
let message :: Member Trace r => Int -> String -> Sem r ()
|
||||
message n msg = trace $ mconcat
|
||||
[ show n, "> ", msg ]
|
||||
~[lock1, lock2] <- embed $
|
||||
replicateM 2 newEmptyMVar
|
||||
a1 <- async $ do
|
||||
v <- get @String
|
||||
message 1 v
|
||||
put $ reverse v
|
||||
|
||||
embed $ putMVar lock1 ()
|
||||
embed $ takeMVar lock2
|
||||
get >>= message 1
|
||||
|
||||
get @String
|
||||
|
||||
void $ async $ do
|
||||
embed $ takeMVar lock1
|
||||
get >>= message 2
|
||||
put "pong"
|
||||
embed $ putMVar lock2 ()
|
||||
|
||||
await a1 <* put "final"
|
||||
|
||||
ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]
|
||||
s `shouldBe` "final"
|
||||
r `shouldBe` Just "pong"
|
||||
@ -151,16 +151,6 @@ runTest = pure
|
||||
. runResource
|
||||
. runError @()
|
||||
|
||||
runTest2
|
||||
:: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a
|
||||
-> IO ([String], ([Char], Either () a))
|
||||
runTest2 = runM
|
||||
. ignoreOutput
|
||||
. runTraceList
|
||||
. runState ""
|
||||
. resourceToIO
|
||||
. runError @()
|
||||
|
||||
runTest3
|
||||
:: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a
|
||||
-> IO ([String], ([Char], Either () a))
|
||||
@ -185,9 +175,6 @@ testAllThree name k m = do
|
||||
k z
|
||||
-- NOTE(sandy): These unsafeCoerces are safe, because we're just weakening
|
||||
-- the end of the union
|
||||
it "via resourceToIO" $ do
|
||||
z <- runTest2 $ unsafeCoerce m
|
||||
k z
|
||||
it "via resourceToIOFinal" $ do
|
||||
z <- runTest3 $ unsafeCoerce m
|
||||
k z
|
||||
@ -200,9 +187,6 @@ testTheIOTwo
|
||||
-> Spec
|
||||
testTheIOTwo name k m = do
|
||||
describe name $ do
|
||||
it "via resourceToIO" $ do
|
||||
z <- runTest2 m
|
||||
k z
|
||||
-- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening
|
||||
-- the end of the union
|
||||
it "via resourceToIOFinal" $ do
|
||||
|
||||
@ -28,7 +28,7 @@ spec = parallel $ do
|
||||
|
||||
it "should happen before Resource" $ do
|
||||
a <-
|
||||
runM $ resourceToIO $ runError @MyExc $ do
|
||||
runFinal $ embedToFinal @IO $ resourceToIOFinal $ runError @MyExc $ do
|
||||
onException
|
||||
(fromException @MyExc $ do
|
||||
_ <- X.throwIO $ MyExc "hello"
|
||||
|
||||
@ -1,77 +0,0 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module InspectorSpec where
|
||||
|
||||
import Control.Monad
|
||||
import Data.IORef
|
||||
import Polysemy
|
||||
import Polysemy.Error
|
||||
import Polysemy.State
|
||||
import Test.Hspec
|
||||
|
||||
|
||||
|
||||
data Callback m a where
|
||||
Callback :: m String -> Callback m ()
|
||||
|
||||
makeSem ''Callback
|
||||
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = parallel $ describe "Inspector" $ do
|
||||
it "should inspect State effects" $ do
|
||||
withNewTTY $ \ref -> do
|
||||
void . (runM .@ runCallback ref)
|
||||
. runState False
|
||||
$ do
|
||||
embed $ pretendPrint ref "hello world"
|
||||
callback $ show <$> get @Bool
|
||||
modify not
|
||||
callback $ show <$> get @Bool
|
||||
|
||||
result <- readIORef ref
|
||||
result `shouldContain` ["hello world"]
|
||||
result `shouldContain` ["False", "True"]
|
||||
|
||||
it "should not inspect thrown Error effects" $ do
|
||||
withNewTTY $ \ref -> do
|
||||
void . (runM .@ runCallback ref)
|
||||
. runError @()
|
||||
$ do
|
||||
callback $ throw ()
|
||||
callback $ pure "nice"
|
||||
|
||||
result <- readIORef ref
|
||||
result `shouldContain` [":(", "nice"]
|
||||
|
||||
|
||||
runCallback
|
||||
:: Member (Embed IO) r
|
||||
=> IORef [String]
|
||||
-> (forall x. Sem r x -> IO x)
|
||||
-> Sem (Callback ': r) a
|
||||
-> Sem r a
|
||||
runCallback ref lower = interpretH $ \case
|
||||
Callback cb -> do
|
||||
cb' <- runT cb
|
||||
ins <- getInspectorT
|
||||
embed $ doCB ref $ do
|
||||
v <- lower .@ runCallback ref $ cb'
|
||||
pure $ maybe ":(" id $ inspect ins v
|
||||
getInitialStateT
|
||||
|
||||
|
||||
doCB :: IORef [String] -> IO String -> IO ()
|
||||
doCB ref m = m >>= pretendPrint ref
|
||||
|
||||
|
||||
pretendPrint :: IORef [String] -> String -> IO ()
|
||||
pretendPrint ref msg = modifyIORef ref (++ [msg])
|
||||
|
||||
|
||||
withNewTTY :: (IORef [String] -> IO a) -> IO a
|
||||
withNewTTY f = do
|
||||
ref <- newIORef []
|
||||
f ref
|
||||
|
||||
@ -45,18 +45,3 @@ interpretBadFirstOrder = ()
|
||||
-- ...
|
||||
tooFewArgumentsReinterpret = ()
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- |
|
||||
-- >>> :{
|
||||
-- let foo :: Member Resource r => Sem r ()
|
||||
-- foo = undefined
|
||||
-- in runM $ lowerResource foo
|
||||
-- :}
|
||||
-- ...
|
||||
-- ... Couldn't match expected type...
|
||||
-- ... with actual type...
|
||||
-- ... Probable cause: ... is applied to too few arguments
|
||||
-- ...
|
||||
missingArgumentToRunResourceInIO = ()
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user