polysemy 1.2.1.0 → 1.2.2.0

raw patch · 6 files changed

+243/−115 lines, 6 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• polysemy.cabal +2/−2
• src/Polysemy/Async.hs +14/−0
• src/Polysemy/AtomicState.hs +10/−0
• src/Polysemy/Resource.hs +23/−2
• test/BracketSpec.hs +186/−111

@@ -1,5 +1,13 @@ # Changelog for polysemy +## 1.2.2.0 (2019-10-22)++- Fixed a bug in `resourceToIO` and `resourceToIOFinal` that prevented the+    finalizers from being called in `BracketOnError` when the computation failed+    due to a `Sem` failure+- Added `atomicGets` (thanks to @googleson78)+- Added `sequenceConcurrently` to `Polysemy.Async` (thanks to @spacekitteh)+ ## 1.2.1.0 (2019-09-15)  - Added `InterpreterFor` (thanks to @bolt12)

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 7ce7e4fdc1a3ebff15b38a550ed247a4ad04bb4c383ad4440212926b3eeea93c+-- hash: 6bdca16663a4fb1932ed4f9ec8736ba29a0355783b546db2811df338a9d21ae8  name:           polysemy-version:        1.2.1.0+version:        1.2.2.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

@@ -8,6 +8,9 @@   , async   , await +    -- * Helpers+  , sequenceConcurrently+     -- * Interpretations   , asyncToIO   , asyncToIOFinal@@ -32,6 +35,17 @@   Await :: A.Async a -> Async m a  makeSem ''Async+++------------------------------------------------------------------------------+-- | Perform a sequence of effectful actions concurrently.+--+-- @since 1.2.2.0+sequenceConcurrently :: forall t r a. (Traversable t, Member Async r) =>+    t (Sem r a) -> Sem r (t (Maybe a))+sequenceConcurrently t = traverse async t >>= traverse await+{-# INLINABLE sequenceConcurrently #-}+  ------------------------------------------------------------------------------ -- | A more flexible --- though less performant ---

@@ -8,6 +8,7 @@   , atomicState   , atomicState'   , atomicGet+  , atomicGets   , atomicPut   , atomicModify   , atomicModify'@@ -47,6 +48,15 @@ atomicGet :: forall s r            . Member (AtomicState s) r           => Sem r s++------------------------------------------------------------------------------+-- | @since 1.2.2.0+atomicGets :: forall s s' r+            . Member (AtomicState s) r+           => (s -> s')+           -> Sem r s'+atomicGets = (<$> atomicGet)+{-# INLINE atomicGets #-}  ----------------------------------------------------------------------------- -- | A variant of 'atomicState' in which the computation is strict in the new

@@ -103,10 +103,23 @@     pure $ X.bracket a d u    BracketOnError alloc dealloc use -> do+    ins <- getInspectorS     a <- runS  alloc     d <- bindS dealloc     u <- bindS use-    pure $ X.bracketOnError a d u+    pure $+      X.bracketOnError+        a+        d+        (\x -> do+          result <- u x+          case inspect ins result of+            Just _ -> pure result+            Nothing -> do+              _ <- d x+              pure result+        )+ {-# INLINE resourceToIOFinal #-}  @@ -222,6 +235,7 @@           (done . mc)    BracketOnError a b c -> do+    ins <- getInspectorT     ma <- runT a     mb <- bindT b     mc <- bindT c@@ -232,6 +246,13 @@       X.bracketOnError           (done ma)           (\x -> done (mb x) >> finish)-          (done . mc)+          (\x -> do+            result <- done $ mc x+            case inspect ins result of+              Just _ -> pure result+              Nothing -> do+                _ <- done $ mb x+                pure result+          ) {-# INLINE resourceToIO #-} 

@@ -1,5 +1,6 @@ module BracketSpec where +import Control.Monad import Polysemy import Polysemy.Error import Polysemy.Output@@ -7,137 +8,211 @@ import Polysemy.State import Polysemy.Trace import Test.Hspec+import Unsafe.Coerce  ++spec :: Spec+spec = parallel $ do+  testAllThree "persist state and call the finalizer"+      (\(ts, (s, e)) -> do+        s `shouldBe` "finalized"+        e `shouldBe` Left ()+        ts `shouldBe` ["allocated", "starting block"]+      ) $ do+    bracket+      (put "allocated" >> pure ())+      (\() -> do+        get >>= trace+        put "finalized"+      )+      (\() -> do+        get >>= trace+        put "starting block"+        _ <- throw ()+        put "don't get here"+      )++  testAllThree "persist state and call the finalizer with bracketOnError"+      (\(ts, (s, e)) -> do+        ts `shouldContain` ["allocated"]+        ts `shouldContain` ["starting block"]+        s `shouldBe` "finalized"+        e `shouldBe` Left ()+      ) $ do+    bracketOnError+      (put "allocated" >> pure ())+      (\() -> do+        get >>= trace+        put "finalized"+      )+      (\() -> do+        get >>= trace+        put "starting block"+        _ <- throw ()+        put "don't get here"+      )++  testAllThree "should not call the finalizer if there no error"+      (\(ts, (s, e)) -> do+        ts `shouldContain` ["allocated"]+        ts `shouldNotContain` ["starting block"]+        s `shouldBe` "don't get here"+        e `shouldBe` Right ()+      ) $ do+    bracketOnError+      (put "allocated" >> pure ())+      (\() -> do+        get >>= trace+        put "finalized"+      )+      (\() -> do+        get >>= trace+        put "starting block"+        put "don't get here"+      )++  testAllThree "should call the finalizer on Error"+      (\(ts, (s, e)) -> do+        ts `shouldContain` ["beginning transaction"]+        ts `shouldContain` ["rolling back transaction"]+        s `shouldBe` ""+        e `shouldBe` Left ()+      ) $ do+    withTransaction $ do+      void $ throw ()+      pure "hello"++  testTheIOTwo "io dispatched bracket"+      (\(ts, (s, e)) -> do+        ts `shouldContain` ["allocated"]+        ts `shouldContain` ["starting block"]+        s `shouldBe` "finalized"+        e `shouldBe` Left ()+      ) $ do+    bracket+      (put "allocated" >> pure ())+      (\() -> do+        get >>= trace+        put "finalized"+      )+      (\() -> do+        get >>= trace+        put "starting block"+        _ <- throw ()+        put "don't get here"+      )++  testTheIOTwo "should not lock when done recursively"+      (\(ts, (s, e)) -> do+        ts `shouldContain` [ "hello 1"+                           , "hello 2"+                           , "RUNNING"+                           , "goodbye 2"+                           ]+        s `shouldBe` "finished"+        e `shouldBe` Left ()+      ) $ do+    bracket+      (put "hello 1")+      (\() -> do+        get >>= trace+        put "finished"+      )+      (\() -> do+        get >>= trace+        void $+          bracket (put "hello 2")+                  (const $ do+                    get >>= trace+                    put "goodbye 2"+                  )+                  (const $ do+                    get >>= trace+                    put "RUNNING"+                    throw ()+                  )+        -- This doesn't run due to the thrown error above+        get >>= trace+        put "goodbye 1"+      )+++------------------------------------------------------------------------------++ runTest   :: Sem '[Error (), Resource, State [Char], Trace] a-  -> ([String], ([Char], Either () a))-runTest = run+  -> IO ([String], ([Char], Either () a))+runTest = pure+        . run         . runTraceList         . runState ""         . runResource         . runError @()  runTest2-  :: Sem '[Error (), Resource, State [Char], Trace, Embed IO] a+  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a   -> IO ([String], ([Char], Either () a)) runTest2 = runM+         . ignoreOutput          . runTraceList          . runState ""          . resourceToIO          . runError @() +runTest3+  :: Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO, Final IO] a+  -> IO ([String], ([Char], Either () a))+runTest3 = runFinal+         . embedToFinal+         . outputToIOMonoid (:[])+         . traceToOutput+         . stateToIO ""+         . resourceToIOFinal+         . runError @() -spec :: Spec-spec = parallel $ do-  describe "pure bracket" $ do-    it "persist state and call the finalizer" $ do-      let (ts, (s, e)) = runTest $ do-            bracket-              (put "allocated" >> pure ())-              (\() -> do-                get >>= trace-                put "finalized"-              )-              (\() -> do-                get >>= trace-                put "starting block"-                _ <- throw ()-                put "don't get here"-              )-      ts `shouldContain` ["allocated"]-      ts `shouldContain` ["starting block"]-      s `shouldBe` "finalized"-      e `shouldBe` Left () -  describe "pure bracketOnError" $ do-    it "persist state and call the finalizer if there was an error" $ do-      let (ts, (s, e)) = runTest $ do-            bracketOnError-              (put "allocated" >> pure ())-              (\() -> do-                get >>= trace-                put "finalized"-              )-              (\() -> do-                get >>= trace-                put "starting block"-                _ <- throw ()-                put "don't get here"-              )-      ts `shouldContain` ["allocated"]-      ts `shouldContain` ["starting block"]-      s `shouldBe` "finalized"-      e `shouldBe` Left ()+testAllThree+    :: String+    -> (([String], ([Char], Either () a)) -> Expectation)+    -> (Sem '[Error (), Resource, State [Char], Trace] a)+    -> Spec+testAllThree name k m = do+  describe name $ do+    it "via runResource" $ do+      z <- runTest m+      k z+    -- NOTE(sandy): These unsafeCoerces are safe, because we're just weakening+    -- the end of the union+    it "via resourceToIO" $ do+      z <- runTest2 $ unsafeCoerce m+      k z+    it "via resourceToIOFinal" $ do+      z <- runTest3 $ unsafeCoerce m+      k z -    it "should not call the finalizer if there no error" $ do-      let (ts, (s, e)) = runTest $ do-            bracketOnError-              (put "allocated" >> pure ())-              (\() -> do-                get >>= trace-                put "finalized"-              )-              (\() -> do-                get >>= trace-                put "starting block"-                put "don't get here"-              )-      ts `shouldContain` ["allocated"]-      ts `shouldNotContain` ["starting block"]-      s `shouldBe` "don't get here"-      e `shouldBe` Right () +testTheIOTwo+    :: String+    -> (([String], ([Char], Either () a)) -> Expectation)+    -> (Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a)+    -> Spec+testTheIOTwo name k m = do+  describe name $ do+    it "via resourceToIO" $ do+      z <- runTest2 m+      k z+    -- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening+    -- the end of the union+    it "via resourceToIOFinal" $ do+      z <- runTest3 $ unsafeCoerce m+      k z -  describe "io dispatched bracket" $ do-    it "persist state and call the finalizer" $ do-      (ts, (s, e)) <- runTest2 $ do-            bracket-              (put "allocated" >> pure ())-              (\() -> do-                get >>= trace-                put "finalized"-              )-              (\() -> do-                get >>= trace-                put "starting block"-                _ <- throw ()-                put "don't get here"-              )-      ts `shouldContain` ["allocated"]-      ts `shouldContain` ["starting block"]-      s `shouldBe` "finalized"-      e `shouldBe` Left () -    it "should not lock when done recursively" $ do-      (ts, (s, e)) <- runTest2 $ do-            bracket-              (put "hello 1")-              (\() -> do-                get >>= trace-                put "finished"-              )-              (\() -> do-                get >>= trace-                bracket (put "hello 2")-                        (const $ do-                          get >>= trace-                          put "goodbye 2"-                        )-                        (const $ do-                          get >>= trace-                          put "RUNNING"-                          throw ()-                        )-                -- This doesn't run due to the thrown error above-                get >>= trace-                put "goodbye 1"-              )-      ts `shouldContain` [ "hello 1"-                         , "hello 2"-                         , "RUNNING"-                         , "goodbye 2"-                         ]-      s `shouldBe` "finished"-      e `shouldBe` Left ()-+withTransaction :: (Member Resource r, Member Trace r) => Sem r a -> Sem r a+withTransaction m =+  bracketOnError+    (trace "beginning transaction")+    (const $ trace "rolling back transaction")+    (const $ m <* trace "committing transaction")