polysemy 1.8.0.0 → 1.9.0.0

raw patch · 44 files changed

+446/−141 lines, 44 filesdep ~doctestPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: doctest

API changes (from Hackage documentation)

Files

• ChangeLog.md +24/−1
• polysemy.cabal +5/−3
• src/Polysemy.hs +1/−0
• src/Polysemy/Async.hs +4/−0
• src/Polysemy/AtomicState.hs +8/−0
• src/Polysemy/Bundle.hs +2/−0
• src/Polysemy/Embed.hs +1/−0
• src/Polysemy/Embed/Type.hs +1/−0
• src/Polysemy/Error.hs +10/−0
• src/Polysemy/Fail.hs +1/−0
• src/Polysemy/Fail/Type.hs +8/−0
• src/Polysemy/Final.hs +3/−0
• src/Polysemy/Fixpoint.hs +1/−0
• src/Polysemy/IO.hs +2/−1
• src/Polysemy/Input.hs +2/−0
• src/Polysemy/Internal.hs +9/−1
• src/Polysemy/Internal/Bundle.hs +6/−0
• src/Polysemy/Internal/Combinators.hs +1/−0
• src/Polysemy/Internal/CustomErrors.hs +5/−3
• src/Polysemy/Internal/CustomErrors/Redefined.hs +1/−0
• src/Polysemy/Internal/Fixpoint.hs +1/−0
• src/Polysemy/Internal/Index.hs +2/−1
• src/Polysemy/Internal/Kind.hs +3/−0
• src/Polysemy/Internal/NonDet.hs +1/−0
• src/Polysemy/Internal/Scoped.hs +10/−5
• src/Polysemy/Internal/Sing.hs +9/−1
• src/Polysemy/Internal/Strategy.hs +4/−1
• src/Polysemy/Internal/TH/Common.hs +4/−3
• src/Polysemy/Internal/TH/Effect.hs +8/−8
• src/Polysemy/Internal/Tactics.hs +5/−0
• src/Polysemy/Internal/Union.hs +9/−1
• src/Polysemy/Internal/Writer.hs +6/−1
• src/Polysemy/Membership.hs +1/−0
• src/Polysemy/NonDet.hs +1/−0
• src/Polysemy/Opaque.hs +54/−0
• src/Polysemy/Output.hs +2/−0
• src/Polysemy/Reader.hs +5/−0
• src/Polysemy/Resource.hs +3/−0
• src/Polysemy/Scoped.hs +151/−101
• src/Polysemy/State.hs +15/−8
• src/Polysemy/Tagged.hs +2/−0
• src/Polysemy/Trace.hs +2/−0
• src/Polysemy/Writer.hs +1/−0
• test/ScopedSpec.hs +52/−2

@@ -6,7 +6,24 @@  ### Other Changes +## 1.9.0.0 (2022-12-28) +### Breaking Changes+- Slightly modified the signatures of the various `Scoped` interpreters.++### Other Changes+- Added `runScopedNew`, a simple but powerful `Scoped` interpreter.+  `runScopedNew` can be considered a sneak-peek of the future of `Scoped`,+  which will eventually receive a major API rework to make it both simpler and+  more expressive.+- Fixed a bug in various `Scoped` interpreters where a `scoped` usage of an+  effect always relied on the nearest enclosing use of `scoped` from the same+  `Scoped` effect, rather than the `scoped` which handles the effect.+- Added `Polysemy.Opaque`, a module for the `Opaque` effect newtype, meant as+  a tool to wrap polymorphic effect variables so they don't jam up resolution of+  `Member` constraints.+- Expose the type alias `Scoped_` for a scoped effect without callsite parameters.+ ## 1.8.0.0 (2022-12-22)  ### Breaking Changes@@ -25,13 +42,19 @@     `fixpointToFinal` instead. - Changed semantics of `errorToIOFinal` so that it no longer catches errors   from other handlers of the same type.+- The semantics of `runScoped` has been changed so that the provided interpreter+  is now used only once per use of `scoped`, instead of each individual action.  ### Other Changes  - Exposed `send` from `Polysemy`. - Dramatically improved build performance of projects when compiling with `-O2`. - Removed the debug `dump-core` flag.-+- Introduced the new meta-effect `Scoped`, which allows running an interpreter locally whose implementation is deferred+  to a later stage.+- Fixed a bug in various `Scoped` interpreters where any explicit recursive+  interpretation of higher-order computations that the handler may perform are+  ignored by the interpreter, and the original handler was reused instead.  ## 1.7.1.0 (2021-11-23) 

@@ -1,11 +1,11 @@ cabal-version: 2.0 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack  name:           polysemy-version:        1.8.0.0+version:        1.9.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@@ -65,6 +65,7 @@       Polysemy.IO       Polysemy.Membership       Polysemy.NonDet+      Polysemy.Opaque       Polysemy.Output       Polysemy.Reader       Polysemy.Resource@@ -142,6 +143,7 @@       Paths_polysemy       Build_doctests   autogen-modules:+      Paths_polysemy       Build_doctests   hs-source-dirs:       test@@ -165,7 +167,7 @@       async >=2.2 && <3     , base >=4.9 && <5     , containers >=0.5 && <0.7-    , doctest >=0.16.0.1 && <0.19+    , doctest >=0.16.0.1 && <0.21     , first-class-families >=0.5.0.0 && <0.9     , hspec >=2.6.0 && <3     , hspec-discover >=2.0

