polysemy-zoo 0.5.0.1 → 0.6.0.0

raw patch · 28 files changed

+1091/−645 lines, 28 filesdep +contravariantdep +transformersdep ~polysemydep ~polysemy-pluginPVP ok

version bump matches the API change (PVP)

Dependencies added: contravariant, transformers

Dependency ranges changed: polysemy, polysemy-plugin

API changes (from Hackage documentation)

Files

• ChangeLog.md +20/−0
• polysemy-zoo.cabal +19/−9
• src/Polysemy/Capture.hs +5/−5
• src/Polysemy/ConstraintAbsorber/MonadCont.hs +61/−0
• src/Polysemy/Cont.hs +55/−17
• src/Polysemy/Cont/Internal.hs +161/−3
• src/Polysemy/EndState.hs +49/−0
• src/Polysemy/Final.hs +0/−284
• src/Polysemy/Final/Async.hs +0/−38
• src/Polysemy/Final/Error.hs +0/−63
• src/Polysemy/Final/Fixpoint.hs +0/−23
• src/Polysemy/Final/IO.hs +57/−0
• src/Polysemy/Final/IO/Internal.hs +107/−0
• src/Polysemy/Final/MTL.hs +34/−34
• src/Polysemy/Final/More.hs +32/−0
• src/Polysemy/Final/NonDet.hs +28/−0
• src/Polysemy/Final/Resource.hs +0/−45
• src/Polysemy/Fresh.hs +118/−0
• src/Polysemy/IdempotentLowering.hs +1/−1
• src/Polysemy/Reader/More.hs +27/−0
• src/Polysemy/RevState.hs +154/−0
• src/Polysemy/Shift.hs +17/−17
• src/Polysemy/Tagged.hs +77/−0
• test/ContSpec.hs +7/−7
• test/FinalSpec.hs +13/−93
• test/IdempotentLoweringSpec.hs +1/−1
• test/RevStateSpec.hs +42/−0
• test/ShiftSpec.hs +6/−5

@@ -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

@@ -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 <https://github.com/isovector/polysemy-zoo#readme> 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

@@ -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

@@ -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 #-}

@@ -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'.

@@ -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

@@ -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)

@@ -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 #-}

@@ -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)

@@ -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)

@@ -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 #-}

@@ -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 #-}

@@ -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."

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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' #-}

@@ -1,5 +1,5 @@ {-# LANGUAGE ImpredicativeTypes #-}-+-- | =__Unless you absolutely have to use explicit lowering functions, use "Polysemy.Final" instead__ module Polysemy.IdempotentLowering   ( (.@!)   , nat

@@ -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 #-}

@@ -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

@@ -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))

@@ -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 #-}+

@@ -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."], ".") 

@@ -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

@@ -1,5 +1,5 @@ {-# LANGUAGE ImpredicativeTypes #-}-+{-# OPTIONS_GHC -Wno-deprecations #-} module IdempotentLoweringSpec where  import Data.IORef

@@ -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"

@@ -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)