polysemy 1.7.1.0 → 1.8.0.0

raw patch · 31 files changed

+685/−1341 lines, 31 filesdep +hspec-discoverdep −QuickCheckdep −criteriondep −dump-coredep ~mtlPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec-discover

Dependencies removed: QuickCheck, criterion, dump-core, free, freer-simple

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• ChangeLog.md +27/−0
• README.md +4/−1
• bench/Poly.hs +0/−64
• bench/countDown.hs +0/−133
• polysemy.cabal +11/−72
• src/Polysemy.hs +6/−8
• src/Polysemy/Async.hs +0/−73
• src/Polysemy/Error.hs +44/−80
• src/Polysemy/Fixpoint.hs +0/−42
• src/Polysemy/IO.hs +0/−29
• src/Polysemy/Internal.hs +25/−66
• src/Polysemy/Internal/Combinators.hs +14/−0
• src/Polysemy/Internal/Forklift.hs +0/−87
• src/Polysemy/Internal/Scoped.hs +154/−0
• src/Polysemy/Internal/TH/Effect.hs +8/−2
• src/Polysemy/Internal/Union.hs +22/−24
• src/Polysemy/Internal/Writer.hs +4/−4
• src/Polysemy/Law.hs +0/−197
• src/Polysemy/Resource.hs +0/−107
• src/Polysemy/Scoped.hs +279/−0
• src/Polysemy/State/Law.hs +0/−59
• src/Polysemy/Tagged.hs +1/−1
• src/Polysemy/View.hs +0/−76
• test/AsyncSpec.hs +0/−47
• test/BracketSpec.hs +0/−16
• test/ErrorSpec.hs +19/−1
• test/InspectorSpec.hs +0/−77
• test/LawsSpec.hs +0/−20
• test/ScopedSpec.hs +67/−0
• test/TypeErrors.hs +0/−15
• test/ViewSpec.hs +0/−40

@@ -6,6 +6,33 @@  ### Other Changes ++## 1.8.0.0 (2022-12-22)++### Breaking Changes++- Removed `Polysemy.View`+- Removed `Polysemy.Law`+- Removed `(@)` and `(@@)` from `Polysemy`+- Removed `withLowerToIO` from `Polysemy`. Use `withWeavingToFinal` instead.+- Removed `asyncToIO` and `lowerAsync` from `Polysemy.Async`. Use+    `asyncToIOFinal` instead.+- Removed `lowerEmbedded` from `Polysemy.IO`. Use `embedToMonadIO` instead.+- Removed `lowerError` from `Polysemy.Error`. Use `errorToIOFinal` instead.+- Removed `resourceToIO` and `lowerResource` from `Polysemy.Resource`. Use+    `resourceToIOFinal` instead.+- Removed `runFixpoint` and `runFixpointM` from `Polysemy.Fixpoint`. Use+    `fixpointToFinal` instead.+- Changed semantics of `errorToIOFinal` so that it no longer catches errors+  from other handlers of the same type.++### Other Changes++- Exposed `send` from `Polysemy`.+- Dramatically improved build performance of projects when compiling with `-O2`.+- Removed the debug `dump-core` flag.++ ## 1.7.1.0 (2021-11-23)  ### Other Changes