@@ -1,3 +1,4 @@+-- | Description: Polysemy is a library for writing high-power, low-boilerplate domain specific languages module Polysemy   ( -- * Core Types     Sem ()

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The effect 'Async', providing an interface to "Control.Concurrent.Async" module Polysemy.Async   ( -- * Effect     Async (..)@@ -30,8 +31,11 @@ -- -- @since 0.5.0.0 data Async m a where+  -- | Run the given action asynchronously and return a thread handle.   Async :: m a -> Async m (A.Async (Maybe a))+  -- | Wait for the thread referenced by the given handle to terminate.   Await :: A.Async a -> Async m a+  -- | Cancel the thread referenced by the given handle.   Cancel :: A.Async a -> Async m ()  makeSem ''Async

@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-}++-- | Description: The 'AtomicState' effect module Polysemy.AtomicState   ( -- * Effect     AtomicState (..)@@ -36,7 +38,9 @@ -- -- @since 1.1.0.0 data AtomicState s m a where+  -- | Run a state action.   AtomicState :: (s -> (s, a)) -> AtomicState s m a+  -- | Get the state.   AtomicGet   :: AtomicState s m s  makeSem_ ''AtomicState@@ -78,6 +82,8 @@   return a {-# INLINE atomicState' #-} +-----------------------------------------------------------------------------+-- | Replace the state with the given value. atomicPut :: Member (AtomicState s) r           => s           -> Sem r ()@@ -86,6 +92,8 @@   return () {-# INLINE atomicPut #-} +-----------------------------------------------------------------------------+-- | Modify the state lazily. atomicModify :: Member (AtomicState s) r              => (s -> s)              -> Sem r ()

@@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}++-- | Description: The 'Bundle' effect for bundling effects module Polysemy.Bundle   ( -- * Effect     Bundle (..)

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for the effect 'Embed' module Polysemy.Embed   ( -- * Effect     Embed (..)

@@ -2,6 +2,7 @@  {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Embed' effect module Polysemy.Embed.Type   ( -- * Effect     Embed (..)

@@ -1,6 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell     #-}+{-# OPTIONS_HADDOCK prune #-} +-- | Description: The effect 'Error' and its interpreters module Polysemy.Error   ( -- * Effect     Error (..)@@ -37,8 +39,16 @@ import           Unsafe.Coerce              (unsafeCoerce)  +------------------------------------------------------------------------------+-- | This effect abstracts the throwing and catching of errors, leaving+-- it up to the interpreter whether to use exceptions or monad transformers+-- like 'E.ExceptT' to perform the short-circuiting mechanism. data Error e m a where+  -- | Short-circuit the current program using the given error value.   Throw :: e -> Error e m a+  -- | Recover from an error that might have been thrown in the higher-order+  -- action given by the first argument by passing the error to the handler+  -- given by the second argument.   Catch :: ∀ e m a. m a -> (e -> m a) -> Error e m a  makeSem ''Error

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: 'Fail' interpreters module Polysemy.Fail   ( -- * Effect     Fail(..)

@@ -1,3 +1,11 @@+-- | Description: 'Fail' effect module Polysemy.Fail.Type where +------------------------------------------------------------------------------+-- | This effect abstracts the concept of 'Control.Monad.Fail.MonadFail',+-- which is a built-in mechanism that converts pattern matching errors to+-- calls to the current monad's instance of that class.+--+-- The instance defined in "Polysemy.Internal" uses this effect to catch+-- those errors. newtype Fail m a = Fail String

@@ -1,4 +1,7 @@ {-# LANGUAGE TemplateHaskell #-}++-- | Description: The effect 'Final' that allows embedding higher-order actions in+-- the final target monad of the effect stack module Polysemy.Final   (     -- * Effect

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-} +-- | Description: Interpreters for 'Fixpoint' module Polysemy.Fixpoint   ( -- * Effect     Fixpoint (..)

@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +-- | Description: Compatibility with 'MonadIO' module Polysemy.IO   ( -- * Interpretations     embedToMonadIO@@ -11,7 +12,7 @@   --------------------------------------------------------------------------------- The 'MonadIO' class is conceptually an interpretation of 'IO' to some+-- | The 'MonadIO' class is conceptually an interpretation of 'IO' to some -- other monad. This function reifies that intuition, by transforming an 'IO' -- effect into some other 'MonadIO'. --

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Input' effect module Polysemy.Input   ( -- * Effect     Input (..)@@ -23,6 +24,7 @@ -- | An effect which can provide input to an application. Useful for dealing -- with streaming input. data Input i m a where+  -- | Get the next available message.   Input :: Input i m i  makeSem ''Input

@@ -8,6 +8,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'Sem' type and the most basic stack manipulation utilities module Polysemy.Internal   ( Sem (..)   , Member@@ -332,11 +333,15 @@   {-# INLINE mfix #-}  +------------------------------------------------------------------------------+-- | Create a 'Sem' from a 'Union' with matching stacks. liftSem :: Union r (Sem r) a -> Sem r a liftSem u = Sem $ \k -> k u {-# INLINE liftSem #-}  +------------------------------------------------------------------------------+-- | Extend the stack of a 'Sem' with an explicit 'Union' transformation. hoistSem     :: (∀ x. Union r (Sem r) x -> Union r' (Sem r') x)     -> Sem r a@@ -344,6 +349,9 @@ hoistSem nat (Sem m) = Sem $ \k -> m $ \u -> k $ nat u {-# INLINE hoistSem #-} +------------------------------------------------------------------------------+-- | Extend the stack of a 'Sem' with an explicit membership proof+-- transformation. restack :: (forall e. ElemOf e r -> ElemOf e r')         -> Sem r a         -> Sem r' a@@ -362,7 +370,7 @@ {-# INLINE raise_ #-}  --- | See 'raise''.+-- | See 'raise'. -- -- @since 1.4.0.0 class Raise (r :: EffectRow) (r' :: EffectRow) where

@@ -2,17 +2,23 @@  {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Stack manipulation handlers for the 'Polysemy.Bundle.Bundle' effect module Polysemy.Internal.Bundle where  import Polysemy (Members) import Polysemy.Internal.Union (ElemOf(..), membership) import Polysemy.Internal.Kind (Append) +------------------------------------------------------------------------------+-- | Extend a membership proof's stack by arbitrary effects. extendMembership :: forall r r' e. ElemOf e r -> ElemOf e (Append r r') extendMembership Here = Here extendMembership (There e) = There (extendMembership @_ @r' e) {-# INLINE extendMembership #-} +------------------------------------------------------------------------------+-- | Transform a membership proof's stack by arbitrary effects using evidence+-- from the context. subsumeMembership :: forall r r' e. Members r r' => ElemOf e r -> ElemOf e r' subsumeMembership Here = membership @e @r' subsumeMembership (There (pr :: ElemOf e r'')) = subsumeMembership @r'' @r' pr

@@ -2,6 +2,7 @@  {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The basic interpreter-building combinators module Polysemy.Internal.Combinators   ( -- * First order     interpret

@@ -4,8 +4,9 @@ {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: type-errors-pretty redefinitions module Polysemy.Internal.CustomErrors   ( WhenStuck   , FirstOrder@@ -16,9 +17,10 @@ import Data.Kind import Fcf import GHC.TypeLits (Symbol)-import Polysemy.Internal.Kind+import Type.Errors hiding (IfStuck, UnlessStuck, WhenStuck)+ import Polysemy.Internal.CustomErrors.Redefined-import Type.Errors hiding (IfStuck, WhenStuck, UnlessStuck)+import Polysemy.Internal.Kind   -- These are taken from type-errors-pretty because it's not in stackage for 9.0.1

@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# OPTIONS_HADDOCK prune #-}  ------------------------------------------------------------------------------ -- | This code is copied verbatim from 'Type.Errors' due to limitations in the

@@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: 'Fixpoint' effect module Polysemy.Internal.Fixpoint where  ------------------------------------------------------------------------------

@@ -4,8 +4,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: Class 'InsertAtIndex' that allows stack extension at a numeric index module Polysemy.Internal.Index where  import GHC.TypeLits (Nat)

@@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Kind aliases 'Effect' and 'EffectRow' module Polysemy.Internal.Kind where  import Data.Kind (Type)@@ -17,6 +18,8 @@ type EffectRow = [Effect]  +------------------------------------------------------------------------------+-- | Append two type-level lists. type family Append l r where   Append (a ': l) r = a ': (Append l r)   Append '[] r = r

@@ -4,6 +4,7 @@  {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The 'NonDet' effect module Polysemy.Internal.NonDet where  

@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The meta-effect 'Scoped' module Polysemy.Internal.Scoped where  import Data.Kind (Type)@@ -103,9 +104,13 @@ -- -- 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+  Run :: ∀ param effect m a . Word -> effect m a -> Scoped param effect m a+  InScope :: ∀ param effect m a . param -> (Word -> m a) -> Scoped param effect m a +-- | An auxiliary effect for 'Scoped'.+data OuterRun (effect :: Effect) :: Effect where+  OuterRun :: ∀ effect m a . Word -> effect m a -> OuterRun effect m a+ -- |A convenience alias for a scope without parameters. type Scoped_ effect =   Scoped () effect@@ -120,8 +125,8 @@   param ->   InterpreterFor effect r scoped param main =-  send $ InScope @param @effect param do-    transform @effect (Run @param) main+  send $ InScope @param @effect param $ \w ->+    transform @effect (Run @param w) main {-# inline scoped #-}  -- | Constructor for 'Scoped_', taking a nested program and transforming all@@ -148,7 +153,7 @@   InterpreterFor (Scoped param0 effect) r rescope fp =   transform \case-    Run e          -> Run @param1 e+    Run w e        -> Run @param1 w e     InScope p main -> InScope (fp p) main {-# inline rescope #-} 

@@ -5,15 +5,21 @@  {-# OPTIONS_HADDOCK not-home #-} +-- | Description: Singleton list module Polysemy.Internal.Sing where -import GHC.TypeLits (type (-), Nat)+import GHC.TypeLits (Nat, type (-))+ import Polysemy.Internal.Kind (Effect) +------------------------------------------------------------------------------+-- | A singleton type used as a witness for type-level lists. data SList l where   SEnd  :: SList '[]   SCons :: SList xs -> SList (x ': xs) +------------------------------------------------------------------------------+-- | A singleton list constructor class. class KnownList l where   singList :: SList l @@ -25,6 +31,8 @@   singList = SCons singList   {-# INLINE singList #-} +------------------------------------------------------------------------------+-- | A utility class for constructing a type-level list of a given length. class ListOfLength (n :: Nat) (l :: [Effect]) where   listOfLength :: SList l 

@@ -1,5 +1,7 @@ {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary effect 'Strategy' used for building interpreters+-- that embed 'Sem's in 'IO' callbacks module Polysemy.Internal.Strategy where  import Polysemy.Internal@@ -7,7 +9,8 @@ import Polysemy.Internal.Tactics (Inspector(..))  -+------------------------------------------------------------------------------+-- | See 'Strategic'. data Strategy m f n z a where   GetInitialState     :: Strategy m f n z (f ())   HoistInterpretation :: (a -> n b) -> Strategy m f n z (f a -> m (f b))

@@ -4,8 +4,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns    #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: TH utilities for generating effect constructors module Polysemy.Internal.TH.Common   ( ConLiftInfo (..)   , getEffectMetadata@@ -168,8 +169,8 @@  ------------------------------------------------------------------------------ -- | Given a 'ConLiftInfo', this will produce an action for it. It's arguments--- will come from any variables in scope that correspond to the 'cliArgs' of--- the 'ConLiftInfo'.+-- will come from any variables in scope that correspond to the 'cliEffArgs'+-- of the 'ConLiftInfo'. makeUnambiguousSend :: Bool -> ConLiftInfo -> Exp makeUnambiguousSend should_make_sigs cli =   let fun_args_names = fst <$> cliFunArgs cli

@@ -3,7 +3,7 @@ {-# OPTIONS_HADDOCK not-home #-}  -- | This module provides Template Haskell functions for automatically generating--- effect operation functions (that is, functions that use 'send') from a given+-- effect operation functions (that is, functions that use 'Polysemy.send') from a given -- effect algebra. For example, using the @FileSystem@ effect from the example in -- the module documentation for "Polysemy", we can write the following: --@@ -18,11 +18,11 @@ -- This will automatically generate (approximately) the following functions: -- -- @--- readFile :: 'Member' FileSystem r => 'FilePath' -> 'Sem' r 'String'--- readFile a = 'send' (ReadFile a)+-- readFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'Polysemy.Sem' r 'String'+-- readFile a = 'Polysemy.send' (ReadFile a) ----- writeFile :: 'Member' FileSystem r => 'FilePath' -> 'String' -> 'Sem' r ()--- writeFile a b = 'send' (WriteFile a b)+-- writeFile :: 'Polysemy.Member' FileSystem r => 'FilePath' -> 'String' -> 'Polysemy.Sem' r ()+-- writeFile a b = 'Polysemy.send' (WriteFile a b) -- @ module Polysemy.Internal.TH.Effect   ( makeSem@@ -76,8 +76,8 @@ -- rules to work properly: -- -- * 'makeSem_' must be used /before/ the explicit type signatures--- * signatures have to specify argument of 'Sem' representing union of--- effects as @r@ (e.g. @'Sem' r ()@)+-- * signatures have to specify argument of 'Polysemy.Sem' representing union of+-- effects as @r@ (e.g. @'Polysemy.Sem' r ()@) -- * all arguments in effect's type constructor have to follow naming scheme -- from data constructor's declaration: --@@ -121,7 +121,7 @@  ------------------------------------------------------------------------------ -- | Generates declarations and possibly signatures for functions to lift GADT--- constructors into 'Sem' actions.+-- constructors into 'Polysemy.Sem' actions. genFreer :: Bool -> Name -> Q [Dec] genFreer should_mk_sigs type_name = do   checkExtensions [ScopedTypeVariables, FlexibleContexts, DataKinds]

@@ -2,6 +2,7 @@  {-# OPTIONS_HADDOCK not-home #-} +-- | Description: The auxiliary higher-order interpreter effect 'Tactics' module Polysemy.Internal.Tactics   ( Tactics (..)   , getInitialStateT@@ -76,8 +77,12 @@ type Tactical e m r x = ∀ f. Functor f                           => Sem (WithTactics e f m r) (f x) +------------------------------------------------------------------------------+-- | Convenience type alias, see 'Tactical'. type WithTactics e f m r = Tactics f m (e ': r) ': r +------------------------------------------------------------------------------+-- | See 'Tactical'. data Tactics f n r m a where   GetInitialState      :: Tactics f n r m (f ())   HoistInterpretation  :: (a -> n b) -> Tactics f n r m (f a -> Sem r (f b))

@@ -14,8 +14,9 @@ {-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE ViewPatterns            #-} -{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-} +-- | Description: 'Union', 'Weaving' and 'ElemOf', Polysemy's core types module Polysemy.Internal.Union   ( Union (..)   , Weaving (..)@@ -75,6 +76,9 @@   {-# INLINABLE fmap #-}  +------------------------------------------------------------------------------+-- | Polysemy's core type that stores effect values together with information+-- about the higher-order interpretation state of its construction site. data Weaving e mAfter resultType where   Weaving     :: forall f e rInitial a resultType mAfter. (Functor f)@@ -188,7 +192,11 @@   Nothing  +------------------------------------------------------------------------------+-- | This class indicates that an effect must be present in the caller's stack.+-- It is the main mechanism by which a program defines its effect dependencies. class Member (t :: Effect) (r :: EffectRow) where+  -- | Create a proof that the effect @t@ is present in the effect stack @r@.   membership' :: ElemOf t r  instance {-# OVERLAPPING #-} Member t (t ': z) where

@@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns, TemplateHaskell, TupleSections #-}-{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_HADDOCK not-home, prune #-}++-- | Description: The 'Writer' effect module Polysemy.Internal.Writer where  import Control.Concurrent.STM@@ -20,8 +22,11 @@ ------------------------------------------------------------------------------ -- | An effect capable of emitting and intercepting messages. data Writer o m a where+  -- | Write a message to the log.   Tell   :: o -> Writer o m ()+  -- | Return the log produced by the higher-order action.   Listen :: ∀ o m a. m a -> Writer o m (o, a)+  -- | Run the given action and apply the function it returns to the log.   Pass   :: m (o -> o, a) -> Writer o m a  makeSem ''Writer

@@ -1,3 +1,4 @@+-- | Description: Reexports of membership related functionality module Polysemy.Membership   ( -- * Witnesses     ElemOf (..)

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass  #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: Interpreters for 'NonDet' module Polysemy.NonDet   ( -- * Effect     NonDet (..)

@@ -0,0 +1,54 @@+-- | The auxiliary effect 'Opaque' used by interpreters of 'Polysemy.Scoped.Scoped'+module Polysemy.Opaque (+  -- * Effect+  Opaque(..),++  -- * Interpreters+  toOpaque,+  fromOpaque,+  ) where++import Polysemy++-- | An effect newtype meant to be used to wrap polymorphic effect variables to+-- prevent them from jamming up resolution of 'Polysemy.Member'.+-- For example, consider:+--+-- @+-- badPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) ()+-- badPut = 'Polysemy.State.put' () -- error+-- @+--+-- This fails to compile. This is because @e@ /could/ be+-- @'Polysemy.State.State' ()@' -- in which case the 'Polysemy.State.put'+-- should target it instead of the concretely provided+-- @'Polysemy.State.State' ()@; as the compiler can't know for sure which effect+-- should be targeted, the program is rejected.+-- There are various ways to resolve this, including using 'raise' or+-- 'Polysemy.Membership.subsumeUsing'. 'Opaque' provides another way:+--+-- @+-- okPut :: 'Sem' (e ': 'Polysemy.State.State' () ': r) ()+-- okPut = 'fromOpaque' ('Polysemy.State.put' ()) -- OK+-- @+--+-- 'Opaque' is most useful as a tool for library writers, in the case where some+-- function of the library requires the user to work with an effect stack+-- containing some polymorphic effect variables. By wrapping the polymorphic+-- effect variables using 'Opaque', users of the function can use effects as+-- normal, without having to use 'raise' or 'Polysemy.Membership.subsumeUsing'+-- in order to have 'Polysemy.Member' resolve. The various interpreters of+-- 'Polysemy.Scoped.Scoped' are examples of such usage of 'Opaque'.+--+-- @since 1.9.0.0+newtype Opaque (e :: Effect) m a = Opaque (e m a)++-- | Wrap 'Opaque' around the top effect of the effect stack+toOpaque :: Sem (e ': r) a -> Sem (Opaque e ': r) a+toOpaque = rewrite Opaque+{-# INLINE toOpaque #-}++-- | Unwrap 'Opaque' around the top effect of the effect stack+fromOpaque :: Sem (Opaque e ': r) a -> Sem (e ': r) a+fromOpaque = rewrite (\(Opaque e) -> e)+{-# INLINE fromOpaque #-}

@@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns, TemplateHaskell #-} +-- | Description: The 'Output' effect for sending side-effecting messages module Polysemy.Output   ( -- * Effect     Output (..)@@ -41,6 +42,7 @@ -- | An effect capable of sending messages. Useful for streaming output and for -- logging. data Output o m a where+  -- | Output a message.   Output :: o -> Output o m ()  makeSem ''Output

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Reader' effect and its interpreters module Polysemy.Reader   ( -- * Effect     Reader (..)@@ -23,12 +24,16 @@ ------------------------------------------------------------------------------ -- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'. data Reader i m a where+  -- | Get the environment.   Ask   :: Reader i m i+  -- | Transform the environment.   Local :: (i -> i) -> m a -> Reader i m a  makeSem ''Reader  +------------------------------------------------------------------------------+-- | Apply a function to the environment and return the result. asks :: forall i j r. Member (Reader i) r => (i -> j) -> Sem r j asks f = f <$> ask {-# INLINABLE asks #-}

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Resource' effect, providing bracketing functionality module Polysemy.Resource   ( -- * Effect     Resource (..)@@ -26,6 +27,7 @@ -- will successfully run the deallocation action even in the presence of other -- short-circuiting effects. data Resource m a where+  -- | Allocate a resource, use it, and clean it up afterwards.   Bracket     :: m a        -- Action to allocate a resource.@@ -35,6 +37,7 @@     -> (a -> m b)        -- Action which uses the resource.     -> Resource m b+  -- | Allocate a resource, use it, and clean it up afterwards if an error occurred.   BracketOnError     :: m a        -- Action to allocate a resource.

@@ -1,8 +1,10 @@-{-# language AllowAmbiguousTypes #-}+{-# language AllowAmbiguousTypes, BangPatterns #-} +-- | Description: Interpreters for 'Scoped' module Polysemy.Scoped (   -- * Effect   Scoped,+  Scoped_,    -- * Constructors   scoped,@@ -10,6 +12,7 @@   rescope,    -- * Interpreters+  runScopedNew,   interpretScopedH,   interpretScopedH',   interpretScoped,@@ -21,6 +24,11 @@   runScopedAs, ) where +import Data.Function ((&))+import Data.Sequence (Seq(..))+import qualified Data.Sequence as S++import Polysemy.Opaque import Polysemy.Internal import Polysemy.Internal.Sing import Polysemy.Internal.Union@@ -40,23 +48,17 @@   -- | 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) ->+  (∀ q x . param ->+   (resource -> Sem (Opaque q ': r) x) ->+   Sem (Opaque q ': 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) ->+  (∀ q r0 x . resource ->+   effect (Sem r0) x ->+   Tactical effect (Sem r0) (Opaque q ': 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))+interpretScopedH withResource scopedHandler = runScopedNew \param sem ->+  withResource param \r -> interpretH (scopedHandler r) sem {-# inline interpretScopedH #-}  -- | Variant of 'interpretScopedH' that allows the resource acquisition function@@ -70,26 +72,28 @@     Tactical (Scoped param effect) (Sem r0) r x) ->   InterpreterFor (Scoped param effect) r interpretScopedH' withResource scopedHandler =-  go (errorWithoutStackTrace "top level run")+  go 0 Empty   where-    go :: resource -> InterpreterFor (Scoped param effect) r-    go resource =+    go :: Word -> Seq resource -> InterpreterFor (Scoped param effect) r+    go depth resources =       interpretH \case-        Run act ->-          scopedHandler resource act-        InScope param main ->-          withResource param \ resource' ->-            raise . go resource' =<< runT main+        Run w act ->+          scopedHandler (S.index resources (fromIntegral w)) act+        InScope param main | !depth' <- depth + 1 ->+          withResource param \ resource ->+            raise . go depth' (resources :|> resource) =<< runT (main depth) {-# inline interpretScopedH' #-}  -- | First-order variant of 'interpretScopedH'. interpretScoped ::   ∀ resource param effect r .-  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->+  (∀ q x . param ->+   (resource -> Sem (Opaque q ': r) x) ->+   Sem (Opaque q ': 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)+  interpretScopedH withResource \ r e -> liftT (raise (scopedHandler r e)) {-# inline interpretScoped #-}  -- | Variant of 'interpretScoped' in which the resource allocator is a plain@@ -100,7 +104,7 @@   (∀ m x . resource -> effect m x -> Sem r x) ->   InterpreterFor (Scoped param effect) r interpretScopedAs resource =-  interpretScoped \ p use -> use =<< resource p+  interpretScoped \ p use -> use =<< raise (resource p) {-# inline interpretScopedAs #-}  -- | Higher-order interpreter for 'Scoped' that allows the handler to use@@ -150,32 +154,24 @@ -- >     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) ->+  ∀ extra resource param effect r .+  KnownList extra =>+  (∀ q x .+   param ->+   (resource -> Sem (Append extra (Opaque q ': r)) x) ->+   Sem (Opaque q ': r) x) ->+  (∀ q r0 x .+   resource ->+   effect (Sem r0) x ->+   Tactical effect (Sem r0) (Append extra (Opaque q ': r)) 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)+interpretScopedWithH withResource scopedHandler = runScopedNew+  \param (sem :: Sem (effect ': Opaque q ': r) x) ->+    withResource param \resource ->+      sem+        & restack+           (injectMembership (singList @'[effect]) (singList @extra))+        & interpretH (scopedHandler @q resource) {-# inline interpretScopedWithH #-}  -- | First-order variant of 'interpretScopedWithH'.@@ -194,13 +190,24 @@ -- >   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) ->+  ∀ extra param resource effect r.+  KnownList extra =>+  (∀ q x .+   param ->+   (resource -> Sem (Append extra (Opaque q ': r)) x) ->+   Sem (Opaque q ': r) x) ->+  (∀ m x . resource -> effect m x -> Sem (Append extra r) x) ->   InterpreterFor (Scoped param effect) r-interpretScopedWith withResource scopedHandler =-  interpretScopedWithH @extra withResource \ r e -> liftT (scopedHandler r e)+interpretScopedWith withResource scopedHandler = runScopedNew+  \param (sem :: Sem (effect ': Opaque q ': r) x) ->+    withResource param \resource ->+      sem+        & restack+           (injectMembership (singList @'[effect]) (singList @extra))+        & interpretH \e -> liftT $+            restack+              (injectMembership @r (singList @extra) (singList @'[Opaque q]))+              (scopedHandler resource e) {-# inline interpretScopedWith #-}  -- | Variant of 'interpretScopedWith' in which no resource is used and the@@ -210,13 +217,18 @@ -- -- 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) ->+  ∀ extra param effect r .+  KnownList extra =>+  (∀ q x .+   param ->+   Sem (Append extra (Opaque q ': r)) x ->+   Sem (Opaque q ': r) x) ->+  (∀ m x . effect m x -> Sem (Append extra r) x) ->   InterpreterFor (Scoped param effect) r interpretScopedWith_ withResource scopedHandler =-  interpretScopedWithH @extra (\ p f -> withResource p (f ())) \ () e -> liftT (scopedHandler e)+  interpretScopedWith @extra+    (\ p f -> withResource p (f ()))+    (\ () -> scopedHandler) {-# inline interpretScopedWith_ #-}  -- | Variant of 'interpretScoped' that uses another interpreter instead of a@@ -226,54 +238,92 @@ -- 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:+-- /Note/: In previous versions of Polysemy, the wrapped interpreter was+-- executed fully, including the initializing code surrounding its handler,+-- for each action in the program. However, new and continuing discoveries+-- regarding 'Scoped' has allowed the improvement of having the interpreter be+-- used only once per use of 'scoped', and have it cover the same scope of+-- actions that the resource allocator does. ----- > runScoped (\ initial use -> use =<< embed (newTVarIO initial)) runAtomicStateTVar+-- This renders the resource allocator practically redundant; for the moment,+-- the API surrounding 'Scoped' remains the same, but work is in progress to+-- revamp the entire API of 'Scoped'. runScoped ::   ∀ resource param effect r .-  (∀ x . param -> (resource -> Sem r x) -> Sem r x) ->-  (resource -> InterpreterFor effect r) ->+  (∀ q x . param -> (resource -> Sem (Opaque q ': r) x) -> Sem (Opaque q ': r) x) ->+  (∀ q . resource -> InterpreterFor effect (Opaque q ': 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))+runScoped withResource scopedInterpreter = runScopedNew \param sem ->+  withResource param (\r -> scopedInterpreter r sem) {-# inline runScoped #-}  -- | Variant of 'runScoped' in which the resource allocator returns the resource--- rather tnen calling a continuation.+-- rather than calling a continuation. runScopedAs ::   ∀ resource param effect r .   (param -> Sem r resource) ->-  (resource -> InterpreterFor effect r) ->+  (∀ q. resource -> InterpreterFor effect (Opaque q ': r)) ->   InterpreterFor (Scoped param effect) r-runScopedAs resource = runScoped \ p use -> use =<< resource p+runScopedAs resource = runScoped \ p use -> use =<< raise (resource p) {-# inline runScopedAs #-}++-- | Run a 'Scoped' effect by specifying the interpreter to be used at every+-- use of 'scoped'.+--+-- This interpretation of 'Scoped' is powerful enough to subsume all other+-- interpretations of 'Scoped' (except 'interpretScopedH'' which works+-- differently from all other interpretations) while also being much simpler.+--+-- Consider this a sneak-peek of the future of 'Scoped'. In the API rework+-- planned for 'Scoped', the effect and its interpreters will be further+-- expanded to make 'Scoped' even more flexible.+--+-- @since 1.9.0.0+runScopedNew ::+  ∀ param effect r .+  (∀ q. param -> InterpreterFor effect (Opaque q ': r)) ->+  InterpreterFor (Scoped param effect) r+runScopedNew h =+  interpretWeaving $ \(Weaving effect s wv ex _) -> case effect of+    Run w _ -> errorWithoutStackTrace $ "top level run with depth " ++ show w+    InScope param main ->+      wv (main 0 <$ s)+        & raiseUnder2+        & go 0+        & h param+        & interpretH (\(Opaque (OuterRun w _)) ->+            errorWithoutStackTrace $ "unhandled OuterRun with depth " ++ show w)+        & fmap ex+  where+    go' :: Word+        -> InterpreterFor+             (Opaque (OuterRun effect))+             (effect ': Opaque (OuterRun effect) ': r)+    go' depth =+      interpretWeaving \ (Weaving sr@(Opaque (OuterRun w act)) s wv ex ins) ->+        if w == depth then+          liftSem $ injWeaving $ Weaving act s (go' depth . wv) ex ins+        else+          liftSem $ injWeaving $ Weaving sr s (go' depth . wv) ex ins++    -- TODO investigate whether loopbreaker optimization is effective here+    go :: Word+       -> InterpreterFor+            (Scoped param effect)+            (effect ': Opaque (OuterRun effect) ': r)+    go depth =+      interpretWeaving \ (Weaving effect s wv ex ins) -> case effect of+        Run w act+          | w == depth -> liftSem $ injWeaving $+            Weaving act s (go depth . wv) ex ins+          | otherwise -> liftSem $ injWeaving $+            Weaving (Opaque (OuterRun w act)) s (go depth . wv) ex ins+        InScope param main -> do+          let !depth' = depth + 1+          wv (main depth' <$ s)+            & go depth'+            & h param+            & raiseUnder2+            & go' depth+            & fmap ex+{-# INLINE runScopedNew #-}

@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'State' effect module Polysemy.State   ( -- * Effect     State (..)@@ -28,15 +29,15 @@   , hoistStateIntoStateT   ) where -import           Control.Monad.ST+import Control.Monad.ST import qualified Control.Monad.Trans.State as S-import           Data.IORef-import           Data.STRef-import           Data.Tuple (swap)-import           Polysemy-import           Polysemy.Internal-import           Polysemy.Internal.Combinators-import           Polysemy.Internal.Union+import Data.IORef+import Data.STRef+import Data.Tuple (swap)+import Polysemy+import Polysemy.Internal+import Polysemy.Internal.Combinators+import Polysemy.Internal.Union   ------------------------------------------------------------------------------@@ -48,17 +49,23 @@ -- Interpreters which require statefulness can 'Polysemy.reinterpret' -- themselves in terms of 'State', and subsequently call 'runState'. data State s m a where+  -- | Get the state.   Get :: State s m s+  -- | Update the state.   Put :: s -> State s m ()  makeSem ''State  +------------------------------------------------------------------------------+-- | Apply a function to the state and return the result. gets :: forall s a r. Member (State s) r => (s -> a) -> Sem r a gets f = f <$> get {-# INLINABLE gets #-}  +------------------------------------------------------------------------------+-- | Modify the state. modify :: Member (State s) r => (s -> s) -> Sem r () modify f = do   s <- get

@@ -1,4 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-}++-- | Description: The 'Tagged' effect and its interpreters module Polysemy.Tagged   (     -- * Effect

@@ -1,5 +1,6 @@ {-# LANGUAGE TemplateHaskell #-} +-- | Description: The 'Trace' effect and its interpreters module Polysemy.Trace   ( -- * Effect     Trace (..)@@ -28,6 +29,7 @@ ------------------------------------------------------------------------------ -- | An effect for logging strings. data Trace m a where+  -- | Log a message.   Trace :: String -> Trace m ()  makeSem ''Trace

@@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections #-} +-- | Description: Interpreters for 'Writer' module Polysemy.Writer   ( -- * Effect     Writer (..)

@@ -4,6 +4,7 @@  import Control.Concurrent.STM import Polysemy+import Polysemy.Internal.Tactics import Polysemy.Scoped import Test.Hspec @@ -54,6 +55,41 @@   tv <- embed (newTVarIO n)   interpretF tv (use tv) +data HO :: Effect where+  Inc :: m a -> HO m a+  Ret :: HO m Int++makeSem ''HO++scopeHO :: () -> (() -> Sem r a) -> Sem r a+scopeHO () use =+  use ()++handleHO :: Int -> () -> HO m a -> Tactical HO m r a+handleHO n () = \case+  Inc ma -> raise . interpretH (handleHO (n + 1) ()) =<< runT ma+  Ret -> pureT n++data Esc :: Effect where+  Esc :: Esc m Int+makeSem ''Esc++data Indirect :: Effect where+  Indirect :: Indirect m Int+makeSem ''Indirect++interpretIndirect :: Member Esc r => InterpreterFor Indirect r+interpretIndirect = interpret \ Indirect -> esc++handleEsc :: Int -> Esc m a -> Sem r a+handleEsc i = \ Esc -> pure i++test_escape :: Sem (Scoped Int Esc ': r) Int+test_escape =+    scoped @Int @Esc 2+  $ interpretIndirect+  $ scoped @Int @Esc 1 indirect+ spec :: Spec spec = parallel do   describe "Scoped" do@@ -63,5 +99,19 @@           i1 <- e1           i2 <- scoped @Par @E 23 e1           pure (i1, i2)-      35 `shouldBe` i1-      38 `shouldBe` i2+      i1 `shouldBe` 35+      i2 `shouldBe` 38+    it "switch interpreter" do+      r <- runM $ interpretScopedH scopeHO (handleHO 1) do+        scoped_ @HO do+          inc do+            ret+      r `shouldBe` 2+    it "scoped depth" do+      r <- runM $ interpretScoped (flip ($)) handleEsc $ test_escape+      r `shouldBe` 2+      r' <- runM $ interpretScopedH'+                    (\r h -> h r)+                    (\i e -> liftT (handleEsc i e))+                 $ test_escape+      r' `shouldBe` 2