polysemy 1.0.0.0 → 1.1.0.0

raw patch · 27 files changed

+647/−90 lines, 27 filesdep +stmPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

API changes (from Hackage documentation)

Files

• ChangeLog.md +19/−2
• README.md +1/−1
• polysemy.cabal +10/−2
• src/Polysemy.hs +0/−2
• src/Polysemy/Async.hs +1/−1
• src/Polysemy/AtomicState.hs +126/−0
• src/Polysemy/Fail.hs +55/−0
• src/Polysemy/Fail/Type.hs +3/−0
• src/Polysemy/Fixpoint.hs +49/−7
• src/Polysemy/IO.hs +1/−1
• src/Polysemy/Internal.hs +6/−4
• src/Polysemy/Internal/Combinators.hs +6/−3
• src/Polysemy/Internal/Fixpoint.hs +15/−0
• src/Polysemy/Internal/Forklift.hs +12/−12
• src/Polysemy/Internal/TH/Effect.hs +1/−1
• src/Polysemy/Internal/Union.hs +0/−21
• src/Polysemy/Output.hs +65/−2
• src/Polysemy/Resource.hs +1/−1
• src/Polysemy/State.hs +15/−0
• src/Polysemy/Trace.hs +1/−1
• src/Polysemy/Writer.hs +47/−3
• test/AlternativeSpec.hs +0/−13
• test/AsyncSpec.hs +7/−4
• test/FailSpec.hs +25/−0
• test/FixpointSpec.hs +97/−0
• test/OutputSpec.hs +47/−2
• test/WriterSpec.hs +37/−7

@@ -1,5 +1,22 @@ # Changelog for polysemy +## 1.1.0.0 (2019-08-15)++### Breaking Changes++- `MonadFail` is now implemented in terms of `Fail`, instead of `NonDet`(thanks to @KingoftheHomeless)+- `State` and `Writer` now have better strictness semantics++### Other Changes++- Added `AtomicState` effect (thanks to @KingoftheHomeless)+- Added `Fail` effect (thanks to @KingoftheHomeless)+- Added `runOutputSem` (thanks to @cnr)+- Added right-associative variants of `runOutputMonoid` and `runWriter` (thanks to @KingoftheHomeless)+- Improved `Fixpoint` so it won't always diverge (thanks to @KingoftheHomeless)+- `makeSem` will now complain if `DataKinds` isn't enabled (thanks to @pepegar)++ ## 1.0.0.0 (2019-07-24)  ### Breaking Changes@@ -30,13 +47,13 @@ - Renamed `runTraceAsOutput` to `traceToOutput` - Renamed `runTraceIO` to `traceToIO` - Renamed `sendM` to `embed` (thanks to @googleson78)-- The `NonDet` effect will no longer perform effects in untaken branches (thanks to @KingoftheHomeless)+- The `NonDet` effect is now higher-order (thanks to @KingoftheHomeless)  ### Other Changes  - Added `evalState` and `evalLazyState` - Added `runNonDetMaybe` (thanks to @KingoftheHomeless)-- Added `nonDetToMaybe` (thanks to @KingoftheHomeless)+- Added `nonDetToError` (thanks to @KingoftheHomeless) - Haddock documentation for smart constructors generated via `makeSem` will no     longer have weird variable names (thanks to @TheMatten) 

