diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index 7ccd39c0..00000000 --- a/hie.yaml +++ /dev/null @@ -1,13 +0,0 @@ -cradle: - cabal: - - path: "." - component: "lib:polysemy" - - - path: "./test" - component: "polysemy:test:polysemy-test" - - - path: "./polysemy-plugin" - component: "lib:polysemy-plugin" - - - path: "./polysemy-plugin/test" - component: "polysemy-plugin:test:polysemy-plugin-test" diff --git a/polysemy-plugin/test/ExampleSpec.hs b/polysemy-plugin/test/ExampleSpec.hs index 79038544..de917442 100644 --- a/polysemy-plugin/test/ExampleSpec.hs +++ b/polysemy-plugin/test/ExampleSpec.hs @@ -34,7 +34,7 @@ program = catch @CustomException work $ \e -> writeTTY ("Caught " ++ show e) foo :: IO (Either CustomException ()) foo = - runFinal + runM . embedToFinal @IO . resourceToIOFinal . errorToIOFinal @CustomException diff --git a/polysemy.cabal b/polysemy.cabal index f36f4aca..ad849550 100644 --- a/polysemy.cabal +++ b/polysemy.cabal @@ -3,6 +3,8 @@ cabal-version: 2.0 -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack +-- +-- hash: 296ffb3e340f4324417e4d774a6aad757fa372fe33fd4551b4321bab6ff6564c name: polysemy version: 1.6.0.0 @@ -52,6 +54,7 @@ library Polysemy.Error Polysemy.Fail Polysemy.Fail.Type + Polysemy.Fatal Polysemy.Final Polysemy.Fixpoint Polysemy.Input @@ -60,30 +63,28 @@ library Polysemy.Internal.Combinators Polysemy.Internal.CustomErrors Polysemy.Internal.CustomErrors.Redefined + Polysemy.Internal.Final Polysemy.Internal.Fixpoint - Polysemy.Internal.Forklift Polysemy.Internal.Index + Polysemy.Internal.Interpretation Polysemy.Internal.Kind Polysemy.Internal.NonDet Polysemy.Internal.Sing - Polysemy.Internal.Strategy - Polysemy.Internal.Tactics Polysemy.Internal.TH.Common Polysemy.Internal.TH.Effect Polysemy.Internal.Union + Polysemy.Internal.WeaveClass Polysemy.Internal.Writer + Polysemy.Interpretation Polysemy.IO - Polysemy.Law Polysemy.Membership Polysemy.NonDet Polysemy.Output Polysemy.Reader Polysemy.Resource Polysemy.State - Polysemy.State.Law Polysemy.Tagged Polysemy.Trace - Polysemy.View Polysemy.Writer other-modules: Polysemy.Internal.PluginLookup @@ -152,15 +153,11 @@ test-suite polysemy-test FixpointSpec FusionSpec HigherOrderSpec - InspectorSpec InterceptSpec KnownRowSpec - LawsSpec OutputSpec - TacticsSpec ThEffectSpec TypeErrors - ViewSpec WriterSpec Paths_polysemy Build_doctests diff --git a/src/Polysemy.hs b/src/Polysemy.hs index 6d5d3cab..6d9929e9 100644 --- a/src/Polysemy.hs +++ b/src/Polysemy.hs @@ -8,7 +8,6 @@ module Polysemy -- * Running Sem , run , runM - , runFinal -- * Type synonyms for user convenience , InterpreterFor @@ -109,15 +108,13 @@ module Polysemy , transform -- * Combinators for Interpreting Higher-Order Effects + , EffHandlerH , interpretH , interceptH , reinterpretH , reinterpret2H , reinterpret3H - -- * Combinators for Interpreting Directly to IO - , withLowerToIO - -- * Kind Synonyms , Effect , EffectRow @@ -126,31 +123,25 @@ module Polysemy , (.@) , (.@@) - -- * Tactics - -- | Higher-order effects need to explicitly thread /other effects'/ state - -- through themselves. Tactics are a domain-specific language for describing - -- exactly how this threading should take place. + -- * 'RunH' + -- | When interpreting higher-order effects using 'interpretH' + -- and friends, you can't execute higher-order \"thunks\" given by + -- the interpreted effect directly. Instead, these must be executed + -- using 'runH' or 'runH''. -- - -- The first computation to be run should use 'runT', and subsequent - -- computations /in the same environment/ should use 'bindT'. Any - -- first-order constructors which appear in a higher-order context may use - -- 'pureT' to satisfy the typechecker. - , Tactical - , WithTactics - , getInitialStateT - , pureT - , runTSimple - , bindTSimple - , runT - , bindT - , getInspectorT - , Inspector (..) + -- These functions are enough for most purposes when using + -- 'interpretH'. However, "Polysemy.Interpretation" offers + -- additional, more complicated features which are occassionally + -- needed. + , RunH + , runH + , runH' + ) where import Polysemy.Final import Polysemy.Internal import Polysemy.Internal.Combinators -import Polysemy.Internal.Forklift +import Polysemy.Internal.Interpretation 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 index e1aa2b66..b2064b7d 100644 --- a/src/Polysemy/Async.hs +++ b/src/Polysemy/Async.hs @@ -13,9 +13,7 @@ module Polysemy.Async , sequenceConcurrently -- * Interpretations - , asyncToIO , asyncToIOFinal - , lowerAsync ) where import qualified Control.Concurrent.Async as A @@ -48,42 +46,6 @@ sequenceConcurrently :: forall t r a. (Traversable t, Member Async r) => sequenceConcurrently t = traverse async t >>= traverse await {-# 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'. @@ -106,36 +68,10 @@ asyncToIO m = withLowerToIO $ \lower _ -> lower $ asyncToIOFinal :: Member (Final IO) r => Sem (Async ': r) a -> Sem r a -asyncToIOFinal = interpretFinal $ \case - Async m -> do - ins <- getInspectorS - m' <- runS m - liftS $ A.async (inspect ins <$> m') - Await a -> liftS (A.wait a) - Cancel a -> liftS (A.cancel a) +asyncToIOFinal = interpretFinal @IO $ \case + Async m -> liftWithS $ \lower -> do + fmap (foldr (const . Just) Nothing) <$> A.async (lower m) + Await a -> embed (A.wait a) + Cancel a -> embed (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/Bundle.hs b/src/Polysemy/Bundle.hs index a419b69a..c431a1c8 100644 --- a/src/Polysemy/Bundle.hs +++ b/src/Polysemy/Bundle.hs @@ -43,9 +43,12 @@ sendBundle => Sem (e ': r) a -> Sem r a sendBundle = hoistSem $ \u -> case decomp u of - Right (Weaving e s wv ex ins) -> + Right (Weaving e mkT lwr ex) -> injWeaving $ - Weaving (Bundle (membership @e @r') e) s (sendBundle @e @r' . wv) ex ins + Weaving (Bundle (membership @e @r') e) + (\n -> mkT (n . sendBundle @e @r')) + lwr + ex Left g -> hoist (sendBundle @e @r') g {-# INLINE sendBundle #-} @@ -57,8 +60,8 @@ runBundle => Sem (Bundle r' ': r) a -> Sem (Append r' r) a runBundle = hoistSem $ \u -> hoist runBundle $ case decomp u of - Right (Weaving (Bundle pr e) s wv ex ins) -> - Union (extendMembershipRight @r' @r pr) $ Weaving e s wv ex ins + Right (Weaving (Bundle pr e) mkT lwr ex) -> + Union (extendMembershipRight @r' @r pr) $ Weaving e mkT lwr ex Left g -> weakenList @r' @r (singList @r') g {-# INLINE runBundle #-} @@ -70,7 +73,7 @@ subsumeBundle => Sem (Bundle r' ': r) a -> Sem r a subsumeBundle = hoistSem $ \u -> hoist subsumeBundle $ case decomp u of - Right (Weaving (Bundle pr e) s wv ex ins) -> - Union (subsumeMembership pr) (Weaving e s wv ex ins) + Right (Weaving (Bundle pr e) mkT lwr ex) -> + Union (subsumeMembership pr) (Weaving e mkT lwr ex) Left g -> g {-# INLINE subsumeBundle #-} diff --git a/src/Polysemy/Error.hs b/src/Polysemy/Error.hs index de27c5e2..d3e8faa6 100644 --- a/src/Polysemy/Error.hs +++ b/src/Polysemy/Error.hs @@ -23,13 +23,11 @@ module Polysemy.Error , runError , mapError , errorToIOFinal - , lowerError ) where 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 Polysemy import Polysemy.Final @@ -43,12 +41,6 @@ data Error e m a where makeSem ''Error - -hush :: Either e a -> Maybe a -hush (Right a) = Just a -hush (Left _) = Nothing - - ------------------------------------------------------------------------------ -- | Upgrade an 'Either' into an 'Error' effect. -- @@ -134,10 +126,8 @@ fromExceptionSemVia -> Sem r a -> Sem r a fromExceptionSemVia f m = do - r <- withStrategicToFinal $ do - m' <- runS m - s <- getInitialStateS - pure $ (fmap . fmap) Right m' `X.catch` \e -> (pure (Left e <$ s)) + r <- controlF $ \lower -> + lower (fmap Right m) `X.catch` (lower . return . Left) case r of Left e -> throw $ f e Right a -> pure a @@ -152,16 +142,16 @@ note _ (Just a) = pure a {-# 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 @@ -174,10 +164,10 @@ tryJust f m = do {-# 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 @@ -197,22 +187,19 @@ runError -> Sem r (Either e a) runError (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u -> case decomp u of - Left x -> E.ExceptT $ k $ - weave (Right ()) - (either (pure . Left) runError) - hush - x - Right (Weaving (Throw e) _ _ _ _) -> E.throwE e - Right (Weaving (Catch main handle) s d y _) -> + Left x -> + liftHandlerWithNat (E.ExceptT . runError) k x + Right (Weaving (Throw e) _ _ _) -> E.throwE e + Right (Weaving (Catch main handle) mkT lwr ex) -> E.ExceptT $ usingSem k $ do - ma <- runError $ d $ main <$ s - case ma of - Right a -> pure . Right $ y a + ea <- runError $ lwr $ mkT id main + case ea of + Right a -> pure . Right $ ex a Left e -> do - ma' <- runError $ d $ (<$ s) $ handle e + ma' <- runError $ lwr $ mkT id $ handle e case ma' of Left e' -> pure $ Left e' - Right a -> pure . Right $ y a + Right a -> pure . Right $ ex a {-# INLINE runError #-} ------------------------------------------------------------------------------ @@ -228,23 +215,14 @@ mapError -> Sem r a mapError f = interpretH $ \case Throw e -> throw $ f e - Catch action handler -> do - a <- runT action - h <- bindT handler - - mx <- raise $ runError a - case mx of + Catch action handler -> + runError (runH' action) >>= \case Right x -> pure x - Left e -> do - istate <- getInitialStateT - mx' <- raise $ runError $ h $ e <$ istate - case mx' of - Right x -> pure x - Left e' -> throw $ f e' + Left e -> runH (handler e) {-# INLINE mapError #-} -newtype WrappedExc e = WrappedExc { unwrapExc :: e } +newtype WrappedExc e = WrappedExc { _unwrapExc :: e } deriving (Typeable) instance Typeable e => Show (WrappedExc e) where @@ -268,14 +246,10 @@ errorToIOFinal ) => Sem (Error e ': r) a -> Sem r (Either e a) -errorToIOFinal sem = withStrategicToFinal @IO $ do - m' <- runS (runErrorAsExcFinal sem) - s <- getInitialStateS - pure $ - either - ((<$ s) . Left . unwrapExc) - (fmap Right) - <$> X.try m' +errorToIOFinal sem = controlF $ \lower -> do + lower (Right <$> runErrorAsExcFinal sem) + `X.catch` \(WrappedExc e) -> + lower $ return $ Left e {-# INLINE errorToIOFinal #-} runErrorAsExcFinal @@ -286,54 +260,10 @@ runErrorAsExcFinal => Sem (Error e ': r) a -> Sem r a runErrorAsExcFinal = interpretFinal $ \case - Throw e -> pure $ X.throwIO $ WrappedExc e - Catch m h -> do - m' <- runS m - h' <- bindS h - s <- getInitialStateS - pure $ X.catch m' $ \(se :: WrappedExc e) -> - h' (unwrapExc se <$ s) + Throw e -> embed $ X.throwIO $ WrappedExc e + Catch m h -> controlS $ \lower -> + lower m + `X.catch` \(WrappedExc e) -> + lower (h e) {-# 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/Fatal.hs b/src/Polysemy/Fatal.hs new file mode 100644 index 00000000..592710a2 --- /dev/null +++ b/src/Polysemy/Fatal.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Polysemy.Fatal + ( -- * Effect + Fatal (..) + + -- * Actions + , fatal + , fatalFromEither + , fatalFromEitherM + , fatalFromException + , fatalFromExceptionVia + , fatalFromExceptionSem + , fatalFromExceptionSemVia + , noteFatal + + -- * Interpretations + , runFatal + , mapFatal + , fatalToError + , fatalToIOFinal + ) where + +import qualified Control.Exception as X +import Control.Monad +import qualified Control.Monad.Trans.Except as E +import Data.Typeable +import Polysemy +import Polysemy.Error +import Polysemy.Final +import Polysemy.Internal +import Polysemy.Internal.Union + + +data Fatal e m a where + Fatal :: e -> Fatal e m a + +makeSem ''Fatal + +------------------------------------------------------------------------------ +-- | Upgrade an 'Either' into an 'Fatal' effect. +-- +-- @since 0.5.1.0 +fatalFromEither + :: Member (Fatal e) r + => Either e a + -> Sem r a +fatalFromEither (Left e) = fatal e +fatalFromEither (Right a) = pure a +{-# INLINABLE fatalFromEither #-} + +------------------------------------------------------------------------------ +-- | A combinator doing 'embed' and 'fromEither' at the same time. Useful for +-- interoperating with 'IO'. +-- +-- @since 0.5.1.0 +fatalFromEitherM + :: forall e m r a + . ( Member (Fatal e) r + , Member (Embed m) r + ) + => m (Either e a) + -> Sem r a +fatalFromEitherM = fatalFromEither <=< embed +{-# INLINABLE fatalFromEitherM #-} + + +------------------------------------------------------------------------------ +-- | Lift an exception generated from an 'IO' action into an 'Fatal'. +fatalFromException + :: forall e r a + . ( X.Exception e + , Member (Fatal e) r + , Member (Embed IO) r + ) + => IO a + -> Sem r a +fatalFromException = fatalFromExceptionVia @e id +{-# INLINABLE fatalFromException #-} + + +------------------------------------------------------------------------------ +-- | Like 'fromException', but with the ability to transform the exception +-- before turning it into an 'Fatal'. +fatalFromExceptionVia + :: ( X.Exception exc + , Member (Fatal err) r + , Member (Embed IO) r + ) + => (exc -> err) + -> IO a + -> Sem r a +fatalFromExceptionVia f m = do + r <- embed $ X.try m + case r of + Left e -> fatal $ f e + Right a -> pure a +{-# INLINABLE fatalFromExceptionVia #-} + +------------------------------------------------------------------------------ +-- | Run a @Sem r@ action, converting any 'IO' exception generated by it into an 'Fatal'. +fatalFromExceptionSem + :: forall e r a + . ( X.Exception e + , Member (Fatal e) r + , Member (Final IO) r + ) + => Sem r a + -> Sem r a +fatalFromExceptionSem = fatalFromExceptionSemVia @e id +{-# INLINABLE fatalFromExceptionSem #-} + + +------------------------------------------------------------------------------ +-- | Like 'fromExceptionSem', but with the ability to transform the exception +-- before turning it into an 'Fatal'. +fatalFromExceptionSemVia + :: ( X.Exception exc + , Member (Fatal err) r + , Member (Final IO) r + ) + => (exc -> err) + -> Sem r a + -> Sem r a +fatalFromExceptionSemVia f m = do + r <- controlF $ \lower -> + lower (fmap Right m) `X.catch` (lower . return . Left) + case r of + Left e -> fatal $ f e + Right a -> pure a +{-# INLINABLE fatalFromExceptionSemVia #-} + + +------------------------------------------------------------------------------ +-- | Attempt to extract a @'Just' a@ from a @'Maybe' a@, throwing the +-- provided exception upon 'Nothing'. +noteFatal :: Member (Fatal e) r => e -> Maybe a -> Sem r a +noteFatal e Nothing = fatal e +noteFatal _ (Just a) = pure a +{-# INLINABLE noteFatal #-} + + +------------------------------------------------------------------------------ +-- | Run an 'Fatal' effect in the style of +-- 'Control.Monad.Trans.Except.ExceptT'. +runFatal + :: Sem (Fatal e ': r) a + -> Sem r (Either e a) +runFatal (Sem m) = Sem $ \k -> E.runExceptT $ m $ \u -> + case decomp u of + Left x -> + liftHandlerWithNat (E.ExceptT . runFatal) k x + Right (Weaving (Fatal e) _ _ _) -> E.throwE e +{-# INLINE runFatal #-} + + +------------------------------------------------------------------------------ +-- | Transform one 'Fatal' into another. This function can be used to aggregate +-- multiple fatals into a single type. +-- +-- @since 1.0.0.0 +mapFatal + :: forall e1 e2 r a + . Member (Fatal e2) r + => (e1 -> e2) + -> Sem (Fatal e1 ': r) a + -> Sem r a +mapFatal f = interpret $ \case + Fatal e -> fatal $ f e +{-# INLINE mapFatal #-} + + +newtype WrappedExc e = WrappedExc { _unwrapExc :: e } + deriving (Typeable) + +instance Typeable e => Show (WrappedExc e) where + show = mappend "WrappedExc: " . show . typeRep + +instance (Typeable e) => X.Exception (WrappedExc e) + + +------------------------------------------------------------------------------ +-- | Run an 'Fatal' effect as an 'IO' 'X.Exception' through final 'IO'. This +-- interpretation is significantly faster than 'runFatal'. +-- +-- /Beware/: Effects that aren't interpreted in terms of 'IO' +-- will have local state semantics in regards to 'Fatal' effects +-- interpreted this way. See 'Final'. +-- +-- @since 1.2.0.0 +fatalToIOFinal + :: ( Typeable e + , Member (Final IO) r + ) + => Sem (Fatal e ': r) a + -> Sem r (Either e a) +fatalToIOFinal sem = controlF $ \lower -> do + lower (Right <$> runFatalAsExcFinal sem) + `X.catch` \(WrappedExc e) -> + lower $ return $ Left e +{-# INLINE fatalToIOFinal #-} + + +runFatalAsExcFinal + :: forall e r a + . ( Typeable e + , Member (Final IO) r + ) + => Sem (Fatal e ': r) a + -> Sem r a +runFatalAsExcFinal = interpretFinal @IO $ \case + Fatal e -> embed $ X.throwIO $ WrappedExc e +{-# INLINE runFatalAsExcFinal #-} + + +fatalToError + :: Member (Error e) r + => Sem (Fatal e ': r) a + -> Sem r a +fatalToError = interpret $ \case + Fatal e -> throw e +{-# INLINE fatalToError #-} + diff --git a/src/Polysemy/Final.hs b/src/Polysemy/Final.hs index c393701f..50748187 100644 --- a/src/Polysemy/Final.hs +++ b/src/Polysemy/Final.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, PatternGuards #-} module Polysemy.Final ( -- * Effect - Final(..) - , ThroughWeavingToFinal + Final -- * Actions - , withWeavingToFinal , withStrategicToFinal + , controlF , embedFinal -- * Combinators for Interpreting to the Final Monad @@ -27,234 +26,19 @@ module Polysemy.Final -- must be a monadic value of the target monad -- with the functorial state wrapped inside of it. , Strategic - , WithStrategy - , pureS - , liftS + , controlS + , liftWithS + , restoreS , runS - , bindS - , getInspectorS - , getInitialStateS + , controlS' + , liftWithS' -- * Interpretations - , runFinal + , runM , finalToFinal -- * Interpretations for Other Effects , embedToFinal ) where -import Polysemy.Internal -import Polysemy.Internal.Combinators -import Polysemy.Internal.Union -import Polysemy.Internal.Strategy -import Polysemy.Internal.TH.Effect - ------------------------------------------------------------------------------ --- | This represents a function which produces --- an action of the final monad @m@ given: --- --- * The initial effectful state at the moment the action --- is to be executed. --- --- * A way to convert @z@ (which is typically @'Sem' r@) to @m@ by --- threading the effectful state through. --- --- * An inspector that is able to view some value within the --- effectful state if the effectful state contains any values. --- --- A @'Polysemy.Internal.Union.Weaving'@ provides these components, --- hence the name 'ThroughWeavingToFinal'. --- --- @since 1.2.0.0 -type ThroughWeavingToFinal m z a = - forall f - . Functor f - => f () - -> (forall x. f (z x) -> m (f x)) - -> (forall x. f x -> Maybe x) - -> m (f a) - ------------------------------------------------------------------------------ --- | An effect for embedding higher-order actions in the final target monad --- of the effect stack. --- --- This is very useful for writing interpreters that interpret higher-order --- effects in terms of the final monad. --- --- 'Final' is more powerful than 'Embed', but is also less flexible --- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal'). --- If you only need the power of 'embed', then you should use 'Embed' instead. --- --- /Beware/: 'Final' actions are interpreted as actions of the final monad, --- and the effectful state visible to --- 'withWeavingToFinal' \/ 'withStrategicToFinal' --- \/ 'interpretFinal' --- is that of /all interpreters run in order to produce the final monad/. --- --- This means that any interpreter built using 'Final' will /not/ --- respect local/global state semantics based on the order of --- interpreters run. You should signal interpreters that make use of --- 'Final' by adding a @-'Final'@ suffix to the names of these. --- --- State semantics of effects that are /not/ --- interpreted in terms of the final monad will always --- appear local to effects that are interpreted in terms of the final monad. --- --- State semantics between effects that are interpreted in terms of the final monad --- depend on the final monad. For example, if the final monad is a monad transformer --- stack, then state semantics will depend on the order monad transformers are stacked. --- --- @since 1.2.0.0 -newtype Final m z a where - WithWeavingToFinal - :: ThroughWeavingToFinal m z a - -> Final m z a - -makeSem_ ''Final - ------------------------------------------------------------------------------ --- | Allows for embedding higher-order actions of the final monad --- by providing the means of explicitly threading effects through @'Sem' r@ --- to the final monad. --- --- Consider using 'withStrategicToFinal' instead, --- which provides a more user-friendly interface, but is also slightly weaker. --- --- You are discouraged from using 'withWeavingToFinal' directly --- in application code, as it ties your application code directly to --- the final monad. --- --- @since 1.2.0.0 -withWeavingToFinal - :: forall m r a - . Member (Final m) r - => ThroughWeavingToFinal m (Sem r) a - -> Sem r a - - ------------------------------------------------------------------------------ --- | 'withWeavingToFinal' admits an implementation of 'embed'. --- --- Just like 'embed', you are discouraged from using this in application code. --- --- @since 1.2.0.0 -embedFinal :: (Member (Final m) r, Functor m) => m a -> Sem r a -embedFinal m = withWeavingToFinal $ \s _ _ -> (<$ s) <$> m -{-# INLINE embedFinal #-} - ------------------------------------------------------------------------------ --- | Allows for embedding higher-order actions of the final monad --- by providing the means of explicitly threading effects through @'Sem' r@ --- to the final monad. This is done through the use of the 'Strategic' --- environment, which provides 'runS' and 'bindS'. --- --- You are discouraged from using 'withStrategicToFinal' in application code, --- as it ties your application code directly to the final monad. --- --- @since 1.2.0.0 -withStrategicToFinal :: Member (Final m) r - => Strategic m (Sem r) a - -> Sem r a -withStrategicToFinal strat = withWeavingToFinal (runStrategy strat) -{-# INLINE withStrategicToFinal #-} - ------------------------------------------------------------------------------- --- | Like 'interpretH', but may be used to --- interpret higher-order effects in terms of the final monad. --- --- 'interpretFinal' requires less boilerplate than using 'interpretH' --- together with 'withStrategicToFinal' \/ 'withWeavingToFinal', --- but is also less powerful. --- 'interpretFinal' does not provide any means of executing actions --- of @'Sem' r@ as you interpret each action, and the provided interpreter --- is automatically recursively used to process higher-order occurences of --- @'Sem' (e ': r)@ to @'Sem' r@. --- --- If you need greater control of how the effect is interpreted, --- use 'interpretH' together with 'withStrategicToFinal' \/ --- 'withWeavingToFinal' instead. --- --- /Beware/: Effects that aren't interpreted in terms of the final --- monad will have local state semantics in regards to effects --- interpreted using 'interpretFinal'. See 'Final'. --- --- @since 1.2.0.0 -interpretFinal - :: forall m e r a - . Member (Final m) r - => (forall x rInitial. e (Sem rInitial) x -> Strategic m (Sem rInitial) x) - -- ^ A natural transformation from the handled effect to the final monad. - -> Sem (e ': r) a - -> Sem r a -interpretFinal n = - let - go :: Sem (e ': r) x -> Sem r x - go = hoistSem $ \u -> case decomp u of - Right (Weaving e s wv ex ins) -> - injWeaving $ - Weaving - (WithWeavingToFinal (runStrategy (n e))) - s - (go . wv) - ex - ins - Left g -> hoist go g - {-# INLINE go #-} - in - go -{-# INLINE interpretFinal #-} - ------------------------------------------------------------------------------- --- | Lower a 'Sem' containing only a single lifted, final 'Monad' into that --- monad. --- --- If you also need to process an @'Embed' m@ effect, use this together with --- 'embedToFinal'. --- --- @since 1.2.0.0 -runFinal :: Monad m => Sem '[Final m] a -> m a -runFinal = usingSem $ \u -> case extract u of - Weaving (WithWeavingToFinal wav) s wv ex ins -> - ex <$> wav s (runFinal . wv) ins -{-# INLINE runFinal #-} - ------------------------------------------------------------------------------- --- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@ --- effect by transforming it into a @'Final' m2@ effect. --- --- @since 1.2.0.0 -finalToFinal :: forall m1 m2 r a - . Member (Final m2) r - => (forall x. m1 x -> m2 x) - -> (forall x. m2 x -> m1 x) - -> Sem (Final m1 ': r) a - -> Sem r a -finalToFinal to from = - let - go :: Sem (Final m1 ': r) x -> Sem r x - go = hoistSem $ \u -> case decomp u of - Right (Weaving (WithWeavingToFinal wav) s wv ex ins) -> - injWeaving $ - Weaving - (WithWeavingToFinal $ \s' wv' ins' -> - to $ wav s' (from . wv') ins' - ) - s - (go . wv) - ex - ins - Left g -> hoist go g - {-# INLINE go #-} - in - go -{-# INLINE finalToFinal #-} - ------------------------------------------------------------------------------- --- | Transform an @'Embed' m@ effect into a @'Final' m@ effect --- --- @since 1.2.0.0 -embedToFinal :: (Member (Final m) r, Functor m) - => Sem (Embed m ': r) a - -> Sem r a -embedToFinal = interpret $ \(Embed m) -> embedFinal m -{-# INLINE embedToFinal #-} +import Polysemy.Internal.Final diff --git a/src/Polysemy/Fixpoint.hs b/src/Polysemy/Fixpoint.hs index 3c30d299..7a34e354 100644 --- a/src/Polysemy/Fixpoint.hs +++ b/src/Polysemy/Fixpoint.hs @@ -9,7 +9,6 @@ module Polysemy.Fixpoint ) where import Control.Monad.Fix -import Data.Maybe import Polysemy import Polysemy.Final @@ -64,54 +63,7 @@ fixpointToFinal :: forall m r a . (Member (Final m) r, MonadFix m) => Sem (Fixpoint ': r) a -> Sem r a -fixpointToFinal = interpretFinal @m $ - \(Fixpoint f) -> do - f' <- bindS f - s <- getInitialStateS - ins <- getInspectorS - pure $ mfix $ \fa -> f' $ - fromMaybe (bomb "fixpointToFinal") (inspect ins fa) <$ s +fixpointToFinal = interpretFinal @m $ \case + Fixpoint f -> controlS $ \lower -> + mfix $ lower . f . foldr const (bomb "fixpointToFinal") {-# 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 index da6200a6..f3f9928c 100644 --- 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 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 index de0f08c3..fbea0d87 100644 --- a/src/Polysemy/Internal.hs +++ b/src/Polysemy/Internal.hs @@ -17,7 +17,6 @@ module Polysemy.Internal , sendUsing , embed , run - , runM , raise_ , Raise (..) , raise @@ -31,6 +30,8 @@ module Polysemy.Internal , subsume , subsumeUsing , insertAt + , expose + , exposeUsing , Embed (..) , usingSem , liftSem @@ -53,6 +54,7 @@ import Control.Monad.Fix import Control.Monad.IO.Class import Data.Functor.Identity import Data.Kind +import Data.Type.Equality import Polysemy.Embed.Type import Polysemy.Fail.Type import Polysemy.Internal.Fixpoint @@ -95,7 +97,7 @@ import Polysemy.Internal.Sing (ListOfLength (listOfLength)) -- than 'Embed', but also less flexible to interpret. -- -- A 'Sem' can be interpreted as a pure value (via 'run') or as any --- traditional 'Monad' (via 'runM' or 'Polysemy.runFinal'). +-- traditional 'Monad' (via 'Polysemy.runM'). -- Each effect @E@ comes equipped with some interpreters of the form: -- -- @ @@ -545,6 +547,22 @@ subsumeUsing pr = in go {-# INLINE subsumeUsing #-} +------------------------------------------------------------------------------ +-- | Moves all uses of an effect @e@ within the argument computation +-- to a new @e@ placed on top of the effect stack. Note that this does not +-- consume the inner @e@. +-- +-- This can be used to create interceptors out of interpreters. +-- For example: +-- +-- @ +-- 'Polysemy.intercept' k = 'Polysemy.interpret' k . 'expose' +-- @ +-- +-- @since TODO +expose :: Member e r => Sem r a -> Sem (e ': r) a +expose = exposeUsing membership +{-# INLINE expose #-} ------------------------------------------------------------------------------ -- | Introduce a set of effects into 'Sem' at the index @i@, before the effect @@ -572,6 +590,21 @@ insertAt = hoistSem $ \u -> hoist (insertAt @index @inserted @head @oldTail) $ weakenMid @oldTail (listOfLength @index @head) (insertAtIndex @Effect @index @head @tail @oldTail @full @inserted) u {-# INLINE insertAt #-} +-- | Given an explicit proof that @e@ exists in @r@, moves all uses of e@ +-- within the argument computation to a new @e@ placed on top of the effect +-- stack. Note that this does not consume the inner @e@. +-- +-- This is useful in conjunction with 'Polysemy.Internal.Union.tryMembership' +-- and 'interpret'\/'interpretH' in order to conditionally perform +-- 'intercept'-like operations. +-- +-- @since TODO +exposeUsing :: forall e r a. ElemOf e r -> Sem r a -> Sem (e ': r) a +exposeUsing pr = hoistSem $ \(Union pr' wav) -> hoist (exposeUsing pr) $ + case sameMember pr pr' of + Just Refl -> Union Here wav + _ -> Union (There pr') wav +{-# INLINE exposeUsing #-} ------------------------------------------------------------------------------ -- | Embed an effect into a 'Sem'. This is used primarily via @@ -608,18 +641,6 @@ run (Sem m) = runIdentity $ m absurdU {-# INLINE run #-} ------------------------------------------------------------------------------- --- | Lower a 'Sem' containing only a single lifted 'Monad' into that --- monad. -runM :: Monad m => Sem '[Embed m] a -> m a -runM (Sem m) = m $ \z -> - case extract z of - Weaving e s _ f _ -> do - a <- unEmbed e - pure $ f $ a <$ s -{-# INLINE runM #-} - - ------------------------------------------------------------------------------ -- | Type synonym for interpreters that consume an effect without changing the -- return value. Offered for user convenience. diff --git a/src/Polysemy/Internal/Combinators.hs b/src/Polysemy/Internal/Combinators.hs index b67751c8..3fb9d904 100644 --- a/src/Polysemy/Internal/Combinators.hs +++ b/src/Polysemy/Internal/Combinators.hs @@ -1,91 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-} - {-# OPTIONS_HADDOCK not-home #-} - +{-# OPTIONS_GHC -Wno-unused-imports #-} module Polysemy.Internal.Combinators ( -- * First order - interpret - , intercept - , reinterpret - , reinterpret2 - , reinterpret3 - , rewrite + rewrite , transform - -- * Higher order - , interpretH - , interceptH - , reinterpretH - , reinterpret2H - , reinterpret3H - - -- * Conditional - , interceptUsing - , interceptUsingH - -- * Statefulness , stateful , lazilyStateful ) where -import Control.Monad +import Control.Monad import qualified Control.Monad.Trans.State.Lazy as LS import qualified Control.Monad.Trans.State.Strict as S import qualified Data.Tuple as S (swap) -import Polysemy.Internal -import Polysemy.Internal.CustomErrors -import Polysemy.Internal.Tactics -import Polysemy.Internal.Union - - ------------------------------------------------------------------------------- --- | A lazier version of 'Data.Tuple.swap'. -swap :: (a, b) -> (b, a) -swap ~(a, b) = (b, a) - - -firstOrder - :: ((forall rInitial x. e (Sem rInitial) x -> - Tactical e (Sem rInitial) r x) -> t) - -> (forall rInitial x. e (Sem rInitial) x -> Sem r x) - -> t -firstOrder higher f = higher $ \(e :: e (Sem rInitial) x) -> - liftT $ f e -{-# INLINE firstOrder #-} - ------------------------------------------------------------------------------- --- | The simplest way to produce an effect handler. Interprets an effect @e@ by --- transforming it into other effects inside of @r@. -interpret - :: FirstOrder e "interpret" - => (∀ rInitial x. e (Sem rInitial) x -> Sem r x) - -- ^ A natural transformation from the handled effect to other effects - -- already in 'Sem'. - -> Sem (e ': r) a - -> Sem r a --- TODO(sandy): could probably give a `coerce` impl for `runTactics` here -interpret = firstOrder interpretH -{-# INLINE interpret #-} - - ------------------------------------------------------------------------------- --- | Like 'interpret', but for higher-order effects (ie. those which make use of --- the @m@ parameter.) --- --- See the notes on 'Tactical' for how to use this function. -interpretH - :: (∀ rInitial x . e (Sem rInitial) x -> Tactical e (Sem rInitial) r x) - -- ^ A natural transformation from the handled effect to other effects - -- already in 'Sem'. - -> Sem (e ': r) a - -> Sem r a -interpretH f (Sem m) = Sem $ \k -> m $ \u -> - case decomp u of - Left x -> k $ hoist (interpretH f) x - Right (Weaving e s d y v) -> do - fmap y $ usingSem k $ runTactics s d v (interpretH f . d) $ f e -{-# INLINE interpretH #-} +import Polysemy.Internal +import Polysemy.Internal.CustomErrors +import Polysemy.Internal.Union ------------------------------------------------------------------------------ -- | A highly-performant combinator for interpreting an effect statefully. See @@ -95,18 +28,16 @@ interpretInStateT -> s -> Sem (e ': r) a -> Sem r (s, a) -interpretInStateT f s (Sem m) = Sem $ \k -> - (S.swap <$!>) $ flip S.runStateT s $ m $ \u -> +interpretInStateT f s (Sem sem) = Sem $ \k -> + (S.swap <$!>) $ flip S.runStateT s $ sem $ \u -> case decomp u of - Left x -> S.StateT $ \s' -> - (S.swap <$!>) - . k - . weave (s', ()) - (uncurry $ interpretInStateT f) - (Just . snd) - $ x - Right (Weaving e z _ y _) -> - y . (<$ z) <$> S.mapStateT (usingSem k) (f e) + Left x -> + liftHandlerWithNat + (\m -> S.StateT $ \s' -> S.swap <$!> interpretInStateT f s' m) + k x + Right (Weaving e _ lwr ex) -> do + let z = mkInitState lwr + ex . (<$ z) <$> S.mapStateT (usingSem k) (f e) {-# INLINE interpretInStateT #-} @@ -118,17 +49,16 @@ interpretInLazyStateT -> s -> Sem (e ': r) a -> Sem r (s, a) -interpretInLazyStateT f s (Sem m) = Sem $ \k -> - fmap swap $ flip LS.runStateT s $ m $ \u -> +interpretInLazyStateT f s (Sem sem) = Sem $ \k -> + fmap S.swap $ flip LS.runStateT s $ sem $ \u -> case decomp u of - Left x -> LS.StateT $ \s' -> - k . fmap swap - . weave (s', ()) - (uncurry $ interpretInLazyStateT f) - (Just . snd) - $ x - Right (Weaving e z _ y _) -> - y . (<$ z) <$> LS.mapStateT (usingSem k) (f e) + Left x -> + liftHandlerWithNat + (\m -> LS.StateT $ \s' -> S.swap <$> interpretInLazyStateT f s' m) + k x + Right (Weaving e _ lwr ex) -> do + let z = mkInitState lwr + ex . (<$ z) <$> LS.mapStateT (usingSem k) (f e) {-# INLINE interpretInLazyStateT #-} @@ -150,210 +80,15 @@ lazilyStateful -> s -> Sem (e ': r) a -> Sem r (s, a) -lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap swap . f e +lazilyStateful f = interpretInLazyStateT $ \e -> LS.StateT $ fmap S.swap . f e {-# INLINE[3] lazilyStateful #-} - ------------------------------------------------------------------------------- --- | Like 'reinterpret', but for higher-order effects. --- --- See the notes on 'Tactical' for how to use this function. -reinterpretH - :: forall e1 e2 r a - . (∀ rInitial x. e1 (Sem rInitial) x -> - Tactical e1 (Sem rInitial) (e2 ': r) x) - -- ^ A natural transformation from the handled effect to the new effect. - -> Sem (e1 ': r) a - -> Sem (e2 ': r) a -reinterpretH f sem = Sem $ \k -> runSem sem $ \u -> - case decompCoerce u of - Left x -> k $ hoist (reinterpretH f) $ x - Right (Weaving e s d y v) -> do - fmap y $ usingSem k - $ runTactics s (raiseUnder . d) v (reinterpretH f . d) - $ f e -{-# INLINE[3] reinterpretH #-} --- TODO(sandy): Make this fuse in with 'stateful' directly. - - ------------------------------------------------------------------------------- --- | Like 'interpret', but instead of removing the effect @e@, reencodes it in --- some new effect @f@. This function will fuse when followed by --- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of --- the 'Polysemy.State.State' effect and immediately run it. -reinterpret - :: forall e1 e2 r a - . FirstOrder e1 "reinterpret" - => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': r) x) - -- ^ A natural transformation from the handled effect to the new effect. - -> Sem (e1 ': r) a - -> Sem (e2 ': r) a -reinterpret = firstOrder reinterpretH -{-# INLINE[3] reinterpret #-} --- TODO(sandy): Make this fuse in with 'stateful' directly. - - ------------------------------------------------------------------------------- --- | Like 'reinterpret2', but for higher-order effects. --- --- See the notes on 'Tactical' for how to use this function. -reinterpret2H - :: forall e1 e2 e3 r a - . (∀ rInitial x. e1 (Sem rInitial) x -> - Tactical e1 (Sem rInitial) (e2 ': e3 ': r) x) - -- ^ A natural transformation from the handled effect to the new effects. - -> Sem (e1 ': r) a - -> Sem (e2 ': e3 ': r) a -reinterpret2H f (Sem m) = Sem $ \k -> m $ \u -> - case decompCoerce u of - Left x -> k $ weaken $ hoist (reinterpret2H f) $ x - Right (Weaving e s d y v) -> do - fmap y $ usingSem k - $ runTactics s (raiseUnder2 . d) v (reinterpret2H f . d) - $ f e -{-# INLINE[3] reinterpret2H #-} - - ------------------------------------------------------------------------------- --- | Like 'reinterpret', but introduces /two/ intermediary effects. -reinterpret2 - :: forall e1 e2 e3 r a - . FirstOrder e1 "reinterpret2" - => (∀ rInitial x. e1 (Sem rInitial) x -> - Sem (e2 ': e3 ': r) x) - -- ^ A natural transformation from the handled effect to the new effects. - -> Sem (e1 ': r) a - -> Sem (e2 ': e3 ': r) a -reinterpret2 = firstOrder reinterpret2H -{-# INLINE[3] reinterpret2 #-} - - ------------------------------------------------------------------------------- --- | Like 'reinterpret3', but for higher-order effects. --- --- See the notes on 'Tactical' for how to use this function. -reinterpret3H - :: forall e1 e2 e3 e4 r a - . (∀ rInitial x. e1 (Sem rInitial) x -> - Tactical e1 (Sem rInitial) (e2 ': e3 ': e4 ': r) x) - -- ^ A natural transformation from the handled effect to the new effects. - -> Sem (e1 ': r) a - -> Sem (e2 ': e3 ': e4 ': r) a -reinterpret3H f (Sem m) = Sem $ \k -> m $ \u -> - case decompCoerce u of - Left x -> k . weaken . weaken . hoist (reinterpret3H f) $ x - Right (Weaving e s d y v) -> - fmap y $ usingSem k - $ runTactics s (raiseUnder3 . d) v (reinterpret3H f . d) - $ f e -{-# INLINE[3] reinterpret3H #-} - - ------------------------------------------------------------------------------- --- | Like 'reinterpret', but introduces /three/ intermediary effects. -reinterpret3 - :: forall e1 e2 e3 e4 r a - . FirstOrder e1 "reinterpret3" - => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': e4 ': r) x) - -- ^ A natural transformation from the handled effect to the new effects. - -> Sem (e1 ': r) a - -> Sem (e2 ': e3 ': e4 ': r) a -reinterpret3 = firstOrder reinterpret3H -{-# INLINE[3] reinterpret3 #-} - - ------------------------------------------------------------------------------- --- | Like 'interpret', but instead of handling the effect, allows responding to --- the effect while leaving it unhandled. This allows you, for example, to --- intercept other effects and insert logic around them. -intercept - :: ( Member e r - , FirstOrder e "intercept" - ) - => (∀ x rInitial. e (Sem rInitial) x -> Sem r x) - -- ^ A natural transformation from the handled effect to other effects - -- already in 'Sem'. - -> Sem r a - -- ^ Unlike 'interpret', 'intercept' does not consume any effects. - -> Sem r a -intercept f = interceptH $ \(e :: e (Sem rInitial) x) -> - liftT @(Sem rInitial) $ f e -{-# INLINE intercept #-} - - ------------------------------------------------------------------------------- --- | Like 'intercept', but for higher-order effects. --- --- See the notes on 'Tactical' for how to use this function. -interceptH - :: Member e r - => (∀ x rInitial. e (Sem rInitial) x -> Tactical e (Sem rInitial) r x) - -- ^ A natural transformation from the handled effect to other effects - -- already in 'Sem'. - -> Sem r a - -- ^ Unlike 'interpretH', 'interceptH' does not consume any effects. - -> Sem r a -interceptH = interceptUsingH membership -{-# INLINE interceptH #-} - ------------------------------------------------------------------------------- --- | A variant of 'intercept' that accepts an explicit proof that the effect --- is in the effect stack rather then requiring a 'Member' constraint. --- --- This is useful in conjunction with 'Polysemy.Membership.tryMembership' --- in order to conditionally perform 'intercept'. --- --- @since 1.3.0.0 -interceptUsing - :: FirstOrder e "interceptUsing" - => ElemOf e r - -- ^ A proof that the handled effect exists in @r@. - -- This can be retrieved through 'Polysemy.Membership.membership' or - -- 'Polysemy.Membership.tryMembership'. - -> (∀ x rInitial. e (Sem rInitial) x -> Sem r x) - -- ^ A natural transformation from the handled effect to other effects - -- already in 'Sem'. - -> Sem r a - -- ^ Unlike 'interpret', 'intercept' does not consume any effects. - -> Sem r a -interceptUsing pr f = interceptUsingH pr $ \(e :: e (Sem rInitial) x) -> - liftT @(Sem rInitial) $ f e -{-# INLINE interceptUsing #-} - ------------------------------------------------------------------------------- --- | A variant of 'interceptH' that accepts an explicit proof that the effect --- is in the effect stack rather then requiring a 'Member' constraint. --- --- This is useful in conjunction with 'Polysemy.Membership.tryMembership' --- in order to conditionally perform 'interceptH'. --- --- See the notes on 'Tactical' for how to use this function. --- --- @since 1.3.0.0 -interceptUsingH - :: ElemOf e r - -- ^ A proof that the handled effect exists in @r@. - -- This can be retrieved through 'Polysemy.Membership.membership' or - -- 'Polysemy.Membership.tryMembership'. - -> (∀ x rInitial. e (Sem rInitial) x -> Tactical e (Sem rInitial) r x) - -- ^ A natural transformation from the handled effect to other effects - -- already in 'Sem'. - -> Sem r a - -- ^ Unlike 'interpretH', 'interceptUsingH' does not consume any effects. - -> Sem r a -interceptUsingH pr f (Sem m) = Sem $ \k -> m $ \u -> - case prjUsing pr u of - Just (Weaving e s d y v) -> - fmap y $ usingSem k - $ runTactics s (raise . d) v (interceptUsingH pr f . d) - $ f e - Nothing -> k $ hoist (interceptUsingH pr f) u -{-# INLINE interceptUsingH #-} - ------------------------------------------------------------------------------ -- | Rewrite an effect @e1@ directly into @e2@, and put it on the top of the -- effect stack. -- +-- @'rewrite' n = 'interpretH' ('propagate' . n)@ +-- -- @since 1.2.3.0 rewrite :: forall e1 e2 r a @@ -363,8 +98,8 @@ rewrite rewrite f (Sem m) = Sem $ \k -> m $ \u -> k $ hoist (rewrite f) $ case decompCoerce u of Left x -> x - Right (Weaving e s d n y) -> - Union Here $ Weaving (f e) s d n y + Right (Weaving e mkT lwr ex) -> + Union Here $ Weaving (f e) mkT lwr ex ------------------------------------------------------------------------------ @@ -381,5 +116,5 @@ transform transform f (Sem m) = Sem $ \k -> m $ \u -> k $ hoist (transform f) $ case decomp u of Left g -> g - Right (Weaving e s wv ex ins) -> - injWeaving (Weaving (f e) s wv ex ins) + Right (Weaving e mkT lwr ex) -> + injWeaving (Weaving (f e) mkT lwr ex) diff --git a/src/Polysemy/Internal/Final.hs b/src/Polysemy/Internal/Final.hs new file mode 100644 index 00000000..5890e639 --- /dev/null +++ b/src/Polysemy/Internal/Final.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE TemplateHaskell, PatternGuards #-} +module Polysemy.Internal.Final + ( + -- * Effect + Final(..) + + -- * Actions + , withStrategicToFinal + , withLoweringToFinal + , controlF + , embedFinal + + -- * Combinators for Interpreting to the Final Monad + , interpretFinal + + -- * Strategy + -- | Strategy is a domain-specific language very similar to @Tactics@ + -- (see 'Polysemy.Tactical'), and is used to describe how higher-order + -- effects are threaded down to the final monad. + -- + -- Much like @Tactics@, computations can be run and threaded + -- through the use of 'runS' and 'bindS', and first-order constructors + -- may use 'pureS'. In addition, 'liftS' may be used to + -- lift actions of the final monad. + -- + -- Unlike @Tactics@, the final return value within a 'Strategic' + -- must be a monadic value of the target monad + -- with the functorial state wrapped inside of it. + , Strategic + , controlS + , liftWithS + , restoreS + , runS + , controlS' + , liftWithS' + + -- * Interpretations + , runM + , finalToFinal + + -- * Interpretations for Other Effects + , embedToFinal + ) where + +import Control.Monad.Trans +import Polysemy.Internal +import Polysemy.Internal.Union +import Polysemy.Internal.TH.Effect +import Polysemy.Internal.Interpretation (interpret) + +----------------------------------------------------------------------------- +-- | An effect for embedding higher-order actions in the final target monad +-- of the effect stack. +-- +-- This is very useful for writing interpreters that interpret higher-order +-- effects in terms of the final monad. +-- +-- 'Final' is more powerful than 'Embed', but is also less flexible +-- to interpret (compare 'Polysemy.Embed.runEmbedded' with 'finalToFinal'). +-- If you only need the power of 'embed', then you should use 'Embed' instead. +-- +-- /Beware/: 'Final' actions are interpreted as actions of the final monad, +-- and the effectful state visible to 'controlF' \/ 'withStrategicToFinal' +-- \/ 'interpretFinal' +-- is that of /all interpreters run in order to produce the final monad/. +-- +-- This means that any interpreter built using 'Final' will /not/ +-- respect local/global state semantics based on the order of +-- interpreters run. You should signal interpreters that make use of +-- 'Final' by adding a @-'Final'@ suffix to the names of these. +-- +-- State semantics of effects that are /not/ +-- interpreted in terms of the final monad will always +-- appear local to effects that are interpreted in terms of the final monad. +-- +-- State semantics between effects that are interpreted in terms of the final monad +-- depend on the final monad. For example, if the final monad is a monad transformer +-- stack, then state semantics will depend on the order monad transformers are stacked. +-- +-- @since 1.2.0.0 +newtype Final m z a where + WithLoweringToFinal + :: (forall t. MonadTransWeave t => (forall x. z x -> t m x) -> t m a) + -> Final m z a + +makeSem ''Final + +data Strategy m t n z a where + LiftWithS :: forall m t n z a + . ( ( forall x + . Sem '[Strategy m t n, Final m, Embed m] x + -> m (t x) + ) + -> m a + ) + -> Strategy m t n z a + RestoreS :: forall m t n z a. t a -> Strategy m t n z a + RunS :: forall m t n z a. n a -> Strategy m t n z a + +restoreS :: forall m t n r a. t a -> Sem (Strategy m t n ': r) a +restoreS = send . RestoreS @m @_ @n +{-# INLINE restoreS #-} + +runS :: forall m t n r a. n a -> Sem (Strategy m t n ': r) a +runS = send . RunS @m @t +{-# INLINE runS #-} + +liftWithS' :: forall m t n r a + . ( ( forall x + . Sem '[Strategy m t n, Final m, Embed m] x -> m (t x) + ) + -> m a + ) + -> Sem (Strategy m t n ': r) a +liftWithS' main = send (LiftWithS main) +{-# INLINE liftWithS' #-} + +controlS' :: forall m t n r a + . ( ( forall x + . Sem '[Strategy m t n, Final m, Embed m] x -> m (t x) + ) + -> m (t a) + ) + -> Sem (Strategy m t n ': r) a +controlS' main = liftWithS' main >>= restoreS +{-# INLINE controlS' #-} + +liftWithS :: forall m t n r a + . ((forall x. n x -> m (t x)) -> m a) -> Sem (Strategy m t n ': r) a +liftWithS main = liftWithS' $ \n -> main (n . runS) +{-# INLINE liftWithS #-} + +controlS :: forall m t n r a + . ((forall x. n x -> m (t x)) -> m (t a)) + -> Sem (Strategy m t n ': r) a +controlS main = controlS' $ \n -> main (n . runS) +{-# INLINE controlS #-} + +-- | A convenience method for @'withStrategicToFinal' . 'controlS'@ +controlF :: forall m r a + . (Member (Final m) r, Monad m) + => ( forall t + . Traversable t + => (forall x. Sem r x -> m (t x)) -> m (t a) + ) + -> Sem r a +controlF main = withLoweringToFinal $ \n -> + controlT $ \lower -> main (lower . n) +{-# INLINE controlF #-} + +type Strategic m n a = + forall t. Traversable t => Sem '[Strategy m t n, Final m, Embed m] a + +runStrategy :: forall m n t a + . (Monad m, MonadTransWeave t) + => Sem '[Strategy m (StT t) n, Final m, Embed m] a + -> (forall x. n x -> t m x) -> t m a +runStrategy main nat = + let + go :: forall x. Sem '[Strategy m (StT t) n, Final m, Embed m] x -> t m x + go = usingSem $ \(Union pr (Weaving eff mkT lwr ex)) -> do + let run_it = (ex . (<$ mkInitState lwr)) + case pr of + Here -> run_it <$> case eff of + RestoreS t -> restoreT (return t) + RunS m -> nat m + LiftWithS main' -> liftWith $ \lower -> main' (lower . go) + There Here | WithLoweringToFinal main' <- eff -> + fmap ex $ lwr $ getComposeT $ main' (ComposeT . mkT go) + There (There Here) | Embed m <- eff -> run_it <$> lift m + in + go main + +----------------------------------------------------------------------------- +-- | Allows for embedding higher-order actions of the final monad +-- by providing the means of explicitly threading effects through @'Sem' r@ +-- to the final monad. This is done through the use of the 'Strategic' +-- environment, which provides a variety of combinators, most notably 'controlS'. +-- +-- You are discouraged from using 'withStrategicToFinal' in application code, +-- as it ties your application code directly to the final monad. +-- +-- @since 1.2.0.0 +withStrategicToFinal :: (Monad m, Member (Final m) r) + => Strategic m (Sem r) a + -> Sem r a +withStrategicToFinal main = withLoweringToFinal (runStrategy main) +{-# INLINE withStrategicToFinal #-} + +------------------------------------------------------------------------------ +-- | Lower a 'Sem' containing only a single lifted 'Monad' into that +-- monad. +runM :: Monad m => Sem '[Final m, Embed m] a -> m a +runM = usingSem $ \u -> case decomp u of + Right (Weaving (WithLoweringToFinal main) mkT lwr ex) -> + fmap ex $ lwr $ main $ mkT runM + Left g -> case extract g of + Weaving (Embed m) _ lwr ex -> fmap (ex . (<$ mkInitState lwr)) m +{-# INLINE runM #-} + + +----------------------------------------------------------------------------- +-- | 'withStrategicToFinal' admits an implementation of 'embed'. +-- +-- Just like 'embed', you are discouraged from using this in application code. +-- +-- @since 1.2.0.0 +embedFinal :: (Member (Final m) r, Monad m) => m a -> Sem r a +embedFinal m = withLoweringToFinal $ \_ -> lift m +{-# INLINE embedFinal #-} + +------------------------------------------------------------------------------ +-- | Like 'interpretH', but may be used to +-- interpret higher-order effects in terms of the final monad. +-- +-- 'interpretFinal' requires less boilerplate than using 'interpretH' +-- together with 'withStrategicToFinal' \/ 'withWeavingToFinal', +-- but is also less powerful. +-- 'interpretFinal' does not provide any means of executing actions +-- of @'Sem' r@ as you interpret each action, and the provided interpreter +-- is automatically recursively used to process higher-order occurences of +-- @'Sem' (e ': r)@ to @'Sem' r@. +-- +-- If you need greater control of how the effect is interpreted, +-- use 'interpretH' together with 'withStrategicToFinal' \/ +-- 'withWeavingToFinal' instead. +-- +-- /Beware/: Effects that aren't interpreted in terms of the final +-- monad will have local state semantics in regards to effects +-- interpreted using 'interpretFinal'. See 'Final'. +-- +-- @since 1.2.0.0 +interpretFinal + :: forall m e r a + . (Member (Final m) r, Monad m) + => (forall x rInitial. e (Sem rInitial) x -> Strategic m (Sem rInitial) x) + -- ^ A natural transformation from the handled effect to the final monad. + -> Sem (e ': r) a + -> Sem r a +interpretFinal h = + let + go :: Sem (e ': r) x -> Sem r x + go = hoistSem $ \u -> case decomp u of + Right (Weaving e mkT lwr ex) -> + injWeaving $ + Weaving + (WithLoweringToFinal (runStrategy (h e))) + (\n -> mkT (n . go)) + lwr + ex + Left g -> hoist go g + {-# INLINE go #-} + in + go +{-# INLINE interpretFinal #-} + +------------------------------------------------------------------------------ +-- | Given natural transformations between @m1@ and @m2@, run a @'Final' m1@ +-- effect by transforming it into a @'Final' m2@ effect. +-- +-- @since 1.2.0.0 +finalToFinal :: forall m1 m2 r a + . (Monad m1, Monad m2, Member (Final m2) r) + => (forall x. m1 x -> m2 x) + -> (forall x. m2 x -> m1 x) + -> Sem (Final m1 ': r) a + -> Sem r a +finalToFinal to from = + let + go :: Sem (Final m1 ': r) x -> Sem r x + go = hoistSem $ \u -> case decomp u of + Right (Weaving (WithLoweringToFinal main) mkT lwr ex) -> + injWeaving $ + Weaving + (WithLoweringToFinal $ \n -> hoistT to $ main (hoistT from . n) + ) + (\n -> mkT (n . go)) + lwr + ex + Left g -> hoist go g + {-# INLINE go #-} + in + go +{-# INLINE finalToFinal #-} + +------------------------------------------------------------------------------ +-- | Transform an @'Embed' m@ effect into a @'Final' m@ effect +-- +-- @since 1.2.0.0 +embedToFinal :: (Member (Final m) r, Monad m) + => Sem (Embed m ': r) a + -> Sem r a +embedToFinal = interpret $ \(Embed m) -> embedFinal m +{-# INLINE embedToFinal #-} diff --git a/src/Polysemy/Internal/Forklift.hs b/src/Polysemy/Internal/Forklift.hs deleted file mode 100644 index 51c943ad..00000000 --- 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/Interpretation.hs b/src/Polysemy/Internal/Interpretation.hs new file mode 100644 index 00000000..7d30ef01 --- /dev/null +++ b/src/Polysemy/Internal/Interpretation.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_HADDOCK not-home #-} +module Polysemy.Internal.Interpretation where + +import Control.Monad + +import Polysemy.Internal +import Polysemy.Internal.CustomErrors (FirstOrder) +import Polysemy.Internal.Kind +import Polysemy.Internal.Union + + +newtype Processor z t r = Processor { getProcessor :: forall x. z x -> Sem r (t x) } + + +-- | An effect for running monadic actions within a higher-order effect +-- currently being interpreted. +data RunH z t e r :: Effect where + RunH :: forall z t e r m a + . z a + -> RunH z t e r m a + WithProcessorH :: forall z t e r m a + . ((forall x. z x -> Sem (e ': r) (t x)) -> a) + -> RunH z t e r m a + WithInterpreterH :: forall z t e r m a + . ((forall x. Sem (e ': r) x -> Sem r x) -> a) + -> RunH z t e r m a + LiftWithH :: forall z t e r m a + . ((forall x. Sem (RunH z t e r ': r) x -> Sem r (t x)) -> a) + -> RunH z t e r m a + RestoreH :: forall z t e r m a + . t a + -> RunH z t e r m a + +propagate :: forall e r rInitial t e' r' a + . Member e r + => e (Sem rInitial) a + -> Sem (RunH (Sem rInitial) t e' r' ': r) a +propagate e = liftSem $ hoist runH $ Union (There membership) (mkWeaving e) +{-# INLINE propagate #-} + +-- | Run a monadic action given by a higher-order effect that is currently +-- being interpreted, and recursively apply the current interpreter on it. +-- +-- This is the standard tool for interpreting higher-order effects. +-- +-- @since TODO +runH :: forall z t e r r' a. z a -> Sem (RunH z t e r ': r') a +runH = send . RunH @z @t @e @r +{-# INLINE runH #-} + +liftWithH :: forall z t e r r' a + . ((forall x. Sem (RunH z t e r ': r) x -> Sem r (t x)) -> Sem r' a) + -> Sem (RunH z t e r ': r') a +liftWithH main = send (LiftWithH main) >>= raise +{-# INLINE liftWithH #-} + +withInterpreterH :: forall z t e r r' a + . ((forall x. Sem (e ': r) x -> Sem r x) -> Sem (RunH z t e r ': r') a) + -> Sem (RunH z t e r ': r') a +withInterpreterH main = join $ send (WithInterpreterH @z @t main) + +controlH :: forall z t e r r' a + . ((forall x. Sem (RunH z t e r ': r) x -> Sem r (t x)) -> Sem r' (t a)) + -> Sem (RunH z t e r ': r') a +controlH main = liftWithH main >>= restoreH @z @t @e @r +{-# INLINE controlH #-} + +-- | Run a monadic action given by a higher-order effect that is currently +-- being interpreted. +-- +-- Unlike 'runH', this doesn't recursively apply the current interpreter +-- to the monadic action -- allowing you to run a different interpreter +-- on it instead. +-- +-- @since TODO +runH' :: forall z t e r a. z a -> Sem (e ': RunH z t e r ': r) a +runH' z = runExposeH' z >>= raise . restoreH +{-# INLINE runH' #-} + +-- | Run a monadic action given by a higher-order effect that is currently +-- being interpreted, recursively apply the current interpreter on it, +-- and reify the effectful state of all local effects +-- as part of the result. +-- +-- By reifying the effectful state, you may do one or more of the following: +-- +-- * Guarantee that the handler won't be interrupted by a local effect failing, +-- since that failure will instead be reified into the state. +-- * Check if the action run has failed because of a local effect by using 'Data.Foldable.null'. +-- * Discard any impact the monadic action has on local effects by never restoring the +-- efectful state. +-- +-- Once an effectful state has been reified, you may restore it using 'restoreH'. +-- +-- @since TODO +runExposeH :: forall z t e r a. z a -> Sem (RunH z t e r ': r) (t a) +runExposeH z = withInterpreterH $ \n -> do + Processor pr <- getProcessorH + raise (n (pr z)) +{-# INLINE runExposeH #-} + +-- | Run a monadic action given by a higher-order effect that is currently +-- being interpreted, and reify the effectful state of all local effects +-- as part of the result. +-- +-- See 'runExposeH' for more information. +-- +-- Unlike 'runH', this doesn't recursively apply the current interpreter +-- to the monadic action -- allowing you to run a different interpreter +-- on it instead. +-- +-- @since TODO +runExposeH' :: forall z t e r a. z a -> Sem (e ': RunH z t e r ': r) (t a) +runExposeH' z = do + Processor pr <- raise getProcessorH + raiseUnder (pr z) +{-# INLINE runExposeH' #-} + + + +-- | Restore a reified effectful state, bringing its changes into scope, and returning +-- the result of the computation. +-- +-- /Note/: this overrides the local effectful state of any previously restored effectful state. +-- +-- For example, consider: +-- +-- @ +-- 'ta' <- runExposeH ma +-- 'tb' <- runExposeH mb +-- 'restoreH' ta +-- 'restoreH' tb +-- @ +-- Unless @'restoreH' ta@ causes the handler to fail (because @ma@ failed due to a local effect), +-- the changes it brings into scope will be overridden by @'restoreH' tb@. +-- +-- If you want to integrate the results of both actions, you need to restore the state +-- in between uses of 'runExposeH', so that @'runExposeH' mb@ works with the changes of @ta@ +-- in scope. +-- @ +-- 'ta' <- runExposeH ma +-- 'restoreH' ta +-- 'tb' <- runExposeH mb +-- 'restoreH' tb +-- @ +-- +-- @since TODO +restoreH :: forall z t e r r' a. t a -> Sem (RunH z t e r ': r') a +restoreH = send . RestoreH @z @_ @e @r +{-# INLINE restoreH #-} + +-- | Reify the effectful state of the local effects of the argument. +-- +-- @'runExposeH' m = 'exposeH' ('runH' m)@ +-- +-- /Note/: `polysemy-plugin` is heavily recommended when using this function +-- to avoid type ambiguous types. If `polysemy-plugin` isn't available, consider +-- using 'runExposeH' and `runExposeH'` instead. +-- +-- @since TODO +exposeH :: forall z t e r a. Sem (RunH z t e r ': r) a -> Sem (RunH z t e r ': r) (t a) +exposeH m = liftWithH $ \lower -> lower m +{-# INLINE exposeH #-} + +-- | Retrieve a 'Processor': a function which can be used +-- to process a monadic action given by a higher-order effect that is currently +-- being interpreted without immediately running it, turning it into a @'Sem' r@ action +-- that returns a reified effectful state. +-- +-- The processor automatically recursively applies the current interpreter on +-- monadic actions processed. +getProcessorH :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t (e ': r)) +getProcessorH = send (WithProcessorH @_ @_ @e Processor) +{-# INLINE getProcessorH #-} + +-- | Retrieve a 'Processor': a function which can be used +-- to process a monadic action given by a higher-order effect that is currently +-- being interpreted without immediately running it, turning it into a @'Sem' (e ': r)@ action +-- that returns a reified effectful state. +-- getProcessorH' :: forall z t e r r'. Sem (RunH z t e r ': r') (Processor z t (e ': r)) +-- getProcessorH' = send GetProcessorH' +-- {-# INLINE getProcessorH' #-} + +type EffHandlerH e r = + forall rInitial t x + . Traversable t + => e (Sem rInitial) x -> Sem (RunH (Sem rInitial) t e r ': r) x + +------------------------------------------------------------------------------ +-- | Like 'interpret', but for higher-order effects (i.e. those which make use +-- of the @m@ parameter.) +-- +-- This is significantly easier to use than 'interpretH' and its corresponding +-- 'Tactical' environment. +-- Because of this, 'interpretH' and friends are /heavily recommended/ over +-- 'interpretH' and friends /unless/ you need the extra power that the 'Tactical' +-- environment provides -- the ability to inspect and manipulate the underlying +-- effectful state. +-- +-- Higher-order thunks within the effect to be interpreted can be run using +-- 'runH'. For example: +-- +-- @ +-- data Bind m a where +-- Bind :: m a -> (a -> m b) -> Bind m b +-- +-- runBind :: Sem (Bind ': r) a -> Sem r a +-- runBind = 'interpretH' \\case +-- Bind ma f -> do +-- a <- 'runH' ma +-- b <- 'runH' (f a) +-- return b +-- @ +-- +-- @since TODO +interpretH :: forall e r a + . EffHandlerH e r + -> Sem (e ': r) a + -> Sem r a +interpretH h (Sem sem) = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) -> + sem $ \u -> case decomp u of + Left g -> k $ hoist (interpretH h) g + Right (Weaving e + (mkT :: forall n x + . Monad n + => (forall y. Sem (e ': r) y -> n y) + -> z x -> t n x + ) + lwr + ex + ) -> + let + {-# SPECIALIZE INLINE commonHandler :: forall n x. Weaving (RunH z (StT t) e r) n x -> t m x #-} + {-# SPECIALIZE INLINE commonHandler :: forall n x. Weaving (RunH z (StT t) e r) n x -> t (Sem r) x #-} + commonHandler :: forall n b x. Monad b => Weaving (RunH z (StT t) e r) n x -> t b x + commonHandler (Weaving eff _ lwr' ex') = do + let run_it = fmap (ex' . (<$ mkInitState lwr')) + case eff of + RunH _ -> errorWithoutStackTrace "RunH not commonly handled" + WithInterpreterH main -> run_it $ return $ main $ interpretH h + WithProcessorH main -> run_it $ + liftWith $ \lower -> return $ main (lower . mkT id) + RestoreH t -> run_it $ + restoreT (return t) + LiftWithH main -> run_it $ liftWith $ \lower -> return $ + main (lower . go2) + + go1 :: forall x. Sem (RunH z (StT t) e r ': r) x -> t m x + go1 = usingSem $ \u' -> case decomp u' of + Left g -> liftHandlerWithNat go2 k g + Right wav@(Weaving eff _ lwr' ex') -> do + let run_it = (ex' . (<$ mkInitState lwr')) + case eff of + RunH z -> run_it <$> mkT (usingSem k . interpretH h) z + _ -> commonHandler wav + {-# INLINE go1 #-} + + go2 :: forall x. Sem (RunH z (StT t) e r ': r) x -> t (Sem r) x + go2 = usingSem $ \u' -> case decomp u' of + Left g -> liftHandlerWithNat go2 liftSem g + Right wav@(Weaving eff _ lwr' ex') -> do + let run_it = (ex' . (<$ mkInitState lwr')) + case eff of + RunH z -> run_it <$> mkT (interpretH h) z + _ -> commonHandler wav + {-# NOINLINE go2 #-} + in + fmap ex $ lwr $ go1 (h e) +{-# INLINE interpretH #-} + +------------------------------------------------------------------------------ +-- | The simplest way to produce an effect handler. Interprets an effect @e@ by +-- transforming it into other effects inside of @r@. +-- +-- @since TODO +interpret :: forall e r a + . FirstOrder e "interpret" + => (∀ rInitial x. e (Sem rInitial) x -> Sem r x) + -> Sem (e ': r) a + -> Sem r a +interpret h = + interpretH (raise . h) +{-# INLINE interpret #-} + +-- TODO (KingoftheHomeless): If it matters, optimize the definitions +-- below + +------------------------------------------------------------------------------ +-- | Like 'reinterpret', but for higher-order effects. +-- +-- @since TODO +reinterpretH :: forall e1 e2 r a + . EffHandlerH e1 (e2 ': r) + -> Sem (e1 ': r) a + -> Sem (e2 ': r) a +reinterpretH h = interpretH h . raiseUnder +{-# INLINE reinterpretH #-} + +------------------------------------------------------------------------------ +-- | Like 'interpret', but instead of removing the effect @e@, reencodes it in +-- some new effect @f@. This function will fuse when followed by +-- 'Polysemy.State.runState', meaning it's free to 'reinterpret' in terms of +-- the 'Polysemy.State.State' effect and immediately run it. +-- +-- @since TODO +reinterpret :: forall e1 e2 r a + . FirstOrder e1 "reinterpret" + => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': r) x) + -> Sem (e1 ': r) a + -> Sem (e2 ': r) a +reinterpret h = + reinterpretH (raise . h) +{-# INLINE reinterpret #-} + +------------------------------------------------------------------------------ +-- | Like 'reinterpret2', but for higher-order effects. +-- +-- @since TODO +reinterpret2H :: forall e1 e2 e3 r a + . EffHandlerH e1 (e2 ': e3 ': r) + -> Sem (e1 ': r) a + -> Sem (e2 ': e3 ': r) a +reinterpret2H h = interpretH h . raiseUnder2 +{-# INLINE reinterpret2H #-} + +------------------------------------------------------------------------------ +-- | Like 'reinterpret', but introduces /two/ intermediary effects. +-- +-- @since TODO +reinterpret2 :: forall e1 e2 e3 r a + . FirstOrder e1 "reinterpret2" + => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': r) x) + -> Sem (e1 ': r) a + -> Sem (e2 ': e3 ': r) a +reinterpret2 h = + reinterpret2H (raise . h) +{-# INLINE reinterpret2 #-} + +------------------------------------------------------------------------------ +-- | Like 'reinterpret3', but for higher-order effects. +-- +-- @since TODO +reinterpret3H :: forall e1 e2 e3 e4 r a + . EffHandlerH e1 (e2 ': e3 ': e4 ': r) + -> Sem (e1 ': r) a + -> Sem (e2 ': e3 ': e4 ': r) a +reinterpret3H h = interpretH h . raiseUnder3 +{-# INLINE reinterpret3H #-} + +------------------------------------------------------------------------------ +-- | Like 'reinterpret', but introduces /three/ intermediary effects. +-- +-- @since TODO +reinterpret3 :: forall e1 e2 e3 e4 r a + . FirstOrder e1 "reinterpret3" + => (∀ rInitial x. e1 (Sem rInitial) x -> Sem (e2 ': e3 ': e4 ': r) x) + -> Sem (e1 ': r) a + -> Sem (e2 ': e3 ': e4 ': r) a +reinterpret3 h = + reinterpret3H (raise . h) +{-# INLINE reinterpret3 #-} + +------------------------------------------------------------------------------ +-- | Like 'intercept', but for higher-order effects. +-- +-- @since TODO +intercept :: forall e r a + . Member e r + => EffHandlerH e r + -> Sem r a + -> Sem r a +intercept h = interpretH h . expose +{-# INLINE intercept #-} + +------------------------------------------------------------------------------ +-- | Like 'interpret', but instead of handling the effect, allows responding to +-- the effect while leaving it unhandled. This allows you, for example, to +-- intercept other effects and insert logic around them. +-- +-- @since TODO +interceptH :: forall e r a + . FirstOrder e "intercept" + => Member e r + => (∀ rInitial x. e (Sem rInitial) x -> Sem r x) + -> Sem r a + -> Sem r a +interceptH h = + intercept (raise . h) +{-# INLINE interceptH #-} + +------------------------------------------------------------------------------ +-- | Like 'interceptUsing', but for higher-order effects. +-- +-- @since TODO +interceptUsing :: forall e r a + . ElemOf e r + -> EffHandlerH e r + -> Sem r a + -> Sem r a +interceptUsing pr h = interpretH h . exposeUsing pr +{-# INLINE interceptUsing #-} + +------------------------------------------------------------------------------ +-- | A variant of 'intercept' that accepts an explicit proof that the effect +-- is in the effect stack rather then requiring a 'Member' constraint. +-- +-- This is useful in conjunction with 'Polysemy.Membership.tryMembership' +-- in order to conditionally perform 'intercept'. +-- +-- @since TODO +interceptUsingH :: forall e r a . + FirstOrder e "interceptUsing" + => Member e r + => ElemOf e r + -> (∀ rInitial x. e (Sem rInitial) x -> Sem r x) + -> Sem r a + -> Sem r a +interceptUsingH pr h = + interceptUsing pr (raise . h) +{-# INLINE interceptUsingH #-} diff --git a/src/Polysemy/Internal/Strategy.hs b/src/Polysemy/Internal/Strategy.hs deleted file mode 100644 index 1ee7182f..00000000 --- a/src/Polysemy/Internal/Strategy.hs +++ /dev/null @@ -1,130 +0,0 @@ -{-# OPTIONS_HADDOCK not-home #-} - -module Polysemy.Internal.Strategy where - -import Polysemy.Internal -import Polysemy.Internal.Combinators -import Polysemy.Internal.Tactics (Inspector(..)) - - - -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)) - GetInspector :: Strategy m f n z (Inspector f) - - ------------------------------------------------------------------------------- --- | 'Strategic' is an environment in which you're capable of explicitly --- threading higher-order effect states to the final monad. --- This is a variant of @Tactics@ (see 'Polysemy.Tactical'), and usage --- is extremely similar. --- --- @since 1.2.0.0 -type Strategic m n a = forall f. Functor f => Sem (WithStrategy m f n) (m (f a)) - - ------------------------------------------------------------------------------- --- | @since 1.2.0.0 -type WithStrategy m f n = '[Strategy m f n] - - ------------------------------------------------------------------------------- --- | Internal function to process Strategies in terms of --- 'Polysemy.Final.withWeavingToFinal'. --- --- @since 1.2.0.0 -runStrategy :: Functor f - => Sem '[Strategy m f n] a - -> f () - -> (forall x. f (n x) -> m (f x)) - -> (forall x. f x -> Maybe x) - -> a -runStrategy sem = \s wv ins -> run $ interpret - (\case - GetInitialState -> pure s - HoistInterpretation f -> pure $ \fa -> wv (f <$> fa) - GetInspector -> pure (Inspector ins) - ) sem -{-# INLINE runStrategy #-} - - ------------------------------------------------------------------------------- --- | Get a natural transformation capable of potentially inspecting values --- inside of @f@. Binding the result of 'getInspectorS' produces a function that --- can sometimes peek inside values returned by 'bindS'. --- --- This is often useful for running callback functions that are not managed by --- polysemy code. --- --- See also 'Polysemy.getInspectorT' --- --- @since 1.2.0.0 -getInspectorS :: forall m f n. Sem (WithStrategy m f n) (Inspector f) -getInspectorS = send (GetInspector @m @f @n) -{-# INLINE getInspectorS #-} - - ------------------------------------------------------------------------------- --- | Get the stateful environment of the world at the moment the --- @Strategy@ is to be run. --- --- Prefer 'pureS', 'liftS', 'runS', or 'bindS' instead of using this function --- directly. --- --- @since 1.2.0.0 -getInitialStateS :: forall m f n. Sem (WithStrategy m f n) (f ()) -getInitialStateS = send (GetInitialState @m @f @n) -{-# INLINE getInitialStateS #-} - - ------------------------------------------------------------------------------- --- | Embed a value into 'Strategic'. --- --- @since 1.2.0.0 -pureS :: Applicative m => a -> Strategic m n a -pureS a = pure . (a <$) <$> getInitialStateS -{-# INLINE pureS #-} - - ------------------------------------------------------------------------------- --- | Lifts an action of the final monad into 'Strategic'. --- --- /Note/: you don't need to use this function if you already have a monadic --- action with the functorial state threaded into it, by the use of --- 'runS' or 'bindS'. --- In these cases, you need only use 'pure' to embed the action into the --- 'Strategic' environment. --- --- @since 1.2.0.0 -liftS :: Functor m => m a -> Strategic m n a -liftS m = do - s <- getInitialStateS - pure $ (<$ s) <$> m -{-# INLINE liftS #-} - - ------------------------------------------------------------------------------- --- | Lifts a monadic action into the stateful environment, in terms --- of the final monad. --- The stateful environment will be the same as the one that the @Strategy@ --- is initially run in. --- --- Use 'bindS' if you'd prefer to explicitly manage your stateful environment. --- --- @since 1.2.0.0 -runS :: n a -> Sem (WithStrategy m f n) (m (f a)) -runS na = bindS (const na) <*> getInitialStateS -{-# INLINE runS #-} - - ------------------------------------------------------------------------------- --- | Embed a kleisli action into the stateful environment, in terms of the final --- monad. You can use 'bindS' to get an effect parameter of the form @a -> n b@ --- into something that can be used after calling 'runS' on an effect parameter --- @n a@. --- --- @since 1.2.0.0 -bindS :: (a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b)) -bindS = send . HoistInterpretation -{-# INLINE bindS #-} diff --git a/src/Polysemy/Internal/Tactics.hs b/src/Polysemy/Internal/Tactics.hs deleted file mode 100644 index 5c46cddb..00000000 --- a/src/Polysemy/Internal/Tactics.hs +++ /dev/null @@ -1,250 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} - -{-# OPTIONS_HADDOCK not-home #-} - -module Polysemy.Internal.Tactics - ( Tactics (..) - , getInitialStateT - , getInspectorT - , Inspector (..) - , runT - , runTSimple - , bindT - , bindTSimple - , pureT - , liftT - , runTactics - , Tactical - , WithTactics - ) where - -import Polysemy.Internal -import Polysemy.Internal.Union - - ------------------------------------------------------------------------------- --- | 'Tactical' is an environment in which you're capable of explicitly --- threading higher-order effect states. This is provided by the (internal) --- effect @Tactics@, which is capable of rewriting monadic actions so they run --- in the correct stateful environment. --- --- Inside a 'Tactical', you're capable of running 'pureT', 'runT' and 'bindT' --- which are the main tools for rewriting monadic stateful environments. --- --- For example, consider trying to write an interpreter for --- 'Polysemy.Resource.Resource', whose effect is defined as: --- --- @ --- data 'Polysemy.Resource.Resource' m a where --- 'Polysemy.Resource.Bracket' :: m a -> (a -> m ()) -> (a -> m b) -> 'Polysemy.Resource.Resource' m b --- @ --- --- Here we have an @m a@ which clearly needs to be run first, and then --- subsequently call the @a -> m ()@ and @a -> m b@ arguments. In a 'Tactical' --- environment, we can write the threading code thusly: --- --- @ --- 'Polysemy.Resource.Bracket' alloc dealloc use -> do --- alloc' <- 'runT' alloc --- dealloc' <- 'bindT' dealloc --- use' <- 'bindT' use --- @ --- --- where --- --- @ --- alloc' :: 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f a1) --- dealloc' :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f ()) --- use' :: f a1 -> 'Polysemy.Sem' ('Polysemy.Resource.Resource' ': r) (f x) --- @ --- --- The @f@ type here is existential and corresponds to "whatever --- state the other effects want to keep track of." @f@ is always --- a 'Functor'. --- --- @alloc'@, @dealloc'@ and @use'@ are now in a form that can be --- easily consumed by your interpreter. At this point, simply bind --- them in the desired order and continue on your merry way. --- --- We can see from the types of @dealloc'@ and @use'@ that since they both --- consume a @f a1@, they must run in the same stateful environment. This --- means, for illustration, any 'Polysemy.State.put's run inside the @use@ --- block will not be visible inside of the @dealloc@ block. --- --- Power users may explicitly use 'getInitialStateT' and 'bindT' to construct --- whatever data flow they'd like; although this is usually unnecessary. -type Tactical e m r x = ∀ f. Functor f - => Sem (WithTactics e f m r) (f x) - -type WithTactics e f m r = Tactics f m (e ': r) ': r - -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)) - HoistInterpretationH :: (a -> n b) -> f a -> Tactics f n r m (f b) - GetInspector :: Tactics f n r m (Inspector f) - - ------------------------------------------------------------------------------- --- | Get the stateful environment of the world at the moment the effect @e@ is --- to be run. Prefer 'pureT', 'runT' or 'bindT' instead of using this function --- directly. -getInitialStateT :: forall f m r e. Sem (WithTactics e f m r) (f ()) -getInitialStateT = send @(Tactics _ m (e ': r)) GetInitialState - - ------------------------------------------------------------------------------- --- | Get a natural transformation capable of potentially inspecting values --- inside of @f@. Binding the result of 'getInspectorT' produces a function that --- can sometimes peek inside values returned by 'bindT'. --- --- This is often useful for running callback functions that are not managed by --- polysemy code. --- --- ==== Example --- --- We can use the result of 'getInspectorT' to "undo" 'pureT' (or any of the other --- 'Tactical' functions): --- --- @ --- ins <- 'getInspectorT' --- fa <- 'pureT' "hello" --- fb <- 'pureT' True --- let a = 'inspect' ins fa -- Just "hello" --- b = 'inspect' ins fb -- Just True --- @ -getInspectorT :: forall e f m r. Sem (WithTactics e f m r) (Inspector f) -getInspectorT = send @(Tactics _ m (e ': r)) GetInspector - - ------------------------------------------------------------------------------- --- | A container for 'inspect'. See the documentation for 'getInspectorT'. -newtype Inspector f = Inspector - { inspect :: forall x. f x -> Maybe x - -- ^ See the documentation for 'getInspectorT'. - } - - ------------------------------------------------------------------------------- --- | Lift a value into 'Tactical'. -pureT :: Functor f => a -> Sem (WithTactics e f m r) (f a) -pureT a = do - istate <- getInitialStateT - pure $ a <$ istate - - ------------------------------------------------------------------------------- --- | Run a monadic action in a 'Tactical' environment. The stateful environment --- used will be the same one that the effect is initally run in. Use 'bindT' if --- you'd prefer to explicitly manage your stateful environment. -runT - :: m a - -- ^ The monadic action to lift. This is usually a parameter in your - -- effect. - -> Sem (WithTactics e f m r) - (Sem (e ': r) (f a)) -runT na = do - istate <- getInitialStateT - na' <- bindT (const na) - pure $ na' istate -{-# INLINE runT #-} - ------------------------------------------------------------------------------- --- | Run a monadic action in a 'Tactical' environment. The stateful environment --- used will be the same one that the effect is initally run in. --- Use 'bindTSimple' if you'd prefer to explicitly manage your stateful --- environment. --- --- This is a less flexible but significantly simpler variant of 'runT'. --- Instead of returning a 'Sem' action corresponding to the provided action, --- 'runTSimple' runs the action immediately. --- --- @since 1.5.0.0 -runTSimple :: m a - -- ^ The monadic action to lift. This is usually a parameter in your - -- effect. - -> Tactical e m r a -runTSimple na = do - istate <- getInitialStateT - bindTSimple (const na) istate -{-# INLINE runTSimple #-} - - ------------------------------------------------------------------------------- --- | Lift a kleisli action into the stateful environment. You can use --- 'bindT' to get an effect parameter of the form @a -> m b@ into something --- that can be used after calling 'runT' on an effect parameter @m a@. -bindT - :: (a -> m b) - -- ^ The monadic continuation to lift. This is usually a parameter in - -- your effect. - -- - -- Continuations lifted via 'bindT' will run in the same environment - -- which produced the @a@. - -> Sem (WithTactics e f m r) - (f a -> Sem (e ': r) (f b)) -bindT f = send $ HoistInterpretation f -{-# INLINE bindT #-} - ------------------------------------------------------------------------------- --- | Lift a kleisli action into the stateful environment. --- You can use 'bindTSimple' to execute an effect parameter of the form --- @a -> m b@ by providing the result of a `runTSimple` or another --- `bindTSimple`. --- --- This is a less flexible but significantly simpler variant of 'bindT'. --- Instead of returning a 'Sem' kleisli action corresponding to the --- provided kleisli action, 'bindTSimple' runs the kleisli action immediately. --- --- @since 1.5.0.0 -bindTSimple - :: forall m f r e a b - . (a -> m b) - -- ^ The monadic continuation to lift. This is usually a parameter in - -- your effect. - -- - -- Continuations executed via 'bindTSimple' will run in the same - -- environment which produced the @a@. - -> f a - -> Sem (WithTactics e f m r) (f b) -bindTSimple f s = send @(Tactics _ _ (e ': r)) $ HoistInterpretationH f s -{-# INLINE bindTSimple #-} - - ------------------------------------------------------------------------------- --- | Internal function to create first-order interpreter combinators out of --- higher-order ones. -liftT - :: forall m f r e a - . Functor f - => Sem r a - -> Sem (WithTactics e f m r) (f a) -liftT m = do - a <- raise m - pureT a -{-# INLINE liftT #-} - - ------------------------------------------------------------------------------- --- | Run the 'Tactics' effect. -runTactics - :: Functor f - => f () - -> (∀ x. f (m x) -> Sem r2 (f x)) - -> (∀ x. f x -> Maybe x) - -> (∀ x. f (m x) -> Sem r (f x)) - -> Sem (Tactics f m r2 ': r) a - -> Sem r a -runTactics s d v d' (Sem m) = Sem $ \k -> m $ \u -> - case decomp u of - Left x -> k $ hoist (runTactics s d v d') x - Right (Weaving GetInitialState s' _ y _) -> - pure $ y $ s <$ s' - Right (Weaving (HoistInterpretation na) s' _ y _) -> do - pure $ y $ (d . fmap na) <$ s' - Right (Weaving (HoistInterpretationH na fa) s' _ y _) -> do - (y . (<$ s')) <$> runSem (d' (fmap na fa)) k - Right (Weaving GetInspector s' _ y _) -> do - pure $ y $ Inspector v <$ s' -{-# INLINE runTactics #-} - diff --git a/src/Polysemy/Internal/Union.hs b/src/Polysemy/Internal/Union.hs index 3da8da27..60b84fc1 100644 --- a/src/Polysemy/Internal/Union.hs +++ b/src/Polysemy/Internal/Union.hs @@ -20,11 +20,16 @@ module Polysemy.Internal.Union , MemberWithError , weave , hoist + , liftHandler + , liftHandlerWithNat + -- * Building Unions , inj , injUsing , injWeaving + , mkWeaving , weaken + -- * Using Unions , decomp , prj @@ -43,14 +48,20 @@ module Polysemy.Internal.Union , extendMembershipRight , injectMembership , weakenList - , weakenMid) where + , weakenMid + + , module Polysemy.Internal.WeaveClass -import Control.Monad + ) where + +import Control.Monad.Trans.Identity +import Data.Coerce import Data.Functor.Compose import Data.Functor.Identity import Data.Kind import Data.Typeable import Polysemy.Internal.Kind +import Polysemy.Internal.WeaveClass import {-# SOURCE #-} Polysemy.Internal import Polysemy.Internal.Sing (SList (SEnd, SCons)) @@ -78,59 +89,55 @@ instance Functor (Union r mWoven) where data Weaving e mAfter resultType where Weaving - :: forall f e rInitial a resultType mAfter. (Functor f) + :: forall t e rInitial a resultType mAfter. (MonadTransWeave t) => { - weaveEffect :: e (Sem rInitial) a + weaveEffect :: e (Sem rInitial) a -- ^ The original effect GADT originally lifted via -- 'Polysemy.Internal.send'. -- ^ @rInitial@ is the effect row that was in scope when this 'Weaving' -- was originally created. - , weaveState :: f () - -- ^ A piece of state that other effects' interpreters have already - -- woven through this 'Weaving'. @f@ is a 'Functor', so you can always - -- 'fmap' into this thing. - , weaveDistrib :: forall x. f (Sem rInitial x) -> mAfter (f x) - -- ^ Distribute @f@ by transforming @Sem rInitial@ into @mAfter@. This is - -- usually of the form @f ('Polysemy.Sem' (Some ': Effects ': r) x) -> - -- Sem r (f x)@ - , weaveResult :: f a -> resultType - -- ^ Even though @f a@ is the moral resulting type of 'Weaving', we - -- can't expose that fact; such a thing would prevent 'Polysemy.Sem' - -- from being a 'Monad'. - , weaveInspect :: forall x. f x -> Maybe x - -- ^ A function for attempting to see inside an @f@. This is no - -- guarantees that such a thing will succeed (for example, - -- 'Polysemy.Error.Error' might have 'Polysemy.Error.throw'n.) + , weaveTrans :: forall n x. Monad n => (forall y. mAfter y -> n y) -> Sem rInitial x -> t n x + , weaveLowering :: forall z x. Monad z => t z x -> z (StT t x) + , weaveResult :: StT t a -> resultType } -> Weaving e mAfter resultType instance Functor (Weaving e m) where - fmap f (Weaving e s d f' v) = Weaving e s d (f . f') v + fmap f (Weaving e mkT lwr ex) = Weaving e mkT lwr (f . ex) {-# INLINE fmap #-} -weave - :: (Functor s, Functor n) - => s () - -> (∀ x. s (m x) -> n (s x)) - -> (∀ x. s x -> Maybe x) - -> Union r m a - -> Union r n (s a) -weave s' d v' (Union w (Weaving e s nt f v)) = - Union w $ Weaving - e (Compose $ s <$ s') - (fmap Compose . d . fmap nt . getCompose) - (fmap f . getCompose) - (v <=< v' . getCompose) +weave :: (MonadTransWeave t, Monad n) + => (forall x. m x -> t n x) + -> (forall z x. Monad z => t z x -> z (StT t x)) + -> Union r m a + -> Union r n (StT t a) +weave mkT' lwr' (Union pr (Weaving e mkT lwr ex)) = + Union pr $ Weaving e + (\n sem0 -> ComposeT $ mkT (hoistT n . mkT') sem0) + (fmap Compose . lwr' . lwr . getComposeT) + (fmap ex . getCompose) {-# INLINE weave #-} +liftHandler :: (MonadTransWeave t, Monad m, Monad n) + => (forall x. Union r m x -> n x) + -> Union r (t m) a -> t n a +liftHandler = liftHandlerWithNat id +{-# INLINE liftHandler #-} + +liftHandlerWithNat :: (MonadTransWeave t, Monad m, Monad n) + => (forall x. q x -> t m x) + -> (forall x. Union r m x -> n x) + -> Union r q a -> t n a +liftHandlerWithNat n handler u = controlT $ \lower -> handler (weave n lower u) +{-# INLINE liftHandlerWithNat #-} hoist :: (∀ x. m x -> n x) -> Union r m a -> Union r n a -hoist f' (Union w (Weaving e s nt f v)) = - Union w $ Weaving e s (f' . nt) f v +hoist n' (Union w (Weaving e mkT lwr ex)) = + Union w $ Weaving e (\n -> mkT (n . n')) lwr ex {-# INLINE hoist #-} @@ -351,14 +358,18 @@ weakenMid sl sm (Union pr e) = Union (injectMembership @right sl sm pr) e ------------------------------------------------------------------------------ -- | Lift an effect @e@ into a 'Union' capable of holding it. -inj :: forall e r rInitial a. (Member e r) => e (Sem rInitial) a -> Union r (Sem rInitial) a -inj e = injWeaving $ Weaving +inj :: forall e r rInitial a. Member e r => e (Sem rInitial) a -> Union r (Sem rInitial) a +inj = injWeaving . mkWeaving +{-# INLINE inj #-} + + +mkWeaving :: forall e rInitial a. e (Sem rInitial) a -> Weaving e (Sem rInitial) a +mkWeaving e = Weaving e - (Identity ()) - (fmap Identity . runIdentity) + (\ nt -> coerce nt) + (fmap Identity . runIdentityT) runIdentity - (Just . runIdentity) -{-# INLINE inj #-} +{-# INLINE mkWeaving #-} ------------------------------------------------------------------------------ @@ -368,10 +379,9 @@ injUsing :: forall e r rInitial a. ElemOf e r -> e (Sem rInitial) a -> Union r (Sem rInitial) a injUsing pr e = Union pr $ Weaving e - (Identity ()) - (fmap Identity . runIdentity) + (\ nt -> coerce nt) + (fmap Identity . runIdentityT) runIdentity - (Just . runIdentity) {-# INLINE injUsing #-} ------------------------------------------------------------------------------ diff --git a/src/Polysemy/Internal/WeaveClass.hs b/src/Polysemy/Internal/WeaveClass.hs new file mode 100644 index 00000000..d20ed1f5 --- /dev/null +++ b/src/Polysemy/Internal/WeaveClass.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, QuantifiedConstraints, TupleSections #-} +{-# OPTIONS_HADDOCK not-home #-} +module Polysemy.Internal.WeaveClass + ( MonadTransWeave(..) + + , mkInitState + , mkDistrib + , Distrib(..) + , mkInspector + + , ComposeT(..) + ) where + +import Control.Monad +import Control.Monad.Trans +import qualified Control.Monad.Trans.Except as E +import Control.Monad.Trans.Identity +import Control.Monad.Trans.Maybe +import qualified Control.Monad.Trans.State.Lazy as LSt +import qualified Control.Monad.Trans.State.Strict as SSt +import qualified Control.Monad.Trans.Writer.Lazy as LWr +import Data.Functor.Compose +import Data.Functor.Identity +import Data.Tuple + +-- | A variant of the classic @MonadTransControl@ class from @monad-control@, +-- but with a small number of changes to make it more suitable for Polysemy's +-- internals. +class ( MonadTrans t + , forall z. Monad z => Monad (t z) + , Traversable (StT t) + ) + => MonadTransWeave t where + type StT t :: * -> * + + hoistT :: (Monad m, Monad n) + => (forall x. m x -> n x) + -> t m a -> t n a + hoistT n m = controlT $ \lower -> n (lower m) + {-# INLINE hoistT #-} + + controlT :: Monad m + => ((forall z x. Monad z => t z x -> z (StT t x)) -> m (StT t a)) + -> t m a + controlT main = liftWith main >>= restoreT . pure + {-# INLINE controlT #-} + + liftWith :: Monad m + => ((forall z x. Monad z => t z x -> z (StT t x)) -> m a) + -> t m a + + restoreT :: Monad m => m (StT t a) -> t m a + +newtype ComposeT t (u :: (* -> *) -> * -> *) m a = ComposeT { + getComposeT :: t (u m) a + } + deriving (Functor, Applicative, Monad) + +instance ( MonadTrans t + , MonadTrans u + , forall m. Monad m => Monad (u m) + ) + => MonadTrans (ComposeT t u) where + lift m = ComposeT (lift (lift m)) + +instance ( MonadTransWeave t + , MonadTransWeave u + ) + => MonadTransWeave (ComposeT t u) where + type StT (ComposeT t u) = Compose (StT u) (StT t) + + hoistT n (ComposeT m) = ComposeT (hoistT (hoistT n) m) + + controlT main = ComposeT $ + controlT $ \lowerT -> + controlT $ \lowerU -> + getCompose <$> main (\(ComposeT m) -> Compose <$> lowerU (lowerT m)) + + liftWith main = ComposeT $ + liftWith $ \lowerT -> + liftWith $ \lowerU -> + main (\(ComposeT m) -> Compose <$> lowerU (lowerT m)) + + restoreT m = ComposeT (restoreT (restoreT (fmap getCompose m))) + +newtype Distrib f q m = Distrib (forall x. f (q x) -> m (f x)) + +mkInitState :: Monad (t Identity) + => (t Identity () -> Identity (StT t ())) + -> StT t () +mkInitState lwr = runIdentity $ lwr (pure ()) +{-# INLINE mkInitState #-} + +mkDistrib :: (MonadTransWeave t, Monad m) + => (forall n x. Monad n => (forall y. m y -> n y) -> q x -> t n x) + -> (forall z x. Monad z => t z x -> z (StT t x)) + -> Distrib (StT t) q m +mkDistrib mkT lwr = Distrib $ lwr . join . restoreT . return . fmap (mkT id) +{-# INLINE mkDistrib #-} + +mkInspector :: Foldable f => f a -> Maybe a +mkInspector = foldr (const . Just) Nothing +{-# INLINE mkInspector #-} + +instance MonadTransWeave IdentityT where + type StT IdentityT = Identity + hoistT nt = IdentityT . nt . runIdentityT + + liftWith main = IdentityT (main (fmap Identity . runIdentityT)) + + controlT main = IdentityT (runIdentity <$> main (fmap Identity . runIdentityT)) + + restoreT = IdentityT . fmap runIdentity + +instance MonadTransWeave (LSt.StateT s) where + type StT (LSt.StateT s) = (,) s + + hoistT nt = LSt.mapStateT nt + + controlT main = LSt.StateT $ \s -> + swap <$> main (\m -> swap <$> LSt.runStateT m s) + + liftWith main = LSt.StateT $ \s -> + (, s) + <$> main (\m -> swap <$> LSt.runStateT m s) + + restoreT m = LSt.StateT $ \_ -> swap <$> m + +instance MonadTransWeave (SSt.StateT s) where + type StT (SSt.StateT s) = (,) s + + hoistT nt = SSt.mapStateT nt + + controlT main = SSt.StateT $ \s -> + swap <$!> main (\m -> swap <$!> SSt.runStateT m s) + + liftWith main = SSt.StateT $ \s -> + (, s) + <$> main (\m -> swap <$!> SSt.runStateT m s) + + restoreT m = SSt.StateT $ \_ -> swap <$!> m + +instance MonadTransWeave (E.ExceptT e) where + type StT (E.ExceptT e) = Either e + + hoistT nt = E.mapExceptT nt + + controlT main = E.ExceptT (main E.runExceptT) + + liftWith main = lift $ main E.runExceptT + + restoreT = E.ExceptT + +instance Monoid w => MonadTransWeave (LWr.WriterT w) where + type StT (LWr.WriterT w) = (,) w + + hoistT nt = LWr.mapWriterT nt + + controlT main = LWr.WriterT (swap <$> main (fmap swap . LWr.runWriterT)) + + liftWith main = lift $ main (fmap swap . LWr.runWriterT) + + restoreT m = LWr.WriterT (swap <$> m) + + +instance MonadTransWeave MaybeT where + type StT MaybeT = Maybe + + hoistT nt = mapMaybeT nt + + controlT main = MaybeT (main runMaybeT) + + liftWith main = lift $ main runMaybeT + + restoreT = MaybeT diff --git a/src/Polysemy/Internal/Writer.hs b/src/Polysemy/Internal/Writer.hs index f83d4c90..de9ef4e5 100644 --- a/src/Polysemy/Internal/Writer.hs +++ b/src/Polysemy/Internal/Writer.hs @@ -7,7 +7,7 @@ import Control.Exception import Control.Monad import qualified Control.Monad.Trans.Writer.Lazy as Lazy -import Data.Bifunctor (first) +import Data.Tuple (swap) import Data.Semigroup import Polysemy @@ -42,32 +42,17 @@ writerToEndoWriter => Sem (Writer o ': r) a -> Sem r a writerToEndoWriter = interpretH $ \case - Tell o -> tell (Endo (o <>)) >>= pureT - Listen m -> do - m' <- writerToEndoWriter <$> runT m - raise $ do - (o, fa) <- listen m' - return $ (,) (appEndo o mempty) <$> fa - Pass m -> do - ins <- getInspectorT - m' <- writerToEndoWriter <$> runT m - raise $ pass $ do - t <- m' - let - f' = - maybe - id - (\(f, _) (Endo oo) -> let !o' = f (oo mempty) in Endo (o' <>)) - (inspect ins t) - return (f', snd <$> t) + Tell o -> tell (Endo (o <>)) + Listen m -> do + (o, a) <- listen (runH m) + return (appEndo o mempty, a) + Pass m -> pass $ do + (f, a) <- runH m + let f' (Endo oo) = let !o' = f (oo mempty) in Endo (o' <>) + return (f', a) {-# INLINE writerToEndoWriter #-} --- TODO(KingoftheHomeless): Make this mess more palatable --- --- 'interpretFinal' is too weak for our purposes, so we --- use 'interpretH' + 'withWeavingToFinal'. - ------------------------------------------------------------------------------ -- | A variant of 'Polysemy.Writer.runWriterTVar' where an 'STM' action is -- used instead of a 'TVar' to commit 'tell's. @@ -77,36 +62,28 @@ runWriterSTMAction :: forall o r a -> Sem (Writer o ': r) a -> Sem r a runWriterSTMAction write = interpretH $ \case - Tell o -> do - t <- embedFinal $ atomically (write o) - pureT t - Listen m -> do - m' <- runT m - -- Using 'withWeavingToFinal' instead of 'withStrategicToFinal' - -- here allows us to avoid using two additional 'embedFinal's in - -- order to create the TVars. - raise $ withWeavingToFinal $ \s wv _ -> mask $ \restore -> do - -- See below to understand how this works - tvar <- newTVarIO mempty - switch <- newTVarIO False - fa <- - restore (wv (runWriterSTMAction (writeListen tvar switch) m' <$ s)) - `onException` commitListen tvar switch - o <- commitListen tvar switch - return $ (fmap . fmap) (o, ) fa - Pass m -> do - m' <- runT m - ins <- getInspectorT - raise $ withWeavingToFinal $ \s wv ins' -> mask $ \restore -> do - -- See below to understand how this works - tvar <- newTVarIO mempty - switch <- newTVarIO False - t <- - restore (wv (runWriterSTMAction (writePass tvar switch) m' <$ s)) - `onException` commitPass tvar switch id - commitPass tvar switch - (maybe id fst $ ins' t >>= inspect ins) - return $ (fmap . fmap) snd t + Tell o -> embedFinal $ atomically (write o) + Listen m -> controlF $ \lower -> mask $ \restore -> do + -- See below to understand how this works + tvar <- newTVarIO mempty + switch <- newTVarIO False + fa <- + restore + (lower (runWriterSTMAction (writeListen tvar switch) (runH' m))) + `onException` + commitListen tvar switch + o <- commitListen tvar switch + return $ fmap (o, ) fa + Pass m -> controlF $ \lower -> mask $ \restore -> do + -- See below to understand how this works + tvar <- newTVarIO mempty + switch <- newTVarIO False + t <- + restore (lower (runWriterSTMAction (writePass tvar switch) (runH' m))) + `onException` + commitPass tvar switch id + commitPass tvar switch $ foldr (const . fst) id t + return $ fmap snd t where {- KingoftheHomeless: @@ -123,7 +100,7 @@ runWriterSTMAction write = interpretH $ \case ('commitListen' serves only as a (likely unneeded) safety measure.) - 'commitListen'/'commitPass' is protected by 'mask'+'onException'. + 'commitListen''/'commitPass' is protected by 'mask'+'onException'. Combine this with the fact that the 'withWeavingToFinal' can't be interrupted by pure errors emitted by effects (since these will be represented as part of the functorial state), and we @@ -205,17 +182,11 @@ interpretViaLazyWriter f sem = Sem $ \(k :: forall x. Union r (Sem r) x -> m x) let go :: forall x. Sem (e ': r) x -> Lazy.WriterT o m x go = usingSem $ \u -> case decomp u of - Right (Weaving e s wv ex ins) -> f $ Weaving e s (go . wv) ex ins - Left g -> Lazy.WriterT $ do - ~(o, a) <- k $ - weave - (mempty, ()) - (\ ~(o, m) -> (fmap . first) (o <>) (interpretViaLazyWriter f m)) - (Just . snd) - g - return (a, o) + Right (Weaving e mkT lwr ex) -> f $ Weaving e (\n -> mkT (n . go)) lwr ex + Left g -> + liftHandlerWithNat + (Lazy.WriterT . fmap swap . interpretViaLazyWriter f) + k g {-# INLINE go #-} - in do - ~(a,s) <- Lazy.runWriterT (go sem) - return (s, a) + in swap <$> Lazy.runWriterT (go sem) {-# INLINE interpretViaLazyWriter #-} diff --git a/src/Polysemy/Interpretation.hs b/src/Polysemy/Interpretation.hs new file mode 100644 index 00000000..b0a7900e --- /dev/null +++ b/src/Polysemy/Interpretation.hs @@ -0,0 +1,17 @@ +-- | Tools for more advanced usages of 'Polysemy.interpretH' +module Polysemy.Interpretation + ( -- * Manipuluating effectful state + runExposeH + , runExposeH' + , exposeH + , restoreH + , propagate + + -- * Lowering Higher-Order thunks to actions of @'Sem' r@. + , Processor(..) + , liftWithH + , controlH + , getProcessorH + ) where + +import Polysemy.Internal.Interpretation diff --git a/src/Polysemy/Law.hs b/src/Polysemy/Law.hs deleted file mode 100644 index c4eb0af3..00000000 --- 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/Membership.hs b/src/Polysemy/Membership.hs index 0b45c3b1..a9c5b608 100644 --- a/src/Polysemy/Membership.hs +++ b/src/Polysemy/Membership.hs @@ -9,9 +9,11 @@ module Polysemy.Membership -- * Using membership , subsumeUsing , interceptUsing + , interceptUsing , interceptUsingH ) where import Polysemy.Internal import Polysemy.Internal.Combinators +import Polysemy.Internal.Interpretation import Polysemy.Internal.Union diff --git a/src/Polysemy/NonDet.hs b/src/Polysemy/NonDet.hs index d2664dd4..6795c395 100644 --- a/src/Polysemy/NonDet.hs +++ b/src/Polysemy/NonDet.hs @@ -12,8 +12,9 @@ module Polysemy.NonDet ) where import Control.Applicative +import Control.Monad import Control.Monad.Trans.Maybe -import Data.Maybe +import Control.Monad.Trans import Polysemy import Polysemy.Error @@ -37,18 +38,14 @@ runNonDet = runNonDetC . runNonDetInC runNonDetMaybe :: Sem (NonDet ': r) a -> Sem r (Maybe a) runNonDetMaybe (Sem sem) = Sem $ \k -> runMaybeT $ sem $ \u -> case decomp u of - Right (Weaving e s wv ex _) -> + Right (Weaving e mkT lwr ex) -> case e of Empty -> empty Choose left right -> MaybeT $ usingSem k $ runMaybeT $ fmap ex $ - MaybeT (runNonDetMaybe (wv (left <$ s))) - <|> MaybeT (runNonDetMaybe (wv (right <$ s))) - Left x -> MaybeT $ - k $ weave (Just ()) - (maybe (pure Nothing) runNonDetMaybe) - id - x + MaybeT (runNonDetMaybe (lwr (mkT id left))) + <|> MaybeT (runNonDetMaybe (lwr (mkT id right))) + Left x -> liftHandlerWithNat (MaybeT . runNonDetMaybe) k x {-# INLINE runNonDetMaybe #-} ------------------------------------------------------------------------------ @@ -65,9 +62,7 @@ nonDetToError :: Member (Error e) r nonDetToError (e :: e) = interpretH $ \case Empty -> throw e Choose left right -> do - left' <- nonDetToError e <$> runT left - right' <- nonDetToError e <$> runT right - raise (left' `catch` \(_ :: e) -> right') + runH left `catch` \(_ :: e) -> runH right {-# INLINE nonDetToError #-} @@ -106,18 +101,24 @@ instance Monad (NonDetC m) where a (\ a' -> unNonDetC (f a') cons) {-# INLINE (>>=) #-} +instance MonadTrans NonDetC where + lift m = NonDetC $ \c b -> m >>= (`c` b) + +instance MonadTransWeave NonDetC where + type StT NonDetC = [] + + hoistT n nd = NonDetC $ \c b -> + join $ n $ unNonDetC nd (\a r -> return $ c a (join (n r))) (return b) + + liftWith main = lift $ main (\m -> unNonDetC m (\a -> fmap (a:)) (return [])) + + restoreT m = NonDetC $ \c b -> m >>= foldr c b + runNonDetInC :: Sem (NonDet ': r) a -> NonDetC (Sem r) a runNonDetInC = usingSem $ \u -> case decomp u of - Left x -> NonDetC $ \c b -> do - l <- liftSem $ weave [()] - -- KingoftheHomeless: This is NOT the right semantics, but - -- the known alternatives are worse. See Issue #246. - (fmap concat . traverse runNonDet) - listToMaybe - x - foldr c b l - Right (Weaving Empty _ _ _ _) -> empty - Right (Weaving (Choose left right) s wv ex _) -> fmap ex $ - runNonDetInC (wv (left <$ s)) <|> runNonDetInC (wv (right <$ s)) + Left x -> liftHandlerWithNat runNonDetInC liftSem x + Right (Weaving Empty _ _ _)-> empty + Right (Weaving (Choose left right) mkT lwr ex) -> fmap ex $ + runNonDetInC (lwr (mkT id left)) <|> runNonDetInC (lwr (mkT id right)) {-# INLINE runNonDetInC #-} diff --git a/src/Polysemy/Output.hs b/src/Polysemy/Output.hs index ae64de24..1913b7e4 100644 --- a/src/Polysemy/Output.hs +++ b/src/Polysemy/Output.hs @@ -32,6 +32,7 @@ import Data.Bifunctor (first) import Polysemy import Polysemy.State import Control.Monad (when) +import Control.Monad.Trans import Polysemy.Internal.Union import Polysemy.Internal.Writer @@ -107,9 +108,9 @@ runLazyOutputMonoid => (o -> m) -> Sem (Output o ': r) a -> Sem r (m, a) -runLazyOutputMonoid f = interpretViaLazyWriter $ \(Weaving e s _ ex _) -> +runLazyOutputMonoid f = interpretViaLazyWriter $ \(Weaving e _ lwr ex) -> case e of - Output o -> ex s <$ Lazy.tell (f o) + Output o -> fmap ex $ lwr $ lift $ Lazy.tell (f o) ------------------------------------------------------------------------------ -- | Like 'runOutputMonoid', but right-associates uses of '<>'. diff --git a/src/Polysemy/Reader.hs b/src/Polysemy/Reader.hs index 615f4925..5e5e0fb0 100644 --- a/src/Polysemy/Reader.hs +++ b/src/Polysemy/Reader.hs @@ -21,7 +21,15 @@ import Polysemy.Input ------------------------------------------------------------------------------ --- | An effect corresponding to 'Control.Monad.Trans.Reader.ReaderT'. +-- | The Polysemy port of 'Control.Monad.Trans.Reader.ReaderT'. +-- __Note that this is probably not the effect you are looking for.__ You +-- probably want 'Polysemy.Input.Input' instead, which is like 'Reader' but +-- without 'local'. +-- +-- If you are trying to emulate anything akin to the @ReaderT IO@ pattern, note +-- that it is /not recommended/ in Polysemy. Instead, your experience will be +-- much more joyful if you avoid @IO@ entirely and think deeply about the +-- lawful chunks of your program that can be turned into effects. data Reader i m a where Ask :: Reader i m i Local :: (i -> i) -> m a -> Reader i m a @@ -38,10 +46,8 @@ asks f = f <$> ask -- | Run a 'Reader' effect with a constant value. runReader :: i -> Sem (Reader i ': r) a -> Sem r a runReader i = interpretH $ \case - Ask -> pureT i - Local f m -> do - mm <- runT m - raise $ runReader (f i) mm + Ask -> return i + Local f m -> runReader (f i) (runH' m) {-# INLINE runReader #-} diff --git a/src/Polysemy/Resource.hs b/src/Polysemy/Resource.hs index 4291f94f..cae31b05 100644 --- a/src/Polysemy/Resource.hs +++ b/src/Polysemy/Resource.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NondecreasingIndentation #-} module Polysemy.Resource ( -- * Effect @@ -14,14 +14,13 @@ module Polysemy.Resource -- * Interpretations , runResource , resourceToIOFinal - , resourceToIO - , lowerResource ) where import qualified Control.Exception as X +import Control.Monad import Polysemy import Polysemy.Final - +import Polysemy.Interpretation ------------------------------------------------------------------------------ -- | An effect capable of providing 'X.bracket' semantics. Interpreters for this @@ -111,69 +110,37 @@ resourceToIOFinal :: Member (Final IO) r => Sem (Resource ': r) a -> Sem r a resourceToIOFinal = interpretFinal $ \case - Bracket alloc dealloc use -> do - a <- runS alloc - d <- bindS dealloc - u <- bindS use - pure $ X.bracket a d u - - BracketOnError alloc dealloc use -> do - ins <- getInspectorS - a <- runS alloc - d <- bindS dealloc - u <- bindS use - pure $ - X.bracketOnError - a - d - (\x -> do - result <- u x - case inspect ins result of - Just _ -> pure result - Nothing -> do - _ <- d x - pure result - ) - + Bracket alloc dealloc use -> + controlS' $ \lower -> X.mask $ \restore -> lower $ do + a <- runS alloc + tb <- liftWithS $ \lower' -> + restore (lower' (use a)) + `X.onException` + lower' (dealloc a) + case traverse (const Nothing) tb of + Just tVoid -> do + _ <- runS (dealloc a) + restoreS tVoid + Nothing -> do + b <- restoreS tb + _ <- runS (dealloc a) + return b + + BracketOnError alloc dealloc use -> + controlS' $ \lower -> X.mask $ \restore -> lower $ do + a <- runS alloc + tb <- liftWithS $ \lower' -> + restore (lower' (use a)) + `X.onException` + lower' (dealloc a) + case traverse (const Nothing) tb of + Just tVoid -> do + _ <- runS (dealloc a) + restoreS tVoid + Nothing -> restoreS tb {-# INLINE resourceToIOFinal #-} ------------------------------------------------------------------------------- --- | 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. -- @@ -184,90 +151,27 @@ runResource -> Sem r a runResource = interpretH $ \case Bracket alloc dealloc use -> do - a <- runT alloc - d <- bindT dealloc - u <- bindT use - - let run_it = raise . runResource - resource <- run_it a - result <- run_it $ u resource - _ <- run_it $ d resource - pure result + r <- runH alloc + ta <- runExposeH (use r) + -- If "use" failed locally -- which we determine by inspecting + -- the effectful state -- then we run 'dealloc', discarding any + -- changes it does to the local state. + if null ta then do + _ <- runExposeH (dealloc r) + restoreH ta + else do + -- If "use" succeeded, then the effectful state is restored and dealloc is + -- run as normal. + a <- restoreH ta + _ <- runH (dealloc r) + return a BracketOnError alloc dealloc use -> do - a <- runT alloc - d <- bindT dealloc - u <- bindT use - - let run_it = raise . runResource - - resource <- run_it a - result <- run_it $ u resource - - ins <- getInspectorT - case inspect ins result of - Just _ -> pure result - Nothing -> do - _ <- run_it $ d resource - pure result + r <- runH alloc + ta <- runExposeH (use r) + when (null ta) $ do + _ <- runExposeH (dealloc r) + return () + restoreH ta {-# 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/State.hs b/src/Polysemy/State.hs index e06e0ed9..451e44ce 100644 --- a/src/Polysemy/State.hs +++ b/src/Polysemy/State.hs @@ -28,15 +28,14 @@ module Polysemy.State , 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 Polysemy +import Polysemy.Internal +import Polysemy.Internal.Combinators +import Polysemy.Internal.Union ------------------------------------------------------------------------------ @@ -248,17 +247,14 @@ hoistStateIntoStateT -> S.StateT s (Sem r) a hoistStateIntoStateT (Sem m) = m $ \u -> case decomp u of - Left x -> S.StateT $ \s -> - liftSem . fmap swap - . weave (s, ()) - (\(s', m') -> swap <$> S.runStateT m' s') - (Just . snd) - $ hoist hoistStateIntoStateT x - Right (Weaving Get z _ y _) -> y . (<$ z) <$> S.get - Right (Weaving (Put s) z _ y _) -> y . (<$ z) <$> S.put s + Left x -> + liftHandlerWithNat hoistStateIntoStateT liftSem x + Right (Weaving Get _ lwr ex) -> ex . (<$ mkInitState lwr) <$> S.get + Right (Weaving (Put s) _ lwr ex) -> ex . (<$ mkInitState lwr) <$> S.put s {-# INLINE hoistStateIntoStateT #-} +-- TODO these don't fire anymore, unless `reinterpret` is inlined later {-# RULES "runState/reinterpret" forall s e (f :: forall m x. e m x -> Sem (State s ': r) x). runState s (reinterpret f e) = stateful (\x s' -> runState s' $ f x) s e diff --git a/src/Polysemy/State/Law.hs b/src/Polysemy/State/Law.hs deleted file mode 100644 index 8f8d90dc..00000000 --- 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 index 4273197f..e351241d 100644 --- a/src/Polysemy/Tagged.hs +++ b/src/Polysemy/Tagged.hs @@ -48,8 +48,8 @@ tag => Sem (e ': r) a -> Sem r a tag = hoistSem $ \u -> case decomp u of - Right (Weaving e s wv ex ins) -> - injWeaving $ Weaving (Tagged @k e) s (tag @k . wv) ex ins + Right (Weaving e mkT lwr ex) -> + injWeaving $ Weaving (Tagged @k e) (\n -> mkT (n . tag @k)) lwr ex Left g -> hoist (tag @k) g {-# INLINE tag #-} @@ -62,8 +62,8 @@ tagged -> Sem (Tagged k e ': r) a tagged = hoistSem $ \u -> case decompCoerce u of - Right (Weaving e s wv ex ins) -> - injWeaving $ Weaving (Tagged @k e) s (tagged @k . wv) ex ins + Right (Weaving e mkT lwr ex) -> + injWeaving $ Weaving (Tagged @k e) (\n -> mkT (n . tagged @k)) lwr ex Left g -> hoist (tagged @k) g {-# INLINE tagged #-} @@ -79,8 +79,8 @@ untag -- but doing so probably worsens performance, as it hampers optimizations. -- Once GHC 8.10 rolls out, I will benchmark and compare. untag = hoistSem $ \u -> case decompCoerce u of - Right (Weaving (Tagged e) s wv ex ins) -> - Union Here (Weaving e s (untag . wv) ex ins) + Right (Weaving (Tagged e) mkT lwr ex) -> + Union Here (Weaving e (\n -> mkT (n . untag)) lwr ex) Left g -> hoist untag g {-# INLINE untag #-} @@ -93,8 +93,8 @@ retag => Sem (Tagged k1 e ': r) a -> Sem r a retag = hoistSem $ \u -> case decomp u of - Right (Weaving (Tagged e) s wv ex ins) -> - injWeaving $ Weaving (Tagged @k2 e) s (retag @_ @k2 . wv) ex ins + Right (Weaving (Tagged e) mkT lwr ex) -> + injWeaving $ Weaving (Tagged @k2 e) (\n -> mkT $ n . retag @_ @k2) lwr ex Left g -> hoist (retag @_ @k2) g {-# INLINE retag #-} diff --git a/src/Polysemy/Trace.hs b/src/Polysemy/Trace.hs index e27b603a..a133e002 100644 --- a/src/Polysemy/Trace.hs +++ b/src/Polysemy/Trace.hs @@ -11,7 +11,6 @@ module Polysemy.Trace , traceToHandle , traceToStdout , traceToStderr - , traceToIO , runTraceList , ignoreTrace , traceToOutput @@ -61,16 +60,6 @@ traceToStderr = traceToHandle stderr {-# INLINE traceToStderr #-} ------------------------------------------------------------------------------- --- | Run a 'Trace' effect by printing the messages to stdout. --- --- @since 1.0.0.0 -traceToIO :: Member (Embed IO) r => Sem (Trace ': r) a -> Sem r a -traceToIO = traceToStdout -{-# INLINE traceToIO #-} -{-# deprecated traceToIO "Use traceToStdout" #-} - - ------------------------------------------------------------------------------ -- | Run a 'Trace' effect by ignoring all of its messages. -- diff --git a/src/Polysemy/View.hs b/src/Polysemy/View.hs deleted file mode 100644 index 6e86acc1..00000000 --- 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/src/Polysemy/Writer.hs b/src/Polysemy/Writer.hs index 78f95c2a..5d846250 100644 --- a/src/Polysemy/Writer.hs +++ b/src/Polysemy/Writer.hs @@ -33,6 +33,7 @@ import Data.Semigroup import Polysemy import Polysemy.Output import Polysemy.State +import Polysemy.Interpretation import Polysemy.Internal.Union import Polysemy.Internal.Writer @@ -68,21 +69,21 @@ runWriter -> Sem r (o, a) runWriter = runState mempty . reinterpretH (\case - Tell o -> do - modify' (<> o) >>= pureT + Tell o -> modify' (<> o) Listen m -> do - mm <- runT m - -- TODO(sandy): this is stupid - (o, fa) <- raise $ runWriter mm + -- runExposeH' to prevent local failures from ruining our day + (o, ta) <- runWriter (runExposeH' m) modify' (<> o) - pure $ (o, ) <$> fa + a <- restoreH ta + return (o, a) Pass m -> do - mm <- runT m - (o, t) <- raise $ runWriter mm - ins <- getInspectorT - let f = maybe id fst (inspect ins t) + (o, t) <- runWriter (runExposeH' m) + -- Try to extract the modification function from the t. + -- If "m" failed, default to id. + let f = foldr (const . fst) id t modify' (<> f o) - pure $ snd <$> t + (_, a) <- restoreH t + return a ) {-# INLINE runWriter #-} @@ -100,18 +101,18 @@ runLazyWriter . Monoid o => Sem (Writer o ': r) a -> Sem r (o, a) -runLazyWriter = interpretViaLazyWriter $ \(Weaving e s wv ex ins) -> +runLazyWriter = interpretViaLazyWriter $ \(Weaving e mkT lwr ex) -> case e of - Tell o -> ex s <$ Lazy.tell o + Tell o -> ex (mkInitState lwr) <$ Lazy.tell o Listen m -> do - let m' = wv (m <$ s) + let m' = lwr $ mkT id m ~(fa, o) <- Lazy.listen m' return $ ex $ (,) o <$> fa Pass m -> do - let m' = wv (m <$ s) + let m' = lwr $ mkT id m Lazy.pass $ do ft <- m' - let f = maybe id fst (ins ft) + let f = foldr (const . fst) id ft return (ex $ snd <$> ft, f) {-# INLINE runLazyWriter #-} diff --git a/test/AsyncSpec.hs b/test/AsyncSpec.hs index a70dd2e8..e8902ffa 100644 --- a/test/AsyncSpec.hs +++ b/test/AsyncSpec.hs @@ -8,16 +8,21 @@ import Polysemy import Polysemy.Async import Polysemy.State import Polysemy.Trace +import Polysemy.Output import Test.Hspec +import Data.IORef spec :: Spec spec = describe "async" $ do it "should thread state and not lock" $ do - (ts, (s, r)) <- runM - . runTraceList - . runState "hello" - . asyncToIO $ do + s_ref <- newIORef "hello" + ts_ref <- newIORef [] + r <- runM + . runOutputSem @String (\x -> embed $ modifyIORef ts_ref (x :)) + . traceToOutput + . runStateIORef s_ref + . asyncToIOFinal $ do let message :: Member Trace r => Int -> String -> Sem r () message n msg = trace $ mconcat [ show n, "> ", msg ] @@ -41,6 +46,8 @@ spec = describe "async" $ do embed $ putMVar lock2 () await a1 <* put "final" + s <- readIORef s_ref + ts <- fmap reverse $ readIORef ts_ref ts `shouldContain` ["1> hello", "2> olleh", "1> pong"] s `shouldBe` "final" diff --git a/test/BracketSpec.hs b/test/BracketSpec.hs index b75109d5..74429a7b 100644 --- a/test/BracketSpec.hs +++ b/test/BracketSpec.hs @@ -151,21 +151,10 @@ runTest = pure . 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 + :: Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a -> IO ([String], ([Char], Either () a)) -runTest3 = runFinal - . embedToFinal +runTest3 = runM . outputToIOMonoid (:[]) . traceToOutput . stateToIO "" @@ -185,9 +174,6 @@ testAllThree name k m = do 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 @@ -196,13 +182,10 @@ testAllThree name k m = do testTheIOTwo :: String -> (([String], ([Char], Either () a)) -> Expectation) - -> (Sem '[Error (), Resource, State [Char], Trace, Output String, Embed IO] a) + -> (Sem '[Error (), Resource, State [Char], Trace, Output String, Final IO, Embed IO] a) -> Spec testTheIOTwo name k m = do describe name $ do - it "via resourceToIO" $ do - z <- runTest2 m - k z -- NOTE(sandy): This unsafeCoerces are safe, because we're just weakening -- the end of the union it "via resourceToIOFinal" $ do diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs index cf9de9d8..f8dd5034 100644 --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -28,7 +28,7 @@ spec = parallel $ do it "should happen before Resource" $ do a <- - runM $ resourceToIO $ runError @MyExc $ do + runM $ resourceToIOFinal $ runError @MyExc $ do onException (fromException @MyExc $ do _ <- X.throwIO $ MyExc "hello" diff --git a/test/FinalSpec.hs b/test/FinalSpec.hs index 2249685f..4520c8ff 100644 --- a/test/FinalSpec.hs +++ b/test/FinalSpec.hs @@ -42,7 +42,7 @@ follow (Node _ ref) = embed $ readIORef ref test1 :: IO (Either Int (String, Int, Maybe Int)) test1 = do ref <- newIORef "abra" - runFinal + runM . embedToFinal @IO . runStateIORef ref -- Order of these interpreters don't matter . errorToIOFinal @@ -64,7 +64,7 @@ test1 = do test2 :: IO ([String], Either () ()) test2 = - runFinal + runM . runTraceList . errorToIOFinal . asyncToIOFinal diff --git a/test/FixpointSpec.hs b/test/FixpointSpec.hs index c0e748f9..d497698c 100644 --- a/test/FixpointSpec.hs +++ b/test/FixpointSpec.hs @@ -31,7 +31,7 @@ runFinalState s sm = mfix $ \ ~(s', _) -> test1 :: (String, (Int, ())) test1 = runIdentity - . runFinal + . runM . fixpointToFinal @Identity . runOutputMonoid (show @Int) . runFinalState 1 @@ -45,7 +45,7 @@ test1 = test2 :: Either [Int] [Int] test2 = runIdentity - . runFinal + . runM . fixpointToFinal @Identity . runError $ mdo @@ -55,7 +55,7 @@ test2 = test3 :: Either () (Int, Int) test3 = runIdentity - . runFinal + . runM . fixpointToFinal @Identity . runError . runLazyState @Int 1 @@ -67,7 +67,7 @@ test3 = test4 :: (Int, Either () Int) test4 = runIdentity - . runFinal + . runM . fixpointToFinal @Identity . runLazyState @Int 1 . runError diff --git a/test/FusionSpec.hs b/test/FusionSpec.hs index db396d1f..9d23b4e0 100644 --- a/test/FusionSpec.hs +++ b/test/FusionSpec.hs @@ -15,13 +15,14 @@ module FusionSpec where import qualified Control.Monad.Trans.Except as E import qualified Control.Monad.Trans.State.Strict as S -import Polysemy.Error -import Polysemy.Internal -import Polysemy.Internal.Combinators -import Polysemy.Internal.Union -import Polysemy.State -import Test.Hspec -import Test.Inspection +import Polysemy.Error +import Polysemy.Internal +import Polysemy.Internal.Combinators +import Polysemy.Internal.Interpretation (reinterpret) +import Polysemy.Internal.Union +import Polysemy.State +import Test.Hspec +import Test.Inspection isSuccess :: Result -> Bool diff --git a/test/InspectorSpec.hs b/test/InspectorSpec.hs deleted file mode 100644 index c6df0274..00000000 --- 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 index 0777bc12..00000000 --- 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/OutputSpec.hs b/test/OutputSpec.hs index 0ac72fbf..ffed64d4 100644 --- a/test/OutputSpec.hs +++ b/test/OutputSpec.hs @@ -48,7 +48,7 @@ spec = parallel $ do it "should commit writes of asynced computations" $ let io = do ref <- newIORef "" - runFinal + runM . embedToFinal @IO . asyncToIOFinal . runOutputMonoidIORef ref (show @Int) @@ -62,7 +62,7 @@ spec = parallel $ do it "should commit writes of asynced computations" $ let io = do ref <- newTVarIO "" - runFinal + runM . embedToFinal @IO . asyncToIOFinal . runOutputMonoidTVar ref (show @Int) diff --git a/test/TacticsSpec.hs b/test/TacticsSpec.hs deleted file mode 100644 index 91da8934..00000000 --- a/test/TacticsSpec.hs +++ /dev/null @@ -1,22 +0,0 @@ -module TacticsSpec where - -import Polysemy -import Polysemy.Internal (send) -import Test.Hspec - -data TestE :: Effect where - TestE :: m a -> (a -> m b) -> TestE m b - -interpretTestE :: InterpreterFor TestE r -interpretTestE = - interpretH $ \case - TestE ma f -> do - a <- runTSimple ma - bindTSimple f a - -spec :: Spec -spec = parallel $ describe "runTH and bindTH" $ do - it "should act as expected" $ do - r <- runM (interpretTestE (send (TestE (pure 5) (pure . (9 +))))) - print r - (14 :: Int) `shouldBe` r diff --git a/test/TypeErrors.hs b/test/TypeErrors.hs index 06fcc8d7..24402f84 100644 --- a/test/TypeErrors.hs +++ b/test/TypeErrors.hs @@ -91,7 +91,7 @@ tooFewArgumentsReinterpret = () -- ... -- ... Unhandled effect 'Embed IO' -- ... --- ... Expected... Sem '[Embed m] (Bool, ()) +-- ... Expected... Sem '[Final m, Embed m] (Bool, ()) -- ... Actual... Sem '[] (Bool, ()) -- ... runningTooManyEffects = () diff --git a/test/ViewSpec.hs b/test/ViewSpec.hs deleted file mode 100644 index 61baaecf..00000000 --- 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)) - diff --git a/test/WriterSpec.hs b/test/WriterSpec.hs index a72134c7..a690716f 100644 --- a/test/WriterSpec.hs +++ b/test/WriterSpec.hs @@ -57,7 +57,7 @@ test3 = run . runWriter $ listen (tell "and hear") test4 :: IO (String, String) test4 = do tvar <- newTVarIO "" - (listened, _) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do + (listened, _) <- runM . asyncToIOFinal . runWriterTVar tvar $ do tell "message " listen $ do tell "has been" @@ -70,7 +70,7 @@ test5 :: IO (String, String) test5 = do tvar <- newTVarIO "" lock <- newEmptyMVar - (listened, a) <- runFinal . asyncToIOFinal . runWriterTVar tvar $ do + (listened, a) <- runM . asyncToIOFinal . runWriterTVar tvar $ do tell "message " listen $ do tell "has been" @@ -153,8 +153,8 @@ spec = do it "should commit writes of asyncs spawned inside a listen block even if \ \the block failed for any reason." $ do - Right end1 <- runFinal . errorToIOFinal $ test6 - Right end2 <- runFinal . runError $ test6 + Right end1 <- runM . raiseUnder . errorToIOFinal $ test6 + Right end2 <- runM . raiseUnder . runError $ test6 end1 `shouldBe` "message has been received" end2 `shouldBe` "message has been received"