in-other-words 0.1.1.0 → 0.2.0.0

raw patch · 44 files changed

+1683/−1008 lines, 44 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +39/−0
• ChangeLog.md +0/−9
• README.md +1/−1
• in-other-words.cabal +8/−4
• src/Control/Effect/Alt.hs +28/−8
• src/Control/Effect/AtomicState.hs +1/−1
• src/Control/Effect/BaseControl.hs +3/−4
• src/Control/Effect/Bracket.hs +42/−1
• src/Control/Effect/Carrier/Internal/Compose.hs +22/−0
• src/Control/Effect/Carrier/Internal/Interpret.hs +3/−3
• src/Control/Effect/Carrier/Internal/Intro.hs +0/−1
• src/Control/Effect/Conc.hs +4/−17
• src/Control/Effect/Cont.hs +0/−45
• src/Control/Effect/Embed.hs +3/−1
• src/Control/Effect/Error.hs +7/−203
• src/Control/Effect/ErrorIO.hs +3/−56
• src/Control/Effect/Exceptional.hs +27/−173
• src/Control/Effect/Fail.hs +31/−6
• src/Control/Effect/Fresh.hs +25/−6
• src/Control/Effect/Internal/BaseControl.hs +0/−1
• src/Control/Effect/Internal/Conc.hs +43/−0
• src/Control/Effect/Internal/Cont.hs +3/−56
• src/Control/Effect/Internal/Derive.hs +1/−1
• src/Control/Effect/Internal/Error.hs +386/−1
• src/Control/Effect/Internal/ErrorIO.hs +82/−0
• src/Control/Effect/Internal/Exceptional.hs +262/−0
• src/Control/Effect/Internal/Intercept.hs +91/−51
• src/Control/Effect/Internal/NonDet.hs +2/−3
• src/Control/Effect/Internal/Regional.hs +0/−1
• src/Control/Effect/Internal/Select.hs +82/−0
• src/Control/Effect/Internal/Unlift.hs +0/−2
• src/Control/Effect/Newtype.hs +1/−1
• src/Control/Effect/Select.hs +1/−91
• src/Control/Effect/Trace.hs +25/−6
• src/Control/Effect/Type/Alt.hs +1/−1
• src/Control/Effect/Type/Fail.hs +16/−16
• src/Control/Effect/Type/Fix.hs +1/−1
• src/Control/Effect/Type/ReaderPrim.hs +2/−4
• src/Control/Effect/Union.hs +32/−12
• src/Control/Effect/Writer.hs +215/−60
• src/Control/Monad/Trans/Free/Church/Alternate.hs +77/−56
• src/Control/Monad/Trans/List/Church.hs +91/−90
• test/ContSpec.hs +0/−15
• test/ErrorSpec.hs +22/−0

@@ -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.

@@ -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.

@@ -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

@@ -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

@@ -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'.

@@ -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. --

@@ -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

@@ -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 

@@ -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

@@ -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 --

@@ -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])

@@ -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@.

@@ -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 

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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 #-}

@@ -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'.

@@ -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 #-}

@@ -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#)

@@ -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)

@@ -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

@@ -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.

@@ -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 #-}

@@ -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 #-}

@@ -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)

@@ -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 #-} 

@@ -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)

@@ -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) 

@@ -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 #-}

@@ -8,8 +8,6 @@ 
 import Control.Effect.Type.Unlift
 
-import Control.Monad.Trans.Identity
-
 
 data UnliftH
 

@@ -4,7 +4,7 @@ 
     -- * Unwrapping
   , EffNewtype(..)
-  , WrapperOf
+  , WrapperOf(..)
 
   , unwrap
 

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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. --

@@ -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.

@@ -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 #-}  

@@ -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

@@ -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

@@ -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 #-}  

@@ -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

@@ -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