diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,39 @@ +# Changelog for `in-other-words` + +## 0.2.0.0 (2021-01-30) +### Breaking Changes +* `-Fast` interpretations of every continuation-related effect have been removed due + to lack of usefulness. +* The `ThreadsEff (ContT r) (ReaderPrim i)` instance has been removed due to unlawfulness. +* `Control.Monad.Trans.List.Church` and `Control.Monad.Trans.Free.Church.Alternate` have + received a minor revamp. Notably, the representations of `ListT` and `FreeT` have been + changed to become lawful monad transformers. +* `bracketToIO` now executes the cleanup action of any `generalBracket` + _uninterruptibly masked_. + +### Non-breaking Changes +* Fixed a bug where `listen` when using `listenToIO` would be lifted incorrectly by carriers + based on `FreeT` and `ListT`, which arose due to these not having been lawful + monad transformers. +* All uses of `CompositionC` in the library has been changed to proper newtypes. + This should improve the quality of error messages as well as compilation times. +* Added `bracketToIOUnsafe`, which has the previous semantics of `bracketToIO` + -- that is, the cleanup action of each `generalBracket` is only executed + _interruptibly masked_. +* `Control.Efffect.Newtype` now exports the constructors of `WrapperOf`, thus + addressing an issue where users wouldn't be allowed to derive via `WrapperOf`. +* `Control.Efffect.Carrier` now exports the constructors of `IdentityT`, thus + addressing an issue where users wouldn't be allowed to derive via `IdentityT`. +* Fixed an issue where `FailC` lacked a `MonadFail` instance. +* Added `errorToIOAsExc` and `errorToErrorIOAsExc` (thanks @poscat0x04!) + + +## 0.1.1.0 (2020-10-30) +### Non-breaking Changes +* Added `runTellAction` and `ignoreTell` interpreters. +* Added `runEmbed` interpreter +* Fixed an issue with `runShift` where HO-actions applied on a `shift` could affect the continuation provided to the argument of `shift`. + + +## 0.1.0.0 (2020-10-10) +Initial release. diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 --- a/ChangeLog.md +++ /dev/null @@ -1,9 +0,0 @@ -# Changelog for `in-other-words` - -## 0.1.1.0 (2020-10-30) -* Added `runTellAction` and `ignoreTell` interpreters. -* Added `runEmbed` interpreter -* Fixed an issue with `runShift` where HO-actions applied on a `shift` could affect the continuation provided to the argument of `shift`. - -## 0.1.0.0 (2020-10-10) -Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -162,7 +162,7 @@ -- one by one. -- Throw an exception if we go through all the inputs without completing the -- challenge. - $ runAskActionSimple (do + $ runAskActionSimple @String (do get >>= \case [] -> throw "Inputs exhausted!" (x:xs) -> put xs >> return x diff --git a/in-other-words.cabal b/in-other-words.cabal --- a/in-other-words.cabal +++ b/in-other-words.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 9c937a4927f283035de5f46009187006236169a826b849566821564b47613a53 +-- hash: 94e61819ea6e924b216d8fa7fe755ab80100afa6a3ebf73d3da409a983481ce9 name: in-other-words -version: 0.1.1.0 +version: 0.2.0.0 synopsis: A higher-order effect system where the sky's the limit description: A low-boilerplate effect system with easy higher-order effects and very high expressive power category: Control @@ -20,7 +20,7 @@ build-type: Simple extra-source-files: README.md - ChangeLog.md + CHANGELOG.md library exposed-modules: @@ -47,10 +47,13 @@ Control.Effect.Intercept Control.Effect.Internal Control.Effect.Internal.BaseControl + Control.Effect.Internal.Conc Control.Effect.Internal.Cont Control.Effect.Internal.Derive Control.Effect.Internal.Effly Control.Effect.Internal.Error + Control.Effect.Internal.ErrorIO + Control.Effect.Internal.Exceptional Control.Effect.Internal.Intercept Control.Effect.Internal.Itself Control.Effect.Internal.KnownList @@ -61,6 +64,7 @@ Control.Effect.Internal.Reader Control.Effect.Internal.Reflection Control.Effect.Internal.Regional + Control.Effect.Internal.Select Control.Effect.Internal.State Control.Effect.Internal.Union Control.Effect.Internal.Unlift @@ -106,7 +110,7 @@ hs-source-dirs: src default-extensions: BangPatterns ConstraintKinds DataKinds DerivingStrategies EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase PolyKinds QuantifiedConstraints RankNTypes ScopedTypeVariables StandaloneDeriving TypeApplications TypeOperators TypeFamilies UndecidableInstances - ghc-options: -Wall + ghc-options: -Wall -haddock build-depends: async >=2.2 && <2.3 , base >=4.7 && <5 diff --git a/src/Control/Effect/Alt.hs b/src/Control/Effect/Alt.hs --- a/src/Control/Effect/Alt.hs +++ b/src/Control/Effect/Alt.hs @@ -44,7 +44,6 @@ import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Intro import Control.Monad.Trans.Except -import Control.Monad.Trans.Identity -- | Like InterpretC specialized to interpret 'Alt', but has 'Alternative' and -- 'MonadPlus' instances based on the interpreted 'Alt'. @@ -103,13 +102,34 @@ Alt ma mb -> ma `catch` \() -> mb {-# INLINEABLE effHandler #-} -type AltMaybeC = CompositionC - '[ IntroUnderC Alt '[Catch (), Throw ()] - , InterpretAltC AltToErrorUnitH - , ErrorC () - ] +newtype AltMaybeC m a = AltMaybeC { + unAltMaybeC :: + IntroUnderC Alt '[Catch (), Throw ()] + ( InterpretAltC AltToErrorUnitH + ( ErrorC () + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroUnderC Alt '[Catch (), Throw ()] + , InterpretAltC AltToErrorUnitH + , ErrorC () + ] +deriving newtype instance (Carrier m, Threads (ExceptT ()) (Prims m)) + => Alternative (AltMaybeC m) +deriving newtype instance (Carrier m, Threads (ExceptT ()) (Prims m)) + => MonadPlus (AltMaybeC m) + +deriving newtype instance (Carrier m, Threads (ExceptT ()) (Prims m)) + => Carrier (AltMaybeC m) + -- | Run an 'Alt' effect purely, returning @Nothing@ on an unhandled -- 'empty'. -- @@ -131,7 +151,7 @@ .# interpretViaHandler .# unInterpretAltC .# introUnder - .# runComposition + .# unAltMaybeC {-# INLINE runAltMaybe #-} -- | Transform an 'Alt' effect into 'Error' by describing it in @@ -144,7 +164,7 @@ -- For example: -- -- @ --- 'altToError' ('throw' exc) 'empty' = 'throw' exc +-- 'altToError' exc 'empty' = 'throw' exc -- @ -- -- 'altToError' has a higher-rank type, as it makes use of 'InterpretAltReifiedC'. diff --git a/src/Control/Effect/AtomicState.hs b/src/Control/Effect/AtomicState.hs --- a/src/Control/Effect/AtomicState.hs +++ b/src/Control/Effect/AtomicState.hs @@ -46,7 +46,7 @@ Box a <- atomicModifyIORef ref $ \s -> let !(s', a) = f s in (s', Box a) return a {-# INLINE atomicModifyIORefP #-} -# endif +#endif -- | An effect for atomically reading and modifying a piece of state. -- diff --git a/src/Control/Effect/BaseControl.hs b/src/Control/Effect/BaseControl.hs --- a/src/Control/Effect/BaseControl.hs +++ b/src/Control/Effect/BaseControl.hs @@ -43,7 +43,6 @@ import Control.Effect.Internal.Utils -import Control.Monad.Trans.Identity import Control.Monad.Trans.Control import GHC.Exts (Proxy#, proxy#) @@ -105,9 +104,9 @@ -- WithFile :: FilePath -> IOMode -> (Handle -> m a) -> WithFile m a -- -- runWithFile :: 'Eff' ('BaseControl' IO) m => 'SimpleInterpreterFor' WithFile m --- runWithFile = 'interpretSimple' $ \case --- WithFile fp mode c -> 'gainBaseControl' $ 'control' $ \lower -> --- SysIO.withFile fp mode (\hdl -> lower (lift (c hdl))) +-- runWithFile = 'interpretSimple' $ \\case +-- WithFile fp mode c -> 'gainBaseControl' $ 'control' $ \\lower -> +-- SysIO.withFile fp mode (\\hdl -> lower (lift (c hdl))) -- @ -- gainBaseControl diff --git a/src/Control/Effect/Bracket.hs b/src/Control/Effect/Bracket.hs --- a/src/Control/Effect/Bracket.hs +++ b/src/Control/Effect/Bracket.hs @@ -13,6 +13,7 @@ -- * Interpretations , bracketToIO + , bracketToIOUnsafe , runBracketLocally @@ -26,6 +27,7 @@ -- * Carriers , BracketToIOC + , BracketToIOUnsafeC , BracketLocallyC , IgnoreBracketC ) where @@ -93,7 +95,9 @@ instance (Carrier m, MonadMask m) => PrimHandler BracketToIOH Bracket m where effPrimHandler (GeneralBracket acquire release use) = - C.generalBracket acquire release use + C.generalBracket acquire + (\a ec -> C.uninterruptibleMask_ (release a ec)) + use {-# INLINEABLE effPrimHandler #-} type BracketToIOC = InterpretPrimC BracketToIOH Bracket @@ -103,6 +107,11 @@ -- any abortive computation of any effect, as well -- as any IO exceptions and asynchronous exceptions. -- +-- Any 'generalBracket' will have its cleanup action be executed +-- /uninterruptibly masked/. +-- This means that the cleanup action /cannot/, under any circumstance, +-- be interrupted by asynchronous exceptions. +-- -- @'Derivs' ('BracketToIOC' m) = 'Bracket' ': 'Derivs' m@ -- -- @'Prims' ('BracketToIOC' m) = 'Bracket' ': 'Prims' m@ @@ -111,6 +120,38 @@ -> m a bracketToIO = interpretPrimViaHandler {-# INLINE bracketToIO #-} + +data BracketToIOUnsafeH + +instance (Carrier m, MonadMask m) + => PrimHandler BracketToIOUnsafeH Bracket m where + effPrimHandler (GeneralBracket acquire release use) = + C.generalBracket acquire release use + {-# INLINEABLE effPrimHandler #-} + +type BracketToIOUnsafeC = InterpretPrimC BracketToIOUnsafeH Bracket + +-- | Run a 'Bracket' by effect that protects against +-- any abortive computation of any effect, as well +-- as any IO exceptions and asynchronous exceptions. +-- +-- Any 'generalBracket' will have its cleanup action +-- be executed /interruptibly masked/. +-- This means that the cleanup action /can/ be interrupted by +-- asynchronous exceptions if the cleanup action executes +-- interruptible (blocking) operations, +-- such as 'Control.Concurrent.MVar.putMVar'. +-- +-- @'Derivs' ('BracketToIOUnsafeC' m) = 'Bracket' ': 'Derivs' m@ +-- +-- @'Prims' ('BracketToIOUnsafeC' m) = 'Bracket' ': 'Prims' m@ +-- +-- @since 0.2.0.0 +bracketToIOUnsafe :: (Carrier m, MonadMask m) + => BracketToIOUnsafeC m a + -> m a +bracketToIOUnsafe = interpretPrimViaHandler +{-# INLINE bracketToIOUnsafe #-} data BracketLocallyH diff --git a/src/Control/Effect/Carrier/Internal/Compose.hs b/src/Control/Effect/Carrier/Internal/Compose.hs --- a/src/Control/Effect/Carrier/Internal/Compose.hs +++ b/src/Control/Effect/Carrier/Internal/Compose.hs @@ -113,6 +113,28 @@ DERIVE_COMP_T(MonadTrans) DERIVE_COMP_T(MonadTransControl) +-- KingoftheHomeless: Why a left fold? Consider: +-- +-- CompositionBaseT [t, u, v] m a +-- = ComposeT (ComposeT (ComposeT IdentityT t) u) v m a +-- ~ ComposeT (ComposeT IdentityT t) u (v m) a +-- ~ ComposeT IdentityT t (u (v m)) a +-- ~ IdentityT (t (u (v m))) a +-- ~ t (u (v m)) a +-- +-- Where "~" is representational equality. +-- +-- In contrast, imagine if CompositionBaseT were a right fold, instead. Then we'd get: +-- +-- CompositionBaseT [t, u, v] m a +-- = ComposeT t (ComposeT u (ComposeT v IdentityT)) m a +-- ~ t (ComposeT u (ComposeT v IdentityT) m) a +-- +-- ... and we can't reduce this further. Why? Because t,u,v may not be representational in the monads they're transforming! +-- This matters! In fact, this library even makes use of monad transformers that aren't representational in the monad, +-- such as InterpretSimpleC. +-- +-- So only with a left fold can we guarantee that the unsafeCoerce in runComposition is safe. type family CompositionBaseT' acc ts :: (* -> *) -> * -> * where CompositionBaseT' acc '[] = acc CompositionBaseT' acc (t ': ts) = CompositionBaseT' (ComposeT acc t) ts diff --git a/src/Control/Effect/Carrier/Internal/Interpret.hs b/src/Control/Effect/Carrier/Internal/Interpret.hs --- a/src/Control/Effect/Carrier/Internal/Interpret.hs +++ b/src/Control/Effect/Carrier/Internal/Interpret.hs @@ -405,7 +405,7 @@ -- echo = readTTY >>= sendTTY -- -- teletypeToIO :: 'Eff' ('Control.Effect.Embed' IO) m => 'Control.Effect.InterpreterFor' Teletype m --- teletypeToIO = 'interpret' $ \case +-- teletypeToIO = 'interpret' $ \\case -- ReadTTY -> 'Control.Effect.embed' getLine -- WriteTTY str -> 'Control.Effect.embed' $ putStrLn str -- @@ -458,7 +458,7 @@ -- echo = readTTY >>= sendTTY -- -- teletypeToIO :: 'Eff' ('Control.Effect.Embed' IO) m => 'Control.Effect.SimpleInterpreterFor' Teletype m --- teletypeToIO = 'interpretSimple' $ \case +-- teletypeToIO = 'interpretSimple' $ \\case -- ReadTTY -> 'Control.Effect.embed' getLine -- WriteTTY str -> 'Control.Effect.embed' $ putStrLn str -- @@ -511,7 +511,7 @@ -- -- instance 'Eff' ('Control.Effect.Embed' IO) m -- => 'Handler' TeletypeToIOH Teletype m where --- effHandler = \case +-- effHandler = \\case -- ReadTTY -> 'Control.Effect.embed' getLine -- WriteTTY str -> 'Control.Effect.embed' $ putStrLn str -- diff --git a/src/Control/Effect/Carrier/Internal/Intro.hs b/src/Control/Effect/Carrier/Internal/Intro.hs --- a/src/Control/Effect/Carrier/Internal/Intro.hs +++ b/src/Control/Effect/Carrier/Internal/Intro.hs @@ -15,7 +15,6 @@ import Control.Effect.Internal.Union import Control.Effect.Internal.Utils import Control.Effect.Internal.KnownList -import Control.Monad.Trans.Identity newtype IntroC (top :: [Effect]) (new :: [Effect]) diff --git a/src/Control/Effect/Conc.hs b/src/Control/Effect/Conc.hs --- a/src/Control/Effect/Conc.hs +++ b/src/Control/Effect/Conc.hs @@ -83,6 +83,7 @@ import qualified Control.Concurrent.Async as A import Control.Effect +import Control.Effect.Internal.Conc import Control.Effect.Unlift import Control.Exception (SomeException, Exception) @@ -90,37 +91,23 @@ -- For coercion purposes import Control.Effect.Internal.Utils -import Control.Monad.Trans.Identity -import Control.Effect.Carrier.Internal.Compose import Control.Effect.Carrier.Internal.Interpret --- | An effect for concurrent execution. -newtype Conc m a = Conc (Unlift IO m a) - deriving EffNewtype via Conc `WrapperOf` Unlift IO -unliftConc :: Eff Conc m => ((forall x. m x -> IO x) -> IO a) -> m a -unliftConc main = wrapWith Conc $ unlift (\lower -> main (lower .# lift)) -{-# INLINE unliftConc #-} - -type ConcToIOC = CompositionC - '[ UnwrapTopC Conc - , UnliftToFinalC IO - ] - type ConcToUnliftIOC = UnwrapC Conc -- | Run a 'Conc' effect if __all__ effects used in the program -- -- past and future -- are eventually reduced to operations on 'IO'. -- -- Due to its very restrictive primitive effect and carrier constraint, --- `concToIO` can't be used together with most pure interpreters. +-- 'concToIO' can't be used together with most pure interpreters. -- For example, instead of 'Control.Effect.Error.runError', you must use -- 'Control.Effect.Error.errorToIO'. -- -- This poses a problem if you want to use some effect that /doesn't have/ -- an interpreter compatible with 'concToIO' -- like -- 'Control.Effect.NonDet.NonDet'. --- In that case, you might sitll be able to use both effects in the same program +-- In that case, you might still be able to use both effects in the same program -- by applying -- [Split Interpretation](https://github.com/KingoftheHomeless/in-other-words/wiki/Advanced-Topics#split-interpretation) -- to seperate their uses. @@ -137,7 +124,7 @@ concToIO = unliftToFinal .# unwrapTop - .# runComposition + .# unConcToIOC {-# INLINE concToIO #-} -- | Transform a 'Conc' effect into @'Unlift' IO@. diff --git a/src/Control/Effect/Cont.hs b/src/Control/Effect/Cont.hs --- a/src/Control/Effect/Cont.hs +++ b/src/Control/Effect/Cont.hs @@ -9,22 +9,17 @@ -- * Interpretations , runCont - , runContFast , runShift - , runShiftFast , contToShift -- * Threading constraints , ContThreads - , ContFastThreads -- * Carriers , ContC - , ContFastC , ShiftC - , ShiftFastC , ContToShiftC ) where @@ -35,7 +30,6 @@ import Control.Effect.Internal.Utils -import qualified Control.Monad.Trans.Cont as C import Control.Monad.Trans.Free.Church.Alternate -- | Call with current continuation. The argument computation is provided @@ -101,26 +95,6 @@ .# unContC {-# INLINE runCont #-} --- | Run a 'Cont' effect. --- --- Compared to 'runCont', this is quite a bit faster, but is significantly more --- restrictive in what interpreters are used after it, since there are very --- few primitive effects that the carrier for 'runContFast' is able to thread. --- In fact, of all the primitive effects provided by this library, only --- one satisfies 'ContFastThreads': namely, --- 'Control.Effect.Type.ReaderPrim.ReaderPrim'. --- --- @'Derivs' ('ContFastC' r m) = 'Cont' ': 'Derivs' m@ --- --- @'Control.Effect.Primitive.Prims' ('ContFastC' r m) = 'Control.Effect.Primitive.Prims' m@ -runContFast :: forall a m p - . ( Carrier m - , Threaders '[ContFastThreads] m p - ) - => ContFastC a m a -> m a -runContFast = C.evalContT .# unContFastC -{-# INLINE runContFast #-} - -- | Run a @'Shift' r@ effect if the program returns @r@. -- -- @'Derivs' ('ShiftC' r m) = 'Shift' r ': 'Derivs' m@ @@ -134,25 +108,6 @@ runShift = coerce (runCont @r @m @p) {-# INLINE runShift #-} --- | Run a @'Shift' r@ effect if the program returns @r@. --- --- Compared to 'runShift', this is quite a bit faster, but is significantly more --- restrictive in what interpreters are used after it, since there are very --- few primitive effects that the carrier for 'runContFast' is able to thread. --- In fact, of all the primitive effects provided by this library, only --- one satisfies 'ContFastThreads': namely, --- 'Control.Effect.Type.ReaderPrim.ReaderPrim'. --- --- @'Derivs' ('ShiftFastC' r m) = 'Shift' r ': 'Derivs' m@ --- --- @'Control.Effect.Primitive.Prims' ('ShiftFastC' r m) = 'Control.Effect.Primitive.Prims' m@ -runShiftFast :: forall r m p - . ( Carrier m - , Threaders '[ContFastThreads] m p - ) - => ShiftFastC r m r -> m r -runShiftFast = C.evalContT .# unShiftFastC -{-# INLINE runShiftFast #-} data ContToShiftH r diff --git a/src/Control/Effect/Embed.hs b/src/Control/Effect/Embed.hs --- a/src/Control/Effect/Embed.hs +++ b/src/Control/Effect/Embed.hs @@ -86,6 +86,8 @@ -- @'Derivs' ('EmbedC' m) = 'Embed' m ': 'Derivs' m@ -- -- @'Prims' ('EmbedC' m) = 'Prims' m@ +-- +-- @since 0.1.1.0 runEmbed :: Carrier m => EmbedC m a -> m a runEmbed = unEmbedC {-# INLINE runEmbed #-} @@ -98,7 +100,7 @@ {-# INLINEABLE algPrims #-} reformulate n alg = powerAlg (reformulate (n .# EmbedC) alg) (n .# EmbedC .# unEmbed) - {-# INLINE reformulate #-} + {-# INLINEABLE reformulate #-} algDerivs = powerAlg (coerce (algDerivs @m)) (EmbedC .# unEmbed) {-# INLINEABLE algDerivs #-} diff --git a/src/Control/Effect/Error.hs b/src/Control/Effect/Error.hs --- a/src/Control/Effect/Error.hs +++ b/src/Control/Effect/Error.hs @@ -21,9 +21,13 @@ , errorToIO + , errorToIOAsExc + -- * Other interpreters , errorToErrorIO + , errorToErrorIOAsExc + , throwToThrow , catchToError , errorToError @@ -58,26 +62,18 @@ import Data.Coerce import Control.Effect -import Control.Effect.ErrorIO import Control.Effect.Type.Throw import Control.Effect.Type.Catch import Control.Effect.Internal.Error -import qualified Control.Exception as X import qualified Control.Monad.Catch as C -- For coercion purposes -import Control.Effect.Internal.Utils import Control.Monad.Trans.Except import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Intro -import Control.Effect.Carrier.Internal.Compose -import Control.Monad.Trans.Identity +import Control.Effect.Internal.Utils --- For errorToIO -import Data.Unique -import GHC.Exts (Any) -import Unsafe.Coerce throw :: Eff (Throw e) m => e -> m a throw = send . Throw @@ -189,22 +185,8 @@ Catch m h -> m &(catchJust from)$ h {-# INLINE catchToError #-} -type ReifiesErrorHandler s s' e m = - ( ReifiesHandler s (Catch e) (InterpretC (ViaReifiedH s') (Throw e) m) - , ReifiesHandler s' (Throw e) m - ) -type InterpretErrorC' s s' smallExc = CompositionC - '[ InterpretC (ViaReifiedH s) (Catch smallExc) - , InterpretC (ViaReifiedH s') (Throw smallExc) - ] -type InterpretErrorC e m a = - forall s s' - . ReifiesErrorHandler s s' e m - => InterpretErrorC' s s' e m a - - -- | Transforms connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- -- into another 'Error' effect by providing functions to convert -- between the two types of exceptions. @@ -230,120 +212,10 @@ Catch m h -> m `catch` \e -> case from e of Just e' -> h e' Nothing -> intro1 $ throw e - $ runComposition + $ unInterpretErrorC' $ m0 {-# INLINE errorToError #-} --- KingoftheHomeless: We could skip having to use 'OpaqueExc' --- by requiring the exception type @e@ to be typeable. Or have it be --- an instance of 'Exception'. --- --- I choose not to for two reasons: --- 1. By making use of OpaqueExc and checking unique references, --- we guarantee that exceptions belonging to an @'Error' e@ effect --- interpreted with 'errorToErrorIO' won't get caught by 'catch'es --- belonging to /another/, identical @'Error' e@ effect interpreted --- using 'errorToErrorIO'. So by using OpaqueExc, we get coherency. --- --- 2. In case we eventually implement a system for polymorphic effect --- interpreters inside of application code, like something like this: --- @ --- manageError :: HasErrorInterpreter s m --- => ProvidedErrorInterpreterC s e m a --- -> m (Either e a) --- @ --- of which 'errorToErrorIO' should be a valid implementation, then --- we shouldn't place any constraints upon @e@. -data OpaqueExc = OpaqueExc Unique Any - -instance Show OpaqueExc where - showsPrec _ (OpaqueExc uniq _) = - showString "errorToIO/errorToErrorIO: Escaped opaque exception. \ - \Unique hash is: " . shows (hashUnique uniq) . showString ". \ - \This should only happen if the computation that threw the \ - \exception was somehow invoked outside of the argument of \ - \'errorToIO'; for example, if you 'async' an exceptional \ - \computation inside of the argument provided to 'errorToIO', \ - \and then 'await' on it *outside* of the argument provided to \ - \'errorToIO'. \ - \If that or any similar shenanigans seems unlikely, then \ - \please open an issue on the GitHub repository." - -instance X.Exception OpaqueExc - - --- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- --- by transforming them into 'ErrorIO' and @'Embed' IO@ --- --- This has a higher-rank type, as it makes use of 'InterpretErrorC'. --- __This makes 'errorToErrorIO' very difficult to use partially applied.__ --- __In particular, it can't be composed using @'.'@.__ --- --- If performance is secondary, consider using the slower --- 'throwToThrowSimple', which doesn't have a higher-rank type. -errorToErrorIO :: forall e m a - . Effs '[ErrorIO, Embed IO] m - => InterpretErrorC e m a - -> m (Either e a) -errorToErrorIO main = do - !uniq <- embed newUnique - let - main' = - interpret \case - Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e)) - $ interpret \case - Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) -> - if uniq == uniq' then - h (unsafeCoerce e) - else - throwIO exc - $ runComposition - $ main - fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) -> - if uniq == uniq' then - return $ Left (unsafeCoerce e) - else - throwIO exc - -type ErrorToIOC' s s' e = CompositionC - '[ IntroC '[Catch e, Throw e] '[ErrorIO] - , InterpretErrorC' s s' e - , ErrorIOToIOC - ] - -type ErrorToIOC e m a = - forall s s' - . ReifiesErrorHandler s s' e (ErrorIOToIOC m) - => ErrorToIOC' s s' e m a - --- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- --- by making use of 'IO' exceptions. --- --- @'Derivs' ('ErrorToIOC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@ --- --- @'Control.Effect.Primitive.Prims' ('ErrorToIOC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@ --- --- This has a higher-rank type, as it makes use of 'ErrorToIOC'. --- __This makes 'errorToIO' very difficult to use partially applied.__ --- __In particular, it can't be composed using @'.'@.__ --- --- If performance is secondary, consider using the slower --- 'errorToIOSimple', which doesn't have a higher-rank type. -errorToIO :: forall e m a - . ( C.MonadCatch m - , Eff (Embed IO) m - ) - => ErrorToIOC e m a - -> m (Either e a) -errorToIO m = - errorIOToIO - $ errorToErrorIO - $ introUnderMany - $ runComposition - $ m -{-# INLINE errorToIO #-} - - -- | Transforms a @'Throw' smallExc@ effect into a @'Throw' bigExc@ effect, -- by providing a function to convert exceptions of the smaller exception type -- @smallExc@ to the larger exception type @bigExc@. @@ -378,12 +250,6 @@ Catch m h -> catchJust from m h {-# INLINE catchToErrorSimple #-} - -type InterpretErrorSimpleC e = CompositionC - '[ InterpretSimpleC (Catch e) - , InterpretSimpleC (Throw e) - ] - -- | Transforms connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- -- into another 'Error' effect by providing functions to convert -- between the two types of exceptions. @@ -402,67 +268,5 @@ throwToThrowSimple to . interpretSimple \case Catch m h -> intro1 $ catchJust from (lift m) (lift #. h) - .# runComposition + .# unInterpretErrorSimpleC {-# INLINE errorToErrorSimple #-} - - -type ErrorToIOSimpleC e = CompositionC - '[ IntroC '[Catch e, Throw e] '[ErrorIO] - , InterpretErrorSimpleC e - , ErrorIOToIOC - ] - - --- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- --- by transforming them into 'ErrorIO' and @'Embed' IO@ --- --- This is a less performant version of 'errorToErrorIO' that doesn't have --- a higher-rank type, making it much easier to use partially applied. -errorToErrorIOSimple :: forall e m a p - . ( Effs '[ErrorIO, Embed IO] m - , Threaders '[ReaderThreads] m p - ) - => InterpretErrorSimpleC e m a - -> m (Either e a) -errorToErrorIOSimple main = do - !uniq <- embed newUnique - let - main' = - interpretSimple \case - Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e)) - $ interpretSimple \case - Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) -> - if uniq == uniq' then - h (unsafeCoerce e) - else - throwIO exc - $ runComposition - $ main - fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) -> - if uniq == uniq' then - return $ Left (unsafeCoerce e) - else - throwIO exc - --- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- --- by making use of 'IO' exceptions. --- --- @'Derivs' ('ErrorToIOSimpleC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@ --- --- @'Control.Effect.Primitive.Prims' ('ErrorToIOSimpleC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@ --- --- This is a less performant version of 'errorToIO' that doesn't have --- a higher-rank type, making it much easier to use partially applied. -errorToIOSimple :: forall e m a p - . ( Eff (Embed IO) m - , MonadCatch m - , Threaders '[ReaderThreads] m p - ) - => ErrorToIOSimpleC e m a - -> m (Either e a) -errorToIOSimple = - errorIOToIO - #. errorToErrorIOSimple - .# introUnderMany - .# runComposition -{-# INLINE errorToIOSimple #-} diff --git a/src/Control/Effect/ErrorIO.hs b/src/Control/Effect/ErrorIO.hs --- a/src/Control/Effect/ErrorIO.hs +++ b/src/Control/Effect/ErrorIO.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} module Control.Effect.ErrorIO ( -- * Effects ErrorIO(..) @@ -21,59 +22,25 @@ , ErrorIOToErrorC ) where -import Control.Monad - import Control.Effect -import Control.Effect.Optional import Control.Effect.Type.ErrorIO import Control.Effect.Type.Throw import Control.Effect.Type.Catch +import Control.Effect.Internal.ErrorIO + import Control.Exception (SomeException) import qualified Control.Exception as X import qualified Control.Monad.Catch as C --- For coercion purposes -import Control.Monad.Trans.Identity -import Control.Effect.Carrier.Internal.Intro -import Control.Effect.Carrier.Internal.Compose -import Control.Effect.Carrier.Internal.Interpret -import Control.Effect.Internal.Utils - throwIO :: (X.Exception e, Eff ErrorIO m) => e -> m a throwIO = send . ThrowIO catchIO :: (X.Exception e, Eff ErrorIO m) => m a -> (e -> m a) -> m a catchIO m h = send (CatchIO m h) -data ErrorIOFinalH - data ErrorIOToErrorH -instance ( C.MonadThrow m - , Eff (Optional ((->) SomeException)) m - ) - => Handler ErrorIOFinalH ErrorIO m where - effHandler = \case - ThrowIO x -> liftBase $ C.throwM x - CatchIO m h -> join $ - optionally - (\x -> case X.fromException x of - Just e -> h e - Nothing -> liftBase $ C.throwM x - ) - (fmap pure m) - {-# INLINEABLE effHandler #-} - -instance ( C.MonadCatch m - , Carrier m - ) - => PrimHandler ErrorIOFinalH (Optional ((->) SomeException)) m where - effPrimHandler = \case - Optionally h m -> m `C.catch` (return . h) - {-# INLINEABLE effPrimHandler #-} - - instance ( Eff (Error SomeException) m , Carrier m ) @@ -86,12 +53,6 @@ {-# INLINEABLE effHandler #-} -type ErrorIOToIOC = CompositionC - '[ ReinterpretC ErrorIOFinalH ErrorIO - '[Optional ((->) SomeException)] - , InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException)) - ] - type ErrorIOToErrorC = InterpretC ErrorIOToErrorH ErrorIO -- | Transform an @'ErrorIO'@ effect into an @'Error' 'SomeException'@ @@ -101,17 +62,3 @@ -> m a errorIOToError = interpretViaHandler {-# INLINE errorIOToError #-} - --- | Run an @'ErrorIO'@ effect by making use of 'IO' exceptions. --- --- @'Derivs' (ErrorIOToIOC e m) = 'ErrorIO' ': 'Derivs' m@ --- --- @'Control.Effect.Carrier.Prims' (ErrorIOToIOC e m) = 'Control.Effect.Optional.Optional' ((->) 'SomeException') ': 'Control.Effect.Carrier.Prims' m@ -errorIOToIO :: (Carrier m, C.MonadCatch m) - => ErrorIOToIOC m a - -> m a -errorIOToIO = - interpretPrimViaHandler - .# reinterpretViaHandler - .# runComposition -{-# INLINE errorIOToIO #-} diff --git a/src/Control/Effect/Exceptional.hs b/src/Control/Effect/Exceptional.hs --- a/src/Control/Effect/Exceptional.hs +++ b/src/Control/Effect/Exceptional.hs @@ -51,9 +51,6 @@ , SafeErrorToErrorIOSimpleC ) where -import Data.Coerce -import Data.Either - import Control.Effect import Control.Effect.Error import Control.Effect.ErrorIO @@ -61,108 +58,15 @@ import Control.Effect.Carrier +import Control.Effect.Internal.Exceptional import Control.Effect.Internal.Utils -import Control.Monad.Trans.Identity -- For coercion purposes import Control.Monad.Trans.Except import Control.Effect.Internal.Error import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Intro -import Control.Effect.Carrier.Internal.Compose - --- | An effect that allows for the safe use of an effect @eff@ that may --- throw exceptions of the type @exc@ by forcing the user to eventually --- catch those exceptions at some point of the program. --- --- The main combinator of 'Exceptional' is 'catching'. --- --- __This could be unsafe in the presence of 'Control.Effect.Conc.Conc'__. --- If you use 'catching' on a computation that: --- --- * Spawns an asynchronous computation --- * Throws an exception inside the asynchronous computation from a use of @eff@ --- * Returns the 'Control.Effect.Conc.Async' of that asynchronous computation --- --- Then 'Control.Effect.Conc.wait'ing on that 'Control.Effect.Conc.Async' --- outside of the 'catching' will throw that exception without it being caught. -newtype Exceptional eff exc m a = Exceptional (Union '[eff, Catch exc] m a) - --- | A particularly useful specialization of 'Exceptional', for gaining --- restricted access to an @'Error' exc@ effect. --- Main combinators are 'catchSafe' and 'trySafe'. -type SafeError exc = Exceptional (Throw exc) exc - -{- -"ExceptionallyC" can easily be implemented using Handler: - -data ExceptionallyH exc - -instance ( Eff (Exceptional eff exc) m - , RepresentationalEff eff - ) - => Handler (ExceptionallH exc) eff m where where - effHandler e = send $ Exceptionally $ inj e - -type ExceptionallyC eff exc = InterpretC (ExceptionallH exc) eff - -catching :: forall eff exc m a - . ( Eff (Exceptional eff exc) m - , RepresentationalEff eff - ) - => ExceptionallyC exc eff m a - -> (exc -> m a) - -> m a -catching m h = - send $ Exceptional @eff @exc $ - inj (Catch @exc (interpretViaHandler m) h) - -We use a standalone carrier to hide the RepresentationalEff constraint, -which is just noise in this case. --} - -newtype ExceptionallyC (eff :: Effect) (exc :: *) m a = ExceptionallyC { - unExceptionallyC :: m a - } - deriving ( Functor, Applicative, Monad - , Alternative, MonadPlus - , MonadFix, MonadFail, MonadIO - , MonadThrow, MonadCatch, MonadMask - , MonadBase b, MonadBaseControl b - ) - deriving (MonadTrans, MonadTransControl) via IdentityT - -instance Eff (Exceptional eff exc) m - => Carrier (ExceptionallyC eff exc m) where - type Derivs (ExceptionallyC eff exc m) = eff ': Catch exc ': Derivs m - type Prims (ExceptionallyC eff exc m) = Prims m - - algPrims = coerce (algPrims @m) - {-# INLINEABLE algPrims #-} - - reformulate n alg = - powerAlg' ( - powerAlg ( - reformulate (n .# lift) alg - ) $ \e -> - reformulate (n .# lift) alg $ inj $ - Exceptional @eff @exc (Union (There Here) e) - ) $ \e -> - reformulate (n .# lift) alg $ inj $ - Exceptional @eff @exc (Union Here e) - {-# INLINEABLE reformulate #-} - - algDerivs = - powerAlg' ( - powerAlg ( - coerce (algDerivs @m) - ) $ \e -> - coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union (There Here) e) - ) $ \e -> - coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union Here e) - {-# INLINEABLE algDerivs #-} - -- | Gain access to @eff@ and @'Catch' exc@ within a region, -- but only if you're ready to handle any unhandled exception @e :: exc@ -- that may arise from the use of @eff@ within that region. @@ -179,9 +83,17 @@ -- -- caringProgram :: 'Eff' ('Exceptional' SomeEffect SomeEffectExc) m => m String -- caringProgram = --- 'catching' \@eff uncaringProgram (\\(exc :: SomeEffectExc) -> handlerForSomeEffectExc exc) +-- 'catching' \@SomeEffect uncaringProgram (\\(exc :: SomeEffectExc) -> handlerForSomeEffectExc exc) -- @ -- +-- It's possible the @'Catch' exc@ effect @'catching'@ gives you access to +-- would override another, identical @'Catch' exc@ effect that you want to use +-- inside the region. To avoid this, use 'catching' together with 'intro1': +-- +-- @'catching' \@SomeEffect ('intro1' uncaringProgram) ...@ +-- +-- If you do this, then @'catching'@ will only introduce @eff@ to be used +-- in @uncaringProgram@, and not @'Catch' exc@. catching :: forall eff exc m a . Eff (Exceptional eff exc) m => ExceptionallyC eff exc m a @@ -203,9 +115,9 @@ catchSafe = catching {-# INLINE catchSafe #-} --- | Gain access to @eff@ within a region. If any use of @eff@ --- within that region 'throw's an unhandled exception @e :: exc@, --- then this returns @Left e@. +-- | Gain access to @eff@ and @'Catch' exc@ within a region. +-- If any use of @eff@ within that region 'throw's an unhandled exception +-- @e :: exc@, then this returns @Left e@. trying :: forall eff exc m a . Eff (Exceptional eff exc) m => ExceptionallyC eff exc m a @@ -222,8 +134,8 @@ trySafe = trying {-# INLINE trySafe #-} --- | Gain access to @eff@ within a region, rethrowing --- any exception @e :: exc@ that may occur from the use of +-- | Gain access to @eff@ and @'Catch' exc@ within a region, +-- rethrowing any exception @e :: exc@ that may occur from the use of -- @eff@ within that region. throwing :: forall eff exc m a . Effs [Exceptional eff exc, Throw exc] m @@ -232,33 +144,14 @@ throwing m = m `catching` throw {-# INLINE throwing #-} -data ExceptionalH - -instance ( Member eff (Derivs m) - , Eff (Catch exc) m - ) - => Handler ExceptionalH (Exceptional eff exc) m where - -- Explicit pattern mathing and use of 'algDerivs' instead of using - -- 'decomp' and 'send' so that we don't introduce the - -- RepresentationalEff constraint. - effHandler (Exceptional e) = case e of - Union Here eff -> algDerivs (Union membership eff) - Union (There Here) eff -> algDerivs (Union membership eff) - Union (There (There pr)) _ -> absurdMember pr - {-# INLINEABLE effHandler #-} - -type ExceptionalC eff exc = InterpretC ExceptionalH (Exceptional eff exc) - -type SafeErrorToErrorC exc = ExceptionalC (Throw exc) exc - -- | Run an @'Exceptional' eff exc@ effect if both @eff@ and @'Catch' exc@ -- are part of the effect stack. -- -- In order for this to be safe, you must ensure that the @'Catch' exc@ -- catches all exceptions that arise from the use of @eff@ and that -- only uses of @eff@ throws those exceptions. --- Otherwise, the use of 'catching' is liable to catch --- exceptions not arising from uses of @eff@, or fail to catch +-- Otherwise, the use of 'catching' is liable to catch exceptions +-- not arising from uses of @eff@, or fail to catch -- exceptions that do arise from uses of @eff@. runExceptional :: forall eff exc m a . ( Member eff (Derivs m) @@ -334,12 +227,6 @@ safeErrorToError = runExceptional {-# INLINE safeErrorToError #-} -type SafeErrorC exc = CompositionC - '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] - , SafeErrorToErrorC exc - , ErrorC exc - ] - -- | Run a @'SafeError' e@ effect purely. -- -- @'Derivs' ('SafeErrorC' e m) = 'SafeError' e ': 'Prims' m@ @@ -352,11 +239,11 @@ => SafeErrorC e m a -> m a runSafeError = - fmap (fromRight bombPure) + (>>= either (\_ -> bombPure) return) .# runError .# safeErrorToError .# introUnder - .# runComposition + .# unSafeErrorC {-# INLINE runSafeError #-} bombPure :: a @@ -375,17 +262,6 @@ \it on the GitHub repository for in-other-words." -type SafeErrorToIOC' s s' exc = CompositionC - '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] - , SafeErrorToErrorC exc - , ErrorToIOC' s s' exc - ] - -type SafeErrorToIOC e m a = - forall s s' - . ReifiesErrorHandler s s' e (ErrorIOToIOC m) - => SafeErrorToIOC' s s' e m a - -- | Runs a @'SafeError' e@ effect by making use of 'IO' exceptions. -- -- @'Derivs' ('SafeErrorToIOC' e m) = 'SafeError' e ': 'Derivs' m@ @@ -405,25 +281,15 @@ => SafeErrorToIOC e m a -> m a safeErrorToIO m = - fmap (fromRight (bombIO "safeErrorToIO")) + (>>= either (\_ -> bombIO "safeErrorToIO") return) $ errorToIO $ safeErrorToError $ introUnder - $ runComposition + $ unSafeErrorToIOC' $ m {-# INLINE safeErrorToIO #-} -type SafeErrorToErrorIOC' s s' exc = CompositionC - '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] - , SafeErrorToErrorC exc - , InterpretErrorC' s s' exc - ] -type SafeErrorToErrorIOC e m a = - forall s s' - . ReifiesErrorHandler s s' e m - => SafeErrorToErrorIOC' s s' e m a - -- | Runs a @'SafeError' e@ effect by transforming it into 'ErrorIO' -- and @'Embed' IO@. -- @@ -438,20 +304,14 @@ => SafeErrorToErrorIOC e m a -> m a safeErrorToErrorIO m = - fmap (fromRight (bombIO "safeErrorToErrorIO")) + (>>= either (\_ -> bombIO "safeErrorToErrorIO") return) $ errorToErrorIO $ safeErrorToError $ introUnder - $ runComposition + $ unSafeErrorToErrorIOC' $ m {-# INLINE safeErrorToErrorIO #-} -type SafeErrorToIOSimpleC exc = CompositionC - '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] - , SafeErrorToErrorC exc - , ErrorToIOSimpleC exc - ] - -- | Runs a @'SafeError' e@ effect by making use of 'IO' exceptions. -- -- @'Derivs' ('SafeErrorToIOSimpleC' e m) = 'SafeError' e ': 'Derivs' m@ @@ -468,19 +328,13 @@ => SafeErrorToIOSimpleC e m a -> m a safeErrorToIOSimple = - fmap (fromRight (bombIO "safeErrorToIOSimple")) + (>>= either (\_ -> bombIO "safeErrorToIOSimple") return) . errorToIOSimple .# safeErrorToError .# introUnder - .# runComposition + .# unSafeErrorToIOSimpleC {-# INLINE safeErrorToIOSimple #-} -type SafeErrorToErrorIOSimpleC exc = CompositionC - '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] - , SafeErrorToErrorC exc - , InterpretErrorSimpleC exc - ] - -- | Runs a @'SafeError' e@ effect by transforming it into 'ErrorIO' -- and @'Embed' IO@. -- @@ -493,9 +347,9 @@ => SafeErrorToErrorIOSimpleC e m a -> m a safeErrorToErrorIOSimple = - fmap (fromRight (bombIO "safeErrorToErrorIOSimple")) + (>>= either (\_ -> bombIO "safeErrorToErrorIOSimple") return) . errorToErrorIOSimple .# safeErrorToError .# introUnder - .# runComposition + .# unSafeErrorToErrorIOSimpleC {-# INLINE safeErrorToErrorIOSimple #-} diff --git a/src/Control/Effect/Fail.hs b/src/Control/Effect/Fail.hs --- a/src/Control/Effect/Fail.hs +++ b/src/Control/Effect/Fail.hs @@ -43,10 +43,11 @@ -- Imports for coercion import Control.Effect.Internal.Utils +import Control.Effect.Internal.Error import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Intro import Control.Effect.Carrier.Internal.Compose -import Control.Monad.Trans.Identity +import Control.Monad.Trans.Except -- | Like 'InterpretC' specialized to interpret 'Fail', but with a 'MonadFail' @@ -156,11 +157,31 @@ data FailH -type FailC = CompositionC - '[ ReinterpretC FailH Fail '[Throw String] - , ThrowC String - ] +newtype FailC m a = FailC { + unFailC :: + ReinterpretC FailH Fail '[Throw String] + ( ThrowC String + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ ReinterpretC FailH Fail '[Throw String] + , ThrowC String + ] +deriving via Effly (FailC m) + instance (Carrier m, Threads (ExceptT String) (Prims m)) + => MonadFail (FailC m) + +deriving instance (Carrier m, Threads (ExceptT String) (Prims m)) + => Carrier (FailC m) + instance Eff (Throw String) m => Handler FailH Fail m where effHandler = throw @String .# coerce @@ -171,6 +192,10 @@ -- -- 'FailC' has an 'MonadFail' instance based on the 'Fail' -- effect it interprets. +-- +-- @'Derivs' ('FailC' m) = 'Fail' ': 'Derivs' m@ +-- +-- @'Control.Effect.Primitive.Prims' ('FailC' m) = 'Control.Effect.Primitive.Prims' m@ runFail :: forall m a p . ( Threaders '[ErrorThreads] m p , Carrier m @@ -180,7 +205,7 @@ runFail = runThrow .# reinterpretViaHandler - .# runComposition + .# unFailC -- | Like 'InterpretSimpleC' specialized to interpret 'Fail', but with -- a 'MonadFail' instance based on the interpreted 'Fail'. diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs --- a/src/Control/Effect/Fresh.hs +++ b/src/Control/Effect/Fresh.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} module Control.Effect.Fresh ( -- * Effects Fresh(..) @@ -31,11 +32,12 @@ import Control.Effect.State -- For coercion purposes +import Control.Effect.Carrier import Control.Effect.Internal.Utils import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Compose import Control.Effect.Carrier.Internal.Intro -import Control.Monad.Trans.Identity +import Control.Monad.Trans.State.Strict (StateT) -- | An effect for creating unique objects which may be used as references, @@ -120,10 +122,27 @@ effHandler Fresh = state' (\s -> (succ s, s)) {-# INLINEABLE effHandler #-} -type FreshEnumC uniq = CompositionC - '[ ReinterpretC FreshEnumH (Fresh uniq) '[State uniq] - , StateC uniq - ] +newtype FreshEnumC uniq m a = FreshEnumC { + unFreshEnumC :: + ReinterpretC FreshEnumH (Fresh uniq) '[State uniq] + ( StateC uniq + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ ReinterpretC FreshEnumH (Fresh uniq) '[State uniq] + , StateC uniq + ] + +deriving instance (Carrier m, Enum uniq, Threads (StateT uniq) (Prims m)) + => Carrier (FreshEnumC uniq m) + -- | Run a 'Fresh' effect purely by specifying an 'Enum' to be used as the -- type of unique objects. -- @@ -154,5 +173,5 @@ runFreshEnum = evalState (toEnum 0) .# reinterpretViaHandler - .# runComposition + .# unFreshEnumC {-# INLINE runFreshEnum #-} diff --git a/src/Control/Effect/Internal/BaseControl.hs b/src/Control/Effect/Internal/BaseControl.hs --- a/src/Control/Effect/Internal/BaseControl.hs +++ b/src/Control/Effect/Internal/BaseControl.hs @@ -6,7 +6,6 @@ import Control.Effect.Internal.Itself import Control.Effect.Carrier.Internal.Interpret -import Control.Monad.Trans.Identity import Control.Effect.Type.Internal.BaseControl import GHC.Exts (Proxy#, proxy#) diff --git a/src/Control/Effect/Internal/Conc.hs b/src/Control/Effect/Internal/Conc.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Conc.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Conc where + +import Control.Effect +import Control.Effect.Unlift +import Control.Effect.Newtype +import Control.Effect.Internal.Newtype +import Control.Effect.Internal.Utils + +-- For coercion purposes +import Control.Effect.Internal.Derive +import Control.Effect.Carrier.Internal.Interpret +import Control.Effect.Carrier.Internal.Compose + +-- | An effect for concurrent execution. +newtype Conc m a = Conc (Unlift IO m a) + deriving EffNewtype via Conc `WrapperOf` Unlift IO + +unliftConc :: Eff Conc m => ((forall x. m x -> IO x) -> IO a) -> m a +unliftConc main = wrapWith Conc $ unlift (\lower -> main (lower .# lift)) +{-# INLINE unliftConc #-} + +newtype ConcToIOC m a = ConcToIOC { + unConcToIOC :: + UnwrapTopC Conc + ( UnliftToFinalC IO + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving MonadTrans + via CompositionBaseT + '[ UnwrapTopC Conc + , UnliftToFinalC IO + ] + +deriving instance (Carrier m, MonadBaseControlPure IO m) + => Carrier (ConcToIOC m) diff --git a/src/Control/Effect/Internal/Cont.hs b/src/Control/Effect/Internal/Cont.hs --- a/src/Control/Effect/Internal/Cont.hs +++ b/src/Control/Effect/Internal/Cont.hs @@ -12,11 +12,10 @@ import Control.Effect.Internal.Utils -import qualified Control.Monad.Trans.Cont as C import Control.Monad.Trans.Free.Church.Alternate -- | An effect for abortive continuations. -newtype Cont m a where +newtype Cont :: Effect where CallCC :: ((forall b. a -> m b) -> m a) -> Cont m a -- | An effect for non-abortive continuations of a program @@ -26,11 +25,11 @@ -- as this doesn't provide any equivalent of the @reset@ operator. -- -- This can be useful as a helper effect. -newtype Shift r m a where +newtype Shift r :: Effect where Shift :: ((a -> m r) -> m r) -> Shift r m a data ContBase mr r a where - Exit :: r -> ContBase mr r a + Exit :: r -> ContBase mr r void Attempt :: mr -> ContBase mr r r GetCont :: ContBase mr r (Either (a -> mr) a) @@ -61,28 +60,6 @@ Right a -> return a {-# INLINEABLE reformulate #-} - -newtype ContFastC (r :: *) m a = ContFastC { unContFastC :: C.ContT r m a } - deriving (Functor, Applicative, Monad, MonadBase b, MonadIO, Fail.MonadFail) - deriving MonadTrans - -instance ( Carrier m - , Threads (C.ContT r) (Prims m) - ) - => Carrier (ContFastC r m) where - type Derivs (ContFastC r m) = Cont ': Derivs m - type Prims (ContFastC r m) = Prims m - - algPrims = coerce (thread @(C.ContT r) (algPrims @m)) - {-# INLINEABLE algPrims #-} - - reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case - CallCC main -> - n (ContFastC $ C.ContT $ \c -> c (Left (c . Right))) >>= \case - Left c -> main (\a -> n $ ContFastC $ C.ContT $ \_ -> c a) - Right a -> return a - {-# INLINEABLE reformulate #-} - newtype ShiftC r m a = ShiftC { unShiftC :: FreeT (ContBase (m r) r) m a } deriving ( Functor, Applicative, Monad , MonadBase b, Fail.MonadFail, MonadIO @@ -110,28 +87,6 @@ Right a -> return a {-# INLINEABLE reformulate #-} -instance ( Carrier m - , Threads (C.ContT r) (Prims m) - ) - => Carrier (ShiftFastC r m) where - type Derivs (ShiftFastC r m) = Shift r ': Derivs m - type Prims (ShiftFastC r m) = Prims m - - algPrims = coerce (thread @(C.ContT r) (algPrims @m)) - {-# INLINEABLE algPrims #-} - - reformulate n alg = powerAlg (reformulate (n . lift) alg) $ \case - Shift main -> - n (ShiftFastC $ C.ContT $ \c -> c (Left (c . Right))) >>= \case - Left c -> main (n . lift . c) >>= \r -> - n (ShiftFastC $ C.ContT $ \_ -> return r) - Right a -> return a - {-# INLINEABLE reformulate #-} - -newtype ShiftFastC (r :: *) m a = ShiftFastC { unShiftFastC :: C.ContT r m a } - deriving (Functor, Applicative, Monad, MonadBase b, MonadIO, Fail.MonadFail) - deriving MonadTrans - -- | 'ContThreads' accepts the following primitive effects: -- -- * 'Control.Effect.Regional.Regional' @s@ @@ -140,11 +95,3 @@ -- * 'Control.Effect.Type.ListenPrim.ListenPrim' @o@ (when @o@ is a 'Monoid') -- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@ type ContThreads = FreeThreads - --- | 'ContFastThreads' accepts the following primitive effects: --- --- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@ -class ( forall s. Threads (C.ContT s) p - ) => ContFastThreads p -instance ( forall s. Threads (C.ContT s) p - ) => ContFastThreads p diff --git a/src/Control/Effect/Internal/Derive.hs b/src/Control/Effect/Internal/Derive.hs --- a/src/Control/Effect/Internal/Derive.hs +++ b/src/Control/Effect/Internal/Derive.hs @@ -6,7 +6,7 @@ , MonadThrow, MonadCatch, MonadMask , MonadBase, MonadBaseControl , MonadTrans, MonadTransControl - , IdentityT + , IdentityT(..) ) where -- TODO(KingoftheHomeless?): Make a TH macro which may be used to newtype-derive as many of these classes as possible. diff --git a/src/Control/Effect/Internal/Error.hs b/src/Control/Effect/Internal/Error.hs --- a/src/Control/Effect/Internal/Error.hs +++ b/src/Control/Effect/Internal/Error.hs @@ -1,5 +1,5 @@ {-# OPTIONS_HADDOCK not-home #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE BlockArguments, DerivingVia #-} module Control.Effect.Internal.Error where import Data.Coerce @@ -8,6 +8,7 @@ import Control.Monad import Control.Effect +import Control.Effect.ErrorIO import Control.Effect.Type.Throw import Control.Effect.Type.Catch import Control.Effect.Optional @@ -16,6 +17,21 @@ import Control.Monad.Trans.Except +import qualified Control.Exception as X +import qualified Control.Monad.Catch as C + +-- For coercion purposes +import Control.Effect.Carrier.Internal.Interpret +import Control.Effect.Carrier.Internal.Intro +import Control.Effect.Carrier.Internal.Compose +import Control.Effect.Internal.ErrorIO +import Control.Effect.Internal.Utils + +-- For errorToIO +import Data.Unique +import GHC.Exts (Any) +import Unsafe.Coerce + newtype ThrowC e m a = ThrowC { unThrowC :: ExceptT e m a } deriving ( Functor, Applicative, Monad , Alternative, MonadPlus @@ -84,3 +100,372 @@ ) => ErrorThreads p instance ( forall e. Threads (ExceptT e) p ) => ErrorThreads p + +type ReifiesErrorHandler s s' e m = + ( ReifiesHandler s (Catch e) (InterpretC (ViaReifiedH s') (Throw e) m) + , ReifiesHandler s' (Throw e) m + ) + + +newtype InterpretErrorC' s s' e m a = InterpretErrorC' { + unInterpretErrorC' :: + InterpretC (ViaReifiedH s) (Catch e) + ( InterpretC (ViaReifiedH s') (Throw e) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ InterpretC (ViaReifiedH s) (Catch e) + , InterpretC (ViaReifiedH s') (Throw e) + ] + +deriving instance (Carrier m, ReifiesErrorHandler s s' e m) + => Carrier (InterpretErrorC' s s' e m) + +type InterpretErrorC e m a = + forall s s' + . ReifiesErrorHandler s s' e m + => InterpretErrorC' s s' e m a + + +newtype ErrorToIOC' s s' e m a = ErrorToIOC' { + unErrorToIOC' :: + IntroC '[Catch e, Throw e] '[ErrorIO] + ( InterpretErrorC' s s' e + ( ErrorIOToIOC + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Catch e, Throw e] '[ErrorIO] + , InterpretErrorC' s s' e + , ErrorIOToIOC + ] + +deriving instance ( Carrier m, C.MonadCatch m + , ReifiesErrorHandler s s' e (ErrorIOToIOC m) + ) + => Carrier (ErrorToIOC' s s' e m) + +type ErrorToIOC e m a = + forall s s' + . ReifiesErrorHandler s s' e (ErrorIOToIOC m) + => ErrorToIOC' s s' e m a + +-- KingoftheHomeless: We could skip having to use 'OpaqueExc' +-- by requiring the exception type @e@ to be typeable. Or have it be +-- an instance of 'Exception'. +-- +-- I choose not to for two reasons: +-- 1. By making use of OpaqueExc and checking unique references, +-- we guarantee that exceptions belonging to an @'Error' e@ effect +-- interpreted with 'errorToErrorIO' won't get caught by 'catch'es +-- belonging to /another/, identical @'Error' e@ effect interpreted +-- using 'errorToErrorIO'. So by using OpaqueExc, we get coherency. +-- +-- 2. In case we eventually implement a system for polymorphic effect +-- interpreters inside of application code, like something like this: +-- @ +-- manageError :: HasErrorInterpreter s m +-- => ProvidedErrorInterpreterC s e m a +-- -> m (Either e a) +-- @ +-- of which 'errorToErrorIO' should be a valid implementation, then +-- we shouldn't place any constraints upon @e@. +data OpaqueExc = OpaqueExc Unique Any + +instance Show OpaqueExc where + showsPrec _ (OpaqueExc uniq _) = + showString "errorToIO/errorToErrorIO: Escaped opaque exception. \ + \Unique hash is: " . shows (hashUnique uniq) . showString ". \ + \This should only happen if the computation that threw the \ + \exception was somehow invoked outside of the argument of \ + \'errorToIO'; for example, if you 'async' an exceptional \ + \computation inside of the argument provided to 'errorToIO', \ + \and then 'await' on it *outside* of the argument provided to \ + \'errorToIO'. \ + \If that or any similar shenanigans seems unlikely, then \ + \please open an issue on the GitHub repository." + +instance X.Exception OpaqueExc + +-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- +-- by transforming them into 'ErrorIO' and @'Embed' IO@ +-- +-- This has a higher-rank type, as it makes use of 'InterpretErrorC'. +-- __This makes 'errorToErrorIO' very difficult to use partially applied.__ +-- __In particular, it can't be composed using @'.'@.__ +-- +-- If performance is secondary, consider using the slower +-- 'errorToErrorIOSimple', which doesn't have a higher-rank type. +errorToErrorIO :: forall e m a + . Effs '[ErrorIO, Embed IO] m + => InterpretErrorC e m a + -> m (Either e a) +errorToErrorIO main = do + !uniq <- embed newUnique + let + main' = + interpret \case + Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e)) + $ interpret \case + Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) -> + if uniq == uniq' then + h (unsafeCoerce e) + else + throwIO exc + $ unInterpretErrorC' + $ main + fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) -> + if uniq == uniq' then + return $ Left (unsafeCoerce e) + else + throwIO exc + +data ErrorToErrorIOAsExcH + +instance (Eff ErrorIO m, Exception e) + => Handler ErrorToErrorIOAsExcH (Throw e) m where + effHandler (Throw e) = throwIO e + + +instance (Eff ErrorIO m, Exception e) + => Handler ErrorToErrorIOAsExcH (Catch e) m where + effHandler (Catch m f) = m `catchIO` f + +newtype ErrorToErrorIOAsExcC e m a = ErrorToErrorIOAsExcC { + unErrorToErrorIOAsExcC :: + InterpretC ErrorToErrorIOAsExcH (Catch e) + ( InterpretC ErrorToErrorIOAsExcH (Throw e) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ InterpretC ErrorToErrorIOAsExcH (Catch e) + , InterpretC ErrorToErrorIOAsExcH (Throw e) + ] + +deriving instance (Eff ErrorIO m, Exception e) + => Carrier (ErrorToErrorIOAsExcC e m) + +-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- +-- by transforming them into 'ErrorIO'. +-- +-- Unlike 'errorToErrorIO', values of @e@ are thrown and caught directly as 'IO' +-- exceptions. This means that, for example, 'catchIO' is able to catch +-- exceptions of @e@ that you throw with 'Control.Effect.Error.throw', +-- and 'Control.Effect.Error.catch' is able to catch exceptions of type @e@ that +-- are thrown with 'throwIO', or by 'embed'ded 'IO' actions. +-- +-- @'Derivs' ('ErrorToErrorIOAsExcC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@ +-- +-- @'Control.Effect.Primitive.Prims' ('ErrorToErrorIOAsExcC' e m) = 'Control.Effect.Primitive.Prims' m@ +-- +-- @since 0.2.0.0 +errorToErrorIOAsExc + :: (Exception e, Eff ErrorIO m) + => ErrorToErrorIOAsExcC e m a + -> m a +errorToErrorIOAsExc = + interpretViaHandler + .# interpretViaHandler + .# unErrorToErrorIOAsExcC +{-# INLINE errorToErrorIOAsExc #-} + +-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- +-- by making use of 'IO' exceptions. +-- +-- @'Derivs' ('ErrorToIOC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@ +-- +-- @'Control.Effect.Primitive.Prims' ('ErrorToIOC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@ +-- +-- This has a higher-rank type, as it makes use of 'ErrorToIOC'. +-- __This makes 'errorToIO' very difficult to use partially applied.__ +-- __In particular, it can't be composed using @'.'@.__ +-- +-- If performance is secondary, consider using the slower +-- 'errorToIOSimple', which doesn't have a higher-rank type. +errorToIO :: forall e m a + . ( C.MonadCatch m + , Eff (Embed IO) m + ) + => ErrorToIOC e m a + -> m (Either e a) +errorToIO m = + errorIOToIO + $ errorToErrorIO + $ introUnderMany + $ unErrorToIOC' + $ m +{-# INLINE errorToIO #-} + +newtype ErrorToIOAsExcC e m a = ErrorToIOAsExcC { + unErrorToIOAsExcC :: + IntroC '[Catch e, Throw e] '[ErrorIO] + ( ErrorToErrorIOAsExcC e + ( ErrorIOToIOC + m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Catch e, Throw e] '[ErrorIO] + , ErrorToErrorIOAsExcC e + , ErrorIOToIOC + ] + +deriving instance (Exception e, C.MonadCatch m, Carrier m) + => Carrier (ErrorToIOAsExcC e m) + +-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- +-- by treating values of @e@ as 'IO' exceptions. +-- +-- Unlike 'errorToIO', values of @e@ are thrown and caught directly as 'IO' +-- exceptions. This means that, for example, 'catchIO' is able to catch +-- exceptions of @e@ that you throw with 'Control.Effect.Error.throw', +-- and 'Control.Effect.Error.catch' is able to catch +-- exceptions of type @e@ that are thrown with 'throwIO', or by 'embed'ded 'IO' +-- actions. +-- +-- @'Derivs' ('ErrorToIOAsExcC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@ +-- +-- @'Control.Effect.Primitive.Prims' ('ErrorToIOAsExcC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@ +-- +-- @since 0.2.0.0 +errorToIOAsExc + :: ( Exception e + , C.MonadCatch m + , Carrier m + ) + => ErrorToIOAsExcC e m a + -> m a +errorToIOAsExc = + errorIOToIO + .# errorToErrorIOAsExc + .# introUnderMany + .# unErrorToIOAsExcC +{-# INLINE errorToIOAsExc #-} + +newtype InterpretErrorSimpleC e m a = InterpretErrorSimpleC { + unInterpretErrorSimpleC :: + InterpretSimpleC (Catch e) + ( InterpretSimpleC (Throw e) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving MonadTrans + via CompositionBaseT + '[ InterpretSimpleC (Catch e) + , InterpretSimpleC (Throw e) + ] + +deriving instance (Carrier m, Threaders '[ReaderThreads] m p) + => Carrier (InterpretErrorSimpleC e m) + +newtype ErrorToIOSimpleC e m a = ErrorToIOSimpleC { + unErrorToIOSimpleC :: + IntroC '[Catch e, Throw e] '[ErrorIO] + ( InterpretErrorSimpleC e + ( ErrorIOToIOC + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving MonadTrans + via CompositionBaseT + '[ IntroC '[Catch e, Throw e] '[ErrorIO] + , InterpretErrorSimpleC e + , ErrorIOToIOC + ] + +deriving instance ( Eff (Embed IO) m, C.MonadCatch m + , Threaders '[ReaderThreads] m p + ) + => Carrier (ErrorToIOSimpleC e m) + + +-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- +-- by transforming them into 'ErrorIO' and @'Embed' IO@ +-- +-- This is a less performant version of 'errorToErrorIO' that doesn't have +-- a higher-rank type, making it much easier to use partially applied. +errorToErrorIOSimple :: forall e m a p + . ( Effs '[ErrorIO, Embed IO] m + , Threaders '[ReaderThreads] m p + ) + => InterpretErrorSimpleC e m a + -> m (Either e a) +errorToErrorIOSimple main = do + !uniq <- embed newUnique + let + main' = + interpretSimple \case + Throw e -> throwIO (OpaqueExc uniq (unsafeCoerce e)) + $ interpretSimple \case + Catch m h -> m `catchIO` \exc@(OpaqueExc uniq' e) -> + if uniq == uniq' then + h (unsafeCoerce e) + else + throwIO exc + $ unInterpretErrorSimpleC + $ main + fmap Right main' `catchIO` \exc@(OpaqueExc uniq' e) -> + if uniq == uniq' then + return $ Left (unsafeCoerce e) + else + throwIO exc + +-- | Runs connected 'Throw' and 'Catch' effects -- i.e. 'Error' -- +-- by making use of 'IO' exceptions. +-- +-- @'Derivs' ('ErrorToIOSimpleC' e m) = 'Catch' e ': 'Throw' e ': 'Derivs' m@ +-- +-- @'Control.Effect.Primitive.Prims' ('ErrorToIOSimpleC' e m) = 'Control.Effect.Optional.Optional' ((->) 'Control.Exception.SomeException') ': 'Control.Effect.Primitive.Prims' m@ +-- +-- This is a less performant version of 'errorToIO' that doesn't have +-- a higher-rank type, making it much easier to use partially applied. +errorToIOSimple :: forall e m a p + . ( Eff (Embed IO) m + , MonadCatch m + , Threaders '[ReaderThreads] m p + ) + => ErrorToIOSimpleC e m a + -> m (Either e a) +errorToIOSimple = + errorIOToIO + #. errorToErrorIOSimple + .# introUnderMany + .# unErrorToIOSimpleC +{-# INLINE errorToIOSimple #-} diff --git a/src/Control/Effect/Internal/ErrorIO.hs b/src/Control/Effect/Internal/ErrorIO.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/ErrorIO.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.ErrorIO where + +import Control.Monad + +import Control.Effect +import Control.Effect.Optional +import Control.Effect.Type.ErrorIO + +import Control.Exception (SomeException) +import qualified Control.Exception as X +import qualified Control.Monad.Catch as C + +-- For coercion purposes +import Control.Effect.Internal.Derive +import Control.Effect.Carrier.Internal.Intro +import Control.Effect.Carrier.Internal.Compose +import Control.Effect.Carrier.Internal.Interpret +import Control.Effect.Internal.Utils + +newtype ErrorIOToIOC m a = ErrorIOToIOC { + unErrorIOToIOC :: + ReinterpretC ErrorIOFinalH ErrorIO + '[Optional ((->) SomeException)] + ( InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException)) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ ReinterpretC ErrorIOFinalH ErrorIO + '[Optional ((->) SomeException)] + , InterpretPrimC ErrorIOFinalH (Optional ((->) SomeException)) + ] + +deriving instance (Carrier m, C.MonadCatch m) + => Carrier (ErrorIOToIOC m) + +-- | Run an @'ErrorIO'@ effect by making use of 'IO' exceptions. +-- +-- @'Derivs' (ErrorIOToIOC e m) = 'ErrorIO' ': 'Derivs' m@ +-- +-- @'Control.Effect.Carrier.Prims' (ErrorIOToIOC e m) = 'Control.Effect.Optional.Optional' ((->) 'SomeException') ': 'Control.Effect.Carrier.Prims' m@ +errorIOToIO :: (Carrier m, C.MonadCatch m) + => ErrorIOToIOC m a + -> m a +errorIOToIO = + interpretPrimViaHandler + .# reinterpretViaHandler + .# unErrorIOToIOC +{-# INLINE errorIOToIO #-} + +data ErrorIOFinalH + +instance ( C.MonadThrow m + , Eff (Optional ((->) SomeException)) m + ) + => Handler ErrorIOFinalH ErrorIO m where + effHandler = \case + ThrowIO x -> liftBase $ C.throwM x + CatchIO m h -> join $ + optionally + (\x -> case X.fromException x of + Just e -> h e + Nothing -> liftBase $ C.throwM x + ) + (fmap pure m) + {-# INLINEABLE effHandler #-} + +instance ( C.MonadCatch m + , Carrier m + ) + => PrimHandler ErrorIOFinalH (Optional ((->) SomeException)) m where + effPrimHandler = \case + Optionally h m -> m `C.catch` (return . h) + {-# INLINEABLE effPrimHandler #-} diff --git a/src/Control/Effect/Internal/Exceptional.hs b/src/Control/Effect/Internal/Exceptional.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Exceptional.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Exceptional where + +import Control.Effect +import Control.Effect.Error +import Control.Effect.ErrorIO +import Control.Effect.Union + +import Control.Effect.Carrier + +import Control.Effect.Internal.Utils + +-- For coercion purposes +import Control.Monad.Trans.Except +import Control.Effect.Internal.Error +import Control.Effect.Carrier.Internal.Interpret +import Control.Effect.Carrier.Internal.Intro +import Control.Effect.Carrier.Internal.Compose + + +-- | An effect that allows for the safe use of an effect @eff@ that may +-- throw exceptions of the type @exc@ by forcing the user to eventually +-- catch those exceptions at some point of the program. +-- +-- The main combinator of 'Exceptional' is 'Control.Effect.Exceptional.catching'. +-- +-- __This could be unsafe in the presence of 'Control.Effect.Conc.Conc'__. +-- If you use 'Control.Effect.Exceptional.catching' on a computation that: +-- +-- * Spawns an asynchronous computation +-- * Throws an exception inside the asynchronous computation from a use of @eff@ +-- * Returns the 'Control.Effect.Conc.Async' of that asynchronous computation +-- +-- Then 'Control.Effect.Conc.wait'ing on that 'Control.Effect.Conc.Async' +-- outside of the 'Control.Effect.Exceptional.catching' will throw that exception +-- without it being caught. +newtype Exceptional eff exc m a = Exceptional (Union '[eff, Catch exc] m a) + +-- | A particularly useful specialization of 'Exceptional', for gaining +-- restricted access to an @'Error' exc@ effect. +-- Main combinators are 'Control.Effect.Exceptional.catchSafe' and +-- 'Control.Effect.Exceptional.trySafe'. +type SafeError exc = Exceptional (Throw exc) exc + +{- +"ExceptionallyC" can easily be implemented using Handler: + +data ExceptionallyH exc + +instance ( Eff (Exceptional eff exc) m + , RepresentationalEff eff + ) + => Handler (ExceptionallH exc) eff m where where + effHandler e = send $ Exceptionally $ inj e + +type ExceptionallyC eff exc = InterpretC (ExceptionallH exc) eff + +catching :: forall eff exc m a + . ( Eff (Exceptional eff exc) m + , RepresentationalEff eff + ) + => ExceptionallyC exc eff m a + -> (exc -> m a) + -> m a +catching m h = + send $ Exceptional @eff @exc $ + inj (Catch @exc (interpretViaHandler m) h) + +We use a standalone carrier to hide the RepresentationalEff constraint, +which is just noise in this case. +-} + +newtype ExceptionallyC (eff :: Effect) (exc :: *) m a = ExceptionallyC { + unExceptionallyC :: m a + } + deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) via IdentityT + +instance Eff (Exceptional eff exc) m + => Carrier (ExceptionallyC eff exc m) where + type Derivs (ExceptionallyC eff exc m) = Catch exc ': eff ': Derivs m + type Prims (ExceptionallyC eff exc m) = Prims m + + algPrims = coerce (algPrims @m) + {-# INLINEABLE algPrims #-} + + reformulate n alg = + powerAlg ( + powerAlg' ( + reformulate (n .# lift) alg + ) $ \e -> + reformulate (n .# lift) alg $ inj $ + Exceptional @eff @exc (Union Here e) + ) $ \e -> + reformulate (n .# lift) alg $ inj $ + Exceptional @eff @exc (Union (There Here) e) + {-# INLINEABLE reformulate #-} + + algDerivs = + powerAlg ( + powerAlg' ( + coerce (algDerivs @m) + ) $ \e -> + coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union Here e) + ) $ \e -> + coerceAlg (algDerivs @m) $ inj $ Exceptional @eff @exc (Union (There Here) e) + {-# INLINEABLE algDerivs #-} + +data ExceptionalH + +instance ( Member eff (Derivs m) + , Eff (Catch exc) m + ) + => Handler ExceptionalH (Exceptional eff exc) m where + -- Explicit pattern mathing and use of 'algDerivs' instead of using + -- 'decomp' and 'send' so that we don't introduce the + -- RepresentationalEff constraint. + effHandler (Exceptional e) = case e of + Union Here eff -> algDerivs (Union membership eff) + Union (There Here) eff -> algDerivs (Union membership eff) + Union (There (There pr)) _ -> absurdMember pr + {-# INLINEABLE effHandler #-} + +type ExceptionalC eff exc = InterpretC ExceptionalH (Exceptional eff exc) + +type SafeErrorToErrorC exc = ExceptionalC (Throw exc) exc + +newtype SafeErrorC exc m a = SafeErrorC { + unSafeErrorC :: + IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + ( SafeErrorToErrorC exc + ( ErrorC exc + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + , SafeErrorToErrorC exc + , ErrorC exc + ] + +deriving instance (Carrier m, Threads (ExceptT exc) (Prims m)) + => Carrier (SafeErrorC exc m) + +newtype SafeErrorToIOC' s s' exc m a = SafeErrorToIOC' { + unSafeErrorToIOC' :: + IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + ( SafeErrorToErrorC exc + ( ErrorToIOC' s s' exc + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + , SafeErrorToErrorC exc + , ErrorToIOC' s s' exc + ] + +deriving instance ( Eff (Embed IO) m, MonadCatch m + , ReifiesErrorHandler s s' exc (ErrorIOToIOC m) + ) + => Carrier (SafeErrorToIOC' s s' exc m) + +type SafeErrorToIOC e m a = + forall s s' + . ReifiesErrorHandler s s' e (ErrorIOToIOC m) + => SafeErrorToIOC' s s' e m a + +newtype SafeErrorToErrorIOC' s s' exc m a = SafeErrorToErrorIOC' { + unSafeErrorToErrorIOC' :: + IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + ( SafeErrorToErrorC exc + ( InterpretErrorC' s s' exc + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + , SafeErrorToErrorC exc + , InterpretErrorC' s s' exc + ] + +deriving instance (Carrier m, ReifiesErrorHandler s s' exc m) + => Carrier (SafeErrorToErrorIOC' s s' exc m) + +type SafeErrorToErrorIOC e m a = + forall s s' + . ReifiesErrorHandler s s' e m + => SafeErrorToErrorIOC' s s' e m a + +newtype SafeErrorToIOSimpleC exc m a = SafeErrorToIOSimpleC { + unSafeErrorToIOSimpleC :: + IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + ( SafeErrorToErrorC exc + ( ErrorToIOSimpleC exc + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving MonadTrans + via CompositionBaseT + '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + , SafeErrorToErrorC exc + , ErrorToIOSimpleC exc + ] + +deriving instance ( Eff (Embed IO) m, MonadCatch m + , Threaders '[ReaderThreads] m p + ) + => Carrier (SafeErrorToIOSimpleC e m) + + +newtype SafeErrorToErrorIOSimpleC exc m a = SafeErrorToErrorIOSimpleC { + unSafeErrorToErrorIOSimpleC :: + IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + ( SafeErrorToErrorC exc + ( InterpretErrorSimpleC exc + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving MonadTrans + via CompositionBaseT + '[ IntroUnderC (SafeError exc) '[Catch exc, Throw exc] + , SafeErrorToErrorC exc + , InterpretErrorSimpleC exc + ] + +deriving instance (Carrier m , Threaders '[ReaderThreads] m p) + => Carrier (SafeErrorToErrorIOSimpleC e m) diff --git a/src/Control/Effect/Internal/Intercept.hs b/src/Control/Effect/Internal/Intercept.hs --- a/src/Control/Effect/Internal/Intercept.hs +++ b/src/Control/Effect/Internal/Intercept.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} {-# OPTIONS_HADDOCK not-home #-} module Control.Effect.Internal.Intercept where @@ -18,7 +19,10 @@ import Control.Effect.Internal.Utils +-- For coercion purposes +import Control.Effect.Carrier.Internal.Compose + -- | An effect for intercepting actions of a first-order effect. -- -- Even for this library, proper usage of this effect is very complicated. @@ -66,15 +70,37 @@ (fmap pure m) {-# INLINE interceptB #-} -type InterceptContC e = CompositionC - '[ IntroC '[InterceptCont e, Intercept e] - '[Unravel (InterceptB e)] - , InterpretC InterceptH (InterceptCont e) - , InterpretC InterceptH (Intercept e) - , InterpretPrimC InterceptH (Unravel (InterceptB e)) - , SteppedC e - ] +newtype InterceptContC e m a = InterceptContC { + unInterceptContC :: + IntroC '[InterceptCont e, Intercept e] + '[Unravel (InterceptB e)] + ( InterpretC InterceptH (InterceptCont e) + ( InterpretC InterceptH (Intercept e) + ( InterpretPrimC InterceptH (Unravel (InterceptB e)) + ( SteppedC e + ( m + ))))) a + } deriving ( Functor, Applicative, Monad + , MonadFail, MonadIO + , MonadThrow, MonadCatch + , MonadBase b + ) + deriving MonadTrans + via CompositionBaseT + '[ IntroC '[InterceptCont e, Intercept e] + '[Unravel (InterceptB e)] + , InterpretC InterceptH (InterceptCont e) + , InterpretC InterceptH (Intercept e) + , InterpretPrimC InterceptH (Unravel (InterceptB e)) + , SteppedC e + ] + +deriving instance ( FirstOrder e, Carrier m, Member e (Derivs m) + , Threaders '[SteppedThreads] m p + ) + => Carrier (InterceptContC e m) + data InterceptH instance ( FirstOrder e @@ -117,11 +143,11 @@ (Unravel (InterceptB e)) (SteppedC e m) where effPrimHandler (Unravel (InterceptB cataEff) cataM main) = - return $ - unFreeT (unSteppedC main) - (\mx c -> cataM $ fmap c $ lift mx) - (\(FOEff e) c -> cataEff c e) - id + return $ cataM + $ lift + $ unFreeT (unSteppedC main) + (\(FOEff e) c -> return $ cataEff (cataM . lift . c) e) + return {-# INLINEABLE effPrimHandler #-} @@ -154,7 +180,6 @@ -> m a runInterceptCont m = (\m' -> unFreeT m' - (>>=) (\(FOEff e) c -> send @e (coerce e) >>= c) return ) @@ -163,7 +188,7 @@ $ interpretViaHandler $ interpretViaHandler $ introUnderMany - $ runComposition + $ unInterceptContC $ m {-# INLINE runInterceptCont #-} @@ -174,16 +199,15 @@ => s -> SteppedC (State s) m a -> m (s, a) -runStateStepped s0 m = - unFreeT - (unSteppedC m) - (\mx c s -> mx >>= (`c` s)) - (\(FOEff e) c s -> case e of - Get -> c s s - Put s' -> c () s' - ) - (\a s -> return (s, a)) - s0 +runStateStepped s0 main = do + foldFreeT' (\m s -> m >>= \f -> f s) + (\a s -> return (s, a)) + (\c (FOEff e) s -> case e of + Get -> c s s + Put s' -> c () s' + ) + (unSteppedC main) + s0 {-# INLINE runStateStepped #-} -- | A variant of 'runTell' with a 'SteppedThreads' threading constraint @@ -194,13 +218,12 @@ ) => SteppedC (Tell o) m a -> m ([o], a) -runTellListStepped m = - unFreeT - (unSteppedC m) - (\mx c s -> mx >>= (`c` s)) - (\(FOEff (Tell o)) c s -> c () (o : s)) - (\a s -> return (reverse s, a)) - [] +runTellListStepped main = + foldFreeT' (\m acc -> m >>= \f -> f acc) + (\a acc -> return (reverse acc, a)) + (\c (FOEff (Tell o)) acc -> c () $! (o:acc)) + (unSteppedC main) + [] {-# INLINE runTellListStepped #-} -- | A variant of 'runTell' with a 'SteppedThreads' threading constraint @@ -212,13 +235,12 @@ ) => SteppedC (Tell w) m a -> m (w, a) -runTellStepped m = - unFreeT - (unSteppedC m) - (\mx c s -> mx >>= (`c` s)) - (\(FOEff (Tell o)) c s -> c () $! s <> o) - (\a s -> return (s, a)) - mempty +runTellStepped main = + foldFreeT' (\m acc -> m >>= \f -> f acc) + (\a acc -> return (acc, a)) + (\c (FOEff (Tell o)) acc -> c () $! acc <> o) + (unSteppedC main) + mempty {-# INLINE runTellStepped #-} data ListenSteppedH @@ -232,20 +254,38 @@ => PrimHandler ListenSteppedH (ListenPrim w) (SteppedC (Tell w) m) where effPrimHandler = \case ListenPrimTell w -> tell w - ListenPrimListen m -> SteppedC $ FreeT $ \bind handler c -> - unFreeT (unSteppedC m) - (\mx c' s -> mx `bind` (`c'` s)) - (\e@(FOEff (Tell o)) c' s -> handler e $ \a -> c' a $! s <> o) - (\a s -> c (s, a)) - mempty + ListenPrimListen main -> SteppedC $ FreeT $ \handler c -> do + foldFreeT' (\mx acc -> mx >>= \f -> f acc) + (\a acc -> c (acc, a)) + (\cn e@(FOEff (Tell o)) acc -> do + handler e $ \t -> cn t $! acc <> o + ) + (unSteppedC main) + mempty {-# INLINEABLE effPrimHandler #-} -type ListenSteppedC w = CompositionC - '[ ReinterpretC ListenSteppedH (Listen w) '[ListenPrim w] - , InterpretPrimC ListenSteppedH (ListenPrim w) - , SteppedC (Tell w) - ] +newtype ListenSteppedC w m a = ListenSteppedC { + unListenSteppedC :: + ReinterpretC ListenSteppedH (Listen w) '[ListenPrim w] + ( InterpretPrimC ListenSteppedH (ListenPrim w) + ( SteppedC (Tell w) + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , MonadFail, MonadIO + , MonadThrow, MonadCatch + , MonadBase b + ) + deriving MonadTrans + via CompositionBaseT + '[ ReinterpretC ListenSteppedH (Listen w) '[ListenPrim w] + , InterpretPrimC ListenSteppedH (ListenPrim w) + , SteppedC (Tell w) + ] +deriving instance (Monoid w, Carrier m, Threaders '[SteppedThreads] m p) + => Carrier (ListenSteppedC w m) + -- | A variant of 'runListen' with a 'SteppedThreads' threading constraint -- instead of a 'StateThreads' threading constraint. -- @@ -263,7 +303,7 @@ runTellStepped $ interpretPrimViaHandler $ reinterpretViaHandler - $ runComposition + $ unListenSteppedC $ m {-# INLINE runListenStepped #-} diff --git a/src/Control/Effect/Internal/NonDet.hs b/src/Control/Effect/Internal/NonDet.hs --- a/src/Control/Effect/Internal/NonDet.hs +++ b/src/Control/Effect/Internal/NonDet.hs @@ -40,7 +40,7 @@ -- * 'Control.Effect.Optional.Optional' @s@ (when @s@ is a functor) -- * 'Control.Effect.Type.Unravel.Unravel' @p@ -- * 'Control.Effect.Type.ListenPrim.ListenPrim' @o@ (when @o@ is a 'Monoid') --- * 'Control.Effect.Type.ListenPrim.ListenPrim' @o@ (when @o@ is a 'Monoid') +-- * 'Control.Effect.Type.WriterPrim.WriterPrim' @o@ (when @o@ is a 'Monoid') -- * 'Control.Effect.Type.ReaderPrim.ReaderPrim' @i@ type NonDetThreads = Threads L.ListT @@ -121,7 +121,7 @@ powerAlg (liftReform reformulate n alg) $ \case - FromList l -> n $ NonDetC $ L.ListT $ \_ c b _ -> foldr c b l + FromList l -> n $ NonDetC $ L.ListT $ \c b _ -> foldr c b l {-# INLINEABLE reformulate #-} @@ -169,7 +169,6 @@ -> m (Maybe a) runNonDet1 m = L.unListT (unNonDetC m) - (>>=) (\a _ -> pure (Just a)) (pure Nothing) (pure Nothing) diff --git a/src/Control/Effect/Internal/Regional.hs b/src/Control/Effect/Internal/Regional.hs --- a/src/Control/Effect/Internal/Regional.hs +++ b/src/Control/Effect/Internal/Regional.hs @@ -10,7 +10,6 @@ import Control.Effect.Carrier.Internal.Interpret import Control.Monad.Trans.Control -import Control.Monad.Trans.Identity newtype HoistCall b = HoistCall (forall x. b x -> b x) diff --git a/src/Control/Effect/Internal/Select.hs b/src/Control/Effect/Internal/Select.hs new file mode 100644 --- /dev/null +++ b/src/Control/Effect/Internal/Select.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DerivingVia #-} +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Internal.Select where + +import Control.Effect +import Control.Effect.Cont + +-- For coercion purposes +import Control.Effect.Carrier +import Control.Effect.Carrier.Internal.Compose +import Control.Effect.Internal.Cont +import Control.Monad.Trans.Free.Church.Alternate + +-- | An effect for backtracking search. +newtype Select s m a where + Select :: (forall r. (a -> m (s, r)) -> m r) -> Select s m a + +-- | Perform a search: capture the continuation +-- of the program, so that you may test values of @a@ and observe +-- what corresponding @s@ each value would result in +-- at the end of the program (which may be seen as the evaluation of @a@). +-- When you find a satisfactory @a@, you may return the associated @r@. +-- +-- The way higher-order actions interact with the continuation depends +-- on the interpretation of 'Select'. In general, you cannot expect to interact +-- with the continuation in any meaningful way: for example, you should not +-- assume that you will be able to catch an exception thrown at some point in +-- the future of the computation by using 'Control.Effect.Error.catch' on the +-- continuation. +select :: Eff (Select s) m + => (forall r. (a -> m (s, r)) -> m r) -> m a +select main = send (Select main) +{-# INLINE select #-} + +data SelectH r + +instance Eff (Shift (s, r)) m + => Handler (SelectH r) (Select s) m where + effHandler = \case + Select main -> shift @(s, r) $ \c -> + main $ \a -> (\(s,r) -> (s, (s, r))) <$> c a + {-# INLINEABLE effHandler #-} + +newtype SelectC s r m a = SelectC { + unSelectC :: + ReinterpretC (SelectH r) (Select s) '[Shift (s, r)] + ( ShiftC (s, r) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , MonadFail, MonadIO + , MonadThrow, MonadCatch + , MonadBase b + ) + deriving MonadTrans + via CompositionBaseT + '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)] + , ShiftC (s, r) + ] + +deriving instance (Carrier m, Threads (FreeT (ContBase (m (s, r)) (s, r))) (Prims m)) + => Carrier (SelectC s r m) + +-- | Run a @'Select' s@ effect by providing an evaluator +-- for the final result of type @a@. +-- +-- @'Derivs' ('SelectC' s r m) = 'Select' s ': 'Derivs' m@ +-- +-- @'Control.Effect.Primitive.Prims' ('SelectC' s r m) = 'Control.Effect.Primitive.Prims' m@ +runSelect :: forall s a m p + . (Carrier m, Threaders '[ContThreads] m p) + => (a -> m s) + -> SelectC s a m a + -> m a +runSelect c m = + fmap snd + $ runShift + $ (>>= \a -> (\s -> (s, a)) <$> lift (c a)) + $ reinterpretViaHandler + $ unSelectC + $ m +{-# INLINE runSelect #-} diff --git a/src/Control/Effect/Internal/Unlift.hs b/src/Control/Effect/Internal/Unlift.hs --- a/src/Control/Effect/Internal/Unlift.hs +++ b/src/Control/Effect/Internal/Unlift.hs @@ -8,8 +8,6 @@ import Control.Effect.Type.Unlift -import Control.Monad.Trans.Identity - data UnliftH diff --git a/src/Control/Effect/Newtype.hs b/src/Control/Effect/Newtype.hs --- a/src/Control/Effect/Newtype.hs +++ b/src/Control/Effect/Newtype.hs @@ -4,7 +4,7 @@ -- * Unwrapping , EffNewtype(..) - , WrapperOf + , WrapperOf(..) , unwrap diff --git a/src/Control/Effect/Select.hs b/src/Control/Effect/Select.hs --- a/src/Control/Effect/Select.hs +++ b/src/Control/Effect/Select.hs @@ -7,99 +7,9 @@ -- * Interpretations , runSelect - , runSelectFast -- * Carriers , SelectC - , SelectFastC ) where -import Control.Effect -import Control.Effect.Cont - --- | An effect for backtracking search. -data Select s m a where - Select :: (forall r. (a -> m (s, r)) -> m r) -> Select s m a - --- | Perform a search: capture the continuation --- of the program, so that you may test values of @a@ and observe --- what corresponding @s@ each value would result in --- at the end of the program (which may be seen as the evaluation of @a@). --- When you find a satisfactory @a@, you may return the associated @r@. --- --- The way higher-order actions interact with the continuation depends --- on the interpretation of 'Select'. In general, you cannot expect to interact --- with the continuation in any meaningful way: for example, you should not --- assume that you will be able to catch an exception thrown at some point in --- the future of the computation by using 'Control.Effect.Error.catch' on the --- continuation. -select :: Eff (Select s) m - => (forall r. (a -> m (s, r)) -> m r) -> m a -select main = send (Select main) -{-# INLINE select #-} - -data SelectH r - -instance Eff (Shift (s, r)) m - => Handler (SelectH r) (Select s) m where - effHandler = \case - Select main -> shift @(s, r) $ \c -> - main $ \a -> (\(s,r) -> (s, (s, r))) <$> c a - {-# INLINEABLE effHandler #-} - -type SelectC s r = CompositionC - '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)] - , ShiftC (s, r) - ] - -type SelectFastC s r = CompositionC - '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)] - , ShiftFastC (s, r) - ] - --- | Run a @'Select' s@ effect by providing an evaluator --- for the final result of type @a@. --- --- @'Derivs' ('SelectC' s r m) = 'Select' s ': 'Derivs' m@ --- --- @'Control.Effect.Primitive.Prims' ('SelectC' s r m) = 'Control.Effect.Primitive.Prims' m@ -runSelect :: forall s a m p - . (Carrier m, Threaders '[ContThreads] m p) - => (a -> m s) - -> SelectC s a m a - -> m a -runSelect c m = - fmap snd - $ runShift - $ (>>= \a -> (\s -> (s, a)) <$> lift (c a)) - $ reinterpretViaHandler - $ runComposition - $ m -{-# INLINE runSelect #-} - --- | Run a @'Select' s@ effect by providing an evaluator --- for the final result of type @a@. --- --- Compared to 'runSelect', this is quite a bit faster, but is significantly --- more restrictive in what interpreters are used after it, since there are --- very few primitive effects that the carrier for 'runSelectFast' is able to --- thread. --- In fact, of all the primitive effects featured in this library, only --- one satisfies 'ContFastThreads': namely, 'Control.Effect.Reader.Reader'. --- --- @'Derivs' ('SelectFastC' s r m) = 'Select' s ': 'Derivs' m@ --- --- @'Control.Effect.Primitive.Prims' ('SelectFastC' s r m) = 'Control.Effect.Primitive.Prims' m@ -runSelectFast :: forall s a m p - . (Carrier m, Threaders '[ContFastThreads] m p) - => (a -> m s) - -> SelectFastC s a m a - -> m a -runSelectFast c m = - fmap snd - $ runShiftFast - $ (>>= \a -> (\s -> (s, a)) <$> lift (c a)) - $ reinterpretViaHandler - $ runComposition - $ m -{-# INLINE runSelectFast #-} +import Control.Effect.Internal.Select diff --git a/src/Control/Effect/Trace.hs b/src/Control/Effect/Trace.hs --- a/src/Control/Effect/Trace.hs +++ b/src/Control/Effect/Trace.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingVia #-} module Control.Effect.Trace ( -- * Effects Trace(..) @@ -33,6 +34,7 @@ ) where import Data.IORef +import Data.Semigroup import Control.Effect import Control.Effect.Writer @@ -40,11 +42,12 @@ import System.IO -- For coercion purposes +import Control.Effect.Carrier import Control.Effect.Internal.Utils import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Compose import Control.Effect.Carrier.Internal.Intro -import Control.Monad.Trans.Identity +import qualified Control.Monad.Trans.Writer.CPS as CPS -- | An effect for debugging by printing/logging strings. @@ -61,11 +64,27 @@ traceShow = trace . show {-# INLINE traceShow #-} -type TraceListC = CompositionC - '[ TraceIntoTellC - , TellListC String - ] +newtype TraceListC m a = TraceListC { + unTraceListC :: + TraceIntoTellC + ( TellListC String + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ TraceIntoTellC + , TellListC String + ] +deriving instance (Carrier m, Threads (CPS.WriterT (Dual [String])) (Prims m)) + => Carrier (TraceListC m) + -- | Run a 'Trace' effect purely by accumulating all 'trace'd strings -- into a list. runTraceList :: forall m a p @@ -77,7 +96,7 @@ runTraceList = runTellList .# traceIntoTell - .# runComposition + .# unTraceListC {-# INLINE runTraceList #-} data TracePrintingH diff --git a/src/Control/Effect/Type/Alt.hs b/src/Control/Effect/Type/Alt.hs --- a/src/Control/Effect/Type/Alt.hs +++ b/src/Control/Effect/Type/Alt.hs @@ -4,7 +4,7 @@ -- | An effect corresponding to the -- 'Control.Applicative.Alternative' type class. -- --- 'Control.Effect.Effly.Effly''s 'Control.Applicative.Alternative' instance +-- 'Control.Effect.Effly''s 'Control.Applicative.Alternative' instance -- is based on this effect; by having access to 'Alt', you're able to use -- 'Control.Applicative.<|>' and 'Control.Applicative.empty' inside of effect -- handlers. diff --git a/src/Control/Effect/Type/Fail.hs b/src/Control/Effect/Type/Fail.hs --- a/src/Control/Effect/Type/Fail.hs +++ b/src/Control/Effect/Type/Fail.hs @@ -1,16 +1,16 @@ -{-# OPTIONS_HADDOCK not-home #-} -module Control.Effect.Type.Fail where - --- | An effect corresponding to the 'Control.Monad.Fail.MonadFail' type class. --- --- 'Control.Effect.Effly.Effly''s 'Control.Monad.Fail.MonadFail' instance is based --- on this effect; by having access to 'Fail', you're able to invoke --- handle pattern-match failure automatically inside of effect handlers. --- --- Each 'Fail' interpreter's associated carrier --- has an 'Control.Monad.Fail.MonadFail' instance based on --- how it interprets 'Fail'. This means you can use --- an 'Fail' interpreter to locally gain access to an 'Control.Monad.Fail.MonadFail' --- instance inside of application code. -newtype Fail (m :: * -> *) (a :: *) where - Fail :: String -> Fail m a +{-# OPTIONS_HADDOCK not-home #-} +module Control.Effect.Type.Fail where + +-- | An effect corresponding to the 'Control.Monad.Fail.MonadFail' type class. +-- +-- 'Control.Effect.Effly''s 'Control.Monad.Fail.MonadFail' instance is based +-- on this effect; by having access to 'Fail', you're able to invoke +-- handle pattern-match failure automatically inside of effect handlers. +-- +-- Each 'Fail' interpreter's associated carrier +-- has an 'Control.Monad.Fail.MonadFail' instance based on +-- how it interprets 'Fail'. This means you can use +-- an 'Fail' interpreter to locally gain access to an 'Control.Monad.Fail.MonadFail' +-- instance inside of application code. +newtype Fail (m :: * -> *) (a :: *) where + Fail :: String -> Fail m a diff --git a/src/Control/Effect/Type/Fix.hs b/src/Control/Effect/Type/Fix.hs --- a/src/Control/Effect/Type/Fix.hs +++ b/src/Control/Effect/Type/Fix.hs @@ -24,7 +24,7 @@ -- | An effect corresponding to the 'MonadFix' type class. -- --- 'Control.Effect.Effly.Effly''s 'MonadFix' instance is based +-- 'Control.Effect.Effly''s 'MonadFix' instance is based -- on this effect; by having access to 'Fix', you're able to -- use recursive do notation inside of effect handlers. -- diff --git a/src/Control/Effect/Type/ReaderPrim.hs b/src/Control/Effect/Type/ReaderPrim.hs --- a/src/Control/Effect/Type/ReaderPrim.hs +++ b/src/Control/Effect/Type/ReaderPrim.hs @@ -23,8 +23,6 @@ import qualified Control.Monad.Trans.Writer.Lazy as LWr import qualified Control.Monad.Trans.Writer.Strict as SWr import qualified Control.Monad.Trans.Writer.CPS as CPSWr -import Control.Monad.Trans.Cont (ContT(..)) -import qualified Control.Monad.Trans.Cont as C import Control.Effect.Internal.ViaAlg import Control.Effect.Type.Regional @@ -58,7 +56,6 @@ -- * 'Control.Effect.NonDet.NonDetThreads' -- * 'Control.Effect.Stepped.SteppedThreads' -- * 'Control.Effect.Cont.ContThreads' --- * 'Control.Effect.Cont.ContFastThreads' data ReaderPrim i :: Effect where ReaderPrimAsk :: ReaderPrim i m i ReaderPrimLocal :: (i -> i) -> m a -> ReaderPrim i m a @@ -147,4 +144,5 @@ THREAD_READER(LSt.StateT s) THREAD_READER_CTX(Monoid w, LWr.WriterT w) THREAD_READER_CTX(Monoid w, SWr.WriterT w) -THREAD_READER(C.ContT r) + +-- We don't thread ReaderPrim for ContT; its MonadReader instance isn't lawful. diff --git a/src/Control/Effect/Union.hs b/src/Control/Effect/Union.hs --- a/src/Control/Effect/Union.hs +++ b/src/Control/Effect/Union.hs @@ -38,12 +38,7 @@ import Control.Effect.Internal.Membership import Control.Effect.Internal.KnownList --- For coercion purposes -import Control.Monad.Trans.Identity -import Control.Effect.Carrier.Internal.Compose -import Control.Effect.Carrier.Internal.Intro - newtype UnionC (l :: [Effect]) m a = UnionC { unUnionC :: m a } deriving ( Functor, Applicative, Monad , Alternative, MonadPlus @@ -98,7 +93,7 @@ -- | Sends uses of effects in @b@ to a @'Union' b@ effect. -- --- @'Derivs' (UnionizeC b m) = b ++ 'Derivs' m@ +-- @'Derivs' ('UnionizeC' b m) = b ++ 'Derivs' m@ unionize :: ( Eff (Union b) m , KnownList b ) @@ -107,21 +102,46 @@ unionize = unUnionizeC {-# INLINE unionize #-} -type UnionizeHeadC b = CompositionC - '[ IntroC b '[Union b] - , UnionizeC b - ] +newtype UnionizeHeadC b m a = UnionizeHeadC { unUnionizeHeadC :: m a } + deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b', MonadBaseControl b' + ) + deriving (MonadTrans, MonadTransControl) via IdentityT +instance ( HeadEff (Union b) m + , KnownList b + ) + => Carrier (UnionizeHeadC b m) where + type Derivs (UnionizeHeadC b m) = Append b (StripPrefix '[Union b] (Derivs m)) + type Prims (UnionizeHeadC b m) = Prims m + algPrims = coerce (algPrims @m) + {-# INLINE algPrims #-} + + reformulate n alg (Union pr e) = + case splitMembership @(StripPrefix '[Union b] (Derivs m)) (singList @b) pr of + Left pr' -> reformulate (n .# UnionizeHeadC) alg $ inj (Union pr' e) + Right pr' -> reformulate (n .# UnionizeHeadC) alg (Union (There pr') e) + {-# INLINE reformulate #-} + + algDerivs (Union pr e) = + case splitMembership @(StripPrefix '[Union b] (Derivs m)) (singList @b) pr of + Left pr' -> UnionizeHeadC $ algDerivs @m $ inj (Union pr' e) + Right pr' -> UnionizeHeadC $ algDerivs @m (Union (There pr') e) + {-# INLINE algDerivs #-} + -- | Rewrite uses of effects in @b@ into a @'Union' b@ effect on top of the effect stack. -- --- @'Derivs' (UnionizeC b m) = b ++ StripPrefix '['Union' b] 'Derivs' m@ +-- @'Derivs' ('UnionizeHeadC' b m) = b ++ StripPrefix '['Union' b] ('Derivs' m)@ unionizeHead :: ( HeadEff (Union b) m , KnownList b ) => UnionizeHeadC b m a -> m a -unionizeHead = coerce +unionizeHead = unUnionizeHeadC {-# INLINE unionizeHead #-} diff --git a/src/Control/Effect/Writer.hs b/src/Control/Effect/Writer.hs --- a/src/Control/Effect/Writer.hs +++ b/src/Control/Effect/Writer.hs @@ -114,6 +114,7 @@ import qualified Control.Monad.Catch as C +import Control.Monad.Trans.Reader (ReaderT) import qualified Control.Monad.Trans.Writer.CPS as W import qualified Control.Monad.Trans.Writer.Lazy as LW @@ -122,7 +123,6 @@ import Control.Effect.Carrier.Internal.Interpret import Control.Effect.Carrier.Internal.Compose import Control.Effect.Carrier.Internal.Intro -import Control.Monad.Trans.Identity -- | A pseudo-effect for connected @'Tell' o@, @'Listen' o@ and @'Pass' o@ effects. -- @@ -149,11 +149,28 @@ data TellListH -type TellListC o = CompositionC - '[ ReinterpretC TellListH (Tell o) '[Tell (Dual [o])] - , TellC (Dual [o]) - ] +newtype TellListC o m a = TellListC { + unTellListC :: + ReinterpretC TellListH (Tell o) '[Tell (Dual [o])] + ( TellC (Dual [o]) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ ReinterpretC TellListH (Tell o) '[Tell (Dual [o])] + , TellC (Dual [o]) + ] +deriving instance (Carrier m, Threads (W.WriterT (Dual [o])) (Prims m)) + => Carrier (TellListC o m) + + instance Eff (Tell (Dual [o])) m => Handler TellListH (Tell o) m where effHandler (Tell o) = tell (Dual [o]) @@ -177,16 +194,32 @@ (fmap . first) (reverse .# getDual) . runTell .# reinterpretViaHandler - .# runComposition + .# unTellListC {-# INLINE runTellList #-} data TellListLazyH -type TellListLazyC o = CompositionC - '[ ReinterpretC TellListLazyH (Tell o) '[Tell (Endo [o])] - , TellLazyC (Endo [o]) - ] +newtype TellListLazyC o m a = TellListLazyC { + unTellListLazyC :: + ReinterpretC TellListLazyH (Tell o) '[Tell (Endo [o])] + ( TellLazyC (Endo [o]) + ( m + )) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ ReinterpretC TellListLazyH (Tell o) '[Tell (Endo [o])] + , TellLazyC (Endo [o]) + ] +deriving instance (Carrier m, Threads (LW.WriterT (Endo [o])) (Prims m)) + => Carrier (TellListLazyC o m) + instance Eff (Tell (Endo [o])) m => Handler TellListLazyH (Tell o) m where effHandler (Tell o) = tell (Endo (o:)) @@ -211,7 +244,7 @@ fromEndoWriter . runTellLazy .# reinterpretViaHandler - .# runComposition + .# unTellListLazyC {-# INLINE runTellListLazy #-} @@ -426,12 +459,30 @@ tellIntoEndoTell = reinterpretViaHandler {-# INLINE tellIntoEndoTell #-} -type ListenIntoEndoListenC o = CompositionC - '[ IntroC '[Listen o, Tell o] '[Listen (Endo o), Tell (Endo o)] - , InterpretC WriterToEndoWriterH (Listen o) - , InterpretC WriterToEndoWriterH (Tell o) - ] +newtype ListenIntoEndoListenC o m a = ListenIntoEndoListenC { + unListenIntoEndoListenC :: + IntroC '[Listen o, Tell o] '[Listen (Endo o), Tell (Endo o)] + ( InterpretC WriterToEndoWriterH (Listen o) + ( InterpretC WriterToEndoWriterH (Tell o) + ( m + ))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Listen o, Tell o] '[Listen (Endo o), Tell (Endo o)] + , InterpretC WriterToEndoWriterH (Listen o) + , InterpretC WriterToEndoWriterH (Tell o) + ] +deriving instance (Monoid o, HeadEffs '[Listen (Endo o), Tell (Endo o)] m) + => Carrier (ListenIntoEndoListenC o m) + + -- | Rewrite connected @'Listen' o@ and @'Tell' o@ effects into -- connected @'Listen' ('Endo' o)@ and @'Tell' ('Endo' o)@ effects. -- @@ -439,7 +490,7 @@ -- asymptotically improves performance if the time complexity of '<>' for the -- 'Monoid' depends only on the size of the first argument. -- In particular, you should use this (if you can be bothered) if the monoid --- is a list, such as String. +-- is a list, such as 'String'. -- -- Usage is to combine this with the 'Listen' interpreter of your choice, -- followed by 'fromEndoWriter', like this: @@ -462,17 +513,36 @@ interpretViaHandler .# interpretViaHandler .# introUnderMany - .# runComposition + .# unListenIntoEndoListenC {-# INLINE listenIntoEndoListen #-} -type WriterIntoEndoWriterC o = CompositionC - '[ IntroC '[Pass o, Listen o, Tell o] - '[Pass (Endo o), Listen (Endo o), Tell (Endo o)] - , InterpretC WriterToEndoWriterH (Pass o) - , InterpretC WriterToEndoWriterH (Listen o) - , InterpretC WriterToEndoWriterH (Tell o) - ] +newtype WriterIntoEndoWriterC o m a = WriterIntoEndoWriterC { + unWriterIntoEndoWriterC :: + IntroC '[Pass o, Listen o, Tell o] + '[Pass (Endo o), Listen (Endo o), Tell (Endo o)] + ( InterpretC WriterToEndoWriterH (Pass o) + ( InterpretC WriterToEndoWriterH (Listen o) + ( InterpretC WriterToEndoWriterH (Tell o) + ( m + )))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Pass o, Listen o, Tell o] + '[Pass (Endo o), Listen (Endo o), Tell (Endo o)] + , InterpretC WriterToEndoWriterH (Pass o) + , InterpretC WriterToEndoWriterH (Listen o) + , InterpretC WriterToEndoWriterH (Tell o) + ] +deriving instance (Monoid o, HeadEffs '[Pass (Endo o), Listen (Endo o), Tell (Endo o)] m) + => Carrier (WriterIntoEndoWriterC o m) + -- | Rewrite connected @'Pass' o@, @'Listen' o@ and @'Tell' o@ effects -- -- i.e. @'Writer' o@ -- into connected @'Pass' ('Endo' o)@, -- @'Listen' ('Endo' o)@ and @'Tell' ('Endo' o)@ effects on top of the effect @@ -507,7 +577,7 @@ .# interpretViaHandler .# interpretViaHandler .# introUnderMany - .# runComposition + .# unWriterIntoEndoWriterC {-# INLINE writerIntoEndoWriter #-} -- | Transform a 'Tell' effect into another 'Tell' effect by providing a function @@ -660,14 +730,38 @@ data WriterToBracketH -type WriterToBracketC o = CompositionC - '[ IntroC '[Pass o, Listen o, Tell o] '[Local (o -> STM ()), Ask (o -> STM ())] - , InterpretC WriterToBracketH (Pass o) - , InterpretC WriterToBracketH (Listen o) - , InterpretC WriterTVarH (Tell o) - , ReaderC (o -> STM ()) - ] +newtype WriterToBracketC o m a = WriterToBracketC { + unWriterToBracketC :: + IntroC '[Pass o, Listen o, Tell o] + '[Local (o -> STM ()), Ask (o -> STM ())] + ( InterpretC WriterToBracketH (Pass o) + ( InterpretC WriterToBracketH (Listen o) + ( InterpretC WriterTVarH (Tell o) + ( ReaderC (o -> STM ()) + ( m + ))))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Pass o, Listen o, Tell o] + '[Local (o -> STM ()), Ask (o -> STM ())] + , InterpretC WriterToBracketH (Pass o) + , InterpretC WriterToBracketH (Listen o) + , InterpretC WriterTVarH (Tell o) + , ReaderC (o -> STM ()) + ] +deriving instance ( Effs '[Bracket, Embed IO] m + , Monoid o + , Threads (ReaderT (o -> STM ())) (Prims m) + ) + => Carrier (WriterToBracketC o m) + instance ( Monoid o , Effs '[Reader (o -> STM ()), Embed IO, Bracket] m ) @@ -733,43 +827,100 @@ .# interpretViaHandler .# interpretViaHandler .# introUnderMany - .# runComposition + .# unWriterToBracketC {-# INLINE writerToBracketTVar #-} data WriterTVarH -type ListenTVarC o = CompositionC - '[ IntroC '[Listen o, Tell o] - '[ ListenPrim o - , Local (o -> STM ()) - , Ask (o -> STM ()) +newtype ListenTVarC o m a = ListenTVarC { + unListenTVarC :: + IntroC '[Listen o, Tell o] + '[ ListenPrim o + , Local (o -> STM ()) + , Ask (o -> STM ()) + ] + ( InterpretC WriterTVarH (Listen o) + ( InterpretC WriterTVarH (Tell o) + ( InterpretPrimC WriterTVarH (ListenPrim o) + ( ReaderC (o -> STM ()) + ( m + ))))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Listen o, Tell o] + '[ ListenPrim o + , Local (o -> STM ()) + , Ask (o -> STM ()) + ] + , InterpretC WriterTVarH (Listen o) + , InterpretC WriterTVarH (Tell o) + , InterpretPrimC WriterTVarH (ListenPrim o) + , ReaderC (o -> STM ()) ] - , InterpretC WriterTVarH (Listen o) - , InterpretC WriterTVarH (Tell o) - , InterpretPrimC WriterTVarH (ListenPrim o) - , ReaderC (o -> STM ()) - ] -type WriterTVarC o = CompositionC - '[ IntroC '[Pass o, Listen o, Tell o] - '[ ListenPrim o - , WriterPrim o - , Local (o -> STM ()) - , Ask (o -> STM ()) +deriving instance ( Monoid o + , Eff (Embed IO) m + , MonadMask m + , Threads (ReaderT (o -> STM ())) (Prims m) + ) + => Carrier (ListenTVarC o m) + +newtype WriterTVarC o m a = WriterTVarC { + unWriterTVarC :: + IntroC '[Pass o, Listen o, Tell o] + '[ ListenPrim o + , WriterPrim o + , Local (o -> STM ()) + , Ask (o -> STM ()) + ] + ( InterpretC WriterTVarH (Pass o) + ( InterpretC WriterTVarH (Listen o) + ( InterpretC WriterTVarH (Tell o) + ( InterpretC WriterTVarH (ListenPrim o) + ( InterpretPrimC WriterTVarH (WriterPrim o) + ( ReaderC (o -> STM ()) + ( m + ))))))) a + } deriving ( Functor, Applicative, Monad + , Alternative, MonadPlus + , MonadFix, MonadFail, MonadIO + , MonadThrow, MonadCatch, MonadMask + , MonadBase b, MonadBaseControl b + ) + deriving (MonadTrans, MonadTransControl) + via CompositionBaseT + '[ IntroC '[Pass o, Listen o, Tell o] + '[ ListenPrim o + , WriterPrim o + , Local (o -> STM ()) + , Ask (o -> STM ()) + ] + , InterpretC WriterTVarH (Pass o) + , InterpretC WriterTVarH (Listen o) + , InterpretC WriterTVarH (Tell o) + , InterpretC WriterTVarH (ListenPrim o) + , InterpretPrimC WriterTVarH (WriterPrim o) + , ReaderC (o -> STM ()) ] - , InterpretC WriterTVarH (Pass o) - , InterpretC WriterTVarH (Listen o) - , InterpretC WriterTVarH (Tell o) - , InterpretC WriterTVarH (ListenPrim o) - , InterpretPrimC WriterTVarH (WriterPrim o) - , ReaderC (o -> STM ()) - ] +deriving instance ( Monoid o + , Eff (Embed IO) m + , MonadMask m + , Threads (ReaderT (o -> STM ())) (Prims m) + ) + => Carrier (WriterTVarC o m) + instance ( Monoid o , Effs '[Reader (o -> STM ()), Embed IO] m ) => Handler WriterTVarH (Tell o) m where - effHandler (Tell o) = tellTVar o + effHandler (Tell o) = liftBase (tellTVar o) {-# INLINEABLE effHandler #-} instance Eff (ListenPrim o) m @@ -982,7 +1133,7 @@ .# interpretViaHandler .# interpretViaHandler .# introUnderMany - .# runComposition + .# unListenTVarC {-# INLINE runListenTVar #-} -- | Run connected @'Pass' o@, @'Listen' o@ and @'Tell' o@ effects @@ -1038,7 +1189,7 @@ .# interpretViaHandler .# interpretViaHandler .# introUnderMany - .# runComposition + .# unWriterTVarC {-# INLINE runWriterTVar #-} @@ -1051,6 +1202,8 @@ -- -- If performance is secondary, consider using the slower 'runTellActionSimple', -- which doesn't have a higher-rank type. +-- +-- @since 0.1.1.0 runTellAction :: forall o m a . Carrier m => (o -> m ()) @@ -1084,6 +1237,8 @@ type IgnoreTellC o = InterpretC IgnoreTellH (Tell o) -- | Run a 'Tell' effect by ignoring it, doing no output at all. +-- +-- @since 0.1.1.0 ignoreTell :: forall o m a . Carrier m => IgnoreTellC o m a -> m a diff --git a/src/Control/Monad/Trans/Free/Church/Alternate.hs b/src/Control/Monad/Trans/Free/Church/Alternate.hs --- a/src/Control/Monad/Trans/Free/Church/Alternate.hs +++ b/src/Control/Monad/Trans/Free/Church/Alternate.hs @@ -1,10 +1,12 @@ module Control.Monad.Trans.Free.Church.Alternate where import Control.Applicative +import Control.Monad import Control.Monad.Trans import Control.Monad.Base import qualified Control.Monad.Fail as Fail import Control.Effect.Internal.Union +import Control.Effect.Internal.Utils import Control.Effect.Type.Unravel import Control.Effect.Type.ListenPrim import Control.Effect.Type.ReaderPrim @@ -12,18 +14,39 @@ import Control.Effect.Type.Optional import Control.Monad.Catch hiding (handle) -newtype FreeT f m a = FreeT { +newtype FreeT f (m :: * -> *) a = FreeT { unFreeT :: forall r - . (forall x. m x -> (x -> r) -> r) - -> (forall x. f x -> (x -> r) -> r) - -> (a -> r) -> r + . (forall x. f x -> (x -> m r) -> m r) + -> (a -> m r) -> m r } +data Coyoneda f a where + Coyoneda :: (x -> a) -> f x -> Coyoneda f a + +newtype LayeredFreeT f m a = LayeredFreeT { + unLayeredFreeT :: m (Either a (Coyoneda f (LayeredFreeT f m a))) + } + +toLayeredFreeT :: Monad m => FreeT f m a -> LayeredFreeT f m a +toLayeredFreeT free = + LayeredFreeT $ unFreeT free + (\fx c -> return $ Right $ Coyoneda (LayeredFreeT #. c) fx) + (return . Left) + +fromLayeredFreeT :: Monad m => LayeredFreeT f m a -> FreeT f m a +fromLayeredFreeT stack0 = FreeT $ \h c -> + let + go stack = unLayeredFreeT stack >>= \case + Left a -> c a + Right (Coyoneda cn f) -> h f (go . cn) + in + go stack0 + class (forall f. Threads (FreeT f) p) => FreeThreads p instance (forall f. Threads (FreeT f) p) => FreeThreads p liftF :: f a -> FreeT f m a -liftF f = FreeT $ \_ handler c -> f `handler` c +liftF f = FreeT $ \h c -> f `h` c {-# INLINE liftF #-} foldFreeT :: Monad m @@ -31,35 +54,45 @@ -> (forall x. (x -> m b) -> f x -> m b) -> FreeT f m a -> m b -foldFreeT b c free = unFreeT free (>>=) (flip c) (pure . b) +foldFreeT b c free = unFreeT free (flip c) (return . b) {-# INLINE foldFreeT #-} +foldFreeT' :: Monad m + => (m r -> r) + -> (a -> r) + -> (forall x. (x -> r) -> f x -> r) + -> FreeT f m a + -> r +foldFreeT' bind b h free = + bind $ unFreeT free (\fx c -> return $ h (bind . c) fx) (return . b) +{-# INLINE foldFreeT' #-} + instance Functor (FreeT f m) where - fmap f cnt = FreeT $ \bind handler c -> - unFreeT cnt bind handler (c . f) + fmap f cnt = FreeT $ \handler c -> + unFreeT cnt handler (c . f) {-# INLINE fmap #-} instance Applicative (FreeT f m) where - pure a = FreeT $ \_ _ c -> c a + pure a = FreeT $ \_ c -> c a {-# INLINE pure #-} - ff <*> fa = FreeT $ \bind handler c -> - unFreeT ff bind handler $ \f -> - unFreeT fa bind handler (c . f) + ff <*> fa = FreeT $ \handler c -> + unFreeT ff handler $ \f -> + unFreeT fa handler (c . f) {-# INLINE (<*>) #-} - liftA2 f fa fb = FreeT $ \bind handler c -> - unFreeT fa bind handler $ \a -> - unFreeT fb bind handler (c . f a) + liftA2 f fa fb = FreeT $ \handler c -> + unFreeT fa handler $ \a -> + unFreeT fb handler (c . f a) {-# INLINE liftA2 #-} fa *> fb = fa >>= \_ -> fb {-# INLINE (*>) #-} instance Monad (FreeT f m) where - m >>= f = FreeT $ \bind handler c -> - unFreeT m bind handler $ \a -> - unFreeT (f a) bind handler c + m >>= f = FreeT $ \handler c -> + unFreeT m handler $ \a -> + unFreeT (f a) handler c {-# INLINE (>>=) #-} instance MonadBase b m => MonadBase b (FreeT f m) where @@ -71,7 +104,7 @@ {-# INLINE fail #-} instance MonadTrans (FreeT f) where - lift m = FreeT $ \bind _ c -> m `bind` c + lift m = FreeT $ \_ c -> m >>= c {-# INLINE lift #-} instance MonadIO m => MonadIO (FreeT f m) where @@ -83,55 +116,43 @@ {-# INLINE throwM #-} instance MonadCatch m => MonadCatch (FreeT f m) where - catch main handle = FreeT $ \bind handler c -> - unFreeT main - (\m cn -> - (`bind` id) $ - fmap cn m - `catch` - \e -> pure $ unFreeT (handle e) bind handler c - ) - handler - c + catch main handle = FreeT $ \handler c -> + foldFreeT' (join . (`catch` \e -> return $ unFreeT (handle e) handler c)) + c + (flip handler) + main {-# INLINE catch #-} instance Monoid w => ThreadsEff (FreeT f) (ListenPrim w) where - threadEff = threadListenPrim $ \alg main -> FreeT $ \bind handler c -> - unFreeT main - (\m cn acc -> - alg (ListenPrimListen m) `bind` \(s, a) -> - cn a $! acc <> s - ) - (\eff cn acc -> handler eff (`cn` acc)) - (\a acc -> c (acc, a)) - mempty - {-# INLINE threadEff #-} + threadEff = threadListenPrim $ \alg main -> FreeT $ \h c -> + foldFreeT' (\m acc -> alg (ListenPrimListen m) >>= \(s', f) -> f $! acc <> s' + ) + (\a acc -> c (acc, a)) + (\cn fx acc -> h fx (`cn` acc)) + main + mempty instance ThreadsEff (FreeT f) (Regional s) where - threadEff alg (Regionally s m) = FreeT $ \bind handler c -> - unFreeT m (bind . alg . Regionally s) handler c + threadEff = threadRegionalViaOptional {-# INLINE threadEff #-} instance Functor s => ThreadsEff (FreeT f) (Optional s) where - threadEff alg (Optionally sa main) = FreeT $ \bind handler c -> - unFreeT main - (\m cn -> - (`bind` id) $ alg $ Optionally (fmap c sa) (fmap cn m) - ) - handler - c + threadEff alg (Optionally sa main) = FreeT $ \h c -> + foldFreeT' (\m -> join $ alg $ Optionally (fmap c sa) m) + c + (flip h) + main {-# INLINE threadEff #-} instance ThreadsEff (FreeT f) (Unravel p) where threadEff alg (Unravel p cataM main) = - unFreeT main - (\m cn -> - lift $ alg $ Unravel p - (cataM . lift) - (fmap (cataM . cn) m) - ) - (\f c -> liftF f >>= c) - return + let + n = \m' -> alg (Unravel p (cataM . lift) m') + in + lift $ n + $ unFreeT main + (\fx cn -> return $ cataM $ liftF fx >>= lift . n . cn) + return {-# INLINE threadEff #-} instance ThreadsEff (FreeT f) (ReaderPrim i) where diff --git a/src/Control/Monad/Trans/List/Church.hs b/src/Control/Monad/Trans/List/Church.hs --- a/src/Control/Monad/Trans/List/Church.hs +++ b/src/Control/Monad/Trans/List/Church.hs @@ -1,6 +1,7 @@ module Control.Monad.Trans.List.Church where import Control.Applicative +import Control.Monad import Control.Monad.Base import Control.Monad.Trans import qualified Control.Monad.Catch as C @@ -15,76 +16,66 @@ import Control.Effect.Type.Unravel import Control.Effect.Type.ReaderPrim -newtype ListT m a = ListT { +newtype ListT (m :: * -> *) a = ListT { unListT :: forall r - . (forall x. m x -> (x -> r) -> r) - -> (a -> r -> r) - -> r -- lose - -> r -- cutfail - -> r + . (a -> m r -> m r) + -> m r -- lose + -> m r -- cutfail + -> m r } + cons :: a -> ListT m a -> ListT m a -cons a m = ListT $ \bind c b t -> c a (unListT m bind c b t) +cons a m = ListT $ \c b t -> c a (unListT m c b t) instance ThreadsEff ListT (Regional s) where - threadEff alg (Regionally s m) = ListT $ \bind -> - unListT m (bind . alg . Regionally s) - {-# INLINE threadEff #-} + threadEff = threadRegionalViaOptional instance Functor s => ThreadsEff ListT (Optional s) where - threadEff alg (Optionally s m) = ListT $ \bind c b -> - unListT m (\mx cn -> - (`bind` id) $ alg $ - fmap (`c` b) s - `Optionally` - fmap cn mx - ) c b + threadEff alg (Optionally s main) = ListT $ \c b t -> + let + n = \m -> alg (Optionally (fmap (`c` b) s) m) + in + join $ n + $ unListT main + (\a r -> return $ c a (join (n r))) + (return b) + (return t) {-# INLINE threadEff #-} instance ThreadsEff ListT (Unravel p) where threadEff alg (Unravel p cataM main) = - unListT - main - (\mx cn -> lift $ alg $ - Unravel p (cataM . lift) (fmap (cataM . cn) mx) - ) - cons - lose - cutfail + let + n = \m' -> alg (Unravel p (cataM . lift) m') + in + lift $ n + $ unListT main + (\a r -> return $ cataM $ cons a (lift (n r))) + (return $ cataM lose) + (return $ cataM cutfail) {-# INLINE threadEff #-} instance Monoid s => ThreadsEff ListT (ListenPrim s) where - threadEff = threadListenPrim $ \alg main -> ListT $ \bind c b t -> - unListT - main - (\mx cn acc -> alg (ListenPrimListen mx) `bind` \(s, a) -> - let - !acc' = acc <> s - in - cn a acc' - ) - (\a r acc -> c (acc, a) (r mempty)) - (const b) - (const t) - mempty + threadEff = threadListenPrim $ \alg main -> + let + listenStack m = LayeredListT $ do + (s, e) <- alg (ListenPrimListen (unLayeredListT m)) + case e of + Right (a, r) -> return $ Right ((s, a), listenStack r) + Left failure -> return $ Left failure + in + (fromLayeredListT . listenStack . toLayeredListT) $ main {-# INLINE threadEff #-} instance Monoid s => ThreadsEff ListT (WriterPrim s) where threadEff = threadWriterPrim $ \alg main -> let - go' m = m >>= \case - Empty -> return (id, Empty) - CutFail -> return (id, CutFail) - Cons (f, a) r -> return (f, Cons a (go r)) - Embed mx cn -> go' (fmap cn mx) - - go Empty = Empty - go CutFail = CutFail - go (Cons (_, a) r) = Cons a (go r) - go (Embed mx cn) = (`Embed` id) $ alg $ WriterPrimPass $ go' (fmap cn mx) + passStack m = LayeredListT $ alg $ WriterPrimPass $ + unLayeredListT m >>= \case + Right ((f, a), r) -> return $ (f, Right (a, passStack r)) + Left e -> return $ (id, Left e) in - fromLayeredListT (go (toLayeredListT main)) + (fromLayeredListT . passStack . toLayeredListT) $ main {-# INLINE threadEff #-} instance ThreadsEff ListT (ReaderPrim i) where @@ -104,58 +95,68 @@ {-# INLINE throwM #-} instance MonadCatch m => MonadCatch (ListT m) where - catch m h = ListT $ \bind c b t -> - unListT - m - (\mx cn -> (`bind` id) $ - fmap cn mx `C.catch` \e -> return $ unListT (h e) bind c b t - ) - c b t + catch main h = ListT $ \c b t -> + let + n = (`C.catch` \e -> return $ unListT (h e) c b t) + in + join $ n + $ unListT main + (\a r -> return $ c a (join (n r))) + (return b) + (return t) {-# INLINE catch #-} cull :: ListT m a -> ListT m a -cull m = ListT $ \bind c b t -> unListT m bind (\a _ -> c a b) b t +cull m = ListT $ \c b t -> unListT m (\a _ -> c a b) b t choose :: ListT m a -> ListT m a -> ListT m a -choose ma mb = ListT $ \bind c b t -> unListT ma bind c (unListT mb bind c b t) t +choose ma mb = ListT $ \c b t -> unListT ma c (unListT mb c b t) t lose :: ListT m a -lose = ListT $ \_ _ b _ -> b +lose = ListT $ \_ b _ -> b cutfail :: ListT m a -cutfail = ListT $ \_ _ _ t -> t +cutfail = ListT $ \_ _ t -> t call :: ListT m a -> ListT m a -call m = ListT $ \bind c b _ -> unListT m bind c b b +call m = ListT $ \c b _ -> unListT m c b b -data LayeredListT m a where - Embed :: m x -> (x -> LayeredListT m a) -> LayeredListT m a - Empty :: LayeredListT m a - CutFail :: LayeredListT m a - Cons :: a -> LayeredListT m a -> LayeredListT m a +data LoseOrCutfail + = Lost + | Cutfailed -toLayeredListT :: ListT m a -> LayeredListT m a -toLayeredListT m = unListT m Embed Cons Empty CutFail +newtype LayeredListT m a = + LayeredListT { + unLayeredListT :: m (Either LoseOrCutfail (a, LayeredListT m a)) + } -split' :: LayeredListT m a -> LayeredListT m (Maybe (a, LayeredListT m a)) -split' (Embed mx cn) = Embed mx (split' . cn) -split' Empty = Cons Nothing Empty -split' CutFail = CutFail -split' (Cons a r) = Cons (Just (a, r)) Empty +toLayeredListT :: Monad m => ListT m a -> LayeredListT m a +toLayeredListT main = + LayeredListT + $ unListT main + (\a mr -> return $ Right $ (a, LayeredListT mr)) + (return $ Left Lost) + (return $ Left Cutfailed) -fromLayeredListT :: LayeredListT m a -> ListT m a -fromLayeredListT m = ListT $ \bind c b t -> +split' :: Monad m => LayeredListT m a -> LayeredListT m (Maybe (a, LayeredListT m a)) +split' m = LayeredListT $ unLayeredListT m >>= \case + Right (a, r) -> return $ Right (Just (a, r), LayeredListT $ return $ Left Lost) + Left Lost -> return $ Right (Nothing, LayeredListT $ return $ Left Lost) + Left Cutfailed -> return $ Left Cutfailed + +fromLayeredListT :: Monad m => LayeredListT m a -> ListT m a +fromLayeredListT main = ListT $ \c b t -> let - go (Embed mx cn) = mx `bind` (go . cn) - go Empty = b - go CutFail = t - go (Cons a r) = c a (go r) + go m = unLayeredListT m >>= \case + Left Lost -> b + Left Cutfailed -> t + Right (a, r) -> c a (go r) in - go m + go main -- split cutfail === cutfail -- If you don't want that behaviour, instead of @split m@, do @split (call m)@ -split :: ListT m a -> ListT m (Maybe (a, ListT m a)) +split :: Monad m => ListT m a -> ListT m (Maybe (a, ListT m a)) split = (fmap . fmap . fmap) fromLayeredListT . fromLayeredListT @@ -164,26 +165,26 @@ {-# INLINE split #-} instance Functor (ListT m) where - fmap f m = ListT $ \bind c b t -> - unListT m bind (c . f) b t + fmap f m = ListT $ \c b t -> + unListT m (c . f) b t {-# INLINE fmap #-} instance Applicative (ListT m) where - pure a = ListT $ \_ c b _ -> c a b - liftA2 f fa fb = ListT $ \bind c b t -> - unListT fa bind (\a r -> unListT fb bind (c . f a) r t) b t + pure a = ListT $ \c b _ -> c a b + liftA2 f fa fb = ListT $ \c b t -> + unListT fa (\a r -> unListT fb (c . f a) r t) b t {-# INLINE liftA2 #-} ma *> mb = ma >>= \_ -> mb {-# INLINE (*>) #-} instance Monad (ListT m) where - m >>= f = ListT $ \bind c b t -> - unListT m bind (\a r -> unListT (f a) bind c r t) b t + m >>= f = ListT $ \c b t -> + unListT m (\a r -> unListT (f a) c r t) b t {-# INLINE (>>=) #-} instance MonadTrans ListT where - lift m = ListT $ \bind c b _ -> m `bind` (`c` b) + lift m = ListT $ \c b _ -> m >>= (`c` b) {-# INLINE lift #-} instance MonadIO m => MonadIO (ListT m) where @@ -194,7 +195,7 @@ => ListT m a -> m (f a) runListT m = - unListT m (>>=) (fmap . (<|>) . pure) (pure empty) (pure empty) + unListT m (fmap . (<|>) . pure) (pure empty) (pure empty) {-# INLINE runListT #-} diff --git a/test/ContSpec.hs b/test/ContSpec.hs --- a/test/ContSpec.hs +++ b/test/ContSpec.hs @@ -34,18 +34,3 @@ let (i', j') = run $ runShift $ runReader @Int 1 $ test i' `shouldBe` 6 j' `shouldBe` 7 - - - describe "runShiftFast" $ do - it "should have horrible semantics when threading ReaderPrim. \ - \See Issue #6." $ do - let (i, j) = run $ runReader @Int 1 $ runShiftFast $ test - i `shouldBe` 6 - j `shouldNotBe` 35 -- This is what we actually want it to be - j `shouldBe` 7 - let (i', j') = run $ runReader @Int 1 $ runShiftFast $ test1 - i' `shouldBe` 3 - j' `shouldBe` 35 - let (i'', j'') = run $ runShiftFast $ runReader @Int 1 $ test - i'' `shouldBe` 6 - j'' `shouldBe` 7 diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -5,6 +5,7 @@ import Control.Effect import Control.Effect.Error import Control.Effect.Conc +import Control.Exception (throwIO, Exception) test1 :: IO (Either () (Either () ())) @@ -25,6 +26,18 @@ a <- async $ throw () wait a `catch` \() -> return () +data MyExec = MyExec deriving (Show, Eq) + +instance Exception MyExec + +test5 :: IO (Either MyExec ()) +test5 = runM $ errorToIOAsExc @MyExec $ + fmap Right (embed (throwIO MyExec)) `catch` (pure . Left) + +test6 :: IO (Either MyExec ()) +test6 = runM $ errorToIOAsExc @MyExec $ + fmap Right (throw MyExec) `catch` (pure . Left) + spec :: Spec spec = do describe "errorToIO" $ do @@ -41,3 +54,12 @@ res4 <- test4 res4 `shouldBe` Right () + + describe "errorToIO'" $ do + it "should catch any exceptions of this specific type that\ + \was thrown by other layers of the effect stack" $ do + res5 <- test5 + res5 `shouldBe` Left MyExec + + res6 <- test6 + res6 `shouldBe` Left MyExec