diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,25 @@ # Changelog for polysemy-zoo + +## 0.6.0.0 (2019-09-05) + +- `Final` has been migrated to `polysemy` proper. + Only `Polysemy.Final.MTL` and experimental features pertaining to + `Final` remain in `polysemy-zoo`. +- Added `Fresh` effect. +- Added `Tagged` effect. +- Added `MonadCont` constraint absorber which operates via the `Cont` effect. +- Added `runContViaFresh`, which is still under development. +- Added `runReaderFixSem` +- Added `EndState` effect +- Added `RevState` effect +- Added `lowerFinal` +- Added `runFinalSem` +- Added `nonDetToFinal` +- Added `interpretFinalGlobal` +- Added `asyncToIOFinalGlobal` +- Added `resourceToIOFinalGlobal` + ## 0.5.0.1 (2019-07-25) - Fixed some bugs with haddock diff --git a/polysemy-zoo.cabal b/polysemy-zoo.cabal --- a/polysemy-zoo.cabal +++ b/polysemy-zoo.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: c9916a386c633f322272b00c91e9e16e395cf2d02474c4da8e7bd02ed2828c0f +-- hash: 138a6e0718009344f60c180fe1afffe26e3cf2f9712657e1a0e7c205a9ddebb0 name: polysemy-zoo -version: 0.5.0.1 +version: 0.6.0.0 synopsis: Experimental, user-contributed effects and interpreters for polysemy description: Please see the README on GitHub at category: Polysemy @@ -32,28 +32,33 @@ Polysemy.Alias Polysemy.Capture Polysemy.ConstraintAbsorber + Polysemy.ConstraintAbsorber.MonadCont Polysemy.ConstraintAbsorber.MonadError Polysemy.ConstraintAbsorber.MonadReader Polysemy.ConstraintAbsorber.MonadState Polysemy.ConstraintAbsorber.MonadWriter Polysemy.Cont Polysemy.Cont.Internal - Polysemy.Final - Polysemy.Final.Async - Polysemy.Final.Error - Polysemy.Final.Fixpoint + Polysemy.EndState + Polysemy.Final.IO + Polysemy.Final.IO.Internal + Polysemy.Final.More Polysemy.Final.MTL - Polysemy.Final.Resource + Polysemy.Final.NonDet Polysemy.Floodgate + Polysemy.Fresh Polysemy.IdempotentLowering Polysemy.KVStore Polysemy.Operators Polysemy.Random + Polysemy.Reader.More Polysemy.Redis.Utils + Polysemy.RevState Polysemy.SetStore Polysemy.Several Polysemy.Shift Polysemy.Shift.Internal + Polysemy.Tagged other-modules: Paths_polysemy_zoo hs-source-dirs: @@ -67,13 +72,15 @@ , bytestring >=0.10.8.2 && <0.11 , constraints >=0.10.1 && <0.12 , containers >=0.5 && <0.7 + , contravariant <2 , ghc-prim >=0.5.2 && <0.6 , hedis >=0.10 && <0.13 , mtl >=2.0.1.0 && <3.0.0.0 - , polysemy >=1.0.0.0 + , polysemy >=1.2.0.0 , polysemy-plugin >=0.2 , random >=1.1 && <1.2 , reflection >=2.1.4 && <3.0.0 + , transformers >=0.5.2.0 && <0.6 default-language: Haskell2010 test-suite polysemy-zoo-test @@ -87,6 +94,7 @@ FloodgateSpec IdempotentLoweringSpec KVStoreSpec + RevStateSpec SeveralSpec ShiftSpec Paths_polysemy_zoo @@ -103,13 +111,15 @@ , bytestring >=0.10.8.2 && <0.11 , constraints >=0.10.1 && <0.12 , containers >=0.5 && <0.7 + , contravariant <2 , ghc-prim >=0.5.2 && <0.6 , hedis >=0.10 && <0.13 , hspec >=2.6.0 && <3 , mtl >=2.0.1.0 && <3.0.0.0 - , polysemy >=0.7.0.0 + , polysemy >=1.2.0.0 , polysemy-plugin >=0.2 , polysemy-zoo , random >=1.1 && <1.2 , reflection >=2.1.4 && <3.0.0 + , transformers >=0.5.2.0 && <0.6 default-language: Haskell2010 diff --git a/src/Polysemy/Capture.hs b/src/Polysemy/Capture.hs --- a/src/Polysemy/Capture.hs +++ b/src/Polysemy/Capture.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, Trustworthy #-} module Polysemy.Capture (-- * Effect Capture(..) @@ -25,7 +25,7 @@ import Polysemy.Internal import Polysemy.Internal.Union -import Polysemy.Cont.Internal(Ref(..)) +import Polysemy.Cont.Internal (Ref(..)) ----------------------------------------------------------------------------- -- | A less powerful variant of 'Polysemy.Shift.Shift' that may always be @@ -60,7 +60,7 @@ -- -- The provided continuation may fail locally in its subcontinuations. -- It may sometimes become necessary to handle such cases. To do so, --- use 'delimit\'' together with 'reflect' (the reified continuation +-- use 'delimit'' together with 'reflect' (the reified continuation -- is already delimited). reflect :: forall ref s a r . Member (Capture ref) r @@ -89,7 +89,7 @@ -- -- The provided continuation may fail locally in its subcontinuations. -- It may sometimes become necessary to handle such cases, in --- which case such failure may be detected by using 'delimit\'' together +-- which case such failure may be detected by using 'delimit'' together -- with the provided continuation (the provided continuation -- is already delimited). capture :: Member (Capture ref) r @@ -99,7 +99,7 @@ {-# INLINE capture #-} ----------------------------------------------------------------------------- --- | Runs a 'Capture' effect by providing 'pure '.' Just' as the final +-- | Runs a 'Capture' effect by providing @'pure' '.' 'Just'@ as the final -- continuation. -- -- The final return type is wrapped in a 'Maybe' due to the fact that diff --git a/src/Polysemy/ConstraintAbsorber/MonadCont.hs b/src/Polysemy/ConstraintAbsorber/MonadCont.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/ConstraintAbsorber/MonadCont.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} + +module Polysemy.ConstraintAbsorber.MonadCont + ( absorbCont + ) where + +import Data.Coerce +import qualified Control.Monad.Cont.Class as C +import Polysemy +import Polysemy.ConstraintAbsorber +import Polysemy.Cont + + +------------------------------------------------------------------------------ +-- | Introduce a local 'C.MonadCont' constraint on 'Sem' --- allowing it to +-- interop nicely with MTL. +-- +-- @since 0.3.0.0 +absorbCont + :: Member (Cont ref) r + => (C.MonadCont (Sem r) => Sem r a) + -- ^ A computation that requires an instance of 'C.MonadCont' for + -- 'Sem'. This might be something with type @'C.MonadCont' m => m a@. + -> Sem r a +absorbCont = absorbWithSem @C.MonadCont @Action + (ContDict callCC) + (Sub Dict) +{-# INLINEABLE absorbCont #-} + + +------------------------------------------------------------------------------ +-- | A dictionary of the functions we need to supply +-- to make an instance of Cont +newtype ContDict m = ContDict + { callCC_ :: forall a b. ((a -> m b) -> m a) -> m a + } + + +------------------------------------------------------------------------------ +-- | Wrapper for a monadic action with phantom +-- type parameter for reflection. +-- Locally defined so that the instance we are going +-- to build with reflection must be coherent, that is +-- there cannot be orphans. +newtype Action m s' a = Action (m a) + deriving (Functor, Applicative, Monad) + + +------------------------------------------------------------------------------ +-- | Given a reifiable mtl Cont dictionary, +-- we can make an instance of @MonadCont@ for the action +-- wrapped in @Action@. +instance ( Monad m + , Reifies s' (ContDict m) + ) => C.MonadCont (Action m s') where + callCC (cc :: (a -> Action m s' b) -> Action m s' a) + = Action $ callCC_ (reflect $ Proxy @s') @a @b (coerce cc) + {-# INLINEABLE callCC #-} diff --git a/src/Polysemy/Cont.hs b/src/Polysemy/Cont.hs --- a/src/Polysemy/Cont.hs +++ b/src/Polysemy/Cont.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Trustworthy #-} module Polysemy.Cont (-- * Effect Cont(..) @@ -10,14 +11,18 @@ -- * Interpretations , runContPure , runContM - , runContFinal + , contToFinal + -- * Experimental Interpretations + , runContViaFresh + -- * Unsafe Interpretations , runContUnsafe -- * Prompt types , Ref(..) , ExitRef(..) + , ViaFreshRef ) where import Data.Void @@ -27,7 +32,10 @@ import Polysemy.Cont.Internal -import Control.Monad.Cont (MonadCont()) +import Polysemy.Error +import Polysemy.Fresh + +import Control.Monad.Cont (MonadCont(), ContT(..), runContT) import qualified Control.Monad.Cont as C (callCC) ----------------------------------------------------------------------------- @@ -35,11 +43,8 @@ -- Executing the provided continuation will abort execution. -- -- Using the provided continuation --- will rollback all effectful state back to the point where 'callCC' was invoked, --- unless such state is interpreted in terms of the final --- monad, /or/ the associated interpreter of the effectful state --- is run after 'runContUnsafe', which may be done if the effect isn't --- higher-order. +-- will rollback all local effectful state back to the point where +-- 'callCC' was invoked. -- -- Higher-order effects do not interact with the continuation in any meaningful -- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect @@ -47,8 +52,8 @@ -- The only exception to this is if you interpret such effects /and/ 'Cont' -- in terms of the final monad, and the final monad can perform such interactions -- in a meaningful manner. -callCC :: forall ref a r. - Member (Cont ref) r +callCC :: forall ref r a + . Member (Cont ref) r => ((forall b. a -> Sem r b) -> Sem r a) -> Sem r a callCC cc = subst (\ref -> cc (jump ref)) pure @@ -77,11 +82,11 @@ -- -- /Beware/: Effects that aren't interpreted in terms of the final monad -- will have local state semantics in regards to 'Cont' effects --- interpreted this way. See 'interpretFinal'. -runContFinal :: (Member (Final m) r, MonadCont m) - => Sem (Cont (ExitRef m) ': r) a - -> Sem r a -runContFinal = interpretFinal $ \case +-- interpreted this way. See 'Final'. +contToFinal :: (Member (Final m) r, MonadCont m) + => Sem (Cont (ExitRef m) ': r) a + -> Sem r a +contToFinal = interpretFinal $ \case Jump ref a -> pure $ enterExit ref a Subst main cb -> do main' <- bindS main @@ -89,9 +94,42 @@ s <- getInitialStateS pure $ C.callCC $ \exit -> main' (ExitRef (\a -> cb' (a <$ s) >>= vacuous . exit) <$ s) -{-# INLINE runContFinal #-} +{-# INLINE contToFinal #-} ----------------------------------------------------------------------------- +-- | A highly experimental 'Cont' interpreter that functions +-- through a combination of 'Error' and 'Fresh'. This may be used safely +-- anywhere in the effect stack. +-- +-- 'runContViaFresh' is still under development. +-- You're encouraged to experiment with it, but don't rely on it. +-- For best results, use 'runContViaFresh' as the first interpreter you run, +-- such that all other effects are global in respect to it. +-- +-- This interpreter may return 'Nothing' if the control flow becomes +-- split into separate, inconsistent parts, +-- such that backtracking fails when trying to invoke continuations. +-- For example, if you reify a continuation inside an +-- 'async':ed thread, and then have that thread return the reified +-- continuation back to the main thread through an 'await', then +-- 'runContViaFresh' will return 'Nothing' upon executing the continuation +-- in the main thread. +runContViaFresh :: forall uniq r a + . (Member (Fresh uniq) r, Eq uniq) + => Sem (Cont (ViaFreshRef uniq) ': r) a + -> Sem r (Maybe a) +runContViaFresh = + let + hush (Right a) = Just a + hush _ = Nothing + in + fmap hush + . runError + . (`runContT` pure) + . runContViaFreshInC +{-# INLINE runContViaFresh #-} + +----------------------------------------------------------------------------- -- | Runs a 'Cont' effect by providing 'pure' as the final continuation. -- -- __Beware__: This interpreter will invalidate all higher-order effects of any @@ -99,8 +137,8 @@ -- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail -- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'. -- --- __You should therefore use 'runContUnsafe' /after/ running all interpreters for --- your higher-order effects.__ +-- __You should therefore use 'runContUnsafe' only /after/ running all__ +-- __interpreters for your higher-order effects.__ -- -- Note that 'Final' is a higher-order effect, and thus 'runContUnsafe' can't -- safely be used together with 'runFinal'. diff --git a/src/Polysemy/Cont/Internal.hs b/src/Polysemy/Cont/Internal.hs --- a/src/Polysemy/Cont/Internal.hs +++ b/src/Polysemy/Cont/Internal.hs @@ -1,12 +1,20 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, Unsafe #-} module Polysemy.Cont.Internal where +import Data.Functor.Contravariant + import Polysemy import Polysemy.Internal import Polysemy.Internal.Union +import Polysemy.Fresh +import Polysemy.Error + import Control.Monad -import Control.Monad.Cont (ContT(..)) +import Control.Monad.Trans.Cont hiding (Cont) +import Unsafe.Coerce +import GHC.Exts (Any) + ----------------------------------------------------------------------------- -- | An effect for abortive continuations. -- @@ -63,7 +71,7 @@ -- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail -- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'. -- --- __You should therefore use 'runContUnsafeWithC' /after/ running all interpreters +-- __You should therefore use 'runContWithCUnsafe' /after/ running all interpreters -- for your higher-order effects.__ runContWithCUnsafe :: (a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) ': r) a -> Sem r s runContWithCUnsafe c (Sem m) = (`runContT` c) $ m $ \u -> case decomp u of @@ -95,4 +103,154 @@ {-# INLINE embedSem #-} newtype Ref m s a = Ref { runRef :: a -> m s } + +instance Contravariant (Ref m s) where + contramap f ref = Ref (runRef ref . f) + newtype ExitRef m a = ExitRef { enterExit :: forall b. a -> m b } + +instance Contravariant (ExitRef m) where + contramap f ref = ExitRef $ \a -> enterExit ref (f a) + +data ViaFreshRef uniq a = ViaFreshRef { getBacktrackException :: a -> (uniq, Any) } + +instance Contravariant (ViaFreshRef uniq) where + contramap f ref = ViaFreshRef $ \a -> getBacktrackException ref (f a) + +{- + KingoftheHomeless: OK, so let's discuss how this works. + The idea here is to instead of providing a monadic computation + to the call of 'callCC' that simply short-circuits everything like + 'ContT' does, we fake that behaviour by instead providing an + exception to 'callCC', and then try to 'catch' that exception + on the continuation. If the exception is caught, then we run the + continuation again. This way, we can get abortive continuations + without having to scope over a result type variable, avoiding + the problem that 'runContUnsafe' has, and making it possible + to weave other effects through without breaking everything. + + Even with that solution, weaving effects through have more problems + of their own; namely, if we simply lower a + 'forall s. ContT s (Sem r) a' to 'Sem r a', then we effectively + delimit all higher-order computations. This is bad, because + if a reified continuation produced within + the higher-order computation escapes from it, + then nothing can catch the underlying backtrack exception + once it is thrown. + + The solution to this is anothor kludge: when weaving other effects through, + we instead use 'runContViaFreshInCWeave'; this makes use 'ContFreshState' + as its functorial state, which stores /handlers/ for backtrack exceptions. + 'runContViaFreshInCWeave', in addition to 'catch'ing exceptions on the continuation + it is given, /also/ returns the handler it uses for the 'catch'. + This handler is then used by 'runContViaFresh' to catch exceptions on the + continuation /it/ gets, but can't provide to the higher-order computation. + + I'm astonished that this even remotely works, but it does have some rather + weird behaviour I haven't completely figured out yet. + + I'm reasonably happy with how 'runContViaFreshInC' looks; + I'm a lot less happy with 'runContViaFreshInCWeave', I just kinda threw + it haphazardly. I figure most weirdness stem from issues in + 'runContViaFreshInCWeave', so I need to think it through some more. +-} +-- | Intermediary monadic interpretation used for running 'runContViaFresh'. +-- See source for a discussion on how this works. +runContViaFreshInC :: forall uniq s r a + . (Member (Fresh uniq) r, Eq uniq) + => Sem (Cont (ViaFreshRef uniq) ': r) a + -> ContT s (Sem (Error (uniq, Any) ': r)) a +runContViaFreshInC = usingSem $ \u -> ContT $ \c -> + case decomp u of + Right (Weaving e s wv ex _) -> + case e of + Subst main cn -> do + ref <- fresh + let + main' = runContViaFreshInC . wv . fmap main . (<$ s) + cn' = runContViaFreshInC . wv . fmap cn . (<$ s) + loop act = + runContT (ex <$> act) c `catch` \ x@(ref', a') -> do + if ref == ref' then + loop (cn' $ unsafeCoerce a') + else + throw x + loop $ main' $ ViaFreshRef (\a -> (ref, unsafeCoerce a)) + Jump ref a -> throw (getBacktrackException ref a) + Left g -> do + ResAndHandler a rc <- liftSem $ + weave + (ResAndHandler @uniq @r () throw) + -- TODO(KingoftheHomeless): is this the distributive law we want? + (\(ResAndHandler a rc) -> + runContT + (runContViaFreshInCWeave a) + (\x -> pure $ + ResAndHandler + x + (rc >=> (`runContT` pure) . runContViaFreshInC) + ) + ) + (Just . getResult) + (weaken g) + let loop x = c x `catch` (rc >=> loop) + loop a + +-- | A variant of 'runContViaFreshInC' which it uses when weaving other effects through. +runContViaFreshInCWeave :: forall uniq s r a + . (Member (Fresh uniq) r, Eq uniq) + => Sem (Cont (ViaFreshRef uniq) ': r) a + -> ContT (ContFreshState uniq r s) + (Sem (Error (uniq, Any) ': r)) + a +runContViaFreshInCWeave = usingSem $ \u -> ContT $ \c -> + case decomp u of + Right (Weaving e s wv ex _) -> + case e of + Subst main cn -> do + ref <- fresh + let + -- TODO(KingoftheHomeless): runContViaFreshInC? + main' = runContViaFreshInCWeave . wv . fmap main . (<$ s) + cn' = runContViaFreshInCWeave . wv . fmap cn . (<$ s) + loop act = + runContT (ex <$> act) c `catch` \ x@(ref', a') -> do + if ref == ref' then + loop (cn' $ unsafeCoerce a') + else + throw x + ResAndHandler res h <- + loop $ main' $ ViaFreshRef (\a -> (ref, unsafeCoerce a)) + return $ ResAndHandler res + -- TODO(KingoftheHomeless): This handler is dubious. + $ \x -> fmap getResult $ loop $ ContT $ \_ -> fmap (`ResAndHandler` h) (h x) + Jump ref a -> throw (getBacktrackException ref a) + Left g -> do + ResAndHandler a h <- liftSem $ + weave + (ResAndHandler @uniq @r () throw) + (\(ResAndHandler a rc) -> + runContT + (runContViaFreshInCWeave a) + (\x -> pure $ + ResAndHandler + x + (rc >=> (`runContT` pure) . runContViaFreshInC) + ) + ) + (Just . getResult) + (weaken g) + let loop x = c x `catch` (h >=> loop) + ResAndHandler res h' <- loop a + -- TODO(KingoftheHomeless): This handler is dubious. + return (ResAndHandler res $ \x -> (h' x `catch` (h >=> fmap getResult . loop))) + +-- | This is the effectful state used by 'runContViaFreshInC' when weaving through +-- other effectful actions. The point of it is to avoid delimiting computations +-- in higher-order effects, by having them return a handler which may be used +-- to intercept backtrack exceptions of the current continuation. +data ContFreshState uniq r a = ResAndHandler { + getResult :: a + , getHandler :: (uniq, Any) -> Sem (Error (uniq, Any) ': r) a + } + deriving Functor diff --git a/src/Polysemy/EndState.hs b/src/Polysemy/EndState.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/EndState.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +module Polysemy.EndState + (-- * Effect + EndState(..) + + -- * Actions + , getEndState + + -- * Interpretations + , runEndState + , runEndAtomicState + ) where + +import Polysemy +import Polysemy.Fixpoint +import Polysemy.Reader +import Polysemy.Reader.More + +import Polysemy.State +import Polysemy.AtomicState + + +----------------------------------------------------------------------------- +-- | An effect for getting the end state of a computation in advance. +data EndState s m a where + GetEndState :: EndState s m s + +makeSem ''EndState + +----------------------------------------------------------------------------- +-- | Runs an 'EndState' effect by getting the state after the computation +-- has finished, and providing it recursively back to calls of 'getEndState'. +runEndState :: (Member (State s) r, Member Fixpoint r) + => Sem (EndState s ': r) a + -> Sem r a +runEndState = + runReaderFixSem get + . reinterpret (\GetEndState -> ask) + + +----------------------------------------------------------------------------- +-- | Like 'runEndState', but for 'AtomicState' rather than 'State'. +runEndAtomicState + :: (Member (AtomicState s) r, Member Fixpoint r) + => Sem (EndState s ': r) a + -> Sem r a +runEndAtomicState = + runReaderFixSem atomicGet + . reinterpret (\GetEndState -> ask) diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs deleted file mode 100644 --- a/src/Polysemy/Final.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Polysemy.Final - ( - -- * Effect - Final(..) - - -- * Actions - , withWeaving - , withStrategic - , embedFinal - - -- * Combinators for Interpreting to the Final Monad - , interpretFinal - - -- * Strategy - -- | Strategy is a domain-specific language very similar to @Tactics@ - -- (see 'Tactical'), and is used to describe how higher-order effects - -- are threaded down to the final monad. - -- - -- Much like @Tactics@, computations can be run and threaded - -- through the use of 'runS' and 'bindS', and first-order constructors - -- may use 'pureS'. In addition, 'liftS' may be used to - -- lift actions of the final monad. - -- - -- Unlike @Tactics@, the final return value within a `Strategic` - -- must be a monadic value of the target monad - -- with the functorial state wrapped inside of it. - , Strategic - , WithStrategy - , pureS - , liftS - , runS - , bindS - , getInspectorS - , getInitialStateS - - -- * Interpretations - , runFinal - , runFinalLift - , runFinalLiftIO - ) where - -import Data.Functor.Identity - -import Polysemy -import Data.Functor.Compose -import Polysemy.Internal -import Polysemy.Internal.Tactics -import Polysemy.Internal.Union -import Control.Monad -import Control.Monad.IO.Class - ------------------------------------------------------------------------------ --- | An effect for embedding higher-order effects in the final target monad --- of the effect stack. --- --- This is very useful for writing interpreters that interpret higher-order --- effects in terms of the final monad - however, these interpreters --- are subject to very different semantics than regular ones. --- --- For more information, see 'interpretFinal'. -data Final m z a where - WithWeaving :: (forall f. - Functor f - => f () - -> (forall x. f (z x) -> m (f x)) - -> (forall x. f x -> Maybe x) - -> m (f a) - ) - -> Final m z a - -makeSem_ ''Final - ------------------------------------------------------------------------------ --- | Allows for embedding higher-order actions of the final monad --- by providing the means of explicitly threading effects through @'Sem' r@ --- to the final monad. --- --- Consider using 'withStrategic' instead, --- as it provides a more user-friendly interface to the same power. --- --- You are discouraged from using 'withWeaving' directly in application code, --- as it ties your application code directly to the underlying monad. -withWeaving :: forall m a r - . Member (Final m) r - => (forall f. - Functor f - => f () - -> (forall x. f (Sem r x) -> m (f x)) - -> (forall x. f x -> Maybe x) - -> m (f a) - ) - -> Sem r a - ------------------------------------------------------------------------------ --- | 'withWeaving' admits an implementation of 'sendM'. --- --- Just like 'sendM', you are discouraged from using this in application code. -embedFinal :: Functor m => Member (Final m) r => m a -> Sem r a -embedFinal m = withWeaving $ \s _ _ -> (<$ s) <$> m - - ------------------------------------------------------------------------------ --- | Allows for embedding higher-order actions of the final monad --- by providing the means of explicitly threading effects through 'Sem r' --- to the final monad. This is done through the use of the 'Strategic' --- environment. --- --- You are discouraged from using 'withStrategic' in application code, --- as it ties your application code directly to the underlying monad. -withStrategic :: Member (Final m) r => Strategic m (Sem r) a -> Sem r a -withStrategic strat = withWeaving $ \s wv ins -> runStrategy s wv ins strat - ------------------------------------------------------------------------------- --- | Like 'interpretH', but may be used to --- interpret higher-order effects in terms of the final monad. --- --- /Beware/: Any interpreters built using this (or 'Final' in general) --- will /not/ respect local/global state semantics based on the order of --- interpreters run. You should signal interpreters that make use of --- 'Final' by adding a "-Final" suffix to the names of these. --- --- State semantics of effects that are /not/ --- interpreted in terms of the final monad will always --- appear local to effects that are interpreted in terms of the final monad. --- --- State semantics between effects that are interpreted in terms of the final monad --- depend on the final monad. I.e. if the final monad is a monad transformer stack, --- then state semantics will depend on the order monad transformers are stacked. -interpretFinal - :: forall e m r a - . (Member (Final m) r, Functor m) - => (forall x n. e n x -> Strategic m n x) - -> Sem (e ': r) a - -> Sem r a -interpretFinal n = - let - go :: Sem (e ': r) x -> Sem r x - go (Sem sem) = sem $ \u -> case decomp u of - Right (Weaving e s wv ex ins) -> - fmap ex $ withWeaving $ \s' wv' ins' - -> fmap getCompose $ - runStrategy - (Compose (s <$ s')) - (fmap Compose . wv' . fmap (go . wv) . getCompose) - (ins' . getCompose >=> ins) - (n e) - Left g -> liftSem (hoist go g) - {-# INLINE go #-} - in - go -{-# INLINE interpretFinal #-} - ------------------------------------------------------------------------------- --- | 'Strategic' is an environment in which you're capable of explicitly --- threading higher-order effect states to the final monad. --- This is based upon @Tactics@, (see 'Tactical'), and usage --- is extremely similar. -type Strategic m n a = forall f. Functor f => Sem (WithStrategy m f n) (m (f a)) - -type WithStrategy m f n = WithTactics (Embed m) f n '[] - ------------------------------------------------------------------------------- --- | Get a natural transformation capable of potentially inspecting values --- inside of @f@. Binding the result of 'getInspectorS' produces a function that --- can sometimes peek inside values returned by 'bindS'. --- --- This is often useful for running callback functions that are not managed by --- polysemy code. --- --- See also 'getInspectorT' -getInspectorS :: Sem (WithStrategy m f n) (Inspector f) -getInspectorS = getInspectorT -{-# INLINE getInspectorS #-} - ------------------------------------------------------------------------------- --- | Get the stateful environment of the world at the moment the --- target monad is to be run. --- Prefer 'pureS', 'runS' or 'bindS' instead of using this function --- directly. -getInitialStateS :: Sem (WithStrategy m f n) (f ()) -getInitialStateS = getInitialStateT -{-# INLINE getInitialStateS #-} - ------------------------------------------------------------------------------- --- | Embed a value into 'Strategic'. -pureS :: Applicative m => a -> Strategic m n a -pureS = fmap pure . pureT -{-# INLINE pureS #-} - ------------------------------------------------------------------------------- --- | Lifts an action of the final monad into 'Strategic'. --- --- Note: you don't need to use this function if you already have a monadic --- action with the functorial state woven into it, by the use of --- 'runS' or 'bindS'. --- In these cases, you need only use 'pure' to embed the action into the --- 'Strategic' environment. -liftS :: Functor m => m a -> Strategic m n a -liftS m = do - s <- getInitialStateS - pure $ fmap (<$ s) m -{-# INLINE liftS #-} - ------------------------------------------------------------------------------- --- | Lifts a monadic action into the stateful environment, in terms --- of the final monad. --- The stateful environment will be the same as the one that the target monad --- is initially run in. --- Use 'bindS' if you'd prefer to explicitly manage your stateful environment. -runS :: Monad m => n a -> Sem (WithStrategy m f n) (m (f a)) -runS = fmap runM . runT -{-# INLINE runS #-} - ------------------------------------------------------------------------------- --- | Embed a kleisli action into the stateful environment, in terms of the final --- monad. You can use 'bindS' to get an effect parameter of the form @a -> n b@ --- into something that can be used after calling 'runS' on an effect parameter --- @n a@. -bindS :: Monad m => (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b)) -bindS = fmap (runM .) . bindT -{-# INLINE bindS #-} - ------------------------------------------------------------------------------- --- | Internal function to process Strategies in terms of 'withWeaving'. -runStrategy :: Functor f - => f () - -> (forall x. f (n x) -> m (f x)) - -> (forall x. f x -> Maybe x) - -> Sem (WithStrategy m f n) a - -> a -runStrategy s wv ins (Sem m) = runIdentity $ m $ \u -> case extract u of - Weaving e s' _ ex' _ -> Identity $ ex' $ (<$ s') $ case e of - GetInitialState -> s - HoistInterpretation na -> embed . wv . fmap na - GetInspector -> Inspector ins -{-# INLINE runStrategy #-} - ------------------------------------------------------------------------------- --- | Lower a 'Sem' containing only a lifted, final monad into that monad. --- The appearance of 'Lift' as the final effect --- is to allow the use of operations that rely on a @'LastMember' ('Lift' m)@ --- constraint. -runFinal :: Monad m => Sem '[Final m, Embed m] a -> m a -runFinal = usingSem $ \u -> case decomp u of - Right (Weaving (WithWeaving wav) s wv ex ins) -> - ex <$> wav s (runFinal . wv) ins - Left g -> case extract g of - Weaving (Embed m) s _ ex _ -> ex . (<$ s) <$> m -{-# INLINE runFinal #-} - ------------------------------------------------------------------------------- --- | Lower a 'Sem' containing two lifted monad into the final monad, --- by interpreting one of the monads in terms of the other one. --- --- This allows for the use of operations that rely on a @'LastMember' ('Lift' m)@ --- constraint, as long as @m@ can be transformed to the final monad; --- but be warned, this breaks the implicit contract of @'LastMember' ('Lift' m)@ --- that @m@ /is/ the final monad, so depending on the final monad and operations --- used, 'runFinalLift' may become /unsafe/. --- --- For example, 'runFinalLift' is unsafe with 'Polysemy.Async.asyncToIO' if --- the final monad is non-deterministic, or a continuation --- monad. -runFinalLift :: Monad m - => (forall x. n x -> m x) - -> Sem [Final m, Embed m, Embed n] a - -> m a -runFinalLift nat = usingSem $ \u -> case decomp u of - Right (Weaving (WithWeaving wav) s wv ex ins) -> - ex <$> wav s (runFinalLift nat . wv) ins - Left g -> case decomp g of - Right (Weaving (Embed m) s _ ex _) -> ex . (<$ s) <$> m - Left g' -> case extract g' of - Weaving (Embed n) s _ ex _ -> ex . (<$ s) <$> nat n -{-# INLINE runFinalLift #-} - ------------------------------------------------------------------------------- --- | 'runFinalLift', specialized to transform 'IO' to a 'MonadIO'. -runFinalLiftIO :: MonadIO m - => Sem [Final m, Embed m, Embed IO] a - -> m a -runFinalLiftIO = runFinalLift liftIO -{-# INLINE runFinalLiftIO #-} diff --git a/src/Polysemy/Final/Async.hs b/src/Polysemy/Final/Async.hs deleted file mode 100644 --- a/src/Polysemy/Final/Async.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Polysemy.Final.Async - ( - module Polysemy.Async - , module Polysemy.Final - , runAsyncFinal - ) where - -import qualified Control.Concurrent.Async as A - -import Polysemy -import Polysemy.Async -import Polysemy.Final - ------------------------------------------------------------------------------- --- | Run an 'Async' effect through final 'IO' --- --- This can be used as an alternative to 'lowerAsync'. --- --- /Beware/: Effects that aren't interpreted in terms of 'IO' --- will have local state semantics in regards to 'Async' effects --- interpreted this way. See 'interpretFinal'. --- --- Notably, unlike 'asyncToIO', this is not consistent with --- 'Polysemy.State.State' unless 'Polysemy.State.runStateInIORef' is used. --- State that seems like it should be threaded globally throughout the `Async` --- /will not be./ --- --- Prefer 'asyncToIO' unless its unsafe or inefficient in the context of your --- application. -runAsyncFinal :: Member (Final IO) r - => Sem (Async ': r) a - -> Sem r a -runAsyncFinal = interpretFinal $ \case - Async m -> do - ins <- getInspectorS - m' <- runS m - liftS $ A.async (inspect ins <$> m') - Await a -> liftS (A.wait a) diff --git a/src/Polysemy/Final/Error.hs b/src/Polysemy/Final/Error.hs deleted file mode 100644 --- a/src/Polysemy/Final/Error.hs +++ /dev/null @@ -1,63 +0,0 @@ -module Polysemy.Final.Error - ( - module Polysemy.Error - , module Polysemy.Final - , runErrorInIOFinal - ) where - -import Control.Exception hiding (throw, catch) -import qualified Control.Exception as X -import Data.Typeable (Typeable, typeRep) -import Polysemy -import Polysemy.Final -import Polysemy.Error - ------------------------------------------------------------------------------- --- | Run an 'Error' effect as an 'IO' 'Exception'. --- --- This can be used as an alternative to 'runErrorInIO' --- --- /Beware/: Effects that aren't interpreted in terms of 'IO' --- will have local state semantics in regards to 'Error' effects --- interpreted this way. See 'interpretFinal'. -runErrorInIOFinal - :: ( Typeable e - , Member (Final IO) r - ) - => Sem (Error e ': r) a - -> Sem r (Either e a) -runErrorInIOFinal sem = withStrategic $ do - m' <- runS (runErrorAsExcFinal sem) - s <- getInitialStateS - pure $ - either - ((<$ s) . Left . unwrapExc) - (fmap Right) - <$> try m' -{-# INLINE runErrorInIOFinal #-} - -runErrorAsExcFinal - :: forall e r a - . ( Typeable e - , Member (Final IO) r - ) - => Sem (Error e ': r) a - -> Sem r a -runErrorAsExcFinal = interpretFinal $ \case - Throw e -> pure $ throwIO $ WrappedExc e - Catch m h -> do - m' <- runS m - h' <- bindS h - s <- getInitialStateS - pure $ X.catch m' $ \(se :: WrappedExc e) -> - h' (unwrapExc se <$ s) -{-# INLINE runErrorAsExcFinal #-} - - -newtype WrappedExc e = WrappedExc { unwrapExc :: e } - deriving (Typeable) - -instance Typeable e => Show (WrappedExc e) where - show = mappend "WrappedExc: " . show . typeRep - -instance (Typeable e) => Exception (WrappedExc e) diff --git a/src/Polysemy/Final/Fixpoint.hs b/src/Polysemy/Final/Fixpoint.hs deleted file mode 100644 --- a/src/Polysemy/Final/Fixpoint.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Polysemy.Final.Fixpoint - ( - module Polysemy.Fixpoint - , module Polysemy.Final - , runFixpointFinal - ) where - -import Polysemy -import Polysemy.Final -import Polysemy.Fixpoint - -import Control.Monad.Fix - ------------------------------------------------------------------------------ --- | Run a 'Fixpoint' effect through a final 'MonadFix' -runFixpointFinal :: (Member (Final m) r, MonadFix m) - => Sem (Fixpoint ': r) a - -> Sem r a -runFixpointFinal = interpretFinal $ \case - Fixpoint f -> do - f' <- bindS f - pure $ mfix f' -{-# INLINE runFixpointFinal #-} diff --git a/src/Polysemy/Final/IO.hs b/src/Polysemy/Final/IO.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Final/IO.hs @@ -0,0 +1,57 @@ +module Polysemy.Final.IO + ( + -- * Combinators for Interpreting to the Final Monad + interpretFinalGlobal + + -- * Interpretations for other effects + , asyncToIOFinalGlobal + , resourceToIOFinalGlobal + ) where + +import qualified Control.Concurrent.Async as A +import qualified Control.Exception as X + +import Polysemy +import Polysemy.Final +import Polysemy.Final.IO.Internal +import Polysemy.Async +import Polysemy.Resource + +------------------------------------------------------------------------------ +-- | 'asyncToIOFinal' implemented using 'interpretFinalGlobal'. +-- +-- This behaves semantically very much like 'asyncToIO', +-- but doesn't need to spin up an interpreter thread, making it more +-- efficient (but not any more safe). +asyncToIOFinalGlobal :: Member (Final IO) r + => Sem (Async ': r) a + -> Sem r a +asyncToIOFinalGlobal = interpretFinalGlobal $ \case + Async m -> do + ins <- getInspectorS + m' <- runS m + liftS $ A.async (inspect ins <$> m') + Await a -> liftS (A.wait a) +{-# INLINE asyncToIOFinalGlobal #-} +------------------------------------------------------------------------------ +-- | 'resourceToIOFinal' implemented using 'interpretFinalGlobal'. +-- +-- This behaves semantically very much like 'resourceToIO', +-- but doesn't need to spin up an interpreter thread, +-- making it more efficient (but not any more safe). +resourceToIOFinalGlobal :: Member (Final IO) r + => Sem (Resource ': r) a + -> Sem r a +resourceToIOFinalGlobal = interpretFinalGlobal $ \case + Bracket alloc dealloc use -> do + a <- runS alloc + d <- bindS dealloc + u <- bindS use + pure $ X.bracket a d u + + BracketOnError alloc dealloc use -> do + a <- runS alloc + d <- bindS dealloc + u <- bindS use + pure $ X.bracketOnError a d u +{-# INLINE resourceToIOFinalGlobal #-} diff --git a/src/Polysemy/Final/IO/Internal.hs b/src/Polysemy/Final/IO/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Final/IO/Internal.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TemplateHaskell #-} +module Polysemy.Final.IO.Internal where + +import Data.Functor.Compose +import Data.Maybe + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Control.Monad.Trans.Maybe + +import Polysemy +import Polysemy.Final +import Polysemy.Internal +import Polysemy.Internal.Union +import Polysemy.Internal.Strategy + +------------------------------------------------------------------------------ +-- | Like 'interpretFinal' specialized to 'IO', but also tries very hard +-- to preserve state semantics dependant on the order interpreters are run, +-- adressing the primary issue with 'Final'. +-- +-- Semantically, interpreters written using this behave very much as +-- though they were written using 'withLowerToIO'. +-- However, this does not need to spawn an interpreter thread, making +-- it more efficient (but not any more safe.) +-- +-- 'interpretFinalGlobal' operates under the assumption that any effectful +-- state which can't be inspected using 'Polysemy.Inspector' can't contain any +-- values. For example, the effectful state for 'Polysemy.runError' is +-- @'Either' e a@. The inspector for this effectful state only fails if the +-- effectful state is a @'Left'@ value, which therefore doesn't contain any +-- values of @a@. +-- +-- The assumption holds true for all interpreters featured in polysemy, +-- and is presumably always true for any properly implemented interpreter. +-- 'interpretFinalGlobal' may throw an exception if it is used together with an +-- interpreter that uses 'Polysemy.Internal.Union.weave' improperly. +interpretFinalGlobal + :: forall e a r + . Member (Final IO) r + => (forall x n. e n x -> Strategic IO n x) + -> Sem (e ': r) a + -> Sem r a +interpretFinalGlobal f sem = withWeavingToFinal $ \s wv ins -> do + st <- newMVar s + res <- runMaybeT $ runViaFinalGlobal st wv ins f sem + s' <- readMVar st + return (fromMaybe bomb res <$ s') +{-# INLINE interpretFinalGlobal #-} + +runViaFinalGlobal :: (Member (Final IO) r, Functor f) + => MVar (f ()) + -> (forall x. f (Sem r x) -> IO (f x)) + -> (forall x. f x -> Maybe x) + -> ( forall x n + . e n x + -> Strategic IO n x + ) + -> Sem (e ': r) a + -> MaybeT IO a +runViaFinalGlobal st wv ins f = usingSem $ \u -> case decomp u of + Right (Weaving e s' wv' ex ins') -> + fmap ex $ MaybeT $ fmap getCompose $ runStrategy (f e) + (Compose (Just s')) + ( maybe + (pure (Compose Nothing)) + ( fmap Compose + . runMaybeT + . runViaFinalGlobal st wv ins f + . wv' + ) + . getCompose + ) + (getCompose >=> ins') + Left g -> case prj g of + Just (Weaving (WithWeavingToFinal wav) s' wv' ex' ins') -> + MaybeT $ fmap (fmap ex' . getCompose) $ + wav + (Compose (Just s')) + ( maybe + (pure (Compose Nothing)) + ( fmap Compose + . runMaybeT + . runViaFinalGlobal st wv ins f + . wv' + ) + . getCompose + ) + (getCompose >=> ins') + _ -> MaybeT $ mask $ \restore -> do + -- TODO(KingoftheHomeless): Figure out a solution to polysemy issue #205. + -- Although we're using a different mechanism, the exact same problem manifests + -- here. + s <- takeMVar st + res <- restore (wv (liftSem (hoist (interpretFinalGlobal f) g) <$ s)) + `onException` putMVar st s + putMVar st (() <$ res) + return $ ins res +{-# INLINE runViaFinalGlobal #-} + +bomb :: a +bomb = error + "interpretFinalGlobal: Uninspectable functorial state \ + \still carried a result. You're likely using an interpreter \ + \that uses 'weave' improperly. \ + \See documentation for more information." diff --git a/src/Polysemy/Final/MTL.hs b/src/Polysemy/Final/MTL.hs --- a/src/Polysemy/Final/MTL.hs +++ b/src/Polysemy/Final/MTL.hs @@ -1,10 +1,10 @@ module Polysemy.Final.MTL ( module Polysemy.Final - , runErrorFinal - , runReaderFinal - , runStateFinal - , runWriterFinal + , errorToFinal + , readerToFinal + , stateToEmbed + , writerToFinal ) where import Control.Monad.Error.Class hiding (Error) @@ -24,64 +24,64 @@ -- -- /Beware/: Effects that aren't interpreted in terms of the final -- monad will have local state semantics in regards to 'Error' effects --- interpreted this way. See 'interpretFinal'. -runErrorFinal :: (Member (Final m) r, MonadError e m) - => Sem (Error e ': r) a - -> Sem r a -runErrorFinal = interpretFinal $ \case +-- interpreted this way. See 'Final'. +errorToFinal :: (Member (Final m) r, MonadError e m) + => Sem (Error e ': r) a + -> Sem r a +errorToFinal = interpretFinal $ \case Throw e -> pure $ throwError e Catch m h -> do m' <- runS m h' <- bindS h - s <- getInitialStateS + s <- getInitialStateS pure $ m' `catchError` (h' . (<$ s)) -{-# INLINE runErrorFinal #-} +{-# INLINE errorToFinal #-} ----------------------------------------------------------------------------- -- | Run a 'Reader' effect through a final 'MonadReader' -- -- /Beware/: Effects that aren't interpreted in terms of the final -- monad will have local state semantics in regards to 'Reader' effects --- interpreted this way. See 'interpretFinal'. -runReaderFinal :: (Member (Final m) r, MonadReader i m) - => Sem (Reader i ': r) a - -> Sem r a -runReaderFinal = interpretFinal $ \case +-- interpreted this way. See 'Final'. +readerToFinal :: (Member (Final m) r, MonadReader i m) + => Sem (Reader i ': r) a + -> Sem r a +readerToFinal = interpretFinal $ \case Ask -> liftS ask Local f m -> do m' <- runS m pure $ local f m' -{-# INLINE runReaderFinal #-} +{-# INLINE readerToFinal #-} ----------------------------------------------------------------------------- --- | Run a 'State' effect through a 'MonadState' +-- | Run a 'State' effect in terms of an underlying 'MonadState' instance -- --- Despite the name, the target monad need not actually be the final --- monad. The "-Final" suffix reflects that this interpreter --- has the unusual semantics of interpreters that runs +-- Although this is not a 'Final' interpreter, as the target monad need not +-- actually be the final monad, 'stateToEmbed' still possesses the +-- unusual semantics of interpreters that runs -- effects by embedding them into another monad. -- --- /Beware/: Effects that aren't interpreted in terms of the final +-- /Beware/: Effects that aren't interpreted in terms of the embedded -- monad will have local state semantics in regards to 'State' effects --- interpreted this way. See 'interpretFinal'. -runStateFinal :: (Member (Embed m) r, MonadState s m) - => Sem (State s ': r) a - -> Sem r a -runStateFinal = interpret $ \case +-- interpreted this way. See 'Final'. +stateToEmbed :: (Member (Embed m) r, MonadState s m) + => Sem (State s ': r) a + -> Sem r a +stateToEmbed = interpret $ \case Get -> embed get Put s -> embed (put s) -{-# INLINE runStateFinal #-} +{-# INLINE stateToEmbed #-} ----------------------------------------------------------------------------- -- | Run a 'Writer' effect through a final 'MonadWriter' -- -- /Beware/: Effects that aren't interpreted in terms of the final -- monad will have local state semantics in regards to 'Writer' effects --- interpreted this way. See 'interpretFinal'. -runWriterFinal :: (Member (Final m) r, MonadWriter o m) - => Sem (Writer o ': r) a - -> Sem r a -runWriterFinal = interpretFinal $ \case +-- interpreted this way. See 'Final'. +writerToFinal :: (Member (Final m) r, MonadWriter o m) + => Sem (Writer o ': r) a + -> Sem r a +writerToFinal = interpretFinal $ \case Tell s -> liftS (tell s) Listen m -> do m' <- runS m @@ -94,4 +94,4 @@ t <- m' let f = maybe id fst (inspect ins t) pure (fmap snd t, f) -{-# INLINE runWriterFinal #-} +{-# INLINE writerToFinal #-} diff --git a/src/Polysemy/Final/More.hs b/src/Polysemy/Final/More.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Final/More.hs @@ -0,0 +1,32 @@ +module Polysemy.Final.More where + +import Polysemy +import Polysemy.Internal +import Polysemy.Internal.Union +import Polysemy.Final + +------------------------------------------------------------------------------ +-- | Run a @'Final' ('Sem' r)@ effect if the remaining effect stack is @r@. +-- +-- This is sometimes useful for interpreters that make use of +-- 'reinterpret', 'raiseUnder', or any of their friends. +runFinalSem :: Sem (Final (Sem r) ': r) a -> Sem r a +runFinalSem = usingSem $ \u -> case decomp u of + Right (Weaving (WithWeavingToFinal wav) s wv ex ins) -> + ex <$> wav s (runFinalSem . wv) ins + Left g -> liftSem (hoist runFinalSem g) +{-# INLINE runFinalSem #-} + +------------------------------------------------------------------------------ +-- | Run a @'Final' m@ effect by providing an explicit lowering function. +-- +-- /Beware/: The lowering function may be invoked multiple times, so +-- __don't do any initialization work inside the lowering function__: +-- it will be duplicated. +lowerFinal :: Member (Embed m) r + => (forall x. Sem r x -> m x) + -> Sem (Final m ': r) a + -> Sem r a +-- TODO(KingoftheHomeless): Write everything out for efficiency? +lowerFinal f = runFinalSem . finalToFinal embed f . raiseUnder +{-# INLINE lowerFinal #-} diff --git a/src/Polysemy/Final/NonDet.hs b/src/Polysemy/Final/NonDet.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Final/NonDet.hs @@ -0,0 +1,28 @@ +module Polysemy.Final.NonDet + ( + module Polysemy.NonDet + , nonDetToFinal + ) where + +import Control.Applicative + +import Polysemy +import Polysemy.NonDet +import Polysemy.Final + +----------------------------------------------------------------------------- +-- | Run an 'NonDet' effect through a final 'Alternative' +-- +-- /Beware/: Effects that aren't interpreted in terms of the final +-- monad will have local state semantics in regards to 'NonDet' effects +-- interpreted this way. See 'Final'. +nonDetToFinal :: (Member (Final m) r, Alternative m) + => Sem (NonDet ': r) a + -> Sem r a +nonDetToFinal = interpretFinal $ \case + Empty -> pure empty + Choose left right -> do + left' <- runS left + right' <- runS right + pure $ left' <|> right' +{-# INLINE nonDetToFinal #-} diff --git a/src/Polysemy/Final/Resource.hs b/src/Polysemy/Final/Resource.hs deleted file mode 100644 --- a/src/Polysemy/Final/Resource.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Polysemy.Final.Resource - ( - module Polysemy.Resource - , module Polysemy.Final - , runResourceFinal - ) where - -import qualified Control.Exception as X -import Polysemy -import Polysemy.Resource -import Polysemy.Final - - ------------------------------------------------------------------------------- --- | Run a 'Resource' effect in terms of 'X.bracket' through final 'IO' --- --- This can be used as an alternative to 'runResourceInIO' --- --- /Beware/: Effects that aren't interpreted in terms of 'IO' --- will have local state semantics in regards to 'Resource' effects --- interpreted this way. See 'interpretFinal'. --- --- Notably, unlike 'runResourceBase', 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./ --- --- Prefer 'runResourceBase' unless it's unsafe or inefficient in the context of --- your application. -runResourceFinal :: Member (Final IO) r - => Sem (Resource ': r) a - -> Sem r a -runResourceFinal = interpretFinal $ \case - Bracket alloc dealloc use -> do - a <- runS alloc - d <- bindS dealloc - u <- bindS use - pure $ X.bracket a d u - - BracketOnError alloc dealloc use -> do - a <- runS alloc - d <- bindS dealloc - u <- bindS use - pure $ X.bracketOnError a d u -{-# INLINE runResourceFinal #-} diff --git a/src/Polysemy/Fresh.hs b/src/Polysemy/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Fresh.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TemplateHaskell, Trustworthy #-} +module Polysemy.Fresh + (-- * Effect + Fresh(..) + + -- * Actions + , fresh + + -- * Interpretations + , freshToIO + + -- * Unsafe Interpretations + , runFreshEnumUnsafe + , runFreshUnsafePerformIO + ) where + +import Data.Unique + +import Polysemy.Internal +import Polysemy.Internal.Union +import System.IO.Unsafe (unsafePerformIO) +import Polysemy +import Polysemy.State + +----------------------------------------------------------------------------- +-- | An effect for creating unique objects which may be used as references, +-- a la 'Unique'. Polymorphic code making use of 'Fresh' is expected +-- to place constraints upon @uniq@ as necessary. +-- +-- Any interpreter for 'Fresh' has the responsibilty of ensuring +-- that any call to 'fresh' produces an object that /never/ +-- compares equal to an object produced by a previous call to 'fresh'. +data Fresh uniq m a where + Fresh :: Fresh uniq m uniq + +makeSem ''Fresh + +----------------------------------------------------------------------------- +-- | Runs a 'Fresh' effect through generating 'Unique's using 'IO'. +freshToIO :: Member (Embed IO) r + => Sem (Fresh Unique ': r) a + -> Sem r a +freshToIO = interpret $ \Fresh -> embed newUnique +{-# INLINE freshToIO #-} + +----------------------------------------------------------------------------- +-- | Run a 'Fresh' effect purely by specifying an 'Enum' to be used as the +-- type of unique objects. +-- +-- __Beware:__ This is safe only if: +-- +-- 1. This is run after all interpreters which may revert local state +-- or produce multiple, inconsistent instances of local state. +-- This includes interpreters that may backtrack or produce multiple results +-- (such as 'Polysemy.Error.runError' or 'Polysemy.NonDet.runNonDet'). +-- +-- 2. You don't use any interpreter which may cause the final monad +-- to revert local state or produce multiple, inconsistent instances of local +-- state. This includes certain 'Polysemy.Final.Final'/@lower-@ interpeters +-- such as 'Polysemy.Error.lowerError' or 'Polysemy.Final.MTL.errorToFinal', +-- as well as interpreters for 'Polysemy.Async.Async'. +-- +-- Prefer 'freshToIO' whenever possible. +-- If you can't use 'runFreshEnumUnsafe' safely, nor use 'freshToIO', consider +-- 'runFreshUnsafePerformIO'. +runFreshEnumUnsafe :: forall n a r + . Enum n + => Sem (Fresh n ': r) a + -> Sem r a +runFreshEnumUnsafe = + (fmap snd .) + $ (runState @n (toEnum 0) .) + $ reinterpret + $ \Fresh -> do + s <- get + put $! succ s + return s +{-# INLINE runFreshEnumUnsafe #-} + +----------------------------------------------------------------------------- +-- | Runs a 'Fresh' effect through generating 'Unique's using +-- 'unsafePerformIO'. +-- +-- Ironically, despite the fact that this uses 'unsafePerformIO', and +-- 'runFreshUnsafe' uses no unsafe operations whatsoever, this is still +-- typically safer to use than 'runFreshUnsafe', although 'runFreshUnsafe' +-- is perhaps more efficient. +-- +-- The worst thing that this particular use of 'unsafePerformIO' could result +-- in is the loss of referential transparency, as rerunning an interpreter stack +-- using 'runFreshUnsafePerformIO' will create different 'Unique's. This should +-- never matter. +-- +-- This could be potentially be less efficient than 'runFreshUnsafe'. +-- +-- If you ever observe that multiple invocations of 'fresh' produce the same +-- 'Unique' under 'runFreshUnsafePerformIO', then open an issue over at the +-- GitHub repository. +runFreshUnsafePerformIO :: Sem (Fresh Unique ': r) a + -> Sem r a +runFreshUnsafePerformIO = usingSem $ \u -> + case decomp u of + Right (Weaving Fresh s _ ex _) -> do + let !uniq = unsafePerformIO (newUnique' u) + {-# NOINLINE uniq #-} + pure $ ex (uniq <$ s) + Left g -> liftSem (hoist runFreshUnsafePerformIO g) +-- KingoftheHomeless: I've tried very hard to prevent optimizations from +-- sharing the call to 'unsafePerformIO'. +-- The inlining of 'interpret' is so that I can give +-- 'u' to 'newUnique'', and thus prevent 'uniq' from floating outside the +-- lambda. This interpreter might even be safe to INLINE, but I'm not taking +-- any chances. +{-# NOINLINE runFreshUnsafePerformIO #-} + +newUnique' :: Union (Fresh Unique ': r) (Sem (Fresh Unique ': r)) a -> IO Unique +newUnique' (Union _ _) = newUnique +{-# NOINLINE newUnique' #-} diff --git a/src/Polysemy/IdempotentLowering.hs b/src/Polysemy/IdempotentLowering.hs --- a/src/Polysemy/IdempotentLowering.hs +++ b/src/Polysemy/IdempotentLowering.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ImpredicativeTypes #-} - +-- | =__Unless you absolutely have to use explicit lowering functions, use "Polysemy.Final" instead__ module Polysemy.IdempotentLowering ( (.@!) , nat diff --git a/src/Polysemy/Reader/More.hs b/src/Polysemy/Reader/More.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Reader/More.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RecursiveDo #-} +module Polysemy.Reader.More + ( + module Polysemy.Reader + -- * Interpretations + , runReaderFixSem + ) where + +import Polysemy +import Polysemy.Reader +import Polysemy.Fixpoint + +------------------------------------------------------------------------------ +-- | Runs a 'Reader' effect by running a monadic action /once/, after the +-- 'Sem' has completed, and then providing the result to each request +-- recursively. +runReaderFixSem :: forall i r a + . Member Fixpoint r + => Sem r i + -> Sem (Reader i ': r) a + -> Sem r a +runReaderFixSem m sem = do + rec + a <- runReader i sem + i <- m + return a +{-# INLINE runReaderFixSem #-} diff --git a/src/Polysemy/RevState.hs b/src/Polysemy/RevState.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/RevState.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE RecursiveDo, TemplateHaskell #-} +module Polysemy.RevState + ( -- * Effect + RevState (..) + + -- * Actions + , revState + , revGet + , revPut + , revModify + + -- * Interpretations + , runRevState + , runLazyRevState + ) where + +import Control.Monad.Fix + +import Polysemy +import Polysemy.Fixpoint +import Polysemy.Internal +import Polysemy.Internal.Union + +------------------------------------------------------------------------------ +-- | A 'Polysemy.State.State' effect for threading state /backwards/ instead +-- of forwards through a computation. +newtype RevState s m a where + RevState :: (s -> (s, a)) -> RevState s m a + +makeSem_ ''RevState + + +------------------------------------------------------------------------------ +-- | Gets the state as sent from the next call to 'revState' +-- \/ 'revPut' \/ 'revModify', use it, and send a new state into the past. +revState :: forall s a r + . Member (RevState s) r + => (s -> (s, a)) + -> Sem r a + +------------------------------------------------------------------------------ +-- | Gets the state as sent from the next call to 'revState' \/ 'revPut' +-- \/ 'revModify'. +revGet :: forall s r + . Member (RevState s) r + => Sem r s +revGet = revState $ \s -> (s, s) + +------------------------------------------------------------------------------ +-- | Sends a new state into the past. +revPut :: forall s r + . Member (RevState s) r + => Sem r s +revPut = revState $ \s -> (s, s) + +------------------------------------------------------------------------------ +-- | Gets the state as sent from the next call to 'revState' +-- \/ 'revModify' \/ 'revPut', modify it, and return it into the past. +revModify :: forall s r + . Member (RevState s) r + => (s -> s) + -> Sem r () +revModify f = revState $ \s -> (f s, ()) + + +------------------------------------------------------------------------------ +-- | Run a 'RevState' effect with local state that is propagated /backwards/ +-- through the computation, from last action to first. +runRevState :: Member Fixpoint r + => s + -> Sem (RevState s ': r) a + -> Sem r (s, a) +runRevState s = + (`runRevStateT` s) + . runRevStateInC + +------------------------------------------------------------------------------ +-- | Run a 'RevState' effect with local state that is lazily propagated +-- /backwards/ through the computation, from last action to first. +runLazyRevState :: Member Fixpoint r + => s + -> Sem (RevState s ': r) a + -> Sem r (s, a) +runLazyRevState s = + (`runLazyRevStateT` s) + . runLazyRevStateInC + +newtype RevStateT s m a = RevStateT { runRevStateT :: s -> m (s, a) } + deriving (Functor) + +instance MonadFix m => Applicative (RevStateT s m) where + pure a = RevStateT $ \s -> pure (s, a) + ff <*> fa = RevStateT $ \s -> do + rec + (s'', f) <- runRevStateT ff s' + (s', a) <- runRevStateT fa s + return (s'', f a) + fa *> fb = fa >>= \_ -> fb + +instance MonadFix m => Monad (RevStateT s m) where + m >>= f = RevStateT $ \s -> do + rec + (s'', a) <- runRevStateT m s' + (s', b) <- runRevStateT (f a) s + return (s'', b) + +newtype LazyRevStateT s m a = LazyRevStateT { runLazyRevStateT :: s -> m (s, a) } + deriving (Functor) + +instance MonadFix m => Applicative (LazyRevStateT s m) where + pure a = LazyRevStateT $ \s -> pure (s, a) + ff <*> fa = LazyRevStateT $ \s -> do + rec + ~(s'', f) <- runLazyRevStateT ff s' + ~(s', a) <- runLazyRevStateT fa s + return (s'', f a) + fa *> fb = fa >>= \_ -> fb + +instance MonadFix m => Monad (LazyRevStateT s m) where + m >>= f = LazyRevStateT $ \s -> do + rec + ~(s'', a) <- runLazyRevStateT m s' + ~(s', b) <- runLazyRevStateT (f a) s + return (s'', b) + +runRevStateInC :: Member Fixpoint r + => Sem (RevState s ': r) a + -> RevStateT s (Sem r) a +runRevStateInC = usingSem $ \u -> RevStateT $ \s -> + case decomp u of + Right (Weaving (RevState f) st _ ex _) -> + return $ (ex . (<$ st)) <$> f s + Left g -> + liftSem $ + weave + (s, ()) + (uncurry runRevState) + (Just . snd) + g + +runLazyRevStateInC :: Member Fixpoint r + => Sem (RevState s ': r) a + -> LazyRevStateT s (Sem r) a +runLazyRevStateInC = usingSem $ \u -> LazyRevStateT $ \s -> + case decomp u of + Right (Weaving (RevState f) st _ ex _) -> + return $ (ex . (<$ st)) <$> f s + Left g -> + liftSem $ + weave + (s, ()) + (uncurry runLazyRevState) + (Just . snd) + g diff --git a/src/Polysemy/Shift.hs b/src/Polysemy/Shift.hs --- a/src/Polysemy/Shift.hs +++ b/src/Polysemy/Shift.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} module Polysemy.Shift ( module Polysemy.Cont @@ -16,7 +16,7 @@ -- * Interpretations , runShiftPure , runShiftM - , runShiftFinal + , shiftToFinal , runShiftWithCPure , runShiftWithCM @@ -75,7 +75,7 @@ -- The final return type is wrapped in a 'Maybe' due to the fact that -- any continuation may fail locally. -- --- This is a safe variant of 'runContUnsafe', as this may only be used +-- This is a safe variant of 'runShiftUnsafe', as this may only be used -- as the final interpreter before 'run'. runShiftPure :: Sem '[Shift (Ref (Sem '[]) (Maybe a)) a] a -> Sem '[] (Maybe a) @@ -89,8 +89,8 @@ -- The final return type is wrapped in a 'Maybe' due to the fact that -- any continuation may fail locally. -- --- This is a safe variant of 'runContUnsafe', as this may only be used --- as the final interpreter before 'run'. +-- This is a safe variant of 'runShiftUnsafe', as this may only be used +-- as the final interpreter before 'runM'. runShiftM :: Sem '[Shift (Ref (Sem '[Embed m]) (Maybe a)) a, Embed m] a -> Sem '[Embed m] (Maybe a) runShiftM = runShiftUnsafe @@ -101,12 +101,12 @@ -- -- /Beware/: Effects that aren't interpreted in terms of the final monad -- will have local state semantics in regards to 'Shift' effects --- interpreted this way. See 'interpretFinal'. -runShiftFinal :: forall s m a r +-- interpreted this way. See 'Final'. +shiftToFinal :: forall s m a r . (Member (Final (ContT (Maybe s) m)) r, Monad m) => Sem (Shift (Ref m (Maybe s)) s ': r) a -> Sem r a -runShiftFinal = interpretFinal $ \case +shiftToFinal = interpretFinal $ \case Trap main -> do main' <- bindS main s <- getInitialStateS @@ -125,7 +125,7 @@ Inspector ins <- getInspectorS liftS $ ContT $ \c -> runContT main' (pure . ins) >>= c -{-# INLINE runShiftFinal #-} +{-# INLINE shiftToFinal #-} ----------------------------------------------------------------------------- -- | Runs a 'Shift' effect by explicitly providing a final @@ -238,8 +238,8 @@ -- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail -- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'. -- --- __You should therefore use 'runShift' /after/ running all interpreters for --- your higher-order effects.__ +-- __You should therefore use 'runShiftUnsafe' /after/ running all__ +-- __interpreters for your higher-order effects.__ runShiftUnsafe :: Sem (Shift (Ref (Sem r) (Maybe a)) a ': r) a -> Sem r (Maybe a) runShiftUnsafe = runShiftWithCUnsafe (pure . Just) {-# INLINE runShiftUnsafe #-} @@ -255,8 +255,8 @@ -- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail -- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'. -- --- __You should therefore use 'runShiftWithC' /after/ running all interpreters for --- your higher-order effects.__ +-- __You should therefore use 'runShiftWithCUnsafe' /after/ running all__ +-- __interpreters for your higher-order effects.__ runShiftWithCUnsafe :: forall s a r. (a -> Sem r (Maybe s)) -> Sem (Shift (Ref (Sem r) (Maybe s)) s ': r) a @@ -278,8 +278,8 @@ -- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail -- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'. -- --- __You should therefore use 'runShift' /after/ running all interpreters for --- your higher-order effects.__ +-- __You should therefore use 'runContShiftUnsafe' /after/ running all__ +-- __interpreters for your higher-order effects.__ runContShiftUnsafe :: Sem ( Cont (Ref (Sem r) (Maybe a)) ': Shift (Ref (Sem r) (Maybe a)) a ': r) a @@ -299,8 +299,8 @@ -- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail -- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'. -- --- __You should therefore use 'runShift' /after/ running all interpreters for --- your higher-order effects.__ +-- __You should therefore use 'runContShiftWithCUnsafe' /after/ running all__ +-- __interpreters for your higher-order effects.__ runContShiftWithCUnsafe :: forall s a r. (a -> Sem r (Maybe s)) -> Sem ( Cont (Ref (Sem r) (Maybe s)) diff --git a/src/Polysemy/Tagged.hs b/src/Polysemy/Tagged.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Tagged.hs @@ -0,0 +1,77 @@ +module Polysemy.Tagged + ( + -- * Effect + Tagged (..) + + -- * Actions + , tag + + -- * Interpretations + , untag + , retag + ) where + +import Polysemy +import Polysemy.Internal +import Polysemy.Internal.Union + + +------------------------------------------------------------------------------ +-- | An effect for annotating effects and disambiguating identical effects. +newtype Tagged k e m a where + Tagged :: forall k e m a. e m a -> Tagged k e m a + +------------------------------------------------------------------------------ +-- | Tag uses of an effect, effectively gaining access to the +-- tagged effect locally. +-- +-- This may be used to create @tagged-@ variants of regular actions. +-- +-- For example (the type applications aren't needed when using @polysemy-plugin@): +-- +-- @ +-- taggedLocal :: forall k i r a +-- . 'Member' ('Tagged' k ('Polysemy.Reader.Reader' i)) r +-- => (i -> i) +-- -> 'Sem' r a +-- -> 'Sem' r a +-- taggedLocal f m = +-- 'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m) +-- @ +-- +tag :: forall k e r a + . Member (Tagged k e) r + => Sem (e ': r) a + -> Sem r a +tag = hoistSem $ \u -> case decomp u of + Right (Weaving e s wv ex ins) -> + injWeaving $ Weaving (Tagged e) s (tag . wv) ex ins + Left g -> hoist tag g +{-# INLINE tag #-} + +------------------------------------------------------------------------------ +-- | Run a @'Tagged' k e@ effect through reinterpreting it to @e@ +untag :: forall k e r a + . Sem (Tagged k e ': r) a + -> Sem (e ': r) a +-- TODO(KingoftheHomeless): I think this is safe to replace with 'unsafeCoerce', +-- but doing so probably worsens performance, as it hampers optimizations. +-- Once GHC 8.10 rolls out, I will benchmark and compare. +untag = hoistSem $ \u -> case decompCoerce u of + Right (Weaving (Tagged e) s wv ex ins) -> + Union SZ (Weaving e s (untag . wv) ex ins) + Left g -> hoist untag g +{-# INLINE untag #-} + +------------------------------------------------------------------------------ +-- | Transform a @'Tagged' k1 e@ effect into a @'Tagged' k2 e@ effect +retag :: forall k1 k2 e r a + . Member (Tagged k2 e) r + => Sem (Tagged k1 e ': r) a + -> Sem r a +retag = hoistSem $ \u -> case decomp u of + Right (Weaving (Tagged e) s wv ex ins) -> + injWeaving $ Weaving (Tagged e) s (retag . wv) ex ins + Left g -> hoist retag g +{-# INLINE retag #-} + diff --git a/test/ContSpec.hs b/test/ContSpec.hs --- a/test/ContSpec.hs +++ b/test/ContSpec.hs @@ -68,7 +68,7 @@ (`S.runState` 1) . runM . runContM - . runStateFinal + . stateToEmbed $ stateTest test5 :: IO (Int, Int) @@ -95,7 +95,7 @@ . runFinal . runTraceList . runReader "" - . runContFinal + . contToFinal $ do j <- local (++".") $ callCC $ \c -> do j <- ask @@ -113,8 +113,8 @@ ($ 1) . (`C.runContT` pure) . runFinal - . runReaderFinal - . runContFinal + . readerToFinal + . contToFinal $ do callCC $ \c -> local (+1) (c ()) @@ -134,14 +134,14 @@ test3 `shouldBe` Right () describe "runContM" $ do - it "should have global state semantics with runStateFinal" $ + it "should have global state semantics with stateToEmbed" $ test4 `shouldBe` (3, 3) - it "should have global state semantics with runStateInIORef" $ do + it "should have global state semantics with runStateIORef" $ do r <- test5 r `shouldBe` (3, 3) - describe "runContFinal" $ do + describe "contToFinal" $ do it "should work just like runContPure/M." $ test7 `shouldBe` (["Nothing", "at", "all."], ".") diff --git a/test/FinalSpec.hs b/test/FinalSpec.hs --- a/test/FinalSpec.hs +++ b/test/FinalSpec.hs @@ -8,83 +8,18 @@ import Control.Monad.Writer hiding (MonadWriter(..), censor) import Data.Either -import Data.IORef import Polysemy -import Polysemy.Trace -import Polysemy.State - -import Polysemy.Final.Async -import Polysemy.Final.Fixpoint -import Polysemy.Final.Error - +import Polysemy.Error import Polysemy.Reader import Polysemy.Writer +import Polysemy.State +import Polysemy.Trace import Polysemy.Final.MTL -data Node a = Node a (IORef (Node a)) - -mkNode :: (Member (Embed IO) r, Member Fixpoint r) - => a - -> Sem r (Node a) -mkNode a = mdo - let nd = Node a p - p <- embed $ newIORef nd - return nd - -linkNode :: Member (Embed IO) r - => Node a - -> Node a - -> Sem r () -linkNode (Node _ r) b = - embed $ writeIORef r b - -readNode :: Node a -> a -readNode (Node a _) = a - -follow :: Member (Embed IO) r - => Node a - -> Sem r (Node a) -follow (Node _ ref) = embed $ readIORef ref - -test1 :: IO (Either Int (String, Int, Maybe Int)) -test1 = do - ref <- newIORef "abra" - runFinal - . runStateIORef ref -- Order of these interpreters don't matter - . runErrorInIOFinal - . runFixpointFinal - . runAsyncFinal - $ do - n1 <- mkNode 1 - n2 <- mkNode 2 - linkNode n2 n1 - aw <- async $ do - linkNode n1 n2 - modify (++"hadabra") - n2' <- follow n2 - throw (readNode n2') - m <- await aw `catch` (\s -> return $ Just s) - n1' <- follow n1 - s <- get - return (s, readNode n1', m) - -test2 :: IO ([String], Either () ()) -test2 = - runFinal - . runTraceList - . runErrorInIOFinal - . runAsyncFinal - $ do - fut <- async $ do - trace "Global state semantics?" - catch (trace "What's that?" *> throw ()) (\_ -> return ()) - _ <- await fut - trace "Nothing at all." - -test3 :: Int -> (Either Bool (([String], Int), Int), [Int]) -test3 i = +test1 :: Int -> (Either Bool (([String], Int), Int), [Int]) +test1 i = let g = do j <- ask @@ -101,11 +36,12 @@ . runExceptT . (`runStateT` 0) . runFinal + . embedToFinal . runTraceList -- Order of these interpreters don't matter - . runWriterFinal - . runStateFinal - . runErrorFinal - . runReaderFinal + . writerToFinal + . stateToEmbed + . errorToFinal + . readerToFinal $ do ask >>= put res <- @@ -119,25 +55,9 @@ spec :: Spec spec = do - describe "Final on IO" $ do - it "should terminate successfully, with no exceptions,\ - \ and have global state semantics on State." $ do - res1 <- test1 - res1 `shouldSatisfy` isRight - case res1 of - Right (s, i, j) -> do - i `shouldBe` 2 - j `shouldBe` Just 1 - s `shouldBe` "abrahadabra" - _ -> pure () - - it "should treat trace with local state semantics" $ do - res2 <- test2 - res2 `shouldBe` (["Nothing at all."], Right ()) - describe "Final with MTL" $ do it "should all work without issue" $ do - let (r, written) = test3 0 + let (r, written) = test1 0 written `shouldBe` [1,0,777,7] r `shouldSatisfy` isRight case r of @@ -148,12 +68,12 @@ _ -> pure () it "should fail, dropping trace, state, and censoring" $ do - let (r, written) = test3 1 + let (r, written) = test1 1 r `shouldBe` Left True written `shouldBe` [2, 1] it "should catch exception, locally dropping trace and state, and not censor" $ do - let (r, written) = test3 2 + let (r, written) = test1 2 written `shouldBe` [3,2,2] r `shouldSatisfy` isRight case r of diff --git a/test/IdempotentLoweringSpec.hs b/test/IdempotentLoweringSpec.hs --- a/test/IdempotentLoweringSpec.hs +++ b/test/IdempotentLoweringSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ImpredicativeTypes #-} - +{-# OPTIONS_GHC -Wno-deprecations #-} module IdempotentLoweringSpec where import Data.IORef diff --git a/test/RevStateSpec.hs b/test/RevStateSpec.hs new file mode 100644 --- /dev/null +++ b/test/RevStateSpec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE RecursiveDo #-} +module RevStateSpec where + +import Test.Hspec + +import Data.Functor.Identity + +import Polysemy +import Polysemy.State +import Polysemy.RevState +import Polysemy.EndState +import Polysemy.Fixpoint + +runStateCircular :: (Member (State s) r, Member Fixpoint r) + => Sem (RevState s ': r) a + -> Sem r (s, a) +runStateCircular sem = runEndState $ do + s <- getEndState + raise $ runRevState s sem + +test :: String +test = + fst + . snd + . runIdentity + . runFinal + . fixpointToFinal + . runState "" + . runStateCircular + $ do + modify (++"time ") + revModify (++"circle") + modify (++"is ") + revModify (++"flat ") + modify (++"a ") + +spec :: Spec +spec = do + describe "runRevState" $ do + it "should thread state backwards \ + \and work together with EndState" $ + test `shouldBe` "time is a flat circle" diff --git a/test/ShiftSpec.hs b/test/ShiftSpec.hs --- a/test/ShiftSpec.hs +++ b/test/ShiftSpec.hs @@ -72,9 +72,10 @@ . (`runStateT` 1) . (`runContT` (pure . Just)) . runFinal - . runStateFinal - . runShiftFinal - . runReaderFinal + . embedToFinal + . stateToEmbed + . shiftToFinal + . readerToFinal $ do shift $ \c -> do _ <- local (+1) (c ()) @@ -111,11 +112,11 @@ test3 `shouldBe` Just (Right ()) describe "runShiftM" $ do - it "should modify multiple times with runStateInIORef" $ do + it "should modify multiple times with runStateIORef" $ do res <- test4 res `shouldBe` Just 4 - describe "runShiftFinal" $ do + describe "shiftToFinal" $ do it "should modify multiple times with runStateFinal\ \ and should be able to apply local to continuation" $ test5 `shouldBe` (Just 10, 10)