@@ -57,9 +57,12 @@  - Raghu Kaippully wrote a beginner friendly   [tutorial](https://haskell-explained.gitlab.io/blog/posts/2019/07/28/polysemy-is-cool-part-1/index.html).+- Sandy Maguire, the author, wrote a post about+  [Porting to Polysemy](https://reasonablypolymorphic.com/blog/porting-to-polysemy/)+  from transformers/MTL-style monads. - Paweł Szulc gave a [great talk](https://youtu.be/idU7GdlfP9Q?t=1394) on how   to start thinking about polysemy.-- Sandy Maguire, the author, gave a talk on some of the+- Sandy Maguire gave a talk on some of the   [performance implementation](https://www.youtube.com/watch?v=-dHFOjcK6pA) - He has also written   [some](http://reasonablypolymorphic.com/blog/freer-higher-order-effects/)

@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs            #-}-{-# LANGUAGE TemplateHaskell  #-}-{-# LANGUAGE TypeApplications #-}--{-# OPTIONS_GHC -fwarn-all-missed-specializations #-}--module Poly where--import Polysemy-import Polysemy.Error-import Polysemy.Resource-import Polysemy.State-import Polysemy.Input-import Polysemy.Output---slowBeforeSpecialization :: Member (State Int) r => Sem r Int-slowBeforeSpecialization = do-  n <- get-  if n <= 0-     then pure n-     else do-       put $ n - 1-       slowBeforeSpecialization--{-# SPECIALIZE slowBeforeSpecialization :: Sem '[State Int] Int #-}---countDown :: Int -> Int-countDown s =-  fst . run . runState s $ slowBeforeSpecialization--prog-    :: Sem '[ State Bool-            , Error Bool-            , Resource-            , Embed IO-            ] Bool-prog = catch @Bool (throw True) (pure . not)--zoinks :: IO (Either Bool Bool)-zoinks = fmap (fmap snd)-       . (runM .@ lowerResource .@@ lowerError)-       . runState False-       $ prog--data Console m a where-  ReadLine :: Console m String-  WriteLine :: String -> Console m ()--makeSem ''Console--runConsoleBoring :: [String] -> Sem (Console ': r) a -> Sem r ([String], a)-runConsoleBoring inputs-  = runOutputMonoid (:[])-  . runInputList inputs-  . reinterpret2-  (\case-      ReadLine -> maybe "" id <$> input-      WriteLine msg -> output msg-  )-

@@ -1,133 +0,0 @@-{-# LANGUAGE DataKinds, DeriveFunctor, FlexibleContexts, GADTs, TypeOperators #-}-module Main (main) where--import Control.Monad (replicateM_)--import qualified Control.Monad.Except as MTL-import qualified Control.Monad.State as MTL-import qualified Control.Monad.Free as Free--import Criterion (bench, bgroup, whnf)-import Criterion.Main (defaultMain)--import Control.Monad.Freer (Member, Eff, run, send)-import Control.Monad.Freer.Internal (Eff(..), decomp, qApp, tsingleton)-import Control.Monad.Freer.Error (runError, throwError)-import Control.Monad.Freer.State (get, put, runState)--import qualified Poly as P-----------------------------------------------------------------------------------                        -- State Benchmarks -------------------------------------------------------------------------------------oneGet :: Int -> (Int, Int)-oneGet n = run (runState n get)--oneGetMTL :: Int -> (Int, Int)-oneGetMTL = MTL.runState MTL.get--countDown :: Int -> (Int, Int)-countDown start = run (runState start go)-  where go = get >>= (\n -> if n <= 0 then pure n else put (n-1) >> go)--countDownMTL :: Int -> (Int, Int)-countDownMTL = MTL.runState go-  where go = MTL.get >>= (\n -> if n <= 0 then pure n else MTL.put (n-1) >> go)-----------------------------------------------------------------------------------                       -- Exception + State ------------------------------------------------------------------------------------countDownExc :: Int -> Either String (Int,Int)-countDownExc start = run $ runError (runState start go)-  where go = get >>= (\n -> if n <= (0 :: Int) then throwError "wat" else put (n-1) >> go)--countDownExcMTL :: Int -> Either String (Int,Int)-countDownExcMTL = MTL.runStateT go-  where go = MTL.get >>= (\n -> if n <= (0 :: Int) then MTL.throwError "wat" else MTL.put (n-1) >> go)-----------------------------------------------------------------------------------                          -- Freer: Interpreter ------------------------------------------------------------------------------------data Http out where-  Open :: String -> Http ()-  Close :: Http ()-  Post  :: String -> Http String-  Get   :: Http String--open' :: Member Http r => String -> Eff r ()-open'  = send . Open--close' :: Member Http r => Eff r ()-close' = send Close--post' :: Member Http r => String -> Eff r String-post' = send . Post--get' :: Member Http r => Eff r String-get' = send Get--runHttp :: Eff (Http ': r) w -> Eff r w-runHttp (Val x) = pure x-runHttp (E u q) = case decomp u of-  Right (Open _) -> runHttp (qApp q ())-  Right Close    -> runHttp (qApp q ())-  Right (Post d) -> runHttp (qApp q d)-  Right Get      -> runHttp (qApp q "")-  Left u'        -> E u' (tsingleton (runHttp . qApp q ))-----------------------------------------------------------------------------------                          -- Free: Interpreter ------------------------------------------------------------------------------------data FHttpT x-  = FOpen String x-  | FClose x-  | FPost String (String -> x)-  | FGet (String -> x)-    deriving Functor--type FHttp = Free.Free FHttpT--fopen' :: String -> FHttp ()-fopen' s = Free.liftF $ FOpen s ()--fclose' :: FHttp ()-fclose' = Free.liftF $ FClose ()--fpost' :: String -> FHttp String-fpost' s = Free.liftF $ FPost s id--fget' :: FHttp String-fget' = Free.liftF $ FGet id--runFHttp :: FHttp a -> Maybe a-runFHttp (Free.Pure x) = pure x-runFHttp (Free.Free (FOpen _ n)) = runFHttp n-runFHttp (Free.Free (FClose n))  = runFHttp n-runFHttp (Free.Free (FPost s n)) = pure s  >>= runFHttp . n-runFHttp (Free.Free (FGet n))    = pure "" >>= runFHttp . n-----------------------------------------------------------------------------------                        -- Benchmark Suite ------------------------------------------------------------------------------------prog :: Member Http r => Eff r ()-prog = open' "cats" >> get' >> post' "cats" >> close'--prog' :: FHttp ()-prog' = fopen' "cats" >> fget' >> fpost' "cats" >> fclose'--p :: Member Http r => Int -> Eff r ()-p count   =  open' "cats" >> replicateM_ count (get' >> post' "cats") >>  close'--p' :: Int -> FHttp ()-p' count  = fopen' "cats" >> replicateM_ count (fget' >> fpost' "cats") >> fclose'--main :: IO ()-main =-  defaultMain [-    bgroup "Countdown Bench" [-        bench "discount"          $ whnf P.countDown 10000-      , bench "freer-simple"      $ whnf countDown 10000-      , bench "mtl"               $ whnf countDownMTL 10000-    ]-  ]

@@ -5,15 +5,15 @@ -- see: https://github.com/sol/hpack  name:           polysemy-version:        1.7.1.0+version:        1.8.0.0 synopsis:       Higher-order, low-boilerplate free monads. description:    Please see the README on GitHub at <https://github.com/polysemy-research/polysemy#readme> category:       Language homepage:       https://github.com/polysemy-research/polysemy#readme bug-reports:    https://github.com/polysemy-research/polysemy/issues author:         Sandy Maguire-maintainer:     sandy@sandymaguire.me-copyright:      2019-2021 Sandy Maguire+maintainer:     https://funprog.zulipchat.com/#narrow/stream/216942-Polysemy+copyright:      2019-2023 The Polysemy Lounge license:        BSD3 license-file:   LICENSE build-type:     Custom@@ -31,11 +31,6 @@     , base >=4.9 && <5     , cabal-doctest >=1.0.6 && <1.1 -flag dump-core-  description: Dump HTML for the core generated by GHC during compilation-  manual: True-  default: False- library   exposed-modules:       Polysemy@@ -56,10 +51,10 @@       Polysemy.Internal.CustomErrors       Polysemy.Internal.CustomErrors.Redefined       Polysemy.Internal.Fixpoint-      Polysemy.Internal.Forklift       Polysemy.Internal.Index       Polysemy.Internal.Kind       Polysemy.Internal.NonDet+      Polysemy.Internal.Scoped       Polysemy.Internal.Sing       Polysemy.Internal.Strategy       Polysemy.Internal.Tactics@@ -68,17 +63,15 @@       Polysemy.Internal.Union       Polysemy.Internal.Writer       Polysemy.IO-      Polysemy.Law       Polysemy.Membership       Polysemy.NonDet       Polysemy.Output       Polysemy.Reader       Polysemy.Resource+      Polysemy.Scoped       Polysemy.State-      Polysemy.State.Law       Polysemy.Tagged       Polysemy.Trace-      Polysemy.View       Polysemy.Writer   other-modules:       Polysemy.Internal.PluginLookup@@ -88,6 +81,7 @@   hs-source-dirs:       src   default-extensions:+      BlockArguments       DataKinds       DeriveFunctor       FlexibleContexts@@ -103,8 +97,7 @@       UnicodeSyntax   ghc-options: -Wall   build-depends:-      QuickCheck >=2.11.3 && <3-    , async >=2.2 && <3+      async >=2.2 && <3     , base >=4.9 && <5     , containers >=0.5 && <0.7     , first-class-families >=0.5.0.0 && <0.9@@ -120,10 +113,6 @@     default-extensions:         MonadFailDesugaring         TypeInType-  if flag(dump-core)-    ghc-options: -fplugin=DumpCore -fplugin-opt=DumpCore:core-html-    build-depends:-        dump-core   if impl(ghc < 8.2.2)     build-depends:         unsupported-ghc-version >1 && <1@@ -134,7 +123,6 @@   main-is: Main.hs   other-modules:       AlternativeSpec-      AsyncSpec       BracketSpec       DoctestSpec       ErrorSpec@@ -143,15 +131,13 @@       FixpointSpec       FusionSpec       HigherOrderSpec-      InspectorSpec       InterceptSpec       KnownRowSpec-      LawsSpec       OutputSpec+      ScopedSpec       TacticsSpec       ThEffectSpec       TypeErrors-      ViewSpec       WriterSpec       Paths_polysemy       Build_doctests@@ -160,6 +146,7 @@   hs-source-dirs:       test   default-extensions:+      BlockArguments       DataKinds       DeriveFunctor       FlexibleContexts@@ -174,64 +161,16 @@       TypeFamilies       UnicodeSyntax   ghc-options: -threaded -rtsopts -with-rtsopts=-N-  build-tool-depends:-      hspec-discover:hspec-discover >=2.0   build-depends:-      QuickCheck >=2.11.3 && <3-    , async >=2.2 && <3+      async >=2.2 && <3     , base >=4.9 && <5     , containers >=0.5 && <0.7     , doctest >=0.16.0.1 && <0.19     , first-class-families >=0.5.0.0 && <0.9     , hspec >=2.6.0 && <3+    , hspec-discover >=2.0     , inspection-testing >=0.4.2 && <0.5     , mtl >=2.2.2 && <3-    , polysemy-    , stm ==2.*-    , syb ==0.7.*-    , template-haskell >=2.12.0.0 && <3-    , th-abstraction >=0.3.1.0 && <0.5-    , transformers >=0.5.2.0 && <0.6-    , type-errors >=0.2.0.0-    , unagi-chan >=0.4.0.0 && <0.5-  if impl(ghc < 8.6)-    default-extensions:-        MonadFailDesugaring-        TypeInType-  default-language: Haskell2010--benchmark polysemy-bench-  type: exitcode-stdio-1.0-  main-is: countDown.hs-  other-modules:-      Poly-      Paths_polysemy-  hs-source-dirs:-      bench-  default-extensions:-      DataKinds-      DeriveFunctor-      FlexibleContexts-      GADTs-      LambdaCase-      PolyKinds-      RankNTypes-      ScopedTypeVariables-      StandaloneDeriving-      TypeApplications-      TypeOperators-      TypeFamilies-      UnicodeSyntax-  build-depends:-      QuickCheck >=2.11.3 && <3-    , async >=2.2 && <3-    , base >=4.9 && <5-    , containers >=0.5 && <0.7-    , criterion-    , first-class-families >=0.5.0.0 && <0.9-    , free-    , freer-simple-    , mtl     , polysemy     , stm ==2.*     , syb ==0.7.*

@@ -68,6 +68,11 @@     -- readLine  :: 'Member' Console r => 'Sem' r String     -- @     --+    -- Each of these generated definitions make use of 'send' in order to perform+    -- the corresponding action of the effect. If you don't want to use+    -- Template Haskell, you can write the necessary boilerplate yourself by+    -- using 'send' directly.+    --     -- Effects which don't make use of the @m@ parameter are known as     -- "first-order effects." @@ -95,6 +100,7 @@     -- @     --     -- As you see, in the smart constructors, the @m@ parameter has become @'Sem' r@.+  , send   , makeSem   , makeSem_ @@ -114,17 +120,10 @@   , reinterpret2H   , reinterpret3H -    -- * Combinators for Interpreting Directly to IO-  , withLowerToIO-     -- * Kind Synonyms   , Effect   , EffectRow -    -- * Composing IO-based Interpreters-  , (.@)-  , (.@@)-     -- * Tactics     -- | Higher-order effects need to explicitly thread /other effects'/ state     -- through themselves. Tactics are a domain-specific language for describing@@ -149,7 +148,6 @@ import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Combinators-import Polysemy.Internal.Forklift import Polysemy.Internal.Kind import Polysemy.Internal.Tactics import Polysemy.Internal.TH.Effect

@@ -13,9 +13,7 @@   , sequenceConcurrently      -- * Interpretations-  , asyncToIO   , asyncToIOFinal-  , lowerAsync   ) where  import qualified Control.Concurrent.Async as A@@ -49,59 +47,12 @@ {-# INLINABLE sequenceConcurrently #-}  --------------------------------------------------------------------------------- | A more flexible --- though less performant ------ version of 'asyncToIOFinal'.------ This function is capable of running 'Async' effects anywhere within an--- effect stack, without relying on 'Final' to lower it into 'IO'.--- Notably, this means that 'Polysemy.State.State' effects will be consistent--- in the presence of 'Async'.------ 'asyncToIO' is __unsafe__ if you're using 'await' inside higher-order actions--- of other effects interpreted after 'Async'.--- See <https://github.com/polysemy-research/polysemy/issues/205 Issue #205>.------ Prefer 'asyncToIOFinal' unless you need to run pure, stateful interpreters--- after the interpreter for 'Async'.--- (Pure interpreters are interpreters that aren't expressed in terms of--- another effect or monad; for example, 'Polysemy.State.runState'.)------ @since 1.0.0.0-asyncToIO-    :: Member (Embed IO) r-    => Sem (Async ': r) a-    -> Sem r a-asyncToIO m = withLowerToIO $ \lower _ -> lower $-  interpretH-    ( \case-        Async a -> do-          ma  <- runT a-          ins <- getInspectorT-          fa  <- embed $ A.async $ lower $ asyncToIO ma-          pureT $ inspect ins <$> fa--        Await a -> pureT =<< embed (A.wait a)-        Cancel a -> pureT =<< embed (A.cancel a)-    )  m-{-# INLINE asyncToIO #-}-------------------------------------------------------------------------------- -- | Run an 'Async' effect in terms of 'A.async' through final 'IO'. -- -- /Beware/: Effects that aren't interpreted in terms of 'IO' -- will have local state semantics in regards to 'Async' effects -- interpreted this way. See 'Final'. ----- Notably, unlike 'asyncToIO', this is not consistent with--- 'Polysemy.State.State' unless 'Polysemy.State.runStateIORef' is used.--- State that seems like it should be threaded globally throughout 'Async'--- /will not be./------ Use 'asyncToIO' instead if you need to run--- pure, stateful interpreters after the interpreter for 'Async'.--- (Pure interpreters are interpreters that aren't expressed in terms of--- another effect or monad; for example, 'Polysemy.State.runState'.)--- -- @since 1.2.0.0 asyncToIOFinal :: Member (Final IO) r                => Sem (Async ': r) a@@ -115,27 +66,3 @@   Cancel a -> liftS (A.cancel a) {-# INLINE asyncToIOFinal #-} ---------------------------------------------------------------------------------- | Run an 'Async' effect in terms of 'A.async'.------ @since 1.0.0.0-lowerAsync-    :: Member (Embed IO) r-    => (forall x. Sem r x -> IO x)-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely-       -- some combination of 'runM' and other interpreters composed via '.@'.-    -> Sem (Async ': r) a-    -> Sem r a-lowerAsync lower m = interpretH-    ( \case-        Async a -> do-          ma  <- runT a-          ins <- getInspectorT-          fa  <- embed $ A.async $ lower $ lowerAsync lower ma-          pureT $ inspect ins <$> fa--        Await a -> pureT =<< embed (A.wait a)-        Cancel a -> pureT =<< embed (A.cancel a)-    )  m-{-# INLINE lowerAsync #-}-{-# DEPRECATED lowerAsync "Use 'asyncToIOFinal' instead" #-}

@@ -23,18 +23,18 @@   , runError   , mapError   , errorToIOFinal-  , lowerError   ) where -import qualified Control.Exception as X+import qualified Control.Exception          as X import           Control.Monad import qualified Control.Monad.Trans.Except as E-import           Data.Bifunctor (first)-import           Data.Typeable+import           Data.Unique                (Unique, hashUnique, newUnique)+import           GHC.Exts                   (Any) import           Polysemy import           Polysemy.Final import           Polysemy.Internal import           Polysemy.Internal.Union+import           Unsafe.Coerce              (unsafeCoerce)   data Error e m a where@@ -46,7 +46,7 @@  hush :: Either e a -> Maybe a hush (Right a) = Just a-hush (Left _) = Nothing+hush (Left _)  = Nothing   ------------------------------------------------------------------------------@@ -57,7 +57,7 @@     :: Member (Error e) r     => Either e a     -> Sem r a-fromEither (Left e) = throw e+fromEither (Left e)  = throw e fromEither (Right a) = pure a {-# INLINABLE fromEither #-} @@ -105,7 +105,7 @@ fromExceptionVia f m = do   r <- embed $ X.try m   case r of-    Left e -> throw $ f e+    Left e  -> throw $ f e     Right a -> pure a {-# INLINABLE fromExceptionVia #-} @@ -139,7 +139,7 @@     s  <- getInitialStateS     pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s))   case r of-    Left e -> throw $ f e+    Left e  -> throw $ f e     Right a -> pure a {-# INLINABLE fromExceptionSemVia #-} @@ -152,16 +152,16 @@ {-# INLINABLE note #-}  --------------------------------------------------------------------------------- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@) --- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type --- @e@ was @'throw'@n and its value is @ex@. +-- | Similar to @'catch'@, but returns an @'Either'@ result which is (@'Right' a@)+-- if no exception of type @e@ was @'throw'@n, or (@'Left' ex@) if an exception of type+-- @e@ was @'throw'@n and its value is @ex@. try :: Member (Error e) r => Sem r a -> Sem r (Either e a) try m = catch (Right <$> m) (return . Left) {-# INLINABLE try #-}  ------------------------------------------------------------------------------ -- | A variant of @'try'@ that takes an exception predicate to select which exceptions--- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, +-- are caught (c.f. @'catchJust'@). If the exception does not match the predicate, -- it is re-@'throw'@n. tryJust :: Member (Error e) r => (e -> Maybe b) -> Sem r a -> Sem r (Either b a) tryJust f m = do@@ -170,14 +170,14 @@       Right v -> return (Right v)       Left e -> case f e of                   Nothing -> throw e-                  Just b -> return $ Left b+                  Just b  -> return $ Left b {-# INLINABLE tryJust #-}  --------------------------------------------------------------------------------- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument --- which is an exception predicate, a function which selects which type of exceptions +-- | The function @'catchJust'@ is like @'catch'@, but it takes an extra argument+-- which is an exception predicate, a function which selects which type of exceptions -- we're interested in.-catchJust :: Member (Error e) r +catchJust :: Member (Error e) r           => (e -> Maybe b) -- ^ Predicate to select exceptions           -> Sem r a  -- ^ Computation to run           -> (b -> Sem r a) -- ^ Handler@@ -186,7 +186,7 @@   where       handler e = case ef e of                     Nothing -> throw e-                    Just b -> bf b+                    Just b  -> bf b {-# INLINABLE catchJust #-}  ------------------------------------------------------------------------------@@ -244,14 +244,24 @@ {-# INLINE mapError #-}  -newtype WrappedExc e = WrappedExc { unwrapExc :: e }-  deriving (Typeable)+data WrappedExc = WrappedExc !Unique Any -instance Typeable e => Show (WrappedExc e) where-  show = mappend "WrappedExc: " . show . typeRep+instance Show WrappedExc where+  show (WrappedExc uid _) =+    "errorToIOFinal: Escaped opaque exception. Unique hash is: " <>+    show (hashUnique uid) <> "This should only happen if the computation that " <>+    "threw the exception was somehow invoked outside of the argument of 'errorToIOFinal'; " <>+    "for example, if you 'async' an exceptional computation inside of the argument " <>+    "provided to 'errorToIOFinal', and then 'await' on it *outside* of the argument " <>+    "provided to 'errorToIOFinal'. If that or any similar shenanigans seems unlikely, " <>+    "please open an issue on the GitHub repository." -instance (Typeable e) => X.Exception (WrappedExc e)+instance X.Exception WrappedExc +catchWithUid :: forall e a. Unique -> IO a -> (e -> IO a) -> IO a+catchWithUid uid m h = X.catch m $ \exc@(WrappedExc uid' e) ->+  if uid == uid' then h (unsafeCoerce e) else X.throwIO exc+{-# INLINE catchWithUid #-}  ------------------------------------------------------------------------------ -- | Run an 'Error' effect as an 'IO' 'X.Exception' through final 'IO'. This@@ -263,77 +273,31 @@ -- -- @since 1.2.0.0 errorToIOFinal-    :: ( Typeable e-       , Member (Final IO) r+    :: forall e r a+    .  ( Member (Final IO) r        )     => Sem (Error e ': r) a     -> Sem r (Either e a) errorToIOFinal sem = withStrategicToFinal @IO $ do-  m' <- runS (runErrorAsExcFinal sem)+  m' <- bindS (`runErrorAsExcFinal` sem)   s  <- getInitialStateS-  pure $-    either-      ((<$ s) . Left . unwrapExc)-      (fmap Right)-    <$> X.try m'+  pure $ do+    uid <- newUnique+    catchWithUid @e uid (fmap Right <$> m' (uid <$ s)) (pure . (<$ s) . Left) {-# INLINE errorToIOFinal #-}  runErrorAsExcFinal     :: forall e r a-    .  ( Typeable e-       , Member (Final IO) r+    .  ( Member (Final IO) r        )-    => Sem (Error e ': r) a+    => Unique+    -> Sem (Error e ': r) a     -> Sem r a-runErrorAsExcFinal = interpretFinal $ \case-  Throw e   -> pure $ X.throwIO $ WrappedExc e+runErrorAsExcFinal uid = interpretFinal $ \case+  Throw e   -> pure $ X.throwIO $ WrappedExc uid (unsafeCoerce e)   Catch m h -> do     m' <- runS m     h' <- bindS h     s  <- getInitialStateS-    pure $ X.catch m' $ \(se :: WrappedExc e) ->-      h' (unwrapExc se <$ s)+    pure $ catchWithUid uid m' $ \e -> h' (e <$ s) {-# INLINE runErrorAsExcFinal #-}----------------------------------------------------------------------------------- | Run an 'Error' effect as an 'IO' 'X.Exception'. This interpretation is--- significantly faster than 'runError', at the cost of being less flexible.------ @since 1.0.0.0-lowerError-    :: ( Typeable e-       , Member (Embed IO) r-       )-    => (∀ x. Sem r x -> IO x)-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is-       -- likely some combination of 'runM' and other interpreters composed via-       -- '.@'.-    -> Sem (Error e ': r) a-    -> Sem r (Either e a)-lowerError lower-    = embed-    . fmap (first unwrapExc)-    . X.try-    . (lower .@ runErrorAsExc)-{-# INLINE lowerError #-}-{-# DEPRECATED lowerError "Use 'errorToIOFinal' instead" #-}----- TODO(sandy): Can we use the new withLowerToIO machinery for this?-runErrorAsExc-    :: forall e r a. ( Typeable e-       , Member (Embed IO) r-       )-    => (∀ x. Sem r x -> IO x)-    -> Sem (Error e ': r) a-    -> Sem r a-runErrorAsExc lower = interpretH $ \case-  Throw e -> embed $ X.throwIO $ WrappedExc e-  Catch main handle -> do-    is <- getInitialStateT-    m  <- runT main-    h  <- bindT handle-    let runIt = lower . runErrorAsExc lower-    embed $ X.catch (runIt m) $ \(se :: WrappedExc e) ->-      runIt $ h $ unwrapExc se <$ is-{-# INLINE runErrorAsExc #-}

@@ -73,45 +73,3 @@       fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s {-# INLINE fixpointToFinal #-} ---------------------------------------------------------------------------------- | Run a 'Fixpoint' effect purely.------ __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'.-runFixpoint-    :: (∀ x. Sem r x -> x)-    -> Sem (Fixpoint ': r) a-    -> Sem r a-runFixpoint lower = interpretH $ \case-  Fixpoint mf -> do-    c   <- bindT mf-    s   <- getInitialStateT-    ins <- getInspectorT-    pure $ fix $ \fa ->-      lower . runFixpoint lower . c $-        fromMaybe (bomb "runFixpoint") (inspect ins fa) <$ s-{-# INLINE runFixpoint #-}-{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \-                           \'Data.Functor.Identity.Identity' instead" #-}------------------------------------------------------------------------------------ | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.------ __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'.-runFixpointM-    :: ( MonadFix m-       , Member (Embed m) r-       )-    => (∀ x. Sem r x -> m x)-    -> Sem (Fixpoint ': r) a-    -> Sem r a-runFixpointM lower = interpretH $ \case-  Fixpoint mf -> do-    c   <- bindT mf-    s   <- getInitialStateT-    ins <- getInspectorT-    embed $ mfix $ \fa ->-      lower . runFixpointM lower . c $-        fromMaybe (bomb "runFixpointM") (inspect ins fa) <$ s-{-# INLINE runFixpointM #-}-{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}

@@ -3,14 +3,11 @@ module Polysemy.IO   ( -- * Interpretations     embedToMonadIO-  , lowerEmbedded   ) where  import Control.Monad.IO.Class import Polysemy import Polysemy.Embed-import Polysemy.Internal-import Polysemy.Internal.Union   ------------------------------------------------------------------------------@@ -44,29 +41,3 @@ embedToMonadIO = runEmbedded $ liftIO @m {-# INLINE embedToMonadIO #-} ----------------------------------------------------------------------------------- | Given some @'MonadIO' m@, interpret all @'Embed' m@ actions in that monad--- at once. This is useful for interpreting effects like databases, which use--- their own monad for describing actions.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 1.0.0.0-lowerEmbedded-    :: ( MonadIO m-       , Member (Embed IO) r-       )-    => (forall x. m x -> IO x)  -- ^ The means of running this monad.-    -> Sem (Embed m ': r) a-    -> Sem r a-lowerEmbedded run_m (Sem m) = withLowerToIO $ \lower _ ->-  run_m $ m $ \u ->-    case decomp u of-      Left x -> liftIO-              . lower-              . liftSem-              $ hoist (lowerEmbedded run_m) x--      Right (Weaving (Embed wd) s _ y _) ->-        y <$> ((<$ s) <$> wd)

@@ -34,11 +34,10 @@   , usingSem   , liftSem   , hoistSem+  , restack   , Append   , InterpreterFor   , InterpretersFor-  , (.@)-  , (.@@)   ) where  import Control.Applicative@@ -345,6 +344,11 @@ hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u {-# INLINE hoistSem #-} +restack :: (forall e. ElemOf e r -> ElemOf e r')+        -> Sem r a+        -> Sem r' a+restack n = hoistSem $ \(Union pr wav) -> hoist (restack n) $ Union (n pr) wav+{-# INLINE restack #-}  ------------------------------------------------------------------------------ -- | Introduce an arbitrary number of effects on top of the effect stack. This@@ -573,8 +577,25 @@   --------------------------------------------------------------------------------- | Embed an effect into a 'Sem'. This is used primarily via--- 'Polysemy.makeSem' to implement smart constructors.+-- | Execute an action of an effect.+--+-- This is primarily used to create methods for actions of effects:+--+-- @+-- data FooBar m a where+--   Foo :: String -> m a -> FooBar m a+--   Bar :: FooBar m Int+--+-- foo :: Member FooBar r => String -> Sem r a -> Sem r a+-- foo s m = send (Foo s m)+--+-- bar :: Member FooBar r => Sem r Int+-- bar = send Bar+-- @+--+-- 'Polysemy.makeSem' allows you to eliminate this boilerplate.+--+-- @since TODO send :: Member e r => e (Sem r) a -> Sem r a send = liftSem . inj {-# INLINE[3] send #-}@@ -637,65 +658,3 @@ -- @since 1.5.0.0 type InterpretersFor es r = ∀ a. Sem (Append es r) a -> Sem r a ----------------------------------------------------------------------------------- | Some interpreters need to be able to lower down to the base monad (often--- 'IO') in order to function properly --- some good examples of this are--- 'Polysemy.Error.lowerError' and 'Polysemy.Resource.lowerResource'.------ However, these interpreters don't compose particularly nicely; for example,--- to run 'Polysemy.Resource.lowerResource', you must write:------ @--- runM . lowerError runM--- @------ Notice that 'runM' is duplicated in two places here. The situation gets--- exponentially worse the more intepreters you have that need to run in this--- pattern.------ Instead, '.@' performs the composition we'd like. The above can be written as------ @--- (runM .@ lowerError)--- @------ The parentheses here are important; without them you'll run into operator--- precedence errors.------ __Warning:__ This combinator will __duplicate work__ that is intended to be--- just for initialization. This can result in rather surprising behavior. For--- a version of '.@' that won't duplicate work, see the @.\@!@ operator in--- <http://hackage.haskell.org/package/polysemy-zoo/docs/Polysemy-IdempotentLowering.html polysemy-zoo>.------ Interpreters using 'Polysemy.Final' may be composed normally, and--- avoid the work duplication issue. For that reason, you're encouraged to use--- @-'Polysemy.Final'@ interpreters instead of @lower-@ interpreters whenever--- possible.-(.@)-    :: Monad m-    => (∀ x. Sem r x -> m x)-       -- ^ The lowering function, likely 'runM'.-    -> (∀ y. (∀ x. Sem r x -> m x)-          -> Sem (e ': r) y-          -> Sem r y)-    -> Sem (e ': r) z-    -> m z-f .@ g = f . g f-infixl 8 .@------------------------------------------------------------------------------------ | Like '.@', but for interpreters which change the resulting type --- eg.--- 'Polysemy.Error.lowerError'.-(.@@)-    :: Monad m-    => (∀ x. Sem r x -> m x)-       -- ^ The lowering function, likely 'runM'.-    -> (∀ y. (∀ x. Sem r x -> m x)-          -> Sem (e ': r) y-          -> Sem r (f y))-    -> Sem (e ': r) z-    -> m (f z)-f .@@ g = f . g f-infixl 8 .@@

@@ -18,6 +18,7 @@   , reinterpretH   , reinterpret2H   , reinterpret3H+  , interpretWeaving    -- * Conditional   , interceptUsing@@ -28,6 +29,7 @@   , lazilyStateful   ) where +import           Control.Arrow ((>>>)) import           Control.Monad import qualified Control.Monad.Trans.State.Lazy as LS import qualified Control.Monad.Trans.State.Strict as S@@ -86,6 +88,18 @@     Right (Weaving e s d y v) -> do       fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e {-# INLINE interpretH #-}++-- | Interpret an effect @e@ through a natural transformation from @Weaving e@+-- to @Sem r@+interpretWeaving ::+  ∀ e r .+  (∀ x . Weaving e (Sem (e : r)) x -> Sem r x) ->+  InterpreterFor e r+interpretWeaving h (Sem m) =+  Sem \ k -> m $ decomp >>> \case+    Right wav -> runSem (h wav) k+    Left g -> k $ hoist (interpretWeaving h) g+{-# inline interpretWeaving #-}  ------------------------------------------------------------------------------ -- | A highly-performant combinator for interpreting an effect statefully. See

@@ -1,87 +0,0 @@-{-# LANGUAGE NumDecimals     #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies    #-}--{-# OPTIONS_HADDOCK not-home #-}--module Polysemy.Internal.Forklift where--import qualified Control.Concurrent.Async as A-import           Control.Concurrent.Chan.Unagi-import           Control.Concurrent.MVar-import           Control.Exception-import           Polysemy.Internal-import           Polysemy.Internal.Union------------------------------------------------------------------------------------ | A promise for interpreting an effect of the union @r@ in another thread.------ @since 0.5.0.0-data Forklift r = forall a. Forklift-  { responseMVar :: MVar a-  , request      :: Union r (Sem r) a-  }------------------------------------------------------------------------------------ | A strategy for automatically interpreting an entire stack of effects by--- just shipping them off to some other interpretation context.------ @since 0.5.0.0-runViaForklift-    :: Member (Embed IO) r-    => InChan (Forklift r)-    -> Sem r a-    -> 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 u-      takeMVar mvar-{-# INLINE runViaForklift #-}------------------------------------------------------------------------------------- | Run an effect stack all the way down to 'IO' by running it in a new--- thread, and temporarily turning the current thread into an event poll.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 0.5.0.0-withLowerToIO-    :: 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-       -- action need not be called.-    -> Sem r a-withLowerToIO action = do-  (inchan, outchan) <- embed newChan-  signal <- embed newEmptyMVar--  res <- embed $ A.async $ do-    a <- action (runViaForklift inchan)-                (putMVar signal ())-          `finally` (putMVar signal ())-    pure a--  let me = do-        raced <- embed $ A.race (takeMVar signal) $ readChan outchan-        case raced of-          Left () -> embed $ A.wait res-          Right (Forklift mvar req) -> do-            resp <- liftSem req-            embed $ putMVar mvar $ resp-            me_b-      {-# INLINE me #-}--      me_b = me-      {-# NOINLINE me_b #-}--  me-

@@ -0,0 +1,154 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_HADDOCK not-home #-}++module Polysemy.Internal.Scoped where++import Data.Kind (Type)++import Polysemy++-- | @Scoped@ transforms a program so that an interpreter for @effect@ may+-- perform arbitrary actions, like resource management, before and after the+-- computation wrapped by a call to 'scoped' is executed.+--+-- An application for this is @Polysemy.Conc.Events@ from+-- <https://hackage.haskell.org/package/polysemy-conc>, in which each program+-- using the effect @Polysemy.Conc.Consume@ is interpreted with its own copy of+-- the event channel; or a database transaction, in which a transaction handle+-- is created for the wrapped program and passed to the interpreter for the+-- database effect.+--+-- For a longer exposition, see <https://www.tweag.io/blog/2022-01-05-polysemy-scoped/>.+-- Note that the interface has changed since the blog post was published: The+-- @resource@ parameter no longer exists.+--+-- Resource allocation is performed by a function passed to+-- 'Polysemy.Scoped.interpretScoped'.+--+-- The constructors are not intended to be used directly; the smart constructor+-- 'scoped' is used like a local interpreter for @effect@. 'scoped' takes an+-- argument of type @param@, which will be passed through to the interpreter, to+-- be used by the resource allocation function.+--+-- As an example, imagine an effect for writing lines to a file:+--+-- > data Write :: Effect where+-- >   Write :: Text -> Write m ()+-- > makeSem ''Write+--+-- If we now have the following requirements:+--+-- 1. The file should be opened and closed right before and after the part of+--    the program in which we write lines+-- 2. The file name should be specifiable at the point in the program where+--    writing begins+-- 3. We don't want to commit to IO, lines should be stored in memory when+--    running tests+--+-- Then we can take advantage of 'Scoped' to write this program:+--+-- > prog :: Member (Scoped FilePath Write) r => Sem r ()+-- > prog = do+-- >   scoped "file1.txt" do+-- >     write "line 1"+-- >     write "line 2"+-- >   scoped "file2.txt" do+-- >     write "line 1"+-- >     write "line 2"+--+-- Here 'scoped' creates a prompt for an interpreter to start allocating a+-- resource for @"file1.txt"@ and handling @Write@ actions using that resource.+-- When the 'scoped' block ends, the resource should be freed.+--+-- The interpreter may look like this:+--+-- > interpretWriteFile :: Members '[Resource, Embed IO] => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteFile =+-- >   interpretScoped allocator handler+-- >   where+-- >     allocator name use = bracket (openFile name WriteMode) hClose use+-- >     handler fileHandle (Write line) = embed (Text.hPutStrLn fileHandle line)+--+-- Essentially, the @bracket@ is executed at the point where @scoped@ was+-- called, wrapping the following block. When the second @scoped@ is executed,+-- another call to @bracket@ is performed.+--+-- The effect of this is that the operation that uses @Embed IO@ was moved from+-- the call site to the interpreter, while the interpreter may be executed at+-- the outermost layer of the app.+--+-- This makes it possible to use a pure interpreter for testing:+--+-- > interpretWriteOutput :: Member (Output (FilePath, Text)) r => InterpreterFor (Scoped FilePath Write) r+-- > interpretWriteOutput =+-- >   interpretScoped (\ name use -> use name) \ name -> \case+-- >     Write line -> output (name, line)+--+-- Here we simply pass the name to the interpreter in the resource allocation+-- function.+--+-- Now imagine that we drop requirement 2 from the initial list – we still want+-- the file to be opened and closed as late/early as possible, but the file name+-- is globally fixed. For this case, the @param@ type is unused, and the API+-- provides some convenience aliases to make your code more concise:+--+-- > prog :: Member (Scoped_ Write) r => Sem r ()+-- > prog = do+-- >   scoped_ do+-- >     write "line 1"+-- >     write "line 2"+-- >   scoped_ do+-- >     write "line 1"+-- >     write "line 2"+--+-- The type 'Scoped_' and the constructor 'scoped_' simply fix @param@ to @()@.+data Scoped (param :: Type) (effect :: Effect) :: Effect where+  Run :: ∀ param effect m a . effect m a -> Scoped param effect m a+  InScope :: ∀ param effect m a . param -> m a -> Scoped param effect m a++-- |A convenience alias for a scope without parameters.+type Scoped_ effect =+  Scoped () effect++-- | Constructor for 'Scoped', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped' param effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped ::+  ∀ param effect r .+  Member (Scoped param effect) r =>+  param ->+  InterpreterFor effect r+scoped param main =+  send $ InScope @param @effect param do+    transform @effect (Run @param) main+{-# inline scoped #-}++-- | Constructor for 'Scoped_', taking a nested program and transforming all+-- instances of @effect@ to @'Scoped_' effect@.+--+-- Please consult the documentation of 'Scoped' for details and examples.+scoped_ ::+  ∀ effect r .+  Member (Scoped_ effect) r =>+  InterpreterFor effect r+scoped_ = scoped ()+{-# inline scoped_ #-}++-- | Transform the parameters of a 'Scoped' program.+--+-- This allows incremental additions to the data passed to the interpreter, for+-- example to create an API that permits different ways of running an effect+-- with some fundamental parameters being supplied at scope creation and some+-- optional or specific parameters being selected by the user downstream.+rescope ::+  ∀ param0 param1 effect r .+  Member (Scoped param1 effect) r =>+  (param0 -> param1) ->+  InterpreterFor (Scoped param0 effect) r+rescope fp =+  transform \case+    Run e          -> Run @param1 e+    InScope p main -> InScope (fp p) main+{-# inline rescope #-}+

@@ -1,4 +1,4 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP, TemplateHaskell #-}  {-# OPTIONS_HADDOCK not-home #-} @@ -31,6 +31,9 @@  import Control.Monad import Language.Haskell.TH+#if __GLASGOW_HASKELL__ >= 902+import Language.Haskell.TH.Syntax (addModFinalizer)+#endif import Language.Haskell.TH.Datatype import Polysemy.Internal.TH.Common @@ -152,7 +155,10 @@ genDec :: Bool -> ConLiftInfo -> Q [Dec] genDec should_mk_sigs cli = do   let fun_args_names = fst <$> cliFunArgs cli-+#if __GLASGOW_HASKELL__ >= 902+  doc <- getDoc $ DeclDoc $ cliConName cli+  maybe (pure ()) (addModFinalizer . putDoc (DeclDoc $ cliFunName cli)) doc+#endif   pure     [ PragmaD $ InlineP (cliFunName cli) Inlinable ConLike AllPhases     , FunD (cliFunName cli)

@@ -72,7 +72,7 @@  instance Functor (Union r mWoven) where   fmap f (Union w t) = Union w $ f <$> t-  {-# INLINE fmap #-}+  {-# INLINABLE fmap #-}   data Weaving e mAfter resultType where@@ -104,7 +104,7 @@  instance Functor (Weaving e m) where   fmap f (Weaving e s d f' v) = Weaving e s d (f . f') v-  {-# INLINE fmap #-}+  {-# INLINABLE fmap #-}   @@ -121,7 +121,7 @@               (fmap Compose . d . fmap nt . getCompose)               (fmap f . getCompose)               (v <=< v' . getCompose)-{-# INLINE weave #-}+{-# INLINABLE weave #-}   hoist@@ -130,7 +130,7 @@     -> Union r n a hoist f' (Union w (Weaving e s nt f v)) =   Union w $ Weaving e s (f' . nt) f v-{-# INLINE hoist #-}+{-# INLINABLE hoist #-}  ------------------------------------------------------------------------------ -- | A proof that @e@ is an element of @r@.@@ -193,11 +193,9 @@  instance {-# OVERLAPPING #-} Member t (t ': z) where   membership' = Here-  {-# INLINE membership' #-}  instance Member t z => Member t (_1 ': z) where   membership' = There $ membership' @t @z-  {-# INLINE membership' #-}  ------------------------------------------------------------------------------ -- | A class for effect rows whose elements are inspectable.@@ -211,27 +209,27 @@  instance KnownRow '[] where   tryMembership' = Nothing-  {-# INLINE tryMembership' #-}+  {-# INLINABLE tryMembership' #-}  instance (Typeable e, KnownRow r) => KnownRow (e ': r) where   tryMembership' :: forall e'. Typeable e' => Maybe (ElemOf e' (e ': r))   tryMembership' = case eqT @e @e' of     Just Refl -> Just Here     _         -> There <$> tryMembership' @r @e'-  {-# INLINE tryMembership' #-}+  {-# INLINABLE tryMembership' #-}  ------------------------------------------------------------------------------ -- | Given @'Member' e r@, extract a proof that @e@ is an element of @r@. membership :: Member e r => ElemOf e r membership = membership'-{-# INLINE membership #-}+{-# INLINABLE membership #-}  ------------------------------------------------------------------------------ -- | Extracts a proof that @e@ is an element of @r@ if that -- is indeed the case; otherwise returns @Nothing@. tryMembership :: forall e r. (Typeable e, KnownRow r) => Maybe (ElemOf e r) tryMembership = tryMembership' @r @e-{-# INLINE tryMembership #-}+{-# INLINABLE tryMembership #-}   ------------------------------------------------------------------------------@@ -241,7 +239,7 @@ extendMembershipLeft :: forall l r e. SList l -> ElemOf e r -> ElemOf e (Append l r) extendMembershipLeft SEnd pr = pr extendMembershipLeft (SCons l) pr = There (extendMembershipLeft l pr)-{-# INLINE extendMembershipLeft #-}+{-# INLINABLE extendMembershipLeft #-}   ------------------------------------------------------------------------------@@ -250,7 +248,7 @@ extendMembershipRight :: forall l r e. ElemOf e l -> ElemOf e (Append l r) extendMembershipRight Here = Here extendMembershipRight (There e) = There (extendMembershipRight @_ @r e)-{-# INLINE extendMembershipRight #-}+{-# INLINABLE extendMembershipRight #-}   ------------------------------------------------------------------------------@@ -265,7 +263,7 @@ injectMembership SEnd sm pr = extendMembershipLeft sm pr injectMembership (SCons _) _ Here = Here injectMembership (SCons sl) sm (There pr) = There (injectMembership @right sl sm pr)-{-# INLINE injectMembership #-}+{-# INLINABLE injectMembership #-}   ------------------------------------------------------------------------------@@ -276,14 +274,14 @@   case p of     Here  -> Right a     There pr -> Left $ Union pr a-{-# INLINE decomp #-}+{-# INLINABLE decomp #-}  ------------------------------------------------------------------------------ -- | Retrieve the last effect in a 'Union'. extract :: Union '[e] m a -> Weaving e m a extract (Union Here a)   = a extract (Union (There _) _) = error "Unsafe use of UnsafeMkElemOf"-{-# INLINE extract #-}+{-# INLINABLE extract #-}   ------------------------------------------------------------------------------@@ -297,7 +295,7 @@ -- head. weaken :: forall e r m a. Union r m a -> Union (e ': r) m a weaken (Union pr a) = Union (There pr) a-{-# INLINE weaken #-}+{-# INLINABLE weaken #-}   ------------------------------------------------------------------------------@@ -305,7 +303,7 @@ -- the head, specified as a singleton list proof. weakenList :: SList l -> Union r m a -> Union (Append l r) m a weakenList sl (Union pr e) = Union (extendMembershipLeft sl pr) e-{-# INLINE weakenList #-}+{-# INLINABLE weakenList #-}   ------------------------------------------------------------------------------@@ -317,7 +315,7 @@           -> Union (Append left right) m a           -> Union (Append left (Append mid right)) m a weakenMid sl sm (Union pr e) = Union (injectMembership @right sl sm pr) e-{-# INLINE weakenMid #-}+{-# INLINABLE weakenMid #-}   ------------------------------------------------------------------------------@@ -329,7 +327,7 @@   (fmap Identity . runIdentity)   runIdentity   (Just . runIdentity)-{-# INLINE inj #-}+{-# INLINABLE inj #-}   ------------------------------------------------------------------------------@@ -343,13 +341,13 @@   (fmap Identity . runIdentity)   runIdentity   (Just . runIdentity)-{-# INLINE injUsing #-}+{-# INLINABLE injUsing #-}  ------------------------------------------------------------------------------ -- | Lift a @'Weaving' e@ into a 'Union' capable of holding it. injWeaving :: forall e r m a. Member e r => Weaving e m a -> Union r m a injWeaving = Union membership-{-# INLINE injWeaving #-}+{-# INLINABLE injWeaving #-}  ------------------------------------------------------------------------------ -- | Attempt to take an @e@ effect out of a 'Union'.@@ -359,7 +357,7 @@     => Union r m a     -> Maybe (Weaving e m a) prj = prjUsing membership-{-# INLINE prj #-}+{-# INLINABLE prj #-}  ------------------------------------------------------------------------------ -- | Attempt to take an @e@ effect out of a 'Union', given an explicit@@ -370,7 +368,7 @@   -> Union r m a   -> Maybe (Weaving e m a) prjUsing pr (Union sn a) = (\Refl -> a) <$> sameMember pr sn-{-# INLINE prjUsing #-}+{-# INLINABLE prjUsing #-}  ------------------------------------------------------------------------------ -- | Like 'decomp', but allows for a more efficient@@ -382,4 +380,4 @@   case p of     Here  -> Right a     There pr -> Left (Union (There pr) a)-{-# INLINE decompCoerce #-}+{-# INLINABLE decompCoerce #-}

@@ -148,8 +148,8 @@                 -> o                 -> STM ()     writeListen tvar switch = \o -> do-      alreadyCommited <- readTVar switch-      unless alreadyCommited $ do+      alreadyCommitted <- readTVar switch+      unless alreadyCommitted $ do         s <- readTVar tvar         writeTVar tvar $! s <> o       write o@@ -184,8 +184,8 @@       o <- readTVar tvar       let !o' = f o       -- Likely redundant, but doesn't hurt.-      alreadyCommited <- readTVar switch-      unless alreadyCommited $+      alreadyCommitted <- readTVar switch+      unless alreadyCommitted $         write o'       writeTVar switch True     {-# INLINE commitPass #-}

@@ -1,197 +0,0 @@-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE UndecidableInstances   #-}--#if __GLASGOW_HASKELL__ < 806--- There is a bug in older versions of Haddock that don't allow documentation--- on GADT arguments.-#define HADDOCK ---#else-#define HADDOCK -- ^-#endif--module Polysemy.Law-  ( Law (..)-  , runLaw-  , MakeLaw (..)-  , Citizen (..)-  , printf-  , module Test.QuickCheck-  ) where--import Control.Arrow (first)-import Data.Char-import Polysemy-import Test.QuickCheck------------------------------------------------------------------------------------ | Associates the name @r@ with the eventual type @a@. For example,--- @'Citizen' (String -> Bool) Bool@ can produce arbitrary @Bool@s by calling--- the given function with arbitrary @String@s.-class Citizen r a | r -> a where-  -- | Generate two @a@s via two @r@s. Additionally, produce a list of strings-  -- corresponding to any arbitrary arguments we needed to build.-  getCitizen :: r -> r -> Gen ([String], (a, a))--instance {-# OVERLAPPING #-} Citizen (Sem r a -> b) (Sem r a -> b) where-  getCitizen r1 r2 = pure ([], (r1, r2))--instance Citizen (Sem r a) (Sem r a) where-  getCitizen r1 r2 = pure ([], (r1, r2))--instance (Arbitrary a, Show a, Citizen b r) => Citizen (a -> b) r where-  getCitizen f1 f2 = do-    a <- arbitrary-    first (show a :) <$> getCitizen (f1 a) (f2 a)------------------------------------------------------------------------------------ | A law that effect @e@ must satisfy whenever it is in environment @r@. You--- can use 'runLaw' to transform these 'Law's into QuickCheck-able 'Property's.-data Law e r where-  -- | A pure 'Law', that doesn't require any access to 'IO'.-  Law-      :: ( Eq a-         , Show a-         , Citizen i12n (Sem r x -> a)-         , Citizen res (Sem (e ': r) x)-         )-      => i12n-         HADDOCK An interpretation from @'Sem' r x@ down to a pure value. This is-         -- likely 'run'.-      -> String-         HADDOCK A string representation of the left-hand of the rule. This is-         -- a formatted string, for more details, refer to 'printf'.-      -> res-         HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this-         -- is a function type, it's guaranteed to be called with the same-         -- arguments that the right-handed side was called with.-      -> String-         HADDOCK A string representation of the right-hand of the rule. This is-         -- a formatted string, for more details, refer to 'printf'.-      -> res-         HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this-         -- is a function type, it's guaranteed to be called with the same-         -- arguments that the left-handed side was called with.-      -> Law e r-  -- | Like 'Law', but for 'IO'-accessing effects.-  LawIO-      :: ( Eq a-         , Show a-         , Citizen i12n (Sem r x -> IO a)-         , Citizen res (Sem (e ': r) x)-         )-      => i12n-         HADDOCK An interpretation from @'Sem' r x@ down to an 'IO' value. This is-         -- likely 'runM'.-      -> String-         HADDOCK A string representation of the left-hand of the rule. This is-         -- a formatted string, for more details, refer to 'printf'.-      -> res-         HADDOCK The left-hand rule. This thing may be of type @'Sem' (e ': r) x@,-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this-         -- is a function type, it's guaranteed to be called with the same-         -- arguments that the right-handed side was called with.-      -> String-         HADDOCK A string representation of the right-hand of the rule. This is-         -- a formatted string, for more details, refer to 'printf'.-      -> res-         HADDOCK The right-hand rule. This thing may be of type @'Sem' (e ': r) x@,-         -- or be a function type that reproduces a @'Sem' (e ': r) x@. If this-         -- is a function type, it's guaranteed to be called with the same-         -- arguments that the left-handed side was called with.-      -> Law e r------------------------------------------------------------------------------------ | A typeclass that provides the smart constructor 'mkLaw'.-class MakeLaw e r where-  -- | A smart constructor for building 'Law's.-  mkLaw-      :: (Eq a, Show a, Citizen res (Sem (e ': r) a))-      => String-      -> res-      -> String-      -> res-      -> Law e r--instance MakeLaw e '[] where-  mkLaw = Law run--instance MakeLaw e '[Embed IO] where-  mkLaw = LawIO runM------------------------------------------------------------------------------------ | Produces a QuickCheck-able 'Property' corresponding to whether the given--- interpreter satisfies the 'Law'.-runLaw :: InterpreterFor e r -> Law e r -> Property-runLaw i12n (Law finish str1 a str2 b) = property $ do-  (_, (lower, _)) <- getCitizen finish finish-  (args, (ma, mb)) <- getCitizen a b-  let run_it = lower . i12n-      a' = run_it ma-      b' = run_it mb-  pure $-    counterexample-      (mkCounterexampleString str1 a' str2 b' args)-      (a' == b')-runLaw i12n (LawIO finish str1 a str2 b) = property $ do-  (_, (lower, _)) <- getCitizen finish finish-  (args, (ma, mb)) <- getCitizen a b-  let run_it = lower . i12n-  pure $ ioProperty $ do-    a' <- run_it ma-    b' <- run_it mb-    pure $-      counterexample-        (mkCounterexampleString str1 a' str2 b' args)-        (a' == b')------------------------------------------------------------------------------------ | Make a string representation for a failing 'runLaw' property.-mkCounterexampleString-    :: Show a-    => String-    -> a-    -> String-    -> a-    -> [String]-    -> String-mkCounterexampleString str1 a str2 b args =-  mconcat-    [ printf str1 args , " (result: " , show a , ")\n /= \n"-    , printf str2 args , " (result: " , show b , ")"-    ]------------------------------------------------------------------------------------ | A bare-boned implementation of printf. This function will replace tokens--- of the form @"%n"@ in the first string with @args !! n@.------ This will only work for indexes up to 9.------ For example:------ >>> printf "hello %1 %2% %3 %1" ["world", "50"]--- "hello world 50% %3 world"-printf :: String -> [String] -> String-printf str args = splitArgs str-  where-    splitArgs :: String -> String-    splitArgs s =-      case break (== '%') s of-        (as, "") -> as-        (as, _ : b : bs)-          | isDigit b-          , let d = read [b] - 1-          , d < length args-            -> as ++ (args !! d) ++ splitArgs bs-        (as, _ : bs) ->  as ++ "%" ++ splitArgs bs-

@@ -14,8 +14,6 @@     -- * Interpretations   , runResource   , resourceToIOFinal-  , resourceToIO-  , lowerResource   ) where  import qualified Control.Exception as X@@ -96,16 +94,6 @@ -- will have local state semantics in regards to 'Resource' effects -- interpreted this way. See 'Final'. ----- Notably, unlike 'resourceToIO', 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./------ Use 'resourceToIO' instead if you need to run--- pure, stateful interpreters after the interpreter for 'Resource'.--- (Pure interpreters are interpreters that aren't expressed in terms of--- another effect or monad; for example, 'Polysemy.State.runState'.)--- -- @since 1.2.0.0 resourceToIOFinal :: Member (Final IO) r                   => Sem (Resource ': r) a@@ -139,42 +127,6 @@   --------------------------------------------------------------------------------- | Run a 'Resource' effect in terms of 'X.bracket'.------ @since 1.0.0.0-lowerResource-    :: ∀ r a-     . Member (Embed IO) r-    => (∀ x. Sem r x -> IO x)-       -- ^ Strategy for lowering a 'Sem' action down to 'IO'. This is likely-       -- some combination of 'runM' and other interpreters composed via '.@'.-    -> Sem (Resource ': r) a-    -> Sem r a-lowerResource finish = interpretH $ \case-  Bracket alloc dealloc use -> do-    a <- runT  alloc-    d <- bindT dealloc-    u <- bindT use--    let run_it :: Sem (Resource ': r) x -> IO x-        run_it = finish .@ lowerResource--    embed $ X.bracket (run_it a) (run_it . d) (run_it . u)--  BracketOnError alloc dealloc use -> do-    a <- runT  alloc-    d <- bindT dealloc-    u <- bindT use--    let run_it :: Sem (Resource ': r) x -> IO x-        run_it = finish .@ lowerResource--    embed $ X.bracketOnError (run_it a) (run_it . d) (run_it . u)-{-# INLINE lowerResource #-}-{-# DEPRECATED lowerResource "Use 'resourceToIOFinal' instead" #-}--------------------------------------------------------------------------------- -- | Run a 'Resource' effect purely. -- -- @since 1.0.0.0@@ -211,63 +163,4 @@         _ <- run_it $ d resource         pure result {-# INLINE runResource #-}------------------------------------------------------------------------------------ | A more flexible --- though less safe ---  version of 'resourceToIOFinal'------ This function is capable of running 'Resource' effects anywhere within an--- effect stack, without relying on an explicit function to lower it into 'IO'.--- Notably, this means that 'Polysemy.State.State' effects will be consistent--- in the presence of 'Resource'.------ ResourceToIO' is safe whenever you're concerned about exceptions thrown--- by effects _already handled_ in your effect stack, or in 'IO' code run--- directly inside of 'bracket'. It is not safe against exceptions thrown--- explicitly at the main thread. If this is not safe enough for your use-case,--- use 'resourceToIOFinal' instead.------ This function creates a thread, and so should be compiled with @-threaded@.------ @since 1.0.0.0-resourceToIO-    :: forall r a-     . Member (Embed IO) r-    => Sem (Resource ': r) a-    -> Sem r a-resourceToIO = interpretH $ \case-  Bracket a b c -> do-    ma <- runT a-    mb <- bindT b-    mc <- bindT c--    withLowerToIO $ \lower finish -> do-      let done :: Sem (Resource ': r) x -> IO x-          done = lower . raise . resourceToIO-      X.bracket-          (done ma)-          (\x -> done (mb x) >> finish)-          (done . mc)--  BracketOnError a b c -> do-    ins <- getInspectorT-    ma <- runT a-    mb <- bindT b-    mc <- bindT c--    withLowerToIO $ \lower finish -> do-      let done :: Sem (Resource ': r) x -> IO x-          done = lower . raise . resourceToIO-      X.bracketOnError-          (done ma)-          (\x -> done (mb x) >> finish)-          (\x -> do-            result <- done $ mc x-            case inspect ins result of-              Just _ -> pure result-              Nothing -> do-                _ <- done $ mb x-                pure result-          )-{-# INLINE resourceToIO #-} 

@@ -0,0 +1,279 @@+{-# language AllowAmbiguousTypes #-}++module Polysemy.Scoped (+  -- * Effect+  Scoped,++  -- * Constructors+  scoped,+  scoped_,+  rescope,++  -- * Interpreters+  interpretScopedH,+  interpretScopedH',+  interpretScoped,+  interpretScopedAs,+  interpretScopedWithH,+  interpretScopedWith,+  interpretScopedWith_,+  runScoped,+  runScopedAs,+) where++import Polysemy.Internal+import Polysemy.Internal.Sing+import Polysemy.Internal.Union+import Polysemy.Internal.Combinators+import Polysemy.Internal.Scoped+import Polysemy.Internal.Tactics++-- | Construct an interpreter for a higher-order effect wrapped in a 'Scoped',+-- given a resource allocation function and a parameterized handler for the+-- plain effect.+--+-- This combinator is analogous to 'interpretH' in that it allows the handler to+-- use the 'Tactical' environment and transforms the effect into other effects+-- on the stack.+interpretScopedH ::+  ∀ resource param effect r .+  -- | A callback function that allows the user to acquire a resource for each+  -- computation wrapped by 'scoped' using other effects, with an additional+  -- argument that contains the call site parameter passed to 'scoped'.+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  -- | A handler like the one expected by 'interpretH' with an additional+  -- parameter that contains the @resource@ allocated by the first argument.+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedH withResource scopedHandler =+  -- TODO investigate whether loopbreaker optimization is effective here+  go (errorWithoutStackTrace "top level run")+  where+    go :: resource -> InterpreterFor (Scoped param effect) r+    go resource =+      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+        Run act ->+          ex <$> runTactics s (raise . go resource . wv) ins (go resource . wv)+            (scopedHandler resource act)+        InScope param main ->+          withResource param \ resource' -> ex <$> go resource' (wv (main <$ s))+{-# inline interpretScopedH #-}++-- | Variant of 'interpretScopedH' that allows the resource acquisition function+-- to use 'Tactical'.+interpretScopedH' ::+  ∀ resource param effect r .+  (∀ e r0 x . param -> (resource -> Tactical e (Sem r0) r x) ->+    Tactical e (Sem r0) r x) ->+  (∀ r0 x .+    resource -> effect (Sem r0) x ->+    Tactical (Scoped param effect) (Sem r0) r x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedH' withResource scopedHandler =+  go (errorWithoutStackTrace "top level run")+  where+    go :: resource -> InterpreterFor (Scoped param effect) r+    go resource =+      interpretH \case+        Run act ->+          scopedHandler resource act+        InScope param main ->+          withResource param \ resource' ->+            raise . go resource' =<< runT main+{-# inline interpretScopedH' #-}++-- | First-order variant of 'interpretScopedH'.+interpretScoped ::+  ∀ resource param effect r .+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (∀ m x . resource -> effect m x -> Sem r x) ->+  InterpreterFor (Scoped param effect) r+interpretScoped withResource scopedHandler =+  interpretScopedH withResource \ r e -> liftT (scopedHandler r e)+{-# inline interpretScoped #-}++-- | Variant of 'interpretScoped' in which the resource allocator is a plain+-- action.+interpretScopedAs ::+  ∀ resource param effect r .+  (param -> Sem r resource) ->+  (∀ m x . resource -> effect m x -> Sem r x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedAs resource =+  interpretScoped \ p use -> use =<< resource p+{-# inline interpretScopedAs #-}++-- | Higher-order interpreter for 'Scoped' that allows the handler to use+-- additional effects that are interpreted by the resource allocator.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@.+--+-- As an example for a higher order effect, consider a mutexed concurrent state+-- effect, where an effectful function may lock write access to the state while+-- making it still possible to read it:+--+-- > data MState s :: Effect where+-- >   MState :: (s -> m (s, a)) -> MState s m a+-- >   MRead :: MState s m s+-- >+-- > makeSem ''MState+--+-- We can now use an 'Polysemy.AtomicState.AtomicState' to store the current+-- value and lock write access with an @MVar@. Since the state callback is+-- effectful, we need a higher order interpreter:+--+-- > withResource ::+-- >   Member (Embed IO) r =>+-- >   s ->+-- >   (MVar () -> Sem (AtomicState s : r) a) ->+-- >   Sem r a+-- > withResource initial use = do+-- >   tv <- embed (newTVarIO initial)+-- >   lock <- embed (newMVar ())+-- >   runAtomicStateTVar tv $ use lock+-- >+-- > interpretMState ::+-- >   ∀ s r .+-- >   Members [Resource, Embed IO] r =>+-- >   InterpreterFor (Scoped s (MState s)) r+-- > interpretMState =+-- >   interpretScopedWithH @'[AtomicState s] withResource \ lock -> \case+-- >     MState f ->+-- >       bracket_ (embed (takeMVar lock)) (embed (tryPutMVar lock ())) do+-- >         s0 <- atomicGet+-- >         res <- runTSimple (f s0)+-- >         Inspector ins <- getInspectorT+-- >         for_ (ins res) \ (s, _) -> atomicPut s+-- >         pure (snd <$> res)+-- >     MRead ->+-- >       liftT atomicGet+interpretScopedWithH ::+  ∀ extra resource param effect r r1 .+  (KnownList extra, r1 ~ Append extra r) =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->+  (∀ r0 x . resource -> effect (Sem r0) x -> Tactical effect (Sem r0) r1 x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedWithH withResource scopedHandler =+  interpretWeaving \case+    Weaving (InScope param main) s wv ex _ ->+      ex <$> withResource param \ resource -> inScope resource $+        restack+          (injectMembership+           (singList @'[Scoped param effect])+           (singList @extra)) $ wv (main <$ s)+    _ ->+      errorWithoutStackTrace "top level Run"+  where+    inScope :: resource -> InterpreterFor (Scoped param effect) r1+    inScope resource =+      interpretWeaving \case+        Weaving (InScope param main) s wv ex _ ->+          restack (extendMembershipLeft (singList @extra))+            (ex <$> withResource param \resource' ->+                inScope resource' (wv (main <$ s)))+        Weaving (Run act) s wv ex ins ->+          ex <$> runTactics s (raise . inScope resource . wv) ins (inScope resource . wv)+            (scopedHandler resource act)+{-# inline interpretScopedWithH #-}++-- | First-order variant of 'interpretScopedWithH'.+--+-- /Note/: It is necessary to specify the list of local interpreters with a type+-- application; GHC won't be able to figure them out from the type of+-- @withResource@:+--+-- > data SomeAction :: Effect where+-- >   SomeAction :: SomeAction m ()+-- >+-- > foo :: InterpreterFor (Scoped () SomeAction) r+-- > foo =+-- >   interpretScopedWith @[Reader Int, State Bool] localEffects \ () -> \case+-- >     SomeAction -> put . (> 0) =<< ask @Int+-- >   where+-- >     localEffects () use = evalState False (runReader 5 (use ()))+interpretScopedWith ::+  ∀ extra param resource effect r r1 .+  (r1 ~ Append extra r, KnownList extra) =>+  (∀ x . param -> (resource -> Sem r1 x) -> Sem r x) ->+  (∀ m x . resource -> effect m x -> Sem r1 x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedWith withResource scopedHandler =+  interpretScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)+{-# inline interpretScopedWith #-}++-- | Variant of 'interpretScopedWith' in which no resource is used and the+-- resource allocator is a plain interpreter.+-- This is useful for scopes that only need local effects, but no resources in+-- the handler.+--+-- See the /Note/ on 'interpretScopedWithH'.+interpretScopedWith_ ::+  ∀ extra param effect r r1 .+  (r1 ~ Append extra r, KnownList extra) =>+  (∀ x . param -> Sem r1 x -> Sem r x) ->+  (∀ m x . effect m x -> Sem r1 x) ->+  InterpreterFor (Scoped param effect) r+interpretScopedWith_ withResource scopedHandler =+  interpretScopedWithH @extra (\ p f -> withResource p (f ())) \ () e -> liftT (scopedHandler e)+{-# inline interpretScopedWith_ #-}++-- | Variant of 'interpretScoped' that uses another interpreter instead of a+-- handler.+--+-- This is mostly useful if you want to reuse an interpreter that you cannot+-- easily rewrite (like from another library). If you have full control over the+-- implementation, 'interpretScoped' should be preferred.+--+-- /Note/: The wrapped interpreter will be executed fully, including the+-- initializing code surrounding its handler, for each action in the program, so+-- if the interpreter allocates any resources, they will be scoped to a single+-- action. Move them to @withResource@ instead.+--+-- For example, consider the following interpreter for+-- 'Polysemy.AtomicState.AtomicState':+--+-- > atomicTVar :: Member (Embed IO) r => a -> InterpreterFor (AtomicState a) r+-- > atomicTVar initial sem = do+-- >   tv <- embed (newTVarIO initial)+-- >   runAtomicStateTVar tv sem+--+-- If this interpreter were used for a scoped version of @AtomicState@ like+-- this:+--+-- > runScoped (\ initial use -> use initial) \ initial -> atomicTVar initial+--+-- Then the @TVar@ would be created every time an @AtomicState@ action is run,+-- not just when entering the scope.+--+-- The proper way to implement this would be to rewrite the resource allocation:+--+-- > runScoped (\ initial use -> use =<< embed (newTVarIO initial)) runAtomicStateTVar+runScoped ::+  ∀ resource param effect r .+  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (resource -> InterpreterFor effect r) ->+  InterpreterFor (Scoped param effect) r+runScoped withResource scopedInterpreter =+  go (errorWithoutStackTrace "top level run")+  where+    go :: resource -> InterpreterFor (Scoped param effect) r+    go resource =+      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+        Run act ->+          scopedInterpreter resource+            $ liftSem $ injWeaving $ Weaving act s (raise . go resource . wv) ex ins+        InScope param main ->+          withResource param \ resource' -> ex <$> go resource' (wv (main <$ s))+{-# inline runScoped #-}++-- | Variant of 'runScoped' in which the resource allocator returns the resource+-- rather tnen calling a continuation.+runScopedAs ::+  ∀ resource param effect r .+  (param -> Sem r resource) ->+  (resource -> InterpreterFor effect r) ->+  InterpreterFor (Scoped param effect) r+runScopedAs resource = runScoped \ p use -> use =<< resource p+{-# inline runScopedAs #-}

@@ -1,59 +0,0 @@-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Polysemy.State.Law where--import Polysemy-import Polysemy.Law-import Polysemy.State-import Control.Applicative-import Control.Arrow------------------------------------------------------------------------------------ | A collection of laws that show a `State` interpreter is correct.-prop_lawfulState-    :: forall r s-     . (Eq s, Show s, Arbitrary s, MakeLaw (State s) r)-    => InterpreterFor (State s) r-    -> Property-prop_lawfulState i12n = conjoin-  [ runLaw i12n law_putTwice-  , runLaw i12n law_getTwice-  , runLaw i12n law_getPutGet-  ]---law_putTwice-    :: forall s r-     . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)-    => Law (State s) r-law_putTwice =-  mkLaw-    "put %1 >> put %2 >> get"-    (\s s' -> put @s s >> put @s s' >> get @s)-    "put %2 >> get"-    (\_ s' ->             put @s s' >> get @s)--law_getTwice-    :: forall s r-     . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)-    => Law (State s) r-law_getTwice =-  mkLaw-    "liftA2 (,) get get"-    (liftA2 (,) (get @s) (get @s))-    "(id &&& id) <$> get"-    ((id &&& id) <$> get @s)--law_getPutGet-    :: forall s r-     . (Eq s, Arbitrary s, Show s, MakeLaw (State s) r)-    => Law (State s) r-law_getPutGet =-  mkLaw-    "get >>= put >> get"-    (get @s >>= put @s >> get @s)-    "get"-    (get @s)-

@@ -39,7 +39,7 @@ --             -> 'Sem' r a --             -> 'Sem' r a -- taggedLocal f m =---   'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m)+--   'tag' \@k \@('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m) -- @ -- tag

@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Polysemy.View-  ( -- * Effect-    View (..)--    -- * Actions-  , see--    -- * Interpretations-  , viewToState-  , viewToInput-  ) where--import Polysemy-import Polysemy.Input-import Polysemy.State-import Polysemy.Tagged------------------------------------------------------------------------------------ | A 'View' is an expensive computation that should be cached.-data View v m a where-  See :: View v m v--makeSem ''View------------------------------------------------------------------------------------ | Transform a 'View' into an 'Input'.-viewToInput-    :: forall v i r a-     . Member (Input i) r-    => (i -> v)-    -> Sem (View v ': r) a-    -> Sem r a-viewToInput f = interpret $ \case-  See -> f <$> input------------------------------------------------------------------------------------ | Get a 'View' as an exensive computation over an underlying 'State' effect.--- This 'View' is only invalidated when the underlying 'State' changes.-viewToState-    :: forall v s r a-     . Member (State s) r-    => (s -> Sem r v)-    -> Sem (View v ': r) a-    -> Sem r a-viewToState f = do-  evalState Dirty-    . untag @"view" @(State (Cached v))-    . intercept @(State s)-      ( \case-        Get -> get-        Put s -> do-          put s-          tag @"view" @(State (Cached v)) $ put $ Dirty @v-      )-    . reinterpret @(View v)-      ( \case-          See -> do-            dirty <- tagged @"view" $ get @(Cached v)-            case dirty of-              Dirty -> do-                s <- get-                v' <- raise $ f s-                tagged @"view" $ put $ Cached v'-                pure v'-              Cached v -> pure v-      )---data Cached a = Cached a | Dirty-  deriving (Eq, Ord, Show, Functor)-

@@ -1,47 +0,0 @@-{-# LANGUAGE NumDecimals #-}--module AsyncSpec where--import Control.Concurrent.MVar-import Control.Monad-import Polysemy-import Polysemy.Async-import Polysemy.State-import Polysemy.Trace-import Test.Hspec---spec :: Spec-spec = describe "async" $ do-  it "should thread state and not lock" $ do-    (ts, (s, r)) <- runM-                  . runTraceList-                  . runState "hello"-                  . asyncToIO $ do-      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 $ putMVar lock1 ()-          embed $ takeMVar lock2-          get >>= message 1--          get @String--      void $ async $ do-          embed $ takeMVar lock1-          get >>= message 2-          put "pong"-          embed $ putMVar lock2 ()--      await a1 <* put "final"--    ts `shouldContain` ["1> hello", "2> olleh", "1> pong"]-    s `shouldBe` "final"-    r `shouldBe` Just "pong"

@@ -151,16 +151,6 @@         . runResource         . runError @() -runTest2-  :: 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))@@ -185,9 +175,6 @@       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@@ -200,9 +187,6 @@     -> 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

@@ -2,6 +2,7 @@  import qualified Control.Exception as X import           Polysemy+import           Polysemy.Async import           Polysemy.Error import           Polysemy.Resource import           Test.Hspec@@ -28,11 +29,28 @@      it "should happen before Resource" $ do       a <--        runM $ resourceToIO $ runError @MyExc $ do+        runFinal $ embedToFinal @IO $ resourceToIOFinal $ runError @MyExc $ do           onException             (fromException @MyExc $ do               _ <- X.throwIO $ MyExc "hello"               pure ()             ) $ pure $ error "this exception shouldn't happen"       a `shouldBe` (Left $ MyExc "hello")+  describe "errorToIOFinal" $ do+    it "should catch errors only for the interpreted Error" $ do+      res1 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do+        raise $ throw () `catch` \() -> return ()+      res1 `shouldBe` Right (Right ())+      res2 <- runFinal $ errorToIOFinal @() $ errorToIOFinal @() $ do+        raise (throw ()) `catch` \() -> return ()+      res2 `shouldBe` Left () +    it "should propagate errors thrown in 'async'" $ do+      res1 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do+        a <- async $ throw ()+        await a+      res1 `shouldBe` (Left () :: Either () (Maybe ()))+      res2 <- runFinal $ errorToIOFinal @() $ asyncToIOFinal $ do+        a <- async $ throw ()+        await a `catch` \() -> return $ Just ()+      res2 `shouldBe` Right (Just ())

@@ -1,77 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module InspectorSpec where--import Control.Monad-import Data.IORef-import Polysemy-import Polysemy.Error-import Polysemy.State-import Test.Hspec----data Callback m a where-  Callback :: m String -> Callback m ()--makeSem ''Callback----spec :: Spec-spec = parallel $ describe "Inspector" $ do-  it "should inspect State effects" $ do-    withNewTTY $ \ref -> do-      void . (runM .@ runCallback ref)-           . runState False-           $ do-        embed $ pretendPrint ref "hello world"-        callback $ show <$> get @Bool-        modify not-        callback $ show <$> get @Bool--      result <- readIORef ref-      result `shouldContain` ["hello world"]-      result `shouldContain` ["False", "True"]--  it "should not inspect thrown Error effects" $ do-    withNewTTY $ \ref -> do-      void . (runM .@ runCallback ref)-           . runError @()-           $ do-        callback $ throw ()-        callback $ pure "nice"--      result <- readIORef ref-      result `shouldContain` [":(", "nice"]---runCallback-    :: Member (Embed IO) r-    => IORef [String]-    -> (forall x. Sem r x -> IO x)-    -> Sem (Callback ': r) a-    -> Sem r a-runCallback ref lower = interpretH $ \case-  Callback cb -> do-    cb' <- runT cb-    ins <- getInspectorT-    embed $ doCB ref $ do-      v <- lower .@ runCallback ref $ cb'-      pure $ maybe ":(" id $ inspect ins v-    getInitialStateT---doCB :: IORef [String] -> IO String -> IO ()-doCB ref m = m >>= pretendPrint ref---pretendPrint :: IORef [String] -> String -> IO ()-pretendPrint ref msg = modifyIORef ref (++ [msg])---withNewTTY :: (IORef [String] -> IO a) -> IO a-withNewTTY f = do-  ref <- newIORef []-  f ref-

@@ -1,20 +0,0 @@-module LawsSpec where--import Polysemy-import Polysemy.Law-import Polysemy.State-import Polysemy.State.Law-import Test.Hspec--spec :: Spec-spec = parallel $ do-  describe "State effects" $ do-    it "runState should pass the laws" $-      property $ prop_lawfulState @'[] $ fmap snd . runState @Int 0--    it "runLazyState should pass the laws" $-      property $ prop_lawfulState @'[] $ fmap snd . runLazyState @Int 0--    it "stateToIO should pass the laws" $-      property $ prop_lawfulState @'[Embed IO] $ fmap snd . stateToIO @Int 0-

@@ -0,0 +1,67 @@+{-# language TemplateHaskell, DerivingStrategies, GeneralizedNewtypeDeriving #-}++module ScopedSpec where++import Control.Concurrent.STM+import Polysemy+import Polysemy.Scoped+import Test.Hspec++newtype Par =+  Par { unPar :: Int }+  deriving stock (Eq, Show)+  deriving newtype (Num, Real, Enum, Integral, Ord)++data E :: Effect where+  E1 :: E m Int+  E2 :: E m Int++makeSem ''E++data F :: Effect where+  F :: F m Int++makeSem ''F++handleE ::+  Member (Embed IO) r =>+  TVar Int ->+  E m a ->+  Tactical effect m (F : r) a+handleE tv = \case+  E1 -> do+    i1 <- embed (readTVarIO tv)+    i2 <- f+    pureT (i1 + i2 + 10)+  E2 ->+    pureT (-1)++interpretF ::+  Member (Embed IO) r =>+  TVar Int ->+  InterpreterFor F r+interpretF tv =+  interpret \ F -> do+    embed (atomically (writeTVar tv 7))+    pure 5++scope ::+  Member (Embed IO) r =>+  Par ->+  (TVar Int -> Sem (F : r) a) ->+  Sem r a+scope (Par n) use = do+  tv <- embed (newTVarIO n)+  interpretF tv (use tv)++spec :: Spec+spec = parallel do+  describe "Scoped" do+    it "local effects" do+      (i1, i2) <- runM $ interpretScopedWithH @'[F] @(TVar Int) @Par @E scope handleE do+        scoped @Par @E 20 do+          i1 <- e1+          i2 <- scoped @Par @E 23 e1+          pure (i1, i2)+      35 `shouldBe` i1+      38 `shouldBe` i2

@@ -45,18 +45,3 @@ -- ... tooFewArgumentsReinterpret = () ------------------------------------------------------------------------------------- |--- >>> :{--- let foo :: Member Resource r => Sem r ()---     foo = undefined---  in runM $ lowerResource foo--- :}--- ...--- ... Couldn't match expected type...--- ... with actual type...--- ... Probable cause: ... is applied to too few arguments--- ...-missingArgumentToRunResourceInIO = ()-

@@ -1,40 +0,0 @@-module ViewSpec where--import Polysemy-import Polysemy.State-import Polysemy.Trace-import Polysemy.View-import Test.Hspec---check_see :: Members '[View String, Trace] r => Sem r ()-check_see = trace . ("saw " ++) =<< see--spec :: Spec-spec = parallel $ do-  describe "View effect" $ do-    it "should cache views" $ do-      let a = run-            . runTraceList-            . runState @Int 0-            . viewToState @String @Int (\i -> do-                  trace $ "caching "  ++ show i-                  pure $ show i  ) $ do-              check_see-              check_see-              put @Int 3-              trace "it's lazy"-              put @Int 5-              check_see-              check_see-              get @Int--      a `shouldBe` ([ "caching 0"-                    , "saw 0"-                    , "saw 0"-                    , "it's lazy"-                    , "caching 5"-                    , "saw 5"-                    , "saw 5"-                    ], (5, 5))-