diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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/) diff --git a/bench/Poly.hs b/bench/Poly.hs deleted file mode 100644 --- a/bench/Poly.hs +++ /dev/null @@ -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 - ) - diff --git a/bench/countDown.hs b/bench/countDown.hs deleted file mode 100644 --- a/bench/countDown.hs +++ /dev/null @@ -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 - ] - ] diff --git a/polysemy.cabal b/polysemy.cabal --- a/polysemy.cabal +++ b/polysemy.cabal @@ -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 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.* diff --git a/src/Polysemy.hs b/src/Polysemy.hs --- a/src/Polysemy.hs +++ b/src/Polysemy.hs @@ -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 diff --git a/src/Polysemy/Async.hs b/src/Polysemy/Async.hs --- a/src/Polysemy/Async.hs +++ b/src/Polysemy/Async.hs @@ -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 . --- --- 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" #-} diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs --- a/src/Polysemy/Error.hs +++ b/src/Polysemy/Error.hs @@ -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 #-} diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs --- a/src/Polysemy/Fixpoint.hs +++ b/src/Polysemy/Fixpoint.hs @@ -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" #-} diff --git a/src/Polysemy/IO.hs b/src/Polysemy/IO.hs --- a/src/Polysemy/IO.hs +++ b/src/Polysemy/IO.hs @@ -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) diff --git a/src/Polysemy/Internal.hs b/src/Polysemy/Internal.hs --- a/src/Polysemy/Internal.hs +++ b/src/Polysemy/Internal.hs @@ -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 --- . --- --- 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 .@@ diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs --- a/src/Polysemy/Internal/Combinators.hs +++ b/src/Polysemy/Internal/Combinators.hs @@ -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 diff --git a/src/Polysemy/Internal/Forklift.hs b/src/Polysemy/Internal/Forklift.hs deleted file mode 100644 --- a/src/Polysemy/Internal/Forklift.hs +++ /dev/null @@ -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 - diff --git a/src/Polysemy/Internal/Scoped.hs b/src/Polysemy/Internal/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Internal/Scoped.hs @@ -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 +-- , 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 . +-- 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 #-} + diff --git a/src/Polysemy/Internal/TH/Effect.hs b/src/Polysemy/Internal/TH/Effect.hs --- a/src/Polysemy/Internal/TH/Effect.hs +++ b/src/Polysemy/Internal/TH/Effect.hs @@ -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) diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs --- a/src/Polysemy/Internal/Union.hs +++ b/src/Polysemy/Internal/Union.hs @@ -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 #-} diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs --- a/src/Polysemy/Internal/Writer.hs +++ b/src/Polysemy/Internal/Writer.hs @@ -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 #-} diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs deleted file mode 100644 --- a/src/Polysemy/Law.hs +++ /dev/null @@ -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 - diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs --- a/src/Polysemy/Resource.hs +++ b/src/Polysemy/Resource.hs @@ -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 #-} diff --git a/src/Polysemy/Scoped.hs b/src/Polysemy/Scoped.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Scoped.hs @@ -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 #-} diff --git a/src/Polysemy/State/Law.hs b/src/Polysemy/State/Law.hs deleted file mode 100644 --- a/src/Polysemy/State/Law.hs +++ /dev/null @@ -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) - diff --git a/src/Polysemy/Tagged.hs b/src/Polysemy/Tagged.hs --- a/src/Polysemy/Tagged.hs +++ b/src/Polysemy/Tagged.hs @@ -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 diff --git a/src/Polysemy/View.hs b/src/Polysemy/View.hs deleted file mode 100644 --- a/src/Polysemy/View.hs +++ /dev/null @@ -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) - diff --git a/test/AsyncSpec.hs b/test/AsyncSpec.hs deleted file mode 100644 --- a/test/AsyncSpec.hs +++ /dev/null @@ -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" diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs --- a/test/BracketSpec.hs +++ b/test/BracketSpec.hs @@ -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 diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -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 ()) diff --git a/test/InspectorSpec.hs b/test/InspectorSpec.hs deleted file mode 100644 --- a/test/InspectorSpec.hs +++ /dev/null @@ -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 - diff --git a/test/LawsSpec.hs b/test/LawsSpec.hs deleted file mode 100644 --- a/test/LawsSpec.hs +++ /dev/null @@ -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 - diff --git a/test/ScopedSpec.hs b/test/ScopedSpec.hs new file mode 100644 --- /dev/null +++ b/test/ScopedSpec.hs @@ -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 diff --git a/test/TypeErrors.hs b/test/TypeErrors.hs --- a/test/TypeErrors.hs +++ b/test/TypeErrors.hs @@ -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 = () - diff --git a/test/ViewSpec.hs b/test/ViewSpec.hs deleted file mode 100644 --- a/test/ViewSpec.hs +++ /dev/null @@ -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)) -