@@ -91,7 +91,7 @@  makeSem ''Teletype -teletypeToIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a+teletypeToIO :: Member (Embed IO) r => Sem (Teletype ': r) a -> Sem r a teletypeToIO = interpret $ \case   ReadTTY      -> embed getLine   WriteTTY msg -> embed $ putStrLn msg

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f543f8ca2c4f661f0b6702fb6ec6d7db075660d19bf550e50a04e64c56826913+-- hash: ed739126c69520676b38ca047f46cbddc31813120ceb38b36fe7ac3c0012a606  name:           polysemy-version:        1.0.0.0+version:        1.1.0.0 synopsis:       Higher-order, low-boilerplate, zero-cost free monads. description:    Please see the README on GitHub at <https://github.com/isovector/polysemy#readme> category:       Language@@ -41,9 +41,12 @@   exposed-modules:       Polysemy       Polysemy.Async+      Polysemy.AtomicState       Polysemy.Embed       Polysemy.Embed.Type       Polysemy.Error+      Polysemy.Fail+      Polysemy.Fail.Type       Polysemy.Fixpoint       Polysemy.Input       Polysemy.Internal@@ -78,6 +81,7 @@     , containers >=0.5 && <0.7     , first-class-families >=0.5.0.0 && <0.6     , mtl >=2.2.2 && <3+    , stm >=2 && <3     , syb >=0.7 && <0.8     , template-haskell >=2.12.0.0 && <3     , th-abstraction >=0.3.1.0 && <0.4@@ -113,6 +117,8 @@       AsyncSpec       BracketSpec       DoctestSpec+      FailSpec+      FixpointSpec       FusionSpec       HigherOrderSpec       InspectorSpec@@ -138,6 +144,7 @@     , inspection-testing >=0.4.2 && <0.5     , mtl >=2.2.2 && <3     , polysemy+    , stm >=2 && <3     , syb >=0.7 && <0.8     , template-haskell >=2.12.0.0 && <3     , th-abstraction >=0.3.1.0 && <0.4@@ -171,6 +178,7 @@     , freer-simple     , mtl     , polysemy+    , stm >=2 && <3     , syb >=0.7 && <0.8     , template-haskell >=2.12.0.0 && <3     , th-abstraction >=0.3.1.0 && <0.4

@@ -3,7 +3,6 @@     Sem ()   , Member   , Members-  , LastMember    -- * Running Sem   , run@@ -125,5 +124,4 @@ import Polysemy.Internal.Kind import Polysemy.Internal.TH.Effect import Polysemy.Internal.Tactics-import Polysemy.Internal.Union 

@@ -41,7 +41,7 @@ -- -- @since 1.0.0.0 asyncToIO-    :: LastMember (Embed IO) r+    :: Member (Embed IO) r     => Sem (Async ': r) a     -> Sem r a asyncToIO m = withLowerToIO $ \lower _ -> lower $

@@ -0,0 +1,126 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TemplateHaskell #-}+module Polysemy.AtomicState+  ( -- * Effect+    AtomicState (..)++    -- * Actions+  , atomicState+  , atomicState'+  , atomicGet+  , atomicPut+  , atomicModify+  , atomicModify'++    -- * Interpretations+  , runAtomicStateIORef+  , runAtomicStateTVar+  , atomicStateToState+  ) where+++import Control.Concurrent.STM++import Polysemy+import Polysemy.State++import Data.IORef++data AtomicState s m a where+  AtomicState :: (s -> (s, a)) -> AtomicState s m a+  AtomicGet   :: AtomicState s m s++makeSem_ ''AtomicState++-----------------------------------------------------------------------------+-- | Atomically reads and modifies the state.+atomicState :: forall s a r+             . Member (AtomicState s) r+            => (s -> (s, a))+            -> Sem r a++atomicGet :: forall s r+           . Member (AtomicState s) r+          => Sem r s++-----------------------------------------------------------------------------+-- | A variant of 'atomicState' in which the computation is strict in the new+-- state and return value.+atomicState' :: Member (AtomicState s) r+              => (s -> (s, a))+              -> Sem r a+atomicState' f = do+  -- KingoftheHomeless: return value needs to be forced due to how+  -- 'atomicModifyIORef' is implemented: the computation+  -- (and thus the new state) is forced only once the return value is.+  !a <- atomicState $ \s ->+    case f s of+      v@(!_, _) -> v+  return a+{-# INLINE atomicState' #-}++atomicPut :: Member (AtomicState s) r+          => s+          -> Sem r ()+atomicPut s = do+  !_ <- atomicState $ \_ -> (s, ()) -- strict put with atomicModifyIORef+  return ()+{-# INLINE atomicPut #-}++atomicModify :: Member (AtomicState s) r+             => (s -> s)+             -> Sem r ()+atomicModify f = atomicState $ \s -> (f s, ())+{-# INLINE atomicModify #-}++-----------------------------------------------------------------------------+-- | A variant of 'atomicModify' in which the computation is strict in the+-- new state.+atomicModify' :: Member (AtomicState s) r+              => (s -> s)+              -> Sem r ()+atomicModify' f = do+  !_ <- atomicState $ \s -> let !s' = f s in (s', ())+  return ()+{-# INLINE atomicModify' #-}++------------------------------------------------------------------------------+-- | Run an 'AtomicState' effect by transforming it into atomic operations+-- over an 'IORef'.+runAtomicStateIORef :: Member (Embed IO) r+                    => IORef s+                    -> Sem (AtomicState s ': r) a+                    -> Sem r a+runAtomicStateIORef ref = interpret $ \case+  AtomicState f -> embed $ atomicModifyIORef ref f+  AtomicGet     -> embed $ readIORef ref+{-# INLINE runAtomicStateIORef #-}++------------------------------------------------------------------------------+-- | Run an 'AtomicState' effect by transforming it into atomic operations+-- over a 'TVar'.+runAtomicStateTVar :: Member (Embed IO) r+                   => TVar s+                   -> Sem (AtomicState s ': r) a+                   -> Sem r a+runAtomicStateTVar tvar = interpret $ \case+  AtomicState f -> embed $ atomically $ do+    (s', a) <- f <$> readTVar tvar+    writeTVar tvar s'+    return a+  AtomicGet -> embed $ readTVarIO tvar+{-# INLINE runAtomicStateTVar #-}++------------------------------------------------------------------------------+-- | Transform an 'AtomicState' effect to a 'State' effect, discarding+-- the notion of atomicity.+atomicStateToState :: Member (State s) r+                   => Sem (AtomicState s ': r) a+                   -> Sem r a+atomicStateToState = interpret $ \case+  AtomicState f -> do+    (s', a) <- f <$> get+    put s'+    return a+  AtomicGet -> get+{-# INLINE atomicStateToState #-}

@@ -0,0 +1,55 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Polysemy.Fail+  ( -- * Effect+    Fail(..)++    -- * Interpretations+  , runFail+  , failToError+  , failToNonDet+  , failToEmbed+  ) where++import Control.Applicative+import Polysemy+import Polysemy.Fail.Type+import Polysemy.Error+import Polysemy.NonDet+import Control.Monad.Fail as Fail++------------------------------------------------------------------------------+-- | Run a 'Fail' effect purely.+runFail :: Sem (Fail ': r) a+        -> Sem r (Either String a)+runFail = runError . reinterpret (\(Fail s) -> throw s)+{-# INLINE runFail #-}++------------------------------------------------------------------------------+-- | Transform a 'Fail' effect into an @'Error' e@ effect,+-- through providing a function for transforming any failure+-- to an exception.+failToError :: Member (Error e) r+            => (String -> e)+            -> Sem (Fail ': r) a+            -> Sem r a+failToError f = interpret $ \(Fail s) -> throw (f s)+{-# INLINE failToError #-}++------------------------------------------------------------------------------+-- | Transform a 'Fail' effect into a 'NonDet' effect,+-- through mapping any failure to 'empty'.+failToNonDet :: Member NonDet r+             => Sem (Fail ': r) a+             -> Sem r a+failToNonDet = interpret $ \(Fail _) -> empty+{-# INLINE failToNonDet #-}++------------------------------------------------------------------------------+-- | Run a 'Fail' effect in terms of an underlying 'MonadFail' instance.+failToEmbed :: forall m a r+             . (Member (Embed m) r, MonadFail m)+            => Sem (Fail ': r) a+            -> Sem r a+failToEmbed = interpret $ \(Fail s) -> embed @m (Fail.fail s)+{-# INLINE failToEmbed #-}

@@ -0,0 +1,3 @@+module Polysemy.Fail.Type where++newtype Fail m a = Fail String

@@ -9,24 +9,62 @@   ) where  import Control.Monad.Fix+import Data.Maybe+ import Polysemy import Polysemy.Internal.Fixpoint - ------------------------------------------------------------------------------ -- | Run a 'Fixpoint' effect purely.+--+-- __Note__: This is subject to the same traps as 'MonadFix' instances for+-- monads with failure: this will throw an exception if you try to recursively use+-- the result of a failed computation in an action whose effect may be observed+-- even though the computation failed.+--+-- For example, the following program will throw an exception upon evaluating the+-- final state:+-- @+-- bad :: (Int, Either () Int)+-- bad =+--    'run'+--  . 'runFixpoint' 'run'+--  . 'Polysemy.State.runLazyState' @Int 1+--  . 'Polysemy.Error.runError'+--  $ mdo+--   'Polysemy.State.put' a+--   a <- 'Polysemy.Error.throw' ()+--   return a+-- @+--+-- 'runFixpoint' also operates under the assumption that any effectful+-- state which can't be inspected using 'Polysemy.Inspector' can't contain any+-- values. This is true for all interpreters featured in this package,+-- and is presumably always true for any properly implemented interpreter.+-- 'runFixpoint' may throw an exception if it is used together with an+-- interpreter that uses 'Polysemy.Internal.Union.weave' improperly.+--+-- If 'runFixpoint' throws an exception for you, and it can't+-- be due to any of the above, then open an issue over at the+-- GitHub repository for polysemy. runFixpoint     :: (∀ x. Sem r x -> x)     -> Sem (Fixpoint ': r) a     -> Sem r a runFixpoint lower = interpretH $ \case   Fixpoint mf -> do-    c <- bindT mf-    pure $ fix $ lower . runFixpoint lower . c-+    c   <- bindT mf+    s   <- getInitialStateT+    ins <- getInspectorT+    pure $ fix $ \fa ->+      lower . runFixpoint lower . c $+        fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s+{-# INLINE runFixpoint #-}  ------------------------------------------------------------------------------ -- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.+--+-- __Note__: 'runFixpointM' is subject to the same caveats as 'runFixpoint'. runFixpointM     :: ( MonadFix m        , Member (Embed m) r@@ -36,6 +74,10 @@     -> Sem r a runFixpointM lower = interpretH $ \case   Fixpoint mf -> do-    c <- bindT mf-    embed $ mfix $ lower . runFixpointM lower . c-+    c   <- bindT mf+    s   <- getInitialStateT+    ins <- getInspectorT+    embed $ mfix $ \fa ->+      lower . runFixpointM lower . c $+        fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s+{-# INLINE runFixpointM #-}

@@ -55,7 +55,7 @@ -- @since 1.0.0.0 lowerEmbedded     :: ( MonadIO m-       , LastMember (Embed IO) r+       , Member (Embed IO) r        )     => (forall x. m x -> IO x)  -- ^ The means of running this monad.     -> Sem (Embed m ': r) a

@@ -33,8 +33,9 @@ import Control.Monad.IO.Class import Data.Functor.Identity import Data.Kind-import Polysemy.Internal.Fixpoint import Polysemy.Embed.Type+import Polysemy.Fail.Type+import Polysemy.Internal.Fixpoint import Polysemy.Internal.NonDet import Polysemy.Internal.PluginLookup import Polysemy.Internal.Union@@ -271,9 +272,10 @@   mzero = empty   mplus = (<|>) --- | @since 0.2.1.0-instance (Member NonDet r) => MonadFail (Sem r) where-  fail = const empty+-- | TODO: @since _+instance (Member Fail r) => MonadFail (Sem r) where+  fail = send . Fail+  {-# INLINE fail #-}   ------------------------------------------------------------------------------

@@ -22,8 +22,10 @@   , lazilyStateful   ) where +import           Control.Monad import qualified Control.Monad.Trans.State.Lazy as LS import qualified Control.Monad.Trans.State.Strict as S+import qualified Data.Tuple as S (swap) import           Polysemy.Internal import           Polysemy.Internal.CustomErrors import           Polysemy.Internal.Tactics@@ -88,10 +90,11 @@     -> Sem (e ': r) a     -> Sem r (s, a) interpretInStateT f s (Sem m) = Sem $ \k ->-  fmap swap $ flip S.runStateT s $ m $ \u ->+  (S.swap <$!>) $ flip S.runStateT s $ m $ \u ->     case decomp u of         Left x -> S.StateT $ \s' ->-          k . fmap swap+              (S.swap <$!>)+            . k             . weave (s', ())                     (uncurry $ interpretInStateT f)                     (Just . snd)@@ -130,7 +133,7 @@     -> s     -> Sem (e ': r) a     -> Sem r (s, a)-stateful f = interpretInStateT $ \e -> S.StateT $ fmap swap . f e+stateful f = interpretInStateT $ \e -> S.StateT $ (S.swap <$!>) . f e {-# INLINE[3] stateful #-}  

@@ -7,3 +7,18 @@ data Fixpoint m a where   Fixpoint :: (a -> m a) -> Fixpoint m a ++------------------------------------------------------------------------------+-- | The error used in 'Polysemy.Fixpoint.runFixpoint' and+-- 'Polysemy.Fixpoint.runFixpointM' when the result of a failed computation+-- is recursively used and somehow visible. You may use this for your own+-- 'Fixpoint' interpreters. The argument should be the name of the interpreter.+bomb :: String -> a+bomb str = error $+    str ++ ": Internal computation failed.\+            \ This is likely because you have tried to recursively use\+            \ the result of a failed computation in an action\+            \ whose effect may be observed even though the computation failed.\+            \ It's also possible that you're using an interpreter\+            \ that uses 'weave' improperly.\+            \ See documentation for more information."

@@ -9,7 +9,6 @@ import qualified Control.Concurrent.Async as A import           Control.Concurrent.Chan.Unagi import           Control.Concurrent.MVar-import           Control.Monad import           Polysemy.Internal import           Polysemy.Internal.Union @@ -19,7 +18,7 @@ -- -- @since 0.5.0.0 data Forklift r = forall a. Forklift-  { responseMVar :: MVar (Sem '[Embed IO] a)+  { responseMVar :: MVar a   , request      :: Union r (Sem r) a   } @@ -30,17 +29,18 @@ -- -- @since 0.5.0.0 runViaForklift-    :: LastMember (Embed IO) r+    :: Member (Embed IO) r     => InChan (Forklift r)     -> Sem r a-    -> Sem '[Embed IO] a-runViaForklift chan (Sem m) = Sem $ \k -> m $ \u -> do-  case decompLast u of-    Left x -> usingSem k $ join $ embed $ do+    -> IO a+runViaForklift chan = usingSem $ \u -> do+  case prj u of+    Just (Weaving (Embed m) s _ ex _) ->+      ex . (<$ s) <$> m+    _ -> do       mvar <- newEmptyMVar-      writeChan chan $ Forklift mvar x+      writeChan chan $ Forklift mvar u       takeMVar mvar-    Right y -> k $ hoist (runViaForklift chan) y {-# INLINE runViaForklift #-}  @@ -53,7 +53,7 @@ -- -- @since 0.5.0.0 withLowerToIO-    :: LastMember (Embed IO) r+    :: Member (Embed IO) r     => ((forall x. Sem r x -> IO x) -> IO () -> IO a)        -- ^ A lambda that takes the lowering function, and a finalizing 'IO'        -- action to mark a the forked thread as being complete. The finalizing@@ -64,7 +64,7 @@   signal <- embed newEmptyMVar    res <- embed $ A.async $ do-    a <- action (runM . runViaForklift inchan)+    a <- action (runViaForklift inchan)                 (putMVar signal ())     putMVar signal ()     pure a@@ -75,7 +75,7 @@           Left () -> embed $ A.wait res           Right (Forklift mvar req) -> do             resp <- liftSem req-            embed $ putMVar mvar $ pure resp+            embed $ putMVar mvar $ resp             me_b       {-# INLINE me #-} 

@@ -122,7 +122,7 @@ -- constructors into 'Sem' actions. genFreer :: Bool -> Name -> Q [Dec] genFreer should_mk_sigs type_name = do-  checkExtensions [ScopedTypeVariables, FlexibleContexts]+  checkExtensions [ScopedTypeVariables, FlexibleContexts, DataKinds]   (dt_name, cl_infos) <- getEffectMetadata type_name   tyfams_on  <- isExtEnabled TypeFamilies   def_mod_fi <- sequence [ tySynInstDCompat

@@ -30,10 +30,8 @@   -- * Witnesses   , SNat (..)   , Nat (..)-  , LastMember (..)   ) where -import Data.Bifunctor import Control.Monad import Data.Functor.Compose import Data.Functor.Identity@@ -263,22 +261,3 @@     SZ -> Right a     SS n -> Left (Union (SS n) a) {-# INLINE decompCoerce #-}------------------------------------------------------------------------------------ | A proof that @end@ is the last effect in the row.------ @since 0.5.0.0-class MemberNoError end r => LastMember end r | r -> end where-  decompLast-      :: Union r m a-      -> Either (Union r m a) (Union '[end] m a)--instance {-# OVERLAPPABLE #-} (LastMember end r, MemberNoError end (eff ': r))-      => LastMember end (eff ': r) where-  decompLast (Union SZ u)     = Left $ Union SZ u-  decompLast (Union (SS n) u) = first weaken $ decompLast $ Union n u--instance LastMember end '[end] where-  decompLast = Right-

@@ -10,10 +10,18 @@     -- * Interpretations   , runOutputList   , runOutputMonoid+  , runOutputMonoidAssocR+  , runOutputMonoidIORef+  , runOutputMonoidTVar   , ignoreOutput   , runOutputBatched+  , runOutputSem   ) where +import Data.IORef+import Control.Concurrent.STM++import Data.Semigroup (Endo(..)) import Data.Bifunctor (first) import Polysemy import Polysemy.State@@ -39,7 +47,7 @@     -> Sem r ([o], a) runOutputList = fmap (first reverse) . runState [] . reinterpret   (\case-      Output o -> modify (o :)+      Output o -> modify' (o :)   ) {-# INLINE runOutputList #-} @@ -55,12 +63,60 @@     -> Sem r (m, a) runOutputMonoid f = runState mempty . reinterpret   (\case-      Output o -> modify (`mappend` f o)+      Output o -> modify' (`mappend` f o)   ) {-# INLINE runOutputMonoid #-} +------------------------------------------------------------------------------+-- | Like 'runOutputMonoid', but right-associates uses of '<>'.+--+-- This asymptotically improves performance if the time complexity of '<>' for+-- the 'Monoid' depends only on the size of the first argument.+--+-- You should always use this instead of 'runOutputMonoid' if the monoid+-- is a list, such as 'String'.+runOutputMonoidAssocR+    :: forall o m r a+     . Monoid m+    => (o -> m)+    -> Sem (Output o ': r) a+    -> Sem r (m, a)+runOutputMonoidAssocR f =+    fmap (first (`appEndo` mempty))+  . runOutputMonoid (\a -> Endo (f a <>))+{-# INLINE runOutputMonoidAssocR #-}  ------------------------------------------------------------------------------+-- | Run an 'Output' effect by transforming it into atomic operations+-- over an 'IORef'.+runOutputMonoidIORef+    :: forall o m r a+     . (Monoid m, Member (Embed IO) r)+    => IORef m+    -> (o -> m)+    -> Sem (Output o ': r) a+    -> Sem r a+runOutputMonoidIORef ref f = interpret $ \case+  Output o -> embed $ atomicModifyIORef' ref (\s -> (s <> f o, ()))+{-# INLINE runOutputMonoidIORef #-}++------------------------------------------------------------------------------+-- | Run an 'Output' effect by transforming it into atomic operations+-- over a 'TVar'.+runOutputMonoidTVar+    :: forall o m r a+     . (Monoid m, Member (Embed IO) r)+    => TVar m+    -> (o -> m)+    -> Sem (Output o ': r) a+    -> Sem r a+runOutputMonoidTVar tvar f = interpret $ \case+  Output o -> embed $ atomically $ do+    s <- readTVar tvar+    writeTVar tvar $! s <> f o+{-# INLINE runOutputMonoidTVar #-}++------------------------------------------------------------------------------ -- | Run an 'Output' effect by ignoring it. -- -- @since 1.0.0.0@@ -101,3 +157,10 @@   when (c > 0) $ output @[o] (reverse res)   pure a +------------------------------------------------------------------------------+-- | Runs an 'Output' effect by running a monadic action for each of its+-- values.+runOutputSem :: (o -> Sem r ()) -> Sem (Output o ': r) a -> Sem r a+runOutputSem act = interpret $ \case+    Output o -> act o+{-# INLINE runOutputSem #-}

@@ -166,7 +166,7 @@ -- @since 1.0.0.0 resourceToIO     :: forall r a-     . LastMember (Embed IO) r+     . Member (Embed IO) r     => Sem (Resource ': r) a     -> Sem r a resourceToIO = interpretH $ \case

@@ -9,6 +9,7 @@   , gets   , put   , modify+  , modify'      -- * Interpretations   , runState@@ -56,7 +57,16 @@   put $ f s {-# INLINABLE modify #-} +------------------------------------------------------------------------------+-- | A variant of 'modify' in which the computation is strict in the+-- new state.+modify' :: Member (State s) r => (s -> s) -> Sem r ()+modify' f = do+  s <- get+  put $! f s+{-# INLINABLE modify' #-} + ------------------------------------------------------------------------------ -- | Run a 'State' effect with local state. runState :: s -> Sem (State s ': r) a -> Sem r (s, a)@@ -94,6 +104,11 @@  ------------------------------------------------------------------------------ -- | Run a 'State' effect by transforming it into operations over an 'IORef'.+--+-- /Note/: This is not safe in a concurrent setting, as 'modify' isn't atomic.+-- If you need operations over the state to be atomic,+-- use 'Polysemy.AtomicState.runAtomicStateIORef' or+-- 'Polysemy.AtomicState.runAtomicStateTVar' instead. -- -- @since 1.0.0.0 runStateIORef

@@ -77,7 +77,7 @@   --------------------------------------------------------------------------------- | Transform a 'Trace' effect into a 'Output' 'String' effect.+-- | Transform an 'Output' 'String' effect into a 'Trace' effect. -- -- @since 1.0.0.0 outputToTrace

@@ -13,11 +13,14 @@      -- * Interpretations   , runWriter+  , runWriterAssocR      -- * Interpretations for Other Effects   , outputToWriter   ) where +import Data.Bifunctor (first)+ import Polysemy import Polysemy.Output import Polysemy.State@@ -61,20 +64,61 @@ runWriter = runState mempty . reinterpretH   (\case       Tell o -> do-        modify (<> o) >>= pureT+        modify' (<> o) >>= pureT       Listen m -> do         mm <- runT m         -- TODO(sandy): this is stupid         (o, fa) <- raise $ runWriter mm-        modify (<> o)+        modify' (<> o)         pure $ fmap (o, ) fa       Pass m -> do         mm <- runT m         (o, t) <- raise $ runWriter mm         ins <- getInspectorT         let f = maybe id fst (inspect ins t)-        modify (<> f o)+        modify' (<> f o)         pure (fmap snd t)   ) {-# INLINE runWriter #-} +-----------------------------------------------------------------------------+-- | Like 'runWriter', but right-associates uses of '<>'.+--+-- This asymptotically improves performance if the time complexity of '<>'+-- for the 'Monoid' depends only on the size of the first argument.+--+-- You should always use this instead of 'runWriter' if the monoid+-- is a list, such as 'String'.+runWriterAssocR+    :: Monoid o+    => Sem (Writer o ': r) a+    -> Sem r (o, a)+runWriterAssocR =+  let+    go :: forall o r a+        . Monoid o+       => Sem (Writer o ': r) a+       -> Sem r (o -> o, a)+    go =+        runState id+      . reinterpretH+      (\case+          Tell o -> do+            modify' @(o -> o) (. (o <>)) >>= pureT+          Listen m -> do+            mm <- runT m+            -- TODO(sandy): this is stupid+            (oo, fa) <- raise $ go mm+            modify' @(o -> o) (. oo)+            pure $ fmap (oo mempty, ) fa+          Pass m -> do+            mm <- runT m+            (o, t) <- raise $ runWriterAssocR mm+            ins <- getInspectorT+            let f = maybe id fst (inspect ins t)+            modify' @(o -> o) (. (f o <>))+            pure (fmap snd t)+      )+    {-# INLINE go #-}+  in fmap (first ($ mempty)) . go+{-# INLINE runWriterAssocR #-}

@@ -6,11 +6,6 @@ import Control.Applicative import Polysemy.Trace -semFail :: Member NonDet r => Maybe Bool -> Sem r Bool-semFail mb = do-  Just b <- pure mb-  pure b- runAlt :: Alternative f => Sem '[NonDet] a -> f a runAlt = run . runNonDet @@ -30,14 +25,6 @@     it "should failover" $ do       runAlt (empty <|> pure '2') `shouldBe` (Just '2')       runAlt (pure '1' <|> empty) `shouldBe` (Just '1')--  describe "MonadFail instance" $ do-    it "should call empty via fail" $ do-      runAlt (semFail Nothing) `shouldBe` Nothing-      runAlt (semFail Nothing) `shouldBe` []-    it "should work fine for non-failing patterns" $ do-      runAlt (semFail $ Just True) `shouldBe` Just True-      runAlt (semFail $ Just False) `shouldBe` [False]    describe "runNonDetMaybe" $ do     it "should skip second branch if the first branch succeeds" $ do

@@ -3,6 +3,7 @@ module AsyncSpec where  import Control.Concurrent+import Control.Concurrent.MVar import Control.Monad import Polysemy import Polysemy.Async@@ -21,22 +22,24 @@       let message :: Member Trace r => Int -> String -> Sem r ()           message n msg = trace $ mconcat             [ show n, "> ", msg ]-+      ~[lock1, lock2] <- embed $+        replicateM 2 newEmptyMVar       a1 <- async $ do           v <- get @String           message 1 v           put $ reverse v -          embed $ threadDelay 1e5+          embed $ putMVar lock1 ()+          embed $ takeMVar lock2           get >>= message 1 -          embed $ threadDelay 1e5           get @String        void $ async $ do-          embed $ threadDelay 5e4+          embed $ takeMVar lock1           get >>= message 2           put "pong"+          embed $ putMVar lock2 ()        await a1 <* put "final" 

@@ -0,0 +1,25 @@+module FailSpec where++import Polysemy+import Polysemy.Fail+import Polysemy.NonDet+import Test.Hspec+import Control.Applicative++semFail :: Member Fail r => Maybe Bool -> Sem r Bool+semFail mb = do+  Just b <- pure mb+  pure b++runAlt :: Alternative f => Sem '[Fail, NonDet] a -> f a+runAlt = run . runNonDet . failToNonDet++spec :: Spec+spec = parallel $ do+  describe "MonadFail instance with failToNonDet" $ do+    it "should call empty via fail" $ do+      runAlt (semFail Nothing) `shouldBe` Nothing+      runAlt (semFail Nothing) `shouldBe` []+    it "should work fine for non-failing patterns" $ do+      runAlt (semFail $ Just True) `shouldBe` Just True+      runAlt (semFail $ Just False) `shouldBe` [False]

@@ -0,0 +1,97 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RecursiveDo #-}+module FixpointSpec where++import Control.Exception (try, evaluate)+import Control.Monad.Fix++import Polysemy+import Polysemy.Fixpoint+import Polysemy.Error+import Polysemy.State+import Polysemy.Output++import Test.Hspec++data FinalState s m a where+  GetEventualState :: FinalState s m s++makeSem ''FinalState++runFinalState :: Member Fixpoint r+              => s+              -> Sem (State s ': FinalState s ': r) a+              -> Sem r (s, a)+runFinalState s sm = mfix $ \ ~(s', _) ->+  interpret+    (\GetEventualState -> pure s')+    (runState s sm)++test1 :: (String, (Int, ()))+test1 =+    run+  . runFixpoint run+  . runOutputMonoid (show @Int)+  . runFinalState 1+  $ do+  s  <- get @Int+  s' <- getEventualState @Int+  output @Int s+  output @Int s'+  put @Int 2++test2 :: Either [Int] [Int]+test2 =+    run+  . runFixpoint run+  . runError+  $ mdo+  a <- throw (2 : a) `catch` (\e -> return (1 : e))+  return a++test3 :: Either () (Int, Int)+test3 =+    run+  . runFixpoint run+  . runError+  . runLazyState @Int 1+  $ mdo+  put a+  a <- throw ()+  return a++test4 :: (Int, Either () Int)+test4 =+    run+  . runFixpoint run+  . runLazyState @Int 1+  . runError+  $ mdo+  put a+  a <- throw ()+  return a+++spec :: Spec+spec = parallel $ describe "runFixpoint" $ do+  it "should work with runState" $ do+    test1 `shouldBe` ("12",  (2, ()))+  it "should work with runError" $ do+    let res = fmap (take 10) test2+    res `shouldBe` Right (take 10 $ cycle [1,2])+  it "should not trigger the bomb" $ do+    test3 `shouldBe` Left ()+  it "should trigger the bomb" $ do+    let (s, a) = test4+    evaluate s `shouldThrow` errorCall bombMessage+    a `shouldBe` Left ()++bombMessage :: String+bombMessage =+  "runFixpoint: Internal computation failed.\+              \ This is likely because you have tried to recursively use\+              \ the result of a failed computation in an action\+              \ whose effect may be observed even though the computation failed.\+              \ It's also possible that you're using an interpreter\+              \ that uses 'weave' improperly.\+              \ See documentation for more information."

@@ -1,10 +1,16 @@ module OutputSpec where +import Control.Concurrent.STM+import Control.Exception (evaluate)++import Data.IORef+import Data.Foldable+ import Polysemy+import Polysemy.Async import Polysemy.Output-import Data.Foldable-import Test.Hspec +import Test.Hspec  spec :: Spec spec = parallel $ do@@ -28,9 +34,48 @@       let (xs, ()) = runOutputList' $ traverse_ (output @Int) [0..100]        in xs `shouldBe` [0..100] +  describe "runOutputMonoid" $+    it "should be strict in the output" $+      let t = runOutputMonoid (id @String) $ do+            output @String (error "strict")+            return ()+      in do+        runM t           `shouldThrow` errorCall "strict"+        evaluate (run t) `shouldThrow` errorCall "strict" +  describe "runOutputMonoidIORef" $ do+    it "should commit writes of asynced computations" $+      let io = do+            ref <- newIORef ""+            (runM .@ lowerAsync) . runOutputMonoidIORef ref (show @Int) $+              test1+            readIORef ref+      in do+        res <- io+        res `shouldBe` "12"++  describe "runOutputMonoidTVar" $ do+    it "should commit writes of asynced computations" $+      let io = do+            ref <- newTVarIO ""+            (runM .@ lowerAsync) . runOutputMonoidTVar ref (show @Int) $+              test1+            readTVarIO ref+      in do+        res <- io+        res `shouldBe` "12"+ runOutput :: Int -> Sem '[Output Int, Output [Int]] a -> ([[Int]], a) runOutput size = run . runOutputMonoid (:[]) . runOutputBatched size  runOutputList' :: Sem '[Output Int] a -> ([Int], a) runOutputList' = run . runOutputList++test1 :: Members '[Async, Output Int] r+     => Sem r ()+test1 = do+  output @Int 1+  a <- async $ do+    output @Int 2+  _ <- await a+  return ()

@@ -3,7 +3,15 @@  import Test.Hspec +import qualified Control.Concurrent.Async as A+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Control.Exception (evaluate)++import Data.IORef+ import Polysemy+import Polysemy.Async import Polysemy.Error import Polysemy.Writer @@ -48,12 +56,34 @@ test3 = run . runWriter $ listen (tell "and hear")  spec :: Spec-spec = describe "writer" $ do-  it "should not censor" $ do-    test1 `shouldBe` ("censoring not applied", Right ())+spec = do+  describe "writer" $ do+    it "should not censor" $ do+      test1 `shouldBe` ("censoring not applied", Right ()) -  it "should censor" $ do-    test2 `shouldBe` ("censoring applied", Right ())+    it "should censor" $ do+      test2 `shouldBe` ("censoring applied", Right ()) -  it "should have a proper listen" $ do-    test3 `shouldBe` ("and hear", ("and hear", ()))+    it "should have a proper listen" $ do+      test3 `shouldBe` ("and hear", ("and hear", ()))++    it "should be strict in the output" $+      let+        t1 = runWriter @String $ do+          tell @String (error "strict")+          return ()++        t2 = runWriter @String $ do+          _ <- listen @String (tell @String (error "strict"))+          return ()++        t3 = runWriter @String $ do+          pass @String $ pure (\_ -> error "strict", ())+          return ()+      in do+        runM t1           `shouldThrow` errorCall "strict"+        evaluate (run t1) `shouldThrow` errorCall "strict"+        runM t2           `shouldThrow` errorCall "strict"+        evaluate (run t2) `shouldThrow` errorCall "strict"+        runM t3           `shouldThrow` errorCall "strict"+        evaluate (run t3) `shouldThrow` errorCall "strict"