polysemy-managed (empty) → 0.1.0.0
raw patch · 7 files changed
+355/−0 lines, 7 filesdep +basedep +exceptionsdep +hedgehogsetup-changed
Dependencies added: base, exceptions, hedgehog, hspec, hw-hspec-hedgehog, mtl, polysemy, polysemy-managed, resourcet, transformers, unliftio-core
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- polysemy-managed.cabal +80/−0
- src/Polysemy/Managed.hs +130/−0
- test/Polysemy/ManagedSpec.hs +111/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright John Ky (c) 2016-2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# polysemy-managed
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ polysemy-managed.cabal view
@@ -0,0 +1,80 @@+cabal-version: 2.2++name: polysemy-managed+version: 0.1.0.0+synopsis: Primitive functions and data types+description: Primitive functions and data types.+category: Data+stability: Experimental+homepage: http://github.com/haskell-works/polysemy-managed#readme+bug-reports: https://github.com/haskell-works/polysemy-managed/issues+author: John Ky+maintainer: newhoggy@gmail.com+copyright: 2016-2021 John Ky+license: BSD-3-Clause+license-file: LICENSE+tested-with: GHC == 9.2.2, GHC == 9.0.2, GHC == 8.10.7+build-type: Simple+extra-source-files: README.md++source-repository head+ type: git+ location: https://github.com/haskell-works/polysemy-managed++flag bounds-checking-enabled+ description: Enable bmi2 instruction set+ manual: False+ default: False++common base { build-depends: base >= 4.11 && < 5 }++common doctest { build-depends: doctest >= 0.16.2 && < 0.21 }+common doctest-discover { build-depends: doctest-discover >= 0.2 && < 0.3 }+common exceptions { build-depends: exceptions >= 0.8 && < 0.11 }+common hedgehog { build-depends: hedgehog >= 1.0 && < 1.2 }+common hspec { build-depends: hspec >= 2.4 && < 2.10 }+common hw-hspec-hedgehog { build-depends: hw-hspec-hedgehog >= 0.1 && < 0.2 }+common mtl { build-depends: mtl >= 2.2.2 && < 2.3 }+common polysemy { build-depends: polysemy >= 1.7.1.0 && < 1.8 }+common resourcet { build-depends: resourcet >= 1.2.5 && < 1.3 }+common transformers { build-depends: transformers >= 0.4 && < 0.7 }+common unliftio-core { build-depends: unliftio-core >= 0.1.2.0 && < 0.3 }++common polysemy-managed+ build-depends: polysemy-managed++common config+ default-language: Haskell2010+ default-extensions: ImportQualifiedPost+ ghc-options: -Wall+ if flag(bounds-checking-enabled)+ cpp-options: -DBOUNDS_CHECKING_ENABLED++library+ import: base, config+ , polysemy+ , resourcet+ , transformers+ , unliftio-core+ exposed-modules: Polysemy.Managed+ other-modules: Paths_polysemy_managed+ autogen-modules: Paths_polysemy_managed+ hs-source-dirs: src++test-suite polysemy-managed-test+ import: base, config+ , exceptions+ , hedgehog+ , hspec+ , hw-hspec-hedgehog+ , mtl+ , polysemy-managed+ , polysemy+ , resourcet+ , transformers+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: Polysemy.ManagedSpec+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-tool-depends: hspec-discover:hspec-discover
+ src/Polysemy/Managed.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Polysemy.Managed+ ( Managed(..)++ , runManagedResource+ , runManaged+ , runManagedFinal++ , managedAsk+ , managedLocal+ ) where++import Control.Exception qualified as E+import Control.Monad.Trans.Resource (createInternalState, MonadResource, InternalState)+import Control.Monad.Trans.Resource qualified as MTR+import Control.Monad.Trans.Resource.Internal qualified as RI+import Polysemy (Embed, Final, Sem, Member)+import Polysemy qualified as P+import Polysemy.Final qualified as PF+import Polysemy.Reader (Reader, runReader)++data Managed m a where+ ManagedAsk :: Managed m InternalState+ ManagedLocal :: m a -> Managed m a++P.makeSem ''Managed++runManaged :: forall a r. ()+ => Member (Embed IO) r+ => Sem (Managed ': r) a+ -> Sem r a+runManaged f = do+ state <- createInternalState+ managedBracketImpl state $ runManagedImpl state f+{-# INLINE runManaged #-}++runManagedFinal :: forall a r. ()+ => Member (Final IO) r+ => Sem (Managed ': r) a+ -> Sem r a+runManagedFinal f = do+ state <- P.embedFinal @IO createInternalState+ managedBracketFinalImpl state $ runManagedFinalImpl state f+{-# INLINE runManagedFinal #-}++runManagedResource :: ()+ => Member (Embed IO) r+ => Sem (Reader MTR.InternalState ': r) a+ -> Sem r a+runManagedResource f = do+ istate <- createInternalState+ runReader istate f++--------------------------------------------------------------------------------+-- Internal++runManagedImpl :: forall a r. ()+ => Member (Embed IO) r+ => InternalState+ -> Sem (Managed ': r) a+ -> Sem r a+runManagedImpl state = P.interpretH $ \case+ ManagedAsk -> P.pureT state+ ManagedLocal m -> do+ mm <- P.runT m+ newState <- createInternalState+ managedBracketImpl newState $ P.raise $ runManagedImpl newState mm+{-# INLINE runManagedImpl #-}++runManagedFinalImpl :: forall a r. ()+ => Member (Final IO) r+ => InternalState+ -> Sem (Managed ': r) a+ -> Sem r a+runManagedFinalImpl state = P.interpretH $ \case+ ManagedAsk -> P.pureT state+ ManagedLocal m -> do+ mm <- P.runT m+ newState <- P.embedFinal @IO createInternalState+ managedBracketFinalImpl newState $ P.raise $ runManagedFinalImpl newState mm+{-# INLINE runManagedFinalImpl #-}++managedBracketImpl :: forall a r. ()+ => Member (Embed IO) r+ => MTR.InternalState+ -> Sem r a+ -> Sem r a+managedBracketImpl istate f = do+ P.withLowerToIO $ \lower finish -> do+ E.mask $ \restore -> do+ res <- restore (lower f) `E.catch` \e -> do+ RI.stateCleanupChecked (Just e) istate+ E.throwIO e+ RI.stateCleanupChecked Nothing istate+ finish+ return res++managedBracketFinalImpl :: forall a r. ()+ => Member (Final IO) r+ => MTR.InternalState+ -> Sem r a+ -> Sem r a+managedBracketFinalImpl istate f = PF.withStrategicToFinal @IO $ do+ f' <- PF.runS f+ pure $ E.mask $ \restore -> do+ res <- restore f' `E.catch` \e -> do+ RI.stateCleanupChecked (Just e) istate+ E.throwIO e+ RI.stateCleanupChecked Nothing istate+ pure res++instance+ ( Member (Embed IO) r+ , Member Managed r+ ) => MonadResource (Sem r) where+ liftResourceT (RI.ResourceT r) = managedAsk >>= P.embed . r
+ test/Polysemy/ManagedSpec.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Polysemy.ManagedSpec (spec) where++import Control.Concurrent.MVar (MVar)+import Control.Concurrent.MVar qualified as IO+import Control.Monad (forM_, void)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource qualified as MTR+import HaskellWorks.Hspec.Hedgehog qualified as H+import Hedgehog ((===), PropertyT)+import Polysemy (Final, Sem)+import Polysemy qualified as PY+import Polysemy.Embed (Embed)+import Polysemy.Managed qualified as PY+import Polysemy.Resource (Resource)+import Polysemy.Resource qualified as PY+import Test.Hspec (describe, it, Spec)++{- HLINT ignore "Redundant do" -}++runMainEffects :: forall a. ()+ => Sem '[Embed IO , Resource , Final IO] a+ -> IO a+runMainEffects =+ PY.runFinal+ . PY.resourceToIOFinal+ . PY.embedToFinal+++run :: MVar [PropertyT IO ()] -> PropertyT IO () -> IO ()+run mv p = do+ ps <- IO.takeMVar mv+ IO.putMVar mv (p:ps)++spec :: Spec+spec = describe "Polysemy.ManagedSpec" $ do+ it "De-allocated allocated resource (embed)" $ H.requireTest $ do+ mva <- liftIO IO.newEmptyMVar+ result1 <- liftIO $ runMainEffects $+ PY.runManaged $ do+ void $ MTR.allocate (return ()) $ const (IO.putMVar mva ())+ liftIO $ IO.tryTakeMVar mva++ result2 <- liftIO $ IO.tryTakeMVar mva++ result1 === Nothing+ result2 === Just ()++ it "De-allocated allocated resource (final)" $ H.requireTest $ do+ mva <- liftIO IO.newEmptyMVar+ result1 <- liftIO $ runMainEffects $+ PY.runManagedFinal $ do+ void $ MTR.allocate (return ()) $ const (IO.putMVar mva ())+ liftIO $ IO.tryTakeMVar mva++ result2 <- liftIO $ IO.tryTakeMVar mva++ result1 === Nothing+ result2 === Just ()++ it "Has local capability (embed)" $ H.requireTest $ do+ mAssertions <- liftIO $ IO.newMVar []+ mva <- liftIO IO.newEmptyMVar+ mvb <- liftIO IO.newEmptyMVar+ liftIO $ runMainEffects $ do+ PY.runManaged $ do+ void $ MTR.allocate (return ()) $ const (IO.putMVar mva ())+ PY.managedLocal $ do+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Nothing+ void $ MTR.allocate (return ()) $ const $ IO.putMVar mvb ()+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Just ()+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Just ()+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Just ()++ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Just ()+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Just ()++ assertions <- fmap reverse . liftIO $ IO.readMVar mAssertions++ forM_ assertions id++ it "Has local capability (final)" $ H.requireTest $ do+ mAssertions <- liftIO $ IO.newMVar []+ mva <- liftIO IO.newEmptyMVar+ mvb <- liftIO IO.newEmptyMVar+ liftIO $ runMainEffects $ do+ PY.runManagedFinal $ do+ void $ MTR.allocate (return ()) $ const (IO.putMVar mva ())+ PY.managedLocal $ do+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Nothing+ void $ MTR.allocate (return ()) $ const $ IO.putMVar mvb ()+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Nothing+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Just ()+ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Just ()+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Just ()++ liftIO $ IO.tryReadMVar mva >>= \result -> run mAssertions $ result === Just ()+ liftIO $ IO.tryReadMVar mvb >>= \result -> run mAssertions $ result === Just ()++ assertions <- fmap reverse . liftIO $ IO.readMVar mAssertions++ forM_ assertions id
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}