packages feed

monadology (empty) → 0.1

raw patch · 55 files changed

+3727/−0 lines, 55 filesdep +basedep +constraintsdep +invariantsetup-changed

Dependencies added: base, constraints, invariant, monadology, tasty, tasty-hunit, transformers, type-rig, witness

Files

+ LICENSE view
@@ -0,0 +1,10 @@+monadology is Copyright (c) Ashley Yakeley, 2021.+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++- Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ changelog.md view
@@ -0,0 +1,3 @@+## [0.1] - 2022-09-12++- initial release
+ monadology.cabal view
@@ -0,0 +1,195 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           monadology+version:        0.1+description:    Monadology is intended as a collection of the best ideas in monad-related classes and types, with a focus on correctness and elegance, and theoretical understanding, rather than practical performance.+homepage:       https://github.com/AshleyYakeley/monadology#readme+bug-reports:    https://github.com/AshleyYakeley/monadology/issues+author:         Ashley Yakeley+maintainer:     <ashley@semantic.org>+copyright:      (c) 2017-2022 Ashley Yakeley+license:        BSD-2-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    changelog.md++source-repository head+  type: git+  location: https://github.com/AshleyYakeley/monadology++library+  exposed-modules:+      Control.Monad.Ology.Specific.Result+      Control.Monad.Ology.General.IO+      Control.Monad.Ology.General.Function+      Control.Monad.Ology.General.Cont+      Control.Monad.Ology.General.Inner+      Control.Monad.Ology.General.Outer+      Control.Monad.Ology.General.Extract+      Control.Monad.Ology.General.Identity+      Control.Monad.Ology.General.Exception+      Control.Monad.Ology.General.Throw+      Control.Monad.Ology.General.Catch+      Control.Monad.Ology.General.Coroutine+      Control.Monad.Ology.General.Trans.Trans+      Control.Monad.Ology.General.Trans.Constraint+      Control.Monad.Ology.General.Trans.Hoist+      Control.Monad.Ology.General.Trans.Tunnel+      Control.Monad.Ology.General.Trans.Coerce+      Control.Monad.Ology.General.Trans.Unlift+      Control.Monad.Ology.General.Trans.AskUnlift+      Control.Monad.Ology.General+      Control.Monad.Ology.Specific.ComposeInner+      Control.Monad.Ology.Specific.ComposeOuter+      Control.Monad.Ology.Specific.IdentityT+      Control.Monad.Ology.Specific.ComposeT+      Control.Monad.Ology.Specific.MaybeT+      Control.Monad.Ology.Specific.ExceptT+      Control.Monad.Ology.Specific.ReaderT+      Control.Monad.Ology.Specific.WriterT+      Control.Monad.Ology.Specific.StateT+      Control.Monad.Ology.Specific.ContT+      Control.Monad.Ology.Specific.ReaderStateT+      Control.Monad.Ology.Specific.StackT+      Control.Monad.Ology.Specific.TransformT+      Control.Monad.Ology.Specific.ResultT+      Control.Monad.Ology.Specific.StepT+      Control.Monad.Ology.Specific.CoroutineT+      Control.Monad.Ology.Specific.LifecycleT+      Control.Monad.Ology.Data.Exn+      Control.Monad.Ology.Data.Param+      Control.Monad.Ology.Data.Prod+      Control.Monad.Ology.Data.Ref+      Control.Monad.Ology.Data+      Control.Monad.Ology+  other-modules:+      Control.Monad.Ology.General.Exception.Class+      Import+  hs-source-dirs:+      src+  default-extensions:+      AllowAmbiguousTypes+      Arrows+      ConstraintKinds+      DataKinds+      DefaultSignatures+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      ForeignFunctionInterface+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImplicitParams+      NoImplicitPrelude+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      OverloadedLabels+      OverloadedStrings+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      NoStarIsType+      TemplateHaskell+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeInType+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances -Wno-partial-type-signatures+  build-depends:+      base >=4.15 && <5+    , constraints >=0.13+    , invariant >=0.6+    , transformers >=0.5+    , type-rig >=0.1+    , witness >=0.6.1+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Useful+      Exception+      Compose+      Coroutine+      Lifecycle+  hs-source-dirs:+      test+  default-extensions:+      AllowAmbiguousTypes+      Arrows+      ConstraintKinds+      DataKinds+      DefaultSignatures+      EmptyCase+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      ForeignFunctionInterface+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImplicitParams+      NoImplicitPrelude+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      OverloadedLabels+      OverloadedStrings+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      QuantifiedConstraints+      RankNTypes+      RecordWildCards+      RecursiveDo+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      StandaloneKindSignatures+      NoStarIsType+      TemplateHaskell+      TypeApplications+      TypeFamilies+      TypeFamilyDependencies+      TypeInType+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      UndecidableSuperClasses+      ViewPatterns+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances -Wno-partial-type-signatures -threaded+  build-depends:+      base >=4.15 && <5+    , monadology+    , tasty >=1.4+    , tasty-hunit >=0.10+    , transformers >=0.5+  default-language: Haskell2010
+ src/Control/Monad/Ology.hs view
@@ -0,0 +1,24 @@+module Control.Monad.Ology+    ( module I+    ) where++import Control.Monad.Ology.Data as I+import Control.Monad.Ology.General as I+import Control.Monad.Ology.Specific.ComposeInner as I+import Control.Monad.Ology.Specific.ComposeOuter as I+import Control.Monad.Ology.Specific.ComposeT as I+import Control.Monad.Ology.Specific.ContT as I+import Control.Monad.Ology.Specific.CoroutineT as I+import Control.Monad.Ology.Specific.ExceptT as I+import Control.Monad.Ology.Specific.IdentityT as I+import Control.Monad.Ology.Specific.LifecycleT as I+import Control.Monad.Ology.Specific.MaybeT as I+import Control.Monad.Ology.Specific.ReaderStateT as I+import Control.Monad.Ology.Specific.ReaderT as I+import Control.Monad.Ology.Specific.Result as I+import Control.Monad.Ology.Specific.ResultT as I+import Control.Monad.Ology.Specific.StackT as I+import Control.Monad.Ology.Specific.StateT as I+import Control.Monad.Ology.Specific.StepT as I+import Control.Monad.Ology.Specific.TransformT as I+import Control.Monad.Ology.Specific.WriterT as I
+ src/Control/Monad/Ology/Data.hs view
@@ -0,0 +1,8 @@+module Control.Monad.Ology.Data+    ( module I+    ) where++import Control.Monad.Ology.Data.Exn as I+import Control.Monad.Ology.Data.Param as I+import Control.Monad.Ology.Data.Prod as I+import Control.Monad.Ology.Data.Ref as I
+ src/Control/Monad/Ology/Data/Exn.hs view
@@ -0,0 +1,99 @@+module Control.Monad.Ology.Data.Exn where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.Result+import Import++-- | Exceptions that can be thrown and caught in this monad.+type Exn :: (Type -> Type) -> Type -> Type+data Exn m e = MkExn+    { exnThrow :: forall a. e -> m a+    , exnCatch :: forall a. m a -> (e -> m a) -> m a+    }++instance Invariant (Exn m) where+    invmap f g (MkExn t c) = MkExn (t . g) (\ma ema -> c ma $ ema . f)++instance Summable (Exn m) where+    rVoid = MkExn {exnThrow = absurd, exnCatch = \m _ -> m}+    exn1 <+++> exn2 =+        MkExn+            { exnThrow = either (exnThrow exn1) (exnThrow exn2)+            , exnCatch = \m k -> exnCatch exn1 (exnCatch exn2 m (k . Right)) (k . Left)+            }++exnTry :: Monad m => Exn m e -> m a -> m (Result e a)+exnTry exn ma = exnCatch exn (fmap SuccessResult ma) $ \e -> return $ FailureResult e++exnHandle :: Exn m e -> (e -> m a) -> m a -> m a+exnHandle exn handler ma = exnCatch exn ma handler++exnOnException ::+       forall e m a. Monad m+    => Exn m e+    -> m a+    -> m ()+    -> m a+exnOnException exn ma handler = exnCatch exn ma $ \e -> handler >> exnThrow exn e++exnBracket ::+       forall e m a b. MonadTunnelIO m+    => Exn m e+    -> m a+    -> (a -> m ())+    -> (a -> m b)+    -> m b+exnBracket exn before after thing =+    mask $ \restore -> do+        a <- before+        r <- exnOnException exn (restore (thing a)) (after a)+        _ <- after a+        return r++exnFinally ::+       forall e m a. MonadTunnelIO m+    => Exn m e+    -> m a+    -> m ()+    -> m a+exnFinally exn ma handler = exnBracket exn (return ()) (const handler) (const ma)++exnBracket_ ::+       forall e m. MonadTunnelIO m+    => Exn m e+    -> m ()+    -> m ()+    -> m --> m+exnBracket_ exn before after thing = exnBracket exn before (const after) (const thing)++mapExn :: (e2 -> e1) -> (e1 -> Maybe e2) -> Exn m e1 -> Exn m e2+mapExn f g exn =+    MkExn+        { exnThrow = exnThrow exn . f+        , exnCatch =+              \ma handler ->+                  exnCatch exn ma $ \e ->+                      case g e of+                          Nothing -> exnThrow exn e+                          Just e' -> handler e'+        }++liftExn ::+       forall t m. (MonadTransTunnel t, Monad m)+    => Exn m --> Exn (t m)+liftExn (MkExn t c :: Exn m e) = let+    t' :: forall a. e -> t m a+    t' e = lift $ t e+    c' :: forall a. t m a -> (e -> t m a) -> t m a+    c' tma handler = tunnel $ \unlift -> c (unlift tma) $ \e -> unlift $ handler e+    in MkExn t' c'++allExn ::+       forall m. MonadException m+    => Exn m (Exc m)+allExn = MkExn throwExc catchExc++someExn ::+       forall e m. MonadCatch e m+    => Exn m e+someExn = MkExn throw catch
+ src/Control/Monad/Ology/Data/Param.hs view
@@ -0,0 +1,51 @@+module Control.Monad.Ology.Data.Param where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.ReaderT+import Import++-- | borrowed from the lens package+type Lens' a b = forall f. Functor f => (b -> f b) -> a -> f a++-- | A parameter of a monad (as in 'ReaderT').+data Param m a = MkParam+    { paramAsk :: m a+    , paramWith :: a -> m --> m+    }++instance Functor m => Invariant (Param m) where+    invmap f g (MkParam a w) = MkParam (fmap f a) (\b mr -> w (g b) mr)++instance Applicative m => Productable (Param m) where+    rUnit = MkParam (pure ()) (\() -> id)+    pa <***> pb = MkParam (liftA2 (,) (paramAsk pa) (paramAsk pb)) (\(a, b) -> paramWith pa a . paramWith pb b)++paramLocal ::+       forall m a. Monad m+    => Param m a+    -> (a -> a)+    -> m --> m+paramLocal param f mr = do+    a <- paramAsk param+    paramWith param (f a) mr++lensMapParam ::+       forall m a b. Monad m+    => Lens' a b+    -> Param m a+    -> Param m b+lensMapParam l param = let+    paramAsk' = fmap (\a -> getConst $ l Const a) $ paramAsk param+    paramWith' :: b -> m --> m+    paramWith' b mr = do+        a <- paramAsk param+        paramWith param (runIdentity $ l (\_ -> Identity b) a) mr+    in MkParam paramAsk' paramWith'++liftParam :: (MonadTransTunnel t, Monad m) => Param m --> Param (t m)+liftParam (MkParam a l) = MkParam (lift a) $ \aa -> hoist $ l aa++readerParam ::+       forall m r. Monad m+    => Param (ReaderT r m) r+readerParam = MkParam ask $ \r -> with r
+ src/Control/Monad/Ology/Data/Prod.hs view
@@ -0,0 +1,45 @@+module Control.Monad.Ology.Data.Prod where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.WriterT+import Import++-- | A product of a monad (as in 'WriterT').+data Prod m a = MkProd+    { prodTell :: a -> m ()+    , prodListen :: forall r. m r -> m (r, a)+    }++instance Functor m => Invariant (Prod m) where+    invmap f g (MkProd t l) = MkProd (t . g) (\mr -> fmap (fmap f) $ l mr)++instance Applicative m => Productable (Prod m) where+    rUnit = MkProd (\() -> pure ()) $ fmap $ \r -> (r, ())+    (<***>) :: forall a b. Prod m a -> Prod m b -> Prod m (a, b)+    MkProd tellA listenA <***> MkProd tellB listenB = let+        tellAB :: (a, b) -> m ()+        tellAB (a, b) = tellA a *> tellB b+        listenAB :: m r -> m (r, (a, b))+        listenAB m = fmap (\((r, a), b) -> (r, (a, b))) $ listenB (listenA m)+        in MkProd tellAB listenAB++prodListen_ :: Functor m => Prod m a -> m () -> m a+prodListen_ p mu = fmap snd $ prodListen p mu++liftProd :: (MonadTransTunnel t, Monad m) => Prod m --> Prod (t m)+liftProd (MkProd t l) =+    MkProd (\a -> lift $ t a) $ \tmr -> tunnel $ \unlift -> fmap (\(tun, a) -> fmap (\r -> (r, a)) tun) $ l $ unlift tmr++writerProd :: Monad m => Prod (WriterT w m) w+writerProd = MkProd {prodTell = tell, prodListen = listen}++foldProd ::+       forall f m a. (Applicative f, Foldable f, Applicative m)+    => Prod m a+    -> Prod m (f a)+foldProd (MkProd prodTell prodListen) = let+    prodTell' :: f a -> m ()+    prodTell' aa = for_ aa prodTell+    prodListen' :: forall r. m r -> m (r, f a)+    prodListen' mr = fmap (\(r, a) -> (r, pure a)) $ prodListen mr+    in MkProd prodTell' prodListen'
+ src/Control/Monad/Ology/Data/Ref.hs view
@@ -0,0 +1,105 @@+module Control.Monad.Ology.Data.Ref where++import Control.Monad.Ology.Data.Param+import Control.Monad.Ology.Data.Prod+import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.StateT+import qualified Control.Monad.ST.Lazy as Lazy+import qualified Control.Monad.ST.Strict as Strict+import Data.IORef+import qualified Data.STRef.Lazy as Lazy+import qualified Data.STRef.Strict as Strict+import Import++-- | A reference of a monad (as in 'StateT').+data Ref m a = MkRef+    { refGet :: m a+    , refPut :: a -> m ()+    }++instance Functor m => Invariant (Ref m) where+    invmap f g (MkRef gt pt) = MkRef (fmap f gt) (pt . g)++instance Applicative m => Productable (Ref m) where+    rUnit = MkRef (pure ()) (\_ -> pure ())+    ra <***> rb = MkRef (liftA2 (,) (refGet ra) (refGet rb)) $ \(a, b) -> refPut ra a *> refPut rb b++refModify :: Monad m => Ref m a -> (a -> a) -> m ()+refModify ref f = do+    a <- refGet ref+    refPut ref $ f a++refModifyM :: Monad m => Ref m a -> (a -> m a) -> m ()+refModifyM ref f = do+    a <- refGet ref+    a' <- f a+    refPut ref a'++-- | Restore the original value of this reference after the operation.+refRestore :: (MonadUnliftIO m, MonadException m) => Ref m a -> m --> m+refRestore ref mr = bracket (refGet ref) (refPut ref) $ \_ -> mr++lensMapRef ::+       forall m a b. Monad m+    => Lens' a b+    -> Ref m a+    -> Ref m b+lensMapRef l ref = let+    refGet' = fmap (\a -> getConst $ l Const a) $ refGet ref+    refPut' b = do+        a <- refGet ref+        refPut ref $ runIdentity $ l (\_ -> Identity b) a+    in MkRef refGet' refPut'++liftRef :: (MonadTrans t, Monad m) => Ref m --> Ref (t m)+liftRef (MkRef g m) = MkRef (lift g) $ \a -> lift $ m a++stateRef :: Monad m => Ref (StateT s m) s+stateRef = MkRef get put++-- | Run a state monad over this reference.+refRunState :: Monad m => Ref m s -> StateT s m --> m+refRunState ref sm = do+    olds <- refGet ref+    (a, news) <- runStateT sm olds+    refPut ref news+    return a++ioRef :: IORef a -> Ref IO a+ioRef r = MkRef (readIORef r) (writeIORef r)++strictSTRef :: Strict.STRef s a -> Ref (Strict.ST s) a+strictSTRef r = MkRef (Strict.readSTRef r) (Strict.writeSTRef r)++lazySTRef :: Lazy.STRef s a -> Ref (Lazy.ST s) a+lazySTRef r = MkRef (Lazy.readSTRef r) (Lazy.writeSTRef r)++-- | Use a reference as a parameter.+refParam ::+       forall m a. (MonadUnliftIO m, MonadException m)+    => Ref m a+    -> Param m a+refParam ref = let+    paramAsk = refGet ref+    paramWith :: a -> m --> m+    paramWith a mr =+        refRestore ref $ do+            refPut ref a+            mr+    in MkParam {..}++-- | Use a reference as a product.+refProd ::+       forall m a. (MonadUnliftIO m, MonadException m, Monoid a)+    => Ref m a+    -> Prod m a+refProd ref = let+    prodTell a = refModify ref $ (<>) a+    prodListen :: forall r. m r -> m (r, a)+    prodListen mr =+        refRestore ref $ do+            refPut ref mempty+            r <- mr+            a <- refGet ref+            return (r, a)+    in MkProd {..}
+ src/Control/Monad/Ology/General.hs view
@@ -0,0 +1,22 @@+module Control.Monad.Ology.General+    ( module I+    ) where++import Control.Monad.Ology.General.Catch as I+import Control.Monad.Ology.General.Cont as I+import Control.Monad.Ology.General.Coroutine as I+import Control.Monad.Ology.General.Exception as I+import Control.Monad.Ology.General.Extract as I+import Control.Monad.Ology.General.Function as I+import Control.Monad.Ology.General.IO as I+import Control.Monad.Ology.General.Identity as I+import Control.Monad.Ology.General.Inner as I+import Control.Monad.Ology.General.Outer as I+import Control.Monad.Ology.General.Throw as I+import Control.Monad.Ology.General.Trans.AskUnlift as I+import Control.Monad.Ology.General.Trans.Coerce as I+import Control.Monad.Ology.General.Trans.Constraint as I+import Control.Monad.Ology.General.Trans.Hoist as I+import Control.Monad.Ology.General.Trans.Trans as I+import Control.Monad.Ology.General.Trans.Tunnel as I+import Control.Monad.Ology.General.Trans.Unlift as I
+ src/Control/Monad/Ology/General/Catch.hs view
@@ -0,0 +1,26 @@+module Control.Monad.Ology.General.Catch where++import qualified Control.Exception as CE+import Control.Monad.Ology.General.Exception+import Control.Monad.Ology.General.Throw+import Control.Monad.Ology.Specific.Result+import Import++-- | Monads that can catch this type of exception.+class MonadThrow e m => MonadCatch e m where+    catch :: forall a. m a -> (e -> m a) -> m a++try :: forall m e a. MonadCatch e m+    => m a+    -> m (Result e a)+try ma = catch (fmap SuccessResult ma) $ \e -> return $ FailureResult e++handle ::+       forall m e a. MonadCatch e m+    => (e -> m a)+    -> m a+    -> m a+handle handler ma = catch ma handler++instance CE.Exception e => MonadCatch e IO where+    catch ma handler = catchSomeExc ma $ \e -> for (CE.fromException e) handler
+ src/Control/Monad/Ology/General/Cont.hs view
@@ -0,0 +1,15 @@+module Control.Monad.Ology.General.Cont where++import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Trans+import Control.Monad.Ology.General.Trans.Tunnel+import Import++class Monad m => MonadCont m where+    callCC :: ((a -> m b) -> m a) -> m a++instance (MonadTransTunnel t, MonadCont m, Monad (t m)) => MonadCont (t m) where+    callCC call =+        tunnel $ \unlift ->+            callCC $ \cont ->+                unlift $ call $ \a -> lift $ cont $ runIdentity $ unlift $ withTransConstraintTM @Monad $ return a
+ src/Control/Monad/Ology/General/Coroutine.hs view
@@ -0,0 +1,56 @@+module Control.Monad.Ology.General.Coroutine where++import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.General.Trans.Trans+import Control.Monad.Ology.General.Trans.Tunnel+import Control.Monad.Ology.General.Trans.Unlift+import Control.Monad.Ology.Specific.CoroutineT+import Control.Monad.Ology.Specific.StepT+import Import++-- | Monads in which one can do coroutines.+class Monad m => MonadCoroutine m where+    coroutineSuspend :: ((p -> m q) -> m r) -> CoroutineT p q m r++-- | Uses threads.+instance MonadCoroutine IO where+    coroutineSuspend :: ((p -> IO q) -> IO r) -> CoroutineT p q IO r+    coroutineSuspend action =+        MkStepT $ do+            invar <- newEmptyMVar+            outvar <- newEmptyMVar+            _ <-+                forkIO $ do+                    r <-+                        action $ \p -> do+                            putMVar outvar $+                                Right $+                                MkTurn p $ \q ->+                                    MkStepT $ do+                                        putMVar invar q+                                        takeMVar outvar+                            takeMVar invar+                    putMVar outvar $ Left r+            takeMVar outvar++instance (MonadTransUnlift t, MonadCoroutine m, MonadTunnelIOInner m, Monad (t m)) => MonadCoroutine (t m) where+    coroutineSuspend call =+        MkStepT $+        liftWithUnlift $ \unlift ->+            (fmap $ fmap $ fmap $ hoist lift) $ unStepT $ coroutineSuspend $ \pmq -> unlift $ call $ \p -> lift $ pmq p++-- | A type synoynm for a common pattern for closing opened resources, e.g.+-- 'System.IO.withFile',+-- 'System.IO.withBinaryFile',+-- etc.+type With (m :: Type -> Type) (t :: Type) = forall (r :: Type). (t -> m r) -> m r++unpickWith ::+       forall m a. MonadCoroutine m+    => With m a+    -> m (a, m ())+unpickWith w = do+    etp <- unStepT $ coroutineSuspend w+    case etp of+        Left a -> return (a, return ())+        Right (MkTurn a f) -> return (a, fmap (\_ -> ()) $ runCoroutine $ f a)
+ src/Control/Monad/Ology/General/Exception.hs view
@@ -0,0 +1,51 @@+module Control.Monad.Ology.General.Exception+    ( module Control.Monad.Ology.General.Exception.Class+    , module Control.Monad.Ology.General.Exception+    , CE.SomeException+    , CE.evaluate+    ) where++import qualified Control.Exception as CE+import Control.Monad.Ology.General.Exception.Class+import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.General.Trans.Tunnel+import Import++-- | Run with asynchronous exceptions masked, passing an unmask function.+mask ::+       forall m b. MonadTunnelIO m+    => ((forall a. m a -> m a) -> m b)+    -> m b+mask call = tunnelIO $ \unlift -> CE.mask $ \restore -> unlift $ call $ hoistIO restore++-- | Bracket an operation with before and after operations.+-- The whole thing is masked, with the main operation unmasked.+bracket ::+       forall m a b. (MonadException m, MonadTunnelIO m)+    => m a+    -> (a -> m ())+    -> (a -> m b)+    -> m b+bracket before after thing =+    mask $ \restore -> do+        a <- before+        b <- onException (restore (thing a)) (after a)+        after a+        return b++-- | Variant of 'bracket'.+finally ::+       forall m a. (MonadException m, MonadTunnelIO m)+    => m a+    -> m ()+    -> m a+finally ma handler = bracket (return ()) (const handler) (const ma)++-- | Variant of 'bracket'.+bracket_ ::+       forall m. (MonadException m, MonadTunnelIO m)+    => m ()+    -> m ()+    -> m --> m+bracket_ before after thing = bracket before (const after) (const thing)
+ src/Control/Monad/Ology/General/Exception/Class.hs view
@@ -0,0 +1,92 @@+module Control.Monad.Ology.General.Exception.Class where++import qualified Control.Exception as CE+import Control.Monad.Ology.Specific.Result+import Import++-- | Pretty much every monad can be made an instance of this class.+class Monad m => MonadException m where+    -- | The type of /all/ exceptions of this monad.+    type Exc m :: Type+    throwExc :: Exc m -> m a+    catchExc :: m a -> (Exc m -> m a) -> m a++instance MonadException Identity where+    type Exc Identity = Void+    throwExc = absurd+    catchExc ma _ = ma++instance MonadException ((->) r) where+    type Exc ((->) r) = Void+    throwExc = absurd+    catchExc ma _ = ma++instance Monoid p => MonadException ((,) p) where+    type Exc ((,) p) = Void+    throwExc = absurd+    catchExc ma _ = ma++instance MonadException Maybe where+    type Exc Maybe = ()+    throwExc () = Nothing+    catchExc Nothing handler = handler ()+    catchExc ma _ = ma++instance MonadException [] where+    type Exc [] = ()+    throwExc _ = []+    catchExc [] handler = handler ()+    catchExc ma _ = ma++instance MonadException (Either e) where+    type Exc (Either e) = e+    throwExc = Left+    catchExc (Right a) _ = Right a+    catchExc (Left e) handler = handler e++instance MonadException (Result e) where+    type Exc (Result e) = e+    throwExc = FailureResult+    catchExc (SuccessResult a) _ = SuccessResult a+    catchExc (FailureResult e) handler = handler e++instance MonadException IO where+    type Exc IO = CE.SomeException+    throwExc = CE.throwIO+    catchExc = CE.catch++-- | Catch all exceptions, optionally returning or re-throwing.+catchSomeExc ::+       forall m a. MonadException m+    => m a+    -> (Exc m -> m (Maybe a))+    -> m a+catchSomeExc ma handler = catchExc ma $ \e -> handler e >>= maybe (throwExc e) return++fromResultExc ::+       forall m a. MonadException m+    => Result (Exc m) a+    -> m a+fromResultExc (SuccessResult a) = return a+fromResultExc (FailureResult e) = throwExc e++-- | Catch all exceptions as a 'Result'.+tryExc ::+       forall m a. MonadException m+    => m a+    -> m (Result (Exc m) a)+tryExc ma = catchExc (fmap SuccessResult ma) $ \e -> return $ FailureResult e++-- | Run the handler on exception.+-- Does not mask asynchronous exceptions on the handler.+onException ::+       forall m a. MonadException m+    => m a+    -> m ()+    -> m a+onException ma handler = catchExc ma $ \ex -> handler >> throwExc ex++-- | This catches certain "bottom values".+-- Of course, since non-termination is bottom, this cannot catch all bottoms.+catchPureError :: a -> IO (Maybe CE.SomeException)+catchPureError a = catchExc (CE.evaluate a >> return Nothing) $ \e -> return $ Just e
+ src/Control/Monad/Ology/General/Extract.hs view
@@ -0,0 +1,19 @@+module Control.Monad.Ology.General.Extract where++import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.Inner+import Import++-- | Instances of this type are isomorphic to @(Q,a)@ for some type @Q@ (with @Monoid Q@).+class MonadInner m => MonadExtract m where+    mToValue :: Extract m++instance MonadExtract Identity where+    mToValue (Identity a) = a++instance Monoid p => MonadExtract ((,) p) where+    mToValue (_, a) = a++instance MonadExtract (Either Void) where+    mToValue (Left p) = absurd p+    mToValue (Right a) = a
+ src/Control/Monad/Ology/General/Function.hs view
@@ -0,0 +1,87 @@+module Control.Monad.Ology.General.Function+    ( TransKind+    -- * Raised+    , Raised+    , type (-->)+    , WRaised(..)+    , wLift+    , wLiftIO+    -- * Backraised+    , Backraised+    , type (-/->)+    , backraisedToRaised+    , WBackraised(..)+    , wBackraisedToWRaised+    -- * Unlift+    , Unlift+    , WUnlift(..)+    , wUnliftToWRaised+    -- * Extract+    , Extract+    , WExtract(..)+    ) where++import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Trans.Trans+import Import++type TransKind = (Type -> Type) -> (Type -> Type)++type Raised :: forall k. (k -> Type) -> (k -> Type) -> Type+type Raised p q = forall a. p a -> q a++type p --> q = Raised p q++type WRaised :: forall k. (k -> Type) -> (k -> Type) -> Type+newtype WRaised p q = MkWRaised+    { unWRaised :: p --> q+    }++wLift :: (MonadTrans t, Monad m) => WRaised m (t m)+wLift = MkWRaised lift++wLiftIO :: MonadIO m => WRaised IO m+wLiftIO = MkWRaised liftIO++instance Category WRaised where+    id = MkWRaised id+    (MkWRaised bc) . (MkWRaised ab) = MkWRaised $ bc . ab++type Backraised :: forall k. (k -> Type) -> (k -> Type) -> Type+type Backraised ma mb = forall r. ((mb --> ma) -> ma r) -> mb r++type ma -/-> mb = Backraised ma mb++backraisedToRaised :: (ma -/-> mb) -> ma --> mb+backraisedToRaised mbf ma = mbf $ \_ -> ma++type WBackraised :: forall k. (k -> Type) -> (k -> Type) -> Type+newtype WBackraised p q = MkWBackraised+    { unWBackraised :: p -/-> q+    }++instance Category WBackraised where+    id = MkWBackraised $ \f -> f id+    (MkWBackraised bc) . (MkWBackraised ab) = MkWBackraised $ \f -> bc $ \mcmb -> ab $ \mbma -> f $ mbma . mcmb++wBackraisedToWRaised :: WBackraised ma mb -> WRaised ma mb+wBackraisedToWRaised (MkWBackraised f) = MkWRaised $ backraisedToRaised f++type Unlift :: ((Type -> Type) -> Constraint) -> TransKind -> Type+type Unlift c t = forall (m :: Type -> Type). c m => t m --> m++type WUnlift :: ((Type -> Type) -> Constraint) -> TransKind -> Type+newtype WUnlift c t = MkWUnlift+    { unWUnlift :: Unlift c t+    }++wUnliftToWRaised :: c m => WUnlift c t -> WRaised (t m) m+wUnliftToWRaised (MkWUnlift unlift) = MkWRaised unlift++type Extract :: (Type -> Type) -> Type+type Extract m = forall a. m a -> a++type WExtract :: (Type -> Type) -> Type+newtype WExtract m = MkWExtract+    { unWExtract :: Extract m+    }
+ src/Control/Monad/Ology/General/IO.hs view
@@ -0,0 +1,5 @@+module Control.Monad.Ology.General.IO+    ( module I+    ) where++import Control.Monad.IO.Class as I
+ src/Control/Monad/Ology/General/Identity.hs view
@@ -0,0 +1,10 @@+module Control.Monad.Ology.General.Identity where++import Control.Monad.Ology.General.Extract+import Control.Monad.Ology.General.Outer+import Import++-- | Instances of this type are isomorphic to @Identity@.+class (MonadOuter m, MonadExtract m) => MonadIdentity m++instance MonadIdentity Identity
+ src/Control/Monad/Ology/General/Inner.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.General.Inner where++import Control.Monad.Ology.General.Exception.Class+import Control.Monad.Ology.Specific.Result+import Import++-- | Monads that can compose as the inner monad with any outer monad to make a monad.+-- See 'Control.Monad.Ology.Specific.ComposeInner.ComposeInner'.+-- Instances of this type are isomorphic to @Either P (Q,a)@ for some types @P@ and @Q@ (with @Monoid Q@).+--+-- Must satisfy:+--+-- * @retrieveInner (fmap f w) = fmap f (retrieveInner w)@+--+-- * @case retrieveInner w of {Left w' -> fmap absurd w'; Right a -> fmap (\\_ -> a) w;} = w@+class (Traversable m, MonadException m) => MonadInner m where+    retrieveInner :: forall a. m a -> Result (Exc m) a++instance MonadInner Identity where+    retrieveInner (Identity a) = SuccessResult a++instance MonadInner Maybe where+    retrieveInner (Just a) = SuccessResult a+    retrieveInner Nothing = FailureResult ()++instance MonadInner (Either p) where+    retrieveInner (Right b) = SuccessResult b+    retrieveInner (Left a) = FailureResult a++instance Monoid p => MonadInner ((,) p) where+    retrieveInner (_, a) = SuccessResult a++instance MonadInner (Result e) where+    retrieveInner ra = ra++mToMaybe ::+       forall m a. MonadInner m+    => m a+    -> Maybe a+mToMaybe = resultToMaybe . retrieveInner++commuteInner ::+       forall m f a. (MonadInner m, Applicative f)+    => m (f a)+    -> f (m a)+commuteInner mfa =+    case retrieveInner mfa of+        SuccessResult fa -> fmap pure fa+        FailureResult ex -> pure $ throwExc ex
+ src/Control/Monad/Ology/General/Outer.hs view
@@ -0,0 +1,28 @@+module Control.Monad.Ology.General.Outer where++import Control.Monad.Ology.General.Function+import Import++-- | Monads that can compose as the outer monad with any inner monad to make a monad.+-- See 'Control.Monad.Ology.Specific.ComposeOuter.ComposeOuter'.+-- Instances of this type are isomorphic to @P -> a@ for some type @P@.+--+-- Must satisfy:+--+-- * @fmap (\\ex -> unWExtract ex ma) getExtract = ma@.+class Monad m => MonadOuter m where+    getExtract :: m (WExtract m)++instance MonadOuter Identity where+    getExtract = return $ MkWExtract runIdentity++instance MonadOuter ((->) r) where+    getExtract r = MkWExtract $ \ra -> ra r++commuteOuter ::+       forall m f a. (MonadOuter m, Functor f)+    => f (m a)+    -> m (f a)+commuteOuter fma = do+    MkWExtract ext <- getExtract+    return $ fmap ext fma
+ src/Control/Monad/Ology/General/Throw.hs view
@@ -0,0 +1,26 @@+module Control.Monad.Ology.General.Throw+    ( module Control.Monad.Ology.General.Throw+    , CE.Exception(..)+    , CE.ErrorCall+    , pattern CE.ErrorCall+    , CE.IOException+    ) where++import qualified Control.Exception as CE+import Control.Monad.Ology.General.Exception+import Control.Monad.Ology.Specific.Result+import Import++-- | Monads that can throw this type of exception.+class Monad m => MonadThrow e m where+    throw :: forall a. e -> m a++instance CE.Exception e => MonadThrow e IO where+    throw e = throwExc $ CE.toException e++fromResult ::+       forall m e a. MonadThrow e m+    => Result e a+    -> m a+fromResult (SuccessResult a) = return a+fromResult (FailureResult e) = throw e
+ src/Control/Monad/Ology/General/Trans/AskUnlift.hs view
@@ -0,0 +1,58 @@+module Control.Monad.Ology.General.Trans.AskUnlift where++import Control.Monad.Ology.General.Extract+import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Identity+import Control.Monad.Ology.General.Outer+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Trans+import Control.Monad.Ology.General.Trans.Tunnel+import Control.Monad.Ology.General.Trans.Unlift+import Control.Monad.Ology.Specific.ComposeOuter+import Import++-- | A transformer that has no effects (such as state change or output).+class MonadTransUnlift t => MonadTransAskUnlift t where+    askUnlift ::+           forall m. Monad m+        => t m (WUnlift Monad t)+    default askUnlift :: forall m. (MonadIdentity (Tunnel t), Monad m) => t m (WUnlift Monad t)+    askUnlift = tunnel $ \unlift -> pure $ pure $ MkWUnlift $ \tma -> fmap mToValue $ unlift tma++-- | A monad that has no effects over IO (such as state change or output).+class MonadUnliftIO m => MonadAskUnliftIO m where+    askUnliftIO :: m (WRaised m IO)+    askUnliftIO = tunnelIO $ \unlift -> pure $ pure $ MkWRaised $ \ma -> fmap mToValue $ unlift ma++instance MonadAskUnliftIO IO where+    askUnliftIO = return $ MkWRaised id++instance (MonadTransAskUnlift t, MonadAskUnliftIO m, MonadFail (t m), MonadIO (t m), MonadFix (t m)) =>+             MonadAskUnliftIO (t m) where+    askUnliftIO = do+        MkWUnlift unlift <- askUnlift+        MkWRaised unliftIO <- lift askUnliftIO+        return $ MkWRaised $ unliftIO . unlift++instance MonadTransAskUnlift t => TransConstraint MonadAskUnliftIO t where+    hasTransConstraint =+        withTransConstraintDict @MonadFail $ withTransConstraintDict @MonadIO $ withTransConstraintDict @MonadFix $ Dict++instance MonadOuter outer => MonadTransAskUnlift (ComposeOuter outer)++contractT ::+       forall (t :: TransKind) m. (MonadTransAskUnlift t, Monad m)+    => t (t m) --> t m+contractT ttma =+    case hasTransConstraint @Monad @t @m of+        Dict -> do+            MkWUnlift unlift <- askUnlift+            unlift ttma++contractTBack ::+       forall (t :: TransKind) m. (MonadTransAskUnlift t, Monad m)+    => t (t m) -/-> t m+contractTBack call =+    case hasTransConstraint @Monad @t @m of+        Dict -> contractT $ call lift
+ src/Control/Monad/Ology/General/Trans/Coerce.hs view
@@ -0,0 +1,10 @@+module Control.Monad.Ology.General.Trans.Coerce where++import Control.Monad.Ology.General.Trans.Trans+import Import++-- | A monad transformer for which coercibility is transitive.+class MonadTrans t => MonadTransCoerce t where+    transCoerce ::+           forall m1 m2. Coercible m1 m2+        => Dict (Coercible (t m1) (t m2))
+ src/Control/Monad/Ology/General/Trans/Constraint.hs view
@@ -0,0 +1,41 @@+module Control.Monad.Ology.General.Trans.Constraint where++import Control.Monad.Ology.General.Function+import Import++-- | Transitivity of some constraint @c@ from @m@ to @t m@.+type TransConstraint :: ((Type -> Type) -> Constraint) -> TransKind -> Constraint+class TransConstraint c t where+    hasTransConstraint ::+           forall (m :: Type -> Type). c m+        => Dict (c (t m))++transConstraintDict ::+       forall c t m. TransConstraint c t+    => Dict (c m)+    -> Dict (c (t m))+transConstraintDict Dict = hasTransConstraint @c @t @m++withTransConstraintTM ::+       forall c t m a. (TransConstraint c t, c m)+    => (c (t m) => t m a)+    -> t m a+withTransConstraintTM tma =+    case hasTransConstraint @c @t @m of+        Dict -> tma++withTransConstraintTM' ::+       forall c t' t m a. (TransConstraint c t, c m)+    => (c (t m) => t' (t m) a)+    -> t' (t m) a+withTransConstraintTM' tma =+    case hasTransConstraint @c @t @m of+        Dict -> tma++withTransConstraintDict ::+       forall c t m c'. (TransConstraint c t, c m)+    => (c (t m) => Dict (c' (t m)))+    -> Dict (c' (t m))+withTransConstraintDict dict =+    case hasTransConstraint @c @t @m of+        Dict -> dict
+ src/Control/Monad/Ology/General/Trans/Hoist.hs view
@@ -0,0 +1,30 @@+module Control.Monad.Ology.General.Trans.Hoist where++import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Trans+import Import++-- | Monad transformers for which monads can be hoisted.+type MonadTransHoist :: TransKind -> Constraint+class (MonadTrans t, TransConstraint Monad t) => MonadTransHoist t where+    hoist ::+           forall m1 m2. (Monad m1, Monad m2)+        => (m1 --> m2)+        -> t m1 --> t m2++hoistTransform :: (MonadTransHoist t, Monad m1, Monad m2) => (m1 --> m2) -> WRaised (t m2) --> WRaised (t m1)+hoistTransform ff (MkWRaised r2) = MkWRaised $ \m1a -> r2 $ hoist ff m1a++class MonadIO m => MonadHoistIO m where+    hoistIO :: (IO --> IO) -> m --> m++instance MonadHoistIO IO where+    hoistIO f = f++instance (MonadTransHoist t, MonadHoistIO m, MonadIO (t m)) => MonadHoistIO (t m) where+    hoistIO f = hoist $ hoistIO f++instance (MonadTransHoist t, TransConstraint MonadIO t) => TransConstraint MonadHoistIO t where+    hasTransConstraint = withTransConstraintDict @MonadIO $ Dict
+ src/Control/Monad/Ology/General/Trans/Trans.hs view
@@ -0,0 +1,5 @@+module Control.Monad.Ology.General.Trans.Trans+    ( module I+    ) where++import Control.Monad.Trans.Class as I
+ src/Control/Monad/Ology/General/Trans/Tunnel.hs view
@@ -0,0 +1,82 @@+module Control.Monad.Ology.General.Trans.Tunnel where++import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Inner+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.Specific.ComposeInner+import Import++-- | Monad transformers that allow \"tunneling\" (working with the monad under the transformer).+type MonadTransTunnel :: TransKind -> Constraint+class (MonadTransHoist t, MonadInner (Tunnel t)) => MonadTransTunnel t where+    -- | The tunnel monad of this transformer.+    type Tunnel t :: Type -> Type+    tunnel ::+           forall m r. Monad m+        => ((forall m1 a. Monad m1 => t m1 a -> m1 (Tunnel t a)) -> m (Tunnel t r))+        -> t m r++tunnelHoist ::+       forall t m1 m2. (MonadTransTunnel t, Monad m1, Monad m2)+    => (m1 --> m2)+    -> t m1 --> t m2+tunnelHoist mma sm1 = tunnel $ \tun -> mma $ tun sm1++backHoist :: (MonadTransTunnel t, Monad ma, Monad mb) => (ma -/-> mb) -> t ma -/-> t mb+backHoist wt tm = tunnel $ \unlift -> wt $ \tba -> unlift $ tm $ hoist tba++wBackHoist :: (MonadTransTunnel t, Monad ma, Monad mb) => WBackraised ma mb -> WBackraised (t ma) (t mb)+wBackHoist (MkWBackraised f) = MkWBackraised $ backHoist f++-- | Commute two transformers in a transformer stack, by commuting their tunnel monads.+commuteTWith ::+       forall ta tb m. (MonadTransTunnel ta, MonadTransTunnel tb, Monad m)+    => (forall r. Tunnel tb (Tunnel ta r) -> Tunnel ta (Tunnel tb r))+    -> ta (tb m) --> tb (ta m)+commuteTWith commutef tabm =+    case hasTransConstraint @Monad @ta @m of+        Dict ->+            case hasTransConstraint @Monad @tb @m of+                Dict -> tunnel $ \unliftb -> tunnel $ \unlifta -> fmap commutef $ unliftb $ unlifta tabm++-- | Commute two transformers in a transformer stack.+commuteT ::+       forall ta tb m. (MonadTransTunnel ta, MonadTransTunnel tb, Monad (Tunnel ta), MonadInner (Tunnel tb), Monad m)+    => ta (tb m) --> tb (ta m)+commuteT = commuteTWith commuteInner++commuteTBack ::+       forall ta tb m.+       (MonadTransTunnel ta, MonadTransTunnel tb, MonadInner (Tunnel ta), MonadInner (Tunnel tb), Monad m)+    => ta (tb m) -/-> tb (ta m)+commuteTBack call = commuteT $ call commuteT++instance MonadInner inner => MonadTransTunnel (ComposeInner inner) where+    type Tunnel (ComposeInner inner) = inner+    tunnel call = MkComposeInner $ call unComposeInner++class (MonadHoistIO m, MonadInner (TunnelIO m)) => MonadTunnelIO m where+    type TunnelIO m :: Type -> Type+    tunnelIO :: forall r. ((forall a. m a -> IO (TunnelIO m a)) -> IO (TunnelIO m r)) -> m r++instance MonadTunnelIO IO where+    type TunnelIO IO = Identity+    tunnelIO call = fmap runIdentity $ call $ \ma -> fmap Identity $ ma++instance (MonadTransTunnel t, MonadInner (Tunnel t), MonadTunnelIO m, MonadIO (t m)) => MonadTunnelIO (t m) where+    type TunnelIO (t m) = ComposeInner (Tunnel t) (TunnelIO m)+    tunnelIO call =+        tunnel $ \unlift -> tunnelIO $ \unliftIO -> fmap unComposeInner $ call $ fmap MkComposeInner . unliftIO . unlift++instance (MonadTransTunnel t, MonadInner (Tunnel t), TransConstraint MonadIO t) => TransConstraint MonadTunnelIO t where+    hasTransConstraint = withTransConstraintDict @MonadIO Dict++-- | for use in 'WUnlift', etc.+class (MonadTunnelIO m, MonadInner (TunnelIO m)) => MonadTunnelIOInner m++instance (MonadTunnelIO m, MonadInner (TunnelIO m)) => MonadTunnelIOInner m++instance (MonadTransTunnel t, MonadInner (Tunnel t), TransConstraint MonadIO t) => TransConstraint MonadTunnelIOInner t where+    hasTransConstraint = withTransConstraintDict @MonadIO Dict
+ src/Control/Monad/Ology/General/Trans/Unlift.hs view
@@ -0,0 +1,81 @@+module Control.Monad.Ology.General.Trans.Unlift where++import Control.Monad.Ology.General.Extract+import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Outer+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.General.Trans.Tunnel+import Control.Monad.Ology.Specific.ComposeOuter+import Import++class ( MonadTransTunnel t+      , TransConstraint MonadFail t+      , TransConstraint MonadIO t+      , TransConstraint MonadFix t+      , TransConstraint Monad t+      , MonadExtract (Tunnel t)+      ) => MonadTransUnlift t where+    -- | Lift with an unlifting function that accounts for the transformer's effects (using MVars where necessary).+    liftWithUnlift ::+           forall m r. MonadIO m+        => (Unlift MonadTunnelIOInner t -> m r)+        -> t m r+    -- | Return an unlifting function that discards the transformer's effects (such as state change or output).+    getDiscardingUnlift ::+           forall m. Monad m+        => t m (WUnlift MonadTunnelIOInner t)+    getDiscardingUnlift = tunnel $ \unlift -> pure $ pure $ MkWUnlift $ \tma -> fmap mToValue $ unlift tma++toDiscardingUnlift ::+       forall t. MonadTransUnlift t+    => Unlift MonadUnliftIO t+    -> Unlift MonadUnliftIO t+toDiscardingUnlift run tmr = do+    MkWUnlift du <- run getDiscardingUnlift+    du tmr++wLiftWithUnlift ::+       forall t m. (MonadTransUnlift t, MonadTunnelIOInner m)+    => WBackraised m (t m)+wLiftWithUnlift = MkWBackraised $ \call -> liftWithUnlift $ \unlift -> call unlift++composeUnliftRaised :: (MonadTransUnlift t, MonadUnliftIO m) => Unlift Functor t -> (m --> n) -> (t m --> n)+composeUnliftRaised rt rm tma = rm $ rt tma++composeUnliftRaisedCommute ::+       (MonadTransUnlift t, MonadUnliftIO m, MonadUnliftIO n) => Unlift Functor t -> (m --> n) -> (t m --> n)+composeUnliftRaisedCommute rt rm tma = rt $ hoist rm tma++class (MonadFail m, MonadIO m, MonadFix m, MonadTunnelIO m, MonadExtract (TunnelIO m)) => MonadUnliftIO m where+    -- | Lift with an unlifting function that accounts for the effects over 'IO'.+    liftIOWithUnlift :: IO -/-> m+    -- | Return an unlifting function that discards the effects over 'IO'.+    getDiscardingIOUnlift :: m (WRaised m IO)+    getDiscardingIOUnlift = tunnelIO $ \unlift -> pure $ pure $ MkWRaised $ \mr -> fmap mToValue $ unlift mr++wLiftIOWithUnlift :: MonadUnliftIO m => WBackraised IO m+wLiftIOWithUnlift = MkWBackraised liftIOWithUnlift++instance MonadUnliftIO IO where+    liftIOWithUnlift call = call id++instance (MonadTransUnlift t, MonadUnliftIO m, MonadFail (t m), MonadIO (t m), MonadFix (t m)) => MonadUnliftIO (t m) where+    liftIOWithUnlift call = liftWithUnlift $ \tmama -> liftIOWithUnlift $ \maioa -> call $ maioa . tmama++instance MonadTransUnlift t => TransConstraint MonadUnliftIO t where+    hasTransConstraint =+        withTransConstraintDict @MonadFail $ withTransConstraintDict @MonadIO $ withTransConstraintDict @MonadFix $ Dict++instance MonadOuter outer => MonadTransUnlift (ComposeOuter outer) where+    liftWithUnlift call =+        MkComposeOuter $ do+            MkWExtract extract <- getExtract+            return $ call $ extract . unComposeOuter++monoHoist ::+       forall (t :: TransKind) ma mb a b. (MonadTransUnlift t, MonadTunnelIOInner ma, MonadIO mb)+    => (ma a -> mb b)+    -> (t ma a -> t mb b)+monoHoist f tma = liftWithUnlift $ \unlift -> f $ unlift tma
+ src/Control/Monad/Ology/Specific/ComposeInner.hs view
@@ -0,0 +1,153 @@+module Control.Monad.Ology.Specific.ComposeInner where++import Control.Monad.Ology.General.Exception.Class+import Control.Monad.Ology.General.Extract+import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Identity+import Control.Monad.Ology.General.Inner+import Control.Monad.Ology.General.Outer+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.General.Trans.Trans+import Control.Monad.Ology.Specific.Result+import Import++type ComposeInner :: (Type -> Type) -> (Type -> Type) -> Type -> Type+newtype ComposeInner inner outer a = MkComposeInner+    { unComposeInner :: outer (inner a)+    }++instance (Foldable inner, Foldable outer, Functor outer) => Foldable (ComposeInner inner outer) where+    foldMap am (MkComposeInner oia) = foldMap id $ fmap (foldMap am) oia++instance (Traversable inner, Traversable outer) => Traversable (ComposeInner inner outer) where+    traverse afb (MkComposeInner oia) = fmap MkComposeInner $ traverse (traverse afb) oia++instance Traversable inner => TransConstraint Traversable (ComposeInner inner) where+    hasTransConstraint = Dict++instance (Functor inner, Functor outer) => Functor (ComposeInner inner outer) where+    fmap ab (MkComposeInner oia) = MkComposeInner $ fmap (fmap ab) oia++instance Functor inner => TransConstraint Functor (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, Monad outer) => Applicative (ComposeInner inner outer) where+    pure a = MkComposeInner $ pure $ pure a+    -- cannot use obvious definition for <*>, because that would incorrectly execute the outer part of ma even if mab fails+    mab <*> ma = do+        ab <- mab+        a <- ma+        return $ ab a++instance (MonadInner inner, Monad outer, Alternative inner) => Alternative (ComposeInner inner outer) where+    empty = MkComposeInner $ pure empty+    -- cannot use obvious definition for <|> for similar reasons as in <*>+    (MkComposeInner oia) <|> cb = do+        ma <-+            MkComposeInner $ do+                ia <- oia+                return $ fmap Just ia <|> return Nothing+        case ma of+            Just a -> return a+            Nothing -> cb++instance (MonadInner inner, Monad outer) => Monad (ComposeInner inner outer) where+    return = pure+    (MkComposeInner oia) >>= p =+        MkComposeInner $ do+            ia <- oia+            case retrieveInner ia of+                SuccessResult a -> do+                    ib <- unComposeInner $ p a+                    return $ ia >> ib+                FailureResult e -> return $ throwExc e++instance MonadInner inner => TransConstraint Monad (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, MonadFail outer) => MonadFail (ComposeInner inner outer) where+    fail s = lift $ fail s++instance MonadInner inner => TransConstraint MonadFail (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, MonadInner outer) => MonadInner (ComposeInner inner outer) where+    retrieveInner (MkComposeInner oia) =+        case retrieveInner oia of+            SuccessResult ia ->+                case retrieveInner ia of+                    SuccessResult a -> SuccessResult a+                    FailureResult e -> FailureResult $ Left e+            FailureResult e -> FailureResult $ Right e++instance MonadInner inner => TransConstraint MonadInner (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, MonadOuter inner, MonadOuter outer) => MonadOuter (ComposeInner inner outer) where+    getExtract =+        MkComposeInner $ do+            MkWExtract oaa <- getExtract+            return $ do+                MkWExtract iaa <- getExtract+                return $ MkWExtract $ \(MkComposeInner oia) -> iaa $ oaa oia++instance (MonadInner inner, MonadOuter inner) => TransConstraint MonadOuter (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, MonadFix outer) => MonadFix (ComposeInner inner outer) where+    mfix ama =+        MkComposeInner $+        mfix $ \ia ->+            unComposeInner $+            ama $+            case retrieveInner ia of+                SuccessResult a -> a+                FailureResult _ -> error "bad ComposeInner mfix"++instance MonadInner inner => TransConstraint MonadFix (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, Monad outer, Alternative inner) => MonadPlus (ComposeInner inner outer)++instance (MonadExtract inner, MonadExtract outer) => MonadExtract (ComposeInner inner outer) where+    mToValue (MkComposeInner oia) = mToValue $ mToValue oia++instance MonadExtract inner => TransConstraint MonadExtract (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadIdentity inner, MonadIdentity outer) => MonadIdentity (ComposeInner inner outer)++instance MonadIdentity inner => TransConstraint MonadIdentity (ComposeInner inner) where+    hasTransConstraint = Dict++instance (MonadInner inner, MonadIO outer) => MonadIO (ComposeInner inner outer) where+    liftIO ioa = lift $ liftIO ioa++instance MonadInner inner => TransConstraint MonadIO (ComposeInner inner) where+    hasTransConstraint = Dict++liftInner :: Applicative outer => inner --> ComposeInner inner outer+liftInner na = MkComposeInner $ pure na++instance (MonadInner inner, MonadException inner, MonadException m) => MonadException (ComposeInner inner m) where+    type Exc (ComposeInner inner m) = Either (Exc inner) (Exc m)+    throwExc (Left e) = liftInner $ throwExc e+    throwExc (Right e) = lift $ throwExc e+    catchExc (MkComposeInner mia) handler =+        MkComposeInner $ do+            ira <- tryExc mia+            case fmap retrieveInner ira of+                FailureResult e -> unComposeInner $ handler $ Right e+                SuccessResult (FailureResult e) -> unComposeInner $ handler $ Left e+                SuccessResult (SuccessResult a) -> return $ return a++instance (MonadInner inner, MonadException inner) => TransConstraint MonadException (ComposeInner inner) where+    hasTransConstraint = Dict++instance MonadInner inner => MonadTrans (ComposeInner inner) where+    lift ma = MkComposeInner $ fmap pure ma++instance MonadInner inner => MonadTransHoist (ComposeInner inner) where+    hoist ii (MkComposeInner ma) = MkComposeInner $ ii ma
+ src/Control/Monad/Ology/Specific/ComposeOuter.hs view
@@ -0,0 +1,93 @@+module Control.Monad.Ology.Specific.ComposeOuter where++import Control.Monad.Ology.General.Exception.Class+import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Outer+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.General.Trans.Trans+import Control.Monad.Ology.General.Trans.Tunnel+import Import++type ComposeOuter :: (Type -> Type) -> (Type -> Type) -> Type -> Type+newtype ComposeOuter outer inner a = MkComposeOuter+    { unComposeOuter :: outer (inner a)+    }++instance (Foldable inner, Foldable outer, Functor outer) => Foldable (ComposeOuter outer inner) where+    foldMap am (MkComposeOuter oia) = foldMap id $ fmap (foldMap am) oia++instance (Traversable inner, Traversable outer) => Traversable (ComposeOuter outer inner) where+    traverse afb (MkComposeOuter oia) = fmap MkComposeOuter $ traverse (traverse afb) oia++instance Traversable outer => TransConstraint Traversable (ComposeOuter outer) where+    hasTransConstraint = Dict++instance (Functor inner, Functor outer) => Functor (ComposeOuter outer inner) where+    fmap ab (MkComposeOuter oia) = MkComposeOuter $ fmap (fmap ab) oia++instance Functor outer => TransConstraint Functor (ComposeOuter outer) where+    hasTransConstraint = Dict++instance (Applicative inner, Applicative outer) => Applicative (ComposeOuter outer inner) where+    pure a = MkComposeOuter $ pure $ pure a+    MkComposeOuter mab <*> MkComposeOuter ma = MkComposeOuter $ liftA2 (<*>) mab ma++instance Applicative outer => TransConstraint Applicative (ComposeOuter outer) where+    hasTransConstraint = Dict++instance (Monad inner, MonadOuter outer) => Monad (ComposeOuter outer inner) where+    return = pure+    MkComposeOuter oia >>= f =+        MkComposeOuter $ do+            ia <- oia+            MkWExtract oaa <- getExtract+            return $ do+                a <- ia+                oaa $ unComposeOuter $ f a++instance MonadOuter outer => TransConstraint Monad (ComposeOuter outer) where+    hasTransConstraint = Dict++liftOuter :: (Functor outer, Applicative inner) => outer --> ComposeOuter outer inner+liftOuter oa = MkComposeOuter $ fmap pure oa++instance MonadOuter outer => MonadTrans (ComposeOuter outer) where+    lift ma = MkComposeOuter $ pure ma++instance (MonadOuter outer, MonadIO inner) => MonadIO (ComposeOuter outer inner) where+    liftIO ioa = lift $ liftIO ioa++instance MonadOuter outer => TransConstraint MonadIO (ComposeOuter outer) where+    hasTransConstraint = Dict++instance (MonadOuter outer, MonadFail inner) => MonadFail (ComposeOuter outer inner) where+    fail e = MkComposeOuter $ return $ fail e++instance MonadOuter outer => TransConstraint MonadFail (ComposeOuter outer) where+    hasTransConstraint = Dict++instance (MonadOuter outer, MonadFix inner) => MonadFix (ComposeOuter outer inner) where+    mfix f =+        MkComposeOuter $ do+            MkWExtract extract <- getExtract+            return $ mfix $ \a -> extract $ unComposeOuter $ f a++instance MonadOuter outer => TransConstraint MonadFix (ComposeOuter outer) where+    hasTransConstraint = Dict++instance (MonadOuter outer, MonadException m) => MonadException (ComposeOuter outer m) where+    type Exc (ComposeOuter outer m) = Exc m+    throwExc e = lift $ throwExc e+    catchExc tma handler = tunnel $ \unlift -> catchExc (unlift tma) $ \e -> unlift $ handler e++instance MonadOuter outer => MonadTransHoist (ComposeOuter outer) where+    hoist = tunnelHoist++instance MonadOuter outer => MonadTransTunnel (ComposeOuter outer) where+    type Tunnel (ComposeOuter outer) = Identity+    tunnel call =+        MkComposeOuter $ do+            MkWExtract oaa <- getExtract+            return $ fmap runIdentity $ call $ fmap Identity . oaa . unComposeOuter
+ src/Control/Monad/Ology/Specific/ComposeT.hs view
@@ -0,0 +1,225 @@+module Control.Monad.Ology.Specific.ComposeT+    ( ComposeT(..)+    , composeTUnlift+    , composeTWUnlift+    , liftOuterComposeT+    , liftInnerComposeT+    , liftOuterComposeTWithUnlift+    , liftInnerComposeTWithUnlift+    ) where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.ComposeInner+import Import++-- | Compose two monad transformers.+type ComposeT :: TransKind -> TransKind -> TransKind+newtype ComposeT (outerT :: TransKind) (innerT :: TransKind) (m :: Type -> Type) (a :: Type) = MkComposeT+    { unComposeT :: outerT (innerT m) a+    } deriving (Functor, Applicative, Alternative, Monad, MonadFail, MonadIO, MonadFix, MonadPlus)++liftOuterComposeT ::+       forall outerT innerT m a. (MonadTransTunnel outerT, MonadTrans innerT, TransConstraint Monad innerT, Monad m)+    => outerT m a+    -> ComposeT outerT innerT m a+liftOuterComposeT oma =+    case hasTransConstraint @Monad @innerT @m of+        Dict -> MkComposeT $ hoist lift oma++liftInnerComposeT ::+       forall outerT innerT m a. (MonadTrans outerT, TransConstraint Monad innerT, Monad m)+    => innerT m a+    -> ComposeT outerT innerT m a+liftInnerComposeT ima =+    case hasTransConstraint @Monad @innerT @m of+        Dict -> MkComposeT $ lift ima++liftOuterComposeTWithUnlift ::+       forall outerT innerT m r. (MonadTransTunnel outerT, MonadTransUnlift innerT, MonadTunnelIOInner m)+    => ((forall a. ComposeT outerT innerT m a -> outerT m a) -> outerT m r)+    -> ComposeT outerT innerT m r+liftOuterComposeTWithUnlift call =+    case hasTransConstraint @MonadIO @innerT @m of+        Dict ->+            MkComposeT $+            tunnel $ \tun -> liftWithUnlift $ \unlift -> tun $ call $ \(MkComposeT ttma) -> hoist unlift ttma++liftInnerComposeTWithUnlift ::+       forall outerT innerT m r. (MonadTransUnlift outerT, MonadTransUnlift innerT, MonadTunnelIOInner m)+    => ((forall a. ComposeT outerT innerT m a -> innerT m a) -> innerT m r)+    -> ComposeT outerT innerT m r+liftInnerComposeTWithUnlift call =+    case hasTransConstraint @MonadTunnelIOInner @innerT @m of+        Dict -> MkComposeT $ liftWithUnlift $ \unlift -> call $ \(MkComposeT ttma) -> unlift ttma++composeTUnlift ::+       forall c outerT innerT. (MonadTransUnlift innerT, TransConstraint c innerT)+    => Unlift c outerT+    -> Unlift c innerT+    -> Unlift c (ComposeT outerT innerT)+composeTUnlift ua ub (MkComposeT tatbma) = ub $ withTransConstraintTM @c $ ua tatbma++composeTWUnlift ::+       forall c outerT innerT. (MonadTransUnlift innerT, TransConstraint c innerT)+    => WUnlift c outerT+    -> WUnlift c innerT+    -> WUnlift c (ComposeT outerT innerT)+composeTWUnlift (MkWUnlift ua) (MkWUnlift ub) = MkWUnlift $ composeTUnlift @c ua ub++instance (MonadTrans outerT, MonadTrans innerT, TransConstraint Monad innerT) => MonadTrans (ComposeT outerT innerT) where+    lift (ma :: m a) =+        case hasTransConstraint @Monad @innerT @m of+            Dict -> MkComposeT $ lift $ lift ma++instance (TransConstraint Functor outerT, TransConstraint Functor innerT) =>+             TransConstraint Functor (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. Functor m+        => Dict (Functor (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @Functor @innerT @m of+            Dict ->+                case hasTransConstraint @Functor @outerT @(innerT m) of+                    Dict -> Dict++instance (TransConstraint Applicative outerT, TransConstraint Applicative innerT) =>+             TransConstraint Applicative (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. Applicative m+        => Dict (Applicative (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @Applicative @innerT @m of+            Dict ->+                case hasTransConstraint @Applicative @outerT @(innerT m) of+                    Dict -> Dict++instance (TransConstraint Monad outerT, TransConstraint Monad innerT) => TransConstraint Monad (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. Monad m+        => Dict (Monad (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @Monad @innerT @m of+            Dict ->+                case hasTransConstraint @Monad @outerT @(innerT m) of+                    Dict -> Dict++instance (TransConstraint MonadIO outerT, TransConstraint Monad innerT, TransConstraint MonadIO innerT) =>+             TransConstraint MonadIO (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. MonadIO m+        => Dict (MonadIO (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @MonadIO @innerT @m of+            Dict ->+                case hasTransConstraint @MonadIO @outerT @(innerT m) of+                    Dict -> Dict++instance (TransConstraint MonadFail outerT, TransConstraint Monad innerT, TransConstraint MonadFail innerT) =>+             TransConstraint MonadFail (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. MonadFail m+        => Dict (MonadFail (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @MonadFail @innerT @m of+            Dict ->+                case hasTransConstraint @MonadFail @outerT @(innerT m) of+                    Dict -> Dict++instance (TransConstraint MonadFix outerT, TransConstraint Monad innerT, TransConstraint MonadFix innerT) =>+             TransConstraint MonadFix (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. MonadFix m+        => Dict (MonadFix (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @MonadFix @innerT @m of+            Dict ->+                case hasTransConstraint @MonadFix @outerT @(innerT m) of+                    Dict -> Dict++instance (TransConstraint MonadPlus outerT, TransConstraint Monad innerT, TransConstraint MonadPlus innerT) =>+             TransConstraint MonadPlus (ComposeT outerT innerT) where+    hasTransConstraint ::+           forall m. MonadPlus m+        => Dict (MonadPlus (ComposeT outerT innerT m))+    hasTransConstraint =+        case hasTransConstraint @MonadPlus @innerT @m of+            Dict ->+                case hasTransConstraint @MonadPlus @outerT @(innerT m) of+                    Dict -> Dict++instance (MonadTransHoist outerT, MonadTransHoist innerT) => MonadTransHoist (ComposeT outerT innerT) where+    hoist ::+           forall m1 m2. (Monad m1, Monad m2)+        => (m1 --> m2)+        -> ComposeT outerT innerT m1 --> ComposeT outerT innerT m2+    hoist f (MkComposeT ma) =+        case hasTransConstraint @Monad @innerT @m1 of+            Dict ->+                case hasTransConstraint @Monad @innerT @m2 of+                    Dict -> MkComposeT $ hoist (hoist f) ma++instance (MonadTransTunnel outerT, MonadTransTunnel innerT) => MonadTransTunnel (ComposeT outerT innerT) where+    type Tunnel (ComposeT outerT innerT) = ComposeInner (Tunnel outerT) (Tunnel innerT)+    tunnel ::+           forall m2 r. Monad m2+        => ((forall m1 a. Monad m1 => ComposeT outerT innerT m1 a -> m1 (ComposeInner (Tunnel outerT) (Tunnel innerT) a)) -> m2 (ComposeInner (Tunnel outerT) (Tunnel innerT) r))+        -> ComposeT outerT innerT m2 r+    tunnel call =+        case hasTransConstraint @Monad @innerT @m2 of+            Dict ->+                MkComposeT $+                tunnel $ \unlift1 ->+                    tunnel $ \unlift2 ->+                        fmap unComposeInner $+                        call $ \(MkComposeT ff :: _ m1 _) ->+                            case hasTransConstraint @Monad @innerT @m1 of+                                Dict -> fmap MkComposeInner $ unlift2 $ unlift1 $ ff++instance (MonadTransCoerce outerT, MonadTransCoerce innerT, TransConstraint Monad innerT) =>+             MonadTransCoerce (ComposeT outerT innerT) where+    transCoerce ::+           forall m1 m2. Coercible m1 m2+        => Dict (Coercible (ComposeT outerT innerT m1) (ComposeT outerT innerT m2))+    transCoerce =+        case transCoerce @innerT @m1 @m2 of+            Dict ->+                case transCoerce @outerT @(innerT m1) @(innerT m2) of+                    Dict -> Dict++instance (MonadTransUnlift outerT, MonadTransUnlift innerT) => MonadTransUnlift (ComposeT outerT innerT) where+    liftWithUnlift ::+           forall m r. MonadIO m+        => (Unlift MonadTunnelIOInner (ComposeT outerT innerT) -> m r)+        -> ComposeT outerT innerT m r+    liftWithUnlift call =+        case hasTransConstraint @MonadIO @innerT @m of+            Dict ->+                MkComposeT $+                liftWithUnlift $ \unlift1 ->+                    liftWithUnlift $ \unlift2 ->+                        call $ \(MkComposeT t1t2ma) ->+                            unlift2 $ withTransConstraintTM @MonadTunnelIOInner $ unlift1 t1t2ma+    getDiscardingUnlift ::+           forall m. Monad m+        => ComposeT outerT innerT m (WUnlift MonadTunnelIOInner (ComposeT outerT innerT))+    getDiscardingUnlift =+        case hasTransConstraint @Monad @innerT @m of+            Dict ->+                MkComposeT $+                withTransConstraintTM @Monad $ do+                    unlift1 <- getDiscardingUnlift+                    unlift2 <- lift getDiscardingUnlift+                    return $ composeTWUnlift unlift1 unlift2++instance (MonadTransAskUnlift outerT, MonadTransAskUnlift innerT) => MonadTransAskUnlift (ComposeT outerT innerT) where+    askUnlift ::+           forall m. Monad m+        => ComposeT outerT innerT m (WUnlift Monad (ComposeT outerT innerT))+    askUnlift =+        case hasTransConstraint @Monad @innerT @m of+            Dict ->+                MkComposeT $+                withTransConstraintTM @Monad $ do+                    unlift1 <- askUnlift+                    unlift2 <- lift askUnlift+                    return $ composeTWUnlift unlift1 unlift2
+ src/Control/Monad/Ology/Specific/ContT.hs view
@@ -0,0 +1,47 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.ContT+    ( module Control.Monad.Trans.Cont+    , module Control.Monad.Ology.Specific.ContT+    ) where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.ReaderT+import Control.Monad.Ology.Specific.StateT+import Control.Monad.Trans.Cont hiding (callCC)+import qualified Control.Monad.Trans.Cont as T+import Import++instance TransConstraint Functor (ContT s) where+    hasTransConstraint = Dict++instance TransConstraint Applicative (ContT s) where+    hasTransConstraint = Dict++instance TransConstraint Monad (ContT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadIO (ContT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadFail (ContT s) where+    hasTransConstraint = Dict++instance forall k (r :: k) (m :: k -> Type). MonadCont (ContT r m) where+    callCC = T.callCC++instance MonadTransCoerce (ContT r) where+    transCoerce = Dict++updateContT :: (m r -> m r) -> ContT r m ()+updateContT m = ContT $ \umr -> m $ umr ()++stateToReaderContT :: Monad m => StateT s m a -> ContT r (ReaderT s m) a+stateToReaderContT (StateT sma) =+    ContT $ \c ->+        ReaderT $ \olds -> do+            (a, news) <- sma olds+            runReaderT (c a) news++hoistContT :: (m1 r1 -> m2 r2) -> (m2 r2 -> m1 r1) -> ContT r1 m1 a -> ContT r2 m2 a+hoistContT m12 m21 (ContT amrmr) = ContT $ \c -> m12 $ amrmr (m21 . c)
+ src/Control/Monad/Ology/Specific/CoroutineT.hs view
@@ -0,0 +1,29 @@+module Control.Monad.Ology.Specific.CoroutineT where++import Control.Monad.Ology.Specific.StepT+import Import++data Turn p q a =+    MkTurn p+           (q -> a)++instance Functor (Turn p q) where+    fmap ab (MkTurn p qa) = MkTurn p $ fmap ab qa++type CoroutineT p q = StepT (Turn p q)++runCoroutine :: Monad m => CoroutineT p p m a -> m a+runCoroutine = runSteps $ \(MkTurn p pa) -> pa p++yieldCoroutine :: Monad m => p -> CoroutineT p q m q+yieldCoroutine p = pendingStep $ MkTurn p id++joinCoroutines :: Monad m => CoroutineT q r m a -> (q -> CoroutineT p q m a) -> CoroutineT p r m a+joinCoroutines cqr qcpq =+    MkStepT $ do+        eqra <- unStepT cqr+        case eqra of+            Left a -> return $ Left a+            Right (MkTurn q rf) -> do+                epqa <- unStepT $ qcpq q+                return $ fmap (\(MkTurn p qa) -> MkTurn p $ \r -> joinCoroutines (rf r) qa) $ epqa
+ src/Control/Monad/Ology/Specific/ExceptT.hs view
@@ -0,0 +1,83 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.ExceptT+    ( module Control.Monad.Trans.Except+    , module Control.Monad.Ology.Specific.ExceptT+    ) where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.Result+import Control.Monad.Trans.Except hiding (liftCallCC, liftListen, liftPass)+import Import++instance TransConstraint Functor (ExceptT e) where+    hasTransConstraint = Dict++instance TransConstraint Monad (ExceptT e) where+    hasTransConstraint = Dict++instance TransConstraint MonadIO (ExceptT e) where+    hasTransConstraint = Dict++instance TransConstraint MonadFail (ExceptT e) where+    hasTransConstraint = Dict++instance TransConstraint MonadFix (ExceptT e) where+    hasTransConstraint = Dict++instance Monoid e => TransConstraint MonadPlus (ExceptT e) where+    hasTransConstraint = Dict++instance MonadInner m => MonadInner (ExceptT e m) where+    retrieveInner (ExceptT meea) =+        case retrieveInner meea of+            SuccessResult (Right a) -> SuccessResult a+            SuccessResult (Left e) -> FailureResult $ Left e+            FailureResult e -> FailureResult $ Right e++instance TransConstraint MonadInner (ExceptT e) where+    hasTransConstraint = Dict++instance MonadTransCoerce (ExceptT e) where+    transCoerce = Dict++instance MonadException m => MonadException (ExceptT e m) where+    type Exc (ExceptT e m) = Either e (Exc m)+    throwExc (Left e) = ExceptT $ return $ Left e+    throwExc (Right e) = ExceptT $ throwExc e+    catchExc (ExceptT mea) handler =+        ExceptT $ do+            ea <- tryExc mea+            case ea of+                FailureResult e -> runExceptT $ handler $ Right e+                SuccessResult (Left e) -> runExceptT $ handler $ Left e+                SuccessResult (Right a) -> return $ return a++instance TransConstraint MonadException (ExceptT e) where+    hasTransConstraint = Dict++instance MonadThrow ex m => MonadThrow (Either e ex) (ExceptT e m) where+    throw (Left e) = ExceptT $ return $ Left e+    throw (Right e) = ExceptT $ throw e++instance MonadCatch ex m => MonadCatch (Either e ex) (ExceptT e m) where+    catch (ExceptT mea) handler =+        ExceptT $ do+            ea <- try mea+            case ea of+                FailureResult e -> runExceptT $ handler $ Right e+                SuccessResult (Left e) -> runExceptT $ handler $ Left e+                SuccessResult (Right a) -> return $ return a++transExcept ::+       forall t m e a. (MonadTransTunnel t, Applicative (Tunnel t), Monad m)+    => t (ExceptT e m) a+    -> t m (Either e a)+transExcept tema = tunnel $ \unlift -> fmap commuteInner $ runExceptT $ unlift tema++instance MonadTransHoist (ExceptT e) where+    hoist = tunnelHoist++instance MonadTransTunnel (ExceptT e) where+    type Tunnel (ExceptT e) = Either e+    tunnel call = ExceptT $ call $ \(ExceptT ma) -> ma
+ src/Control/Monad/Ology/Specific/IdentityT.hs view
@@ -0,0 +1,95 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.IdentityT+    ( module Control.Monad.Trans.Identity+    , module Control.Monad.Ology.Specific.IdentityT+    ) where++import Control.Monad.Ology.General+import Control.Monad.Trans.Identity hiding (liftCallCC, liftCatch)+import Import++instance TransConstraint Functor IdentityT where+    hasTransConstraint = Dict++instance TransConstraint Applicative IdentityT where+    hasTransConstraint = Dict++instance TransConstraint Monad IdentityT where+    hasTransConstraint = Dict++instance TransConstraint MonadIO IdentityT where+    hasTransConstraint = Dict++instance TransConstraint MonadFail IdentityT where+    hasTransConstraint = Dict++instance TransConstraint MonadFix IdentityT where+    hasTransConstraint = Dict++instance TransConstraint MonadPlus IdentityT where+    hasTransConstraint = Dict++instance TransConstraint MonadOuter IdentityT where+    hasTransConstraint = Dict++instance MonadExtract m => MonadExtract (IdentityT m) where+    mToValue (IdentityT ma) = mToValue ma++instance TransConstraint MonadExtract IdentityT where+    hasTransConstraint = Dict++instance MonadException m => MonadException (IdentityT m) where+    type Exc (IdentityT m) = Exc m+    throwExc e = lift $ throwExc e+    catchExc tma handler = tunnel $ \unlift -> catchExc (unlift tma) $ \e -> unlift $ handler e++instance TransConstraint MonadException IdentityT where+    hasTransConstraint = Dict++instance MonadThrow e m => MonadThrow e (IdentityT m) where+    throw e = lift $ throw e++instance TransConstraint (MonadThrow e) IdentityT where+    hasTransConstraint = Dict++instance MonadCatch e m => MonadCatch e (IdentityT m) where+    catch ma handler = tunnel $ \unlift -> catch (unlift ma) $ \e -> unlift $ handler e++instance TransConstraint (MonadCatch e) IdentityT where+    hasTransConstraint = Dict++instance MonadInner m => MonadInner (IdentityT m) where+    retrieveInner (IdentityT ma) = retrieveInner ma++instance TransConstraint MonadInner IdentityT where+    hasTransConstraint = Dict++instance MonadIdentity m => MonadIdentity (IdentityT m)++instance TransConstraint MonadIdentity IdentityT where+    hasTransConstraint = Dict++instance MonadTransCoerce IdentityT where+    transCoerce = Dict++instance MonadTransHoist IdentityT where+    hoist = tunnelHoist++instance MonadTransTunnel IdentityT where+    type Tunnel IdentityT = Identity+    tunnel call = IdentityT $ fmap runIdentity $ call $ \(IdentityT ma) -> fmap Identity ma++instance MonadOuter m => MonadOuter (IdentityT m) where+    getExtract =+        IdentityT $ do+            MkWExtract maa <- getExtract+            return $ MkWExtract $ maa . runIdentityT++instance MonadTransUnlift IdentityT where+    liftWithUnlift call = IdentityT $ call runIdentityT++instance MonadTransAskUnlift IdentityT++identityWUnlift :: WUnlift c IdentityT+identityWUnlift = MkWUnlift runIdentityT
+ src/Control/Monad/Ology/Specific/LifecycleT.hs view
@@ -0,0 +1,236 @@+module Control.Monad.Ology.Specific.LifecycleT+    ( LifecycleT(..)+    , Lifecycle+    , runLifecycle+    , lifecycleOnCloseIO+    , lifecycleOnClose+    , lifecycleGetCloser+    , forkLifecycle+    , lifecycleMonitor+    -- * With+    , With+    , withLifecycle+    , lifecycleWith+    -- * LifeState+    , LifeState(..)+    , closeLifeState+    , getLifeState+    , addLifeState+    , modifyLifeState+    ) where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.StateT+import Import++-- | This represents all the actions that need to be done when closing the lifecycle.+newtype LifeState = MkLifeState+    { unLifeState :: Maybe (IO ()) -- special case for empty+    }++closeLifeState :: LifeState -> IO ()+closeLifeState (MkLifeState (Just c)) = c+closeLifeState (MkLifeState Nothing) = return ()++instance Semigroup LifeState where+    MkLifeState Nothing <> q = q+    p <> MkLifeState Nothing = p+    MkLifeState (Just p) <> MkLifeState (Just q) = MkLifeState $ Just $ p >> q++instance Monoid LifeState where+    mempty = MkLifeState Nothing++-- | This is for managing the automatic closing of opened resources.+newtype LifecycleT m a = MkLifecycleT+    { unLifecycleT :: MVar LifeState -> m a+    }++instance Functor m => Functor (LifecycleT m) where+    fmap ab (MkLifecycleT f) = MkLifecycleT $ \var -> fmap ab $ f var++instance TransConstraint Functor LifecycleT where+    hasTransConstraint = Dict++instance Applicative m => Applicative (LifecycleT m) where+    pure t = MkLifecycleT $ \_ -> pure t+    (MkLifecycleT ocab) <*> (MkLifecycleT oca) = MkLifecycleT $ \var -> ocab var <*> oca var++instance TransConstraint Applicative LifecycleT where+    hasTransConstraint = Dict++instance Monad m => Monad (LifecycleT m) where+    return = pure+    (MkLifecycleT va) >>= f =+        MkLifecycleT $ \var -> do+            a <- va var+            unLifecycleT (f a) var++instance TransConstraint Monad LifecycleT where+    hasTransConstraint = Dict++instance MonadTrans LifecycleT where+    lift ma = MkLifecycleT $ \_ -> ma++instance MonadFail m => MonadFail (LifecycleT m) where+    fail s = lift $ fail s++instance TransConstraint MonadFail LifecycleT where+    hasTransConstraint = Dict++instance MonadException m => MonadException (LifecycleT m) where+    type Exc (LifecycleT m) = Exc m+    throwExc e = lift $ throwExc e+    catchExc :: forall a. LifecycleT m a -> (Exc m -> LifecycleT m a) -> LifecycleT m a+    catchExc (MkLifecycleT f) handler = MkLifecycleT $ \var -> catchExc (f var) $ \e -> unLifecycleT (handler e) var++instance TransConstraint MonadException LifecycleT where+    hasTransConstraint = Dict++instance MonadThrow e m => MonadThrow e (LifecycleT m) where+    throw e = lift $ throw e++instance TransConstraint (MonadThrow e) LifecycleT where+    hasTransConstraint = Dict++instance MonadCatch e m => MonadCatch e (LifecycleT m) where+    catch (MkLifecycleT f) handler = MkLifecycleT $ \var -> catch (f var) $ \e -> unLifecycleT (handler e) var++instance TransConstraint (MonadCatch e) LifecycleT where+    hasTransConstraint = Dict++instance MonadFix m => MonadFix (LifecycleT m) where+    mfix f = MkLifecycleT $ \var -> mfix $ \a -> unLifecycleT (f a) var++instance TransConstraint MonadFix LifecycleT where+    hasTransConstraint = Dict++instance MonadIO m => MonadIO (LifecycleT m) where+    liftIO ioa = lift $ liftIO ioa++instance TransConstraint MonadIO LifecycleT where+    hasTransConstraint = Dict++instance MonadTransHoist LifecycleT where+    hoist f (MkLifecycleT g) = MkLifecycleT $ \var -> f $ g var++instance MonadTransTunnel LifecycleT where+    type Tunnel LifecycleT = Identity+    tunnel ::+           forall m r. Monad m+        => ((forall m1 a. Monad m1 => LifecycleT m1 a -> m1 (Identity a)) -> m (Identity r))+        -> LifecycleT m r+    tunnel f = MkLifecycleT $ \var -> fmap runIdentity $ f $ \a -> fmap Identity $ unLifecycleT a var++instance MonadTransUnlift LifecycleT where+    liftWithUnlift call = MkLifecycleT $ \var -> call $ \(MkLifecycleT f) -> f var+    getDiscardingUnlift =+        return $+        MkWUnlift $ \(MkLifecycleT f) -> do+            var <- liftIO $ newMVar mempty+            f var++addLifeState :: MonadIO m => LifeState -> LifecycleT m ()+addLifeState ls =+    MkLifecycleT $ \var -> do+        dangerousMVarRunStateT var $ do+            s <- get+            put $ ls <> s++-- | Add a closing action.+lifecycleOnCloseIO :: MonadIO m => IO () -> LifecycleT m ()+lifecycleOnCloseIO closer = addLifeState $ MkLifeState $ Just closer++-- | Add a closing action.+lifecycleOnClose :: MonadAskUnliftIO m => m () -> LifecycleT m ()+lifecycleOnClose closer = do+    MkWRaised unlift <- lift askUnliftIO+    lifecycleOnCloseIO $ unlift closer++-- | Convert a lifecycle to a function that uses the \"with\" pattern.+withLifecycle ::+       forall m a. (MonadException m, MonadTunnelIO m)+    => LifecycleT m a+    -> With m a+withLifecycle (MkLifecycleT f) run = do+    var <- liftIO $ newMVar mempty+    finally (f var >>= run) $+        liftIO $ do+            ls <- takeMVar var+            closeLifeState ls++-- | Run the lifecycle, then close all resources in reverse order they were opened.+runLifecycle ::+       forall m. (MonadException m, MonadTunnelIO m)+    => LifecycleT m --> m+runLifecycle lc = withLifecycle lc return++-- | Fork a thread that will complete in this lifecycle. Closing will wait for the thread to finish.+forkLifecycle :: MonadUnliftIO m => m () -> LifecycleT m ThreadId+forkLifecycle action = do+    var <- liftIO newEmptyMVar+    lifecycleOnCloseIO $ takeMVar var+    lift $ liftIOWithUnlift $ \unlift -> forkIO $ finally (unlift action) $ putMVar var ()++-- | Runs a lifecycle, but instead of running the closing actions, return them as a 'LifeState'.+getLifeState ::+       forall m a. MonadIO m+    => LifecycleT m a+    -> m (a, LifeState)+getLifeState (MkLifecycleT f) = do+    var <- liftIO $ newMVar mempty+    t <- f var+    let+        ls =+            MkLifeState $+            Just $ do+                ls0 <- takeMVar var+                closeLifeState ls0+    return (t, ls)++modifyLifeState ::+       forall m. MonadIO m+    => (LifeState -> LifeState)+    -> LifecycleT m --> LifecycleT m+modifyLifeState ss la = do+    (a, ls) <- lift $ getLifeState la+    addLifeState $ ss ls+    return a++-- | Runs the given lifecycle, returning a closer.+-- This is how you close things out of order.+--+-- The closer is an idempotent action that will close the lifecycle only if it hasn't already been closed.+-- The closer will also be run as the closer of the resulting lifecycle.+lifecycleGetCloser ::+       forall m a. MonadIO m+    => LifecycleT m a+    -> LifecycleT m (a, IO ())+lifecycleGetCloser lc = do+    (a, ls) <- lift $ getLifeState lc+    var <- liftIO $ newMVar ()+    let+        earlycloser :: IO ()+        earlycloser = do+            mu <- tryTakeMVar var+            case mu of+                Just () -> closeLifeState ls+                Nothing -> return ()+    lifecycleOnCloseIO earlycloser+    return (a, earlycloser)++-- | Returned action returns 'True' if still alive, 'False' if closed.+lifecycleMonitor :: MonadIO m => LifecycleT m (IO Bool)+lifecycleMonitor = do+    ref <- liftIO $ newIORef True+    lifecycleOnCloseIO $ writeIORef ref False+    return $ readIORef ref++-- | Convert a function that uses the \"with\" pattern to a lifecycle.+lifecycleWith :: (MonadCoroutine m, MonadAskUnliftIO m) => With m t -> LifecycleT m t+lifecycleWith withX = do+    (t, closer) <- lift $ unpickWith withX+    lifecycleOnClose closer+    return t++-- | This is the expected most common use.+type Lifecycle = LifecycleT IO
+ src/Control/Monad/Ology/Specific/MaybeT.hs view
@@ -0,0 +1,73 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.MaybeT+    ( module Control.Monad.Trans.Maybe+    ) where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.Result+import Control.Monad.Trans.Maybe hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Import++instance TransConstraint Functor MaybeT where+    hasTransConstraint = Dict++instance TransConstraint Monad MaybeT where+    hasTransConstraint = Dict++instance TransConstraint MonadIO MaybeT where+    hasTransConstraint = Dict++instance TransConstraint MonadFail MaybeT where+    hasTransConstraint = Dict++instance TransConstraint MonadFix MaybeT where+    hasTransConstraint = Dict++instance TransConstraint MonadPlus MaybeT where+    hasTransConstraint = Dict++instance MonadException m => MonadException (MaybeT m) where+    type Exc (MaybeT m) = Maybe (Exc m)+    throwExc Nothing = MaybeT $ return Nothing+    throwExc (Just e) = MaybeT $ throwExc e+    catchExc (MaybeT mea) handler =+        MaybeT $ do+            ea <- tryExc mea+            case ea of+                FailureResult e -> runMaybeT $ handler $ Just e+                SuccessResult Nothing -> runMaybeT $ handler Nothing+                SuccessResult (Just a) -> return $ return a++instance MonadThrow e m => MonadThrow (Maybe e) (MaybeT m) where+    throw Nothing = MaybeT $ return Nothing+    throw (Just e) = MaybeT $ throw e++instance MonadCatch e m => MonadCatch (Maybe e) (MaybeT m) where+    catch (MaybeT mea) handler =+        MaybeT $ do+            ea <- try mea+            case ea of+                FailureResult e -> runMaybeT $ handler $ Just e+                SuccessResult Nothing -> runMaybeT $ handler Nothing+                SuccessResult (Just a) -> return $ return a++instance MonadInner m => MonadInner (MaybeT m) where+    retrieveInner (MaybeT mma) =+        case retrieveInner mma of+            SuccessResult (Just a) -> SuccessResult a+            SuccessResult Nothing -> FailureResult Nothing+            FailureResult e -> FailureResult $ Just e++instance TransConstraint MonadInner MaybeT where+    hasTransConstraint = Dict++instance MonadTransCoerce MaybeT where+    transCoerce = Dict++instance MonadTransHoist MaybeT where+    hoist = tunnelHoist++instance MonadTransTunnel MaybeT where+    type Tunnel MaybeT = Maybe+    tunnel call = MaybeT $ call $ \(MaybeT ma) -> ma
+ src/Control/Monad/Ology/Specific/ReaderStateT.hs view
@@ -0,0 +1,33 @@+module Control.Monad.Ology.Specific.ReaderStateT where++import Control.Monad.Ology.Data+import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.StateT+import Import++type ReaderStateT f m = StateT (WRaised f m) m++evalReaderStateT :: Monad m => ReaderStateT f m a -> (f --> m) -> m a+evalReaderStateT rsa fm = evalStateT rsa (MkWRaised fm)++readerStateLift :: (Monad f, Monad m) => f --> ReaderStateT f m+readerStateLift fa = do+    MkWRaised fm <- get+    a <- lift $ fm fa+    put $ MkWRaised $ \c -> fm $ fa >> c+    return a++readerStateUpdate :: Monad m => (f --> f) -> ReaderStateT f m ()+readerStateUpdate ff = modify (\fm -> fm . MkWRaised ff)++readerStateParamRef ::+       forall f m. Monad m+    => Param f --> Ref (ReaderStateT f m)+readerStateParamRef (param :: _ a) = let+    refGet :: ReaderStateT f m a+    refGet = do+        MkWRaised ff <- get+        lift $ ff $ paramAsk param+    refPut :: a -> ReaderStateT f m ()+    refPut a = readerStateUpdate $ paramWith param a+    in MkRef {..}
+ src/Control/Monad/Ology/Specific/ReaderT.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.ReaderT+    ( module Control.Monad.Trans.Reader+    , module Control.Monad.Ology.Specific.ReaderT+    ) where++import Control.Monad.Ology.General+import Control.Monad.Trans.Reader hiding (liftCallCC, liftCatch)+import Import++with :: r -> ReaderT r m a -> ReaderT r m a+with r = local $ \_ -> r++instance TransConstraint Functor (ReaderT s) where+    hasTransConstraint = Dict++instance TransConstraint Applicative (ReaderT s) where+    hasTransConstraint = Dict++instance TransConstraint Monad (ReaderT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadIO (ReaderT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadFail (ReaderT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadFix (ReaderT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadPlus (ReaderT s) where+    hasTransConstraint = Dict++instance MonadTransCoerce (ReaderT r) where+    transCoerce = Dict++instance MonadException m => MonadException (ReaderT r m) where+    type Exc (ReaderT r m) = Exc m+    throwExc e = lift $ throwExc e+    catchExc tma handler = tunnel $ \unlift -> catchExc (unlift tma) $ \e -> unlift $ handler e++instance TransConstraint MonadException (ReaderT r) where+    hasTransConstraint = Dict++instance MonadThrow e m => MonadThrow e (ReaderT r m) where+    throw e = lift $ throw e++instance TransConstraint (MonadThrow e) (ReaderT r) where+    hasTransConstraint = Dict++instance MonadCatch e m => MonadCatch e (ReaderT r m) where+    catch ma handler = tunnel $ \unlift -> catch (unlift ma) $ \e -> unlift $ handler e++instance TransConstraint (MonadCatch e) (ReaderT r) where+    hasTransConstraint = Dict++instance MonadOuter m => MonadOuter (ReaderT r m) where+    getExtract =+        ReaderT $ \r -> do+            MkWExtract maa <- getExtract+            return $ MkWExtract $ \(ReaderT rma) -> maa $ rma r++instance TransConstraint MonadOuter (ReaderT s) where+    hasTransConstraint = Dict++instance MonadTransHoist (ReaderT r) where+    hoist = tunnelHoist++instance MonadTransTunnel (ReaderT r) where+    type Tunnel (ReaderT r) = Identity+    tunnel call = ReaderT $ \r -> fmap runIdentity $ call $ \(ReaderT smr) -> fmap Identity $ smr r++instance MonadTransUnlift (ReaderT r) where+    liftWithUnlift call = ReaderT $ \r -> call $ \(ReaderT smr) -> smr r++instance MonadTransAskUnlift (ReaderT r)++readerTUnliftToT ::+       forall t m. (MonadTransUnlift t, MonadTunnelIO m)+    => ReaderT (WUnlift MonadTunnelIOInner t) m --> t m+readerTUnliftToT rma = liftWithUnlift $ \tr -> runReaderT rma $ MkWUnlift tr++tToReaderTUnlift :: MonadTunnelIO m => t m --> ReaderT (WUnlift Monad t) m+tToReaderTUnlift tma = do+    MkWUnlift unlift <- ask+    lift $ unlift tma
+ src/Control/Monad/Ology/Specific/Result.hs view
@@ -0,0 +1,82 @@+module Control.Monad.Ology.Specific.Result where++import Import++data Result e a+    = SuccessResult a+    | FailureResult e++resultToMaybe :: Result e a -> Maybe a+resultToMaybe (SuccessResult a) = Just a+resultToMaybe _ = Nothing++resultToM :: MonadFail m => Result String a -> m a+resultToM (SuccessResult a) = return a+resultToM (FailureResult e) = fail e++resultToEither :: Result e a -> Either e a+resultToEither (FailureResult e) = Left e+resultToEither (SuccessResult a) = Right a++eitherToResult :: Either e a -> Result e a+eitherToResult (Left e) = FailureResult e+eitherToResult (Right a) = SuccessResult a++resultFromMaybe :: e -> Maybe a -> Result e a+resultFromMaybe _ (Just a) = SuccessResult a+resultFromMaybe e Nothing = FailureResult e++maybeToM :: MonadFail m => String -> Maybe a -> m a+maybeToM e = resultToM . resultFromMaybe e++deriving instance (Eq e, Eq a) => Eq (Result e a)++instance Functor (Result e) where+    fmap ab (SuccessResult a) = SuccessResult (ab a)+    fmap _ (FailureResult e) = FailureResult e++instance Foldable (Result e) where+    foldMap am (SuccessResult a) = am a+    foldMap _ (FailureResult _) = mempty++instance Traversable (Result e) where+    traverse afb (SuccessResult a) = fmap SuccessResult (afb a)+    traverse _ (FailureResult e) = pure (FailureResult e)+    sequenceA (SuccessResult fa) = fmap SuccessResult fa+    sequenceA (FailureResult e) = pure (FailureResult e)++instance Applicative (Result e) where+    pure = SuccessResult+    (SuccessResult ab) <*> (SuccessResult a) = SuccessResult (ab a)+    (SuccessResult _) <*> (FailureResult e) = FailureResult e+    (FailureResult e) <*> _ = FailureResult e++instance Monad (Result e) where+    (FailureResult e) >>= _ = FailureResult e+    (SuccessResult a) >>= amq = amq a++instance IsString e => MonadFail (Result e) where+    fail s = FailureResult $ fromString s++instance Monoid e => Alternative (Result e) where+    empty = FailureResult mempty+    (SuccessResult a) <|> _ = SuccessResult a+    (FailureResult _) <|> (SuccessResult a) = SuccessResult a+    (FailureResult e1) <|> (FailureResult e2) = FailureResult $ mappend e1 e2++instance Monoid e => MonadPlus (Result e)++instance MonadFix (Result e) where+    mfix ama = let+        getSuccess (SuccessResult a) = a+        getSuccess (FailureResult _) = error "mfix FailureResult"+        ma = ama $ getSuccess ma+        in ma++instance (Show e, Show a) => Show (Result e a) where+    show (SuccessResult a) = "success: " ++ show a+    show (FailureResult e) = "failure: " ++ show e++mapResultFailure :: (e1 -> e2) -> Result e1 a -> Result e2 a+mapResultFailure _ (SuccessResult a) = SuccessResult a+mapResultFailure e1e2 (FailureResult e1) = FailureResult (e1e2 e1)
+ src/Control/Monad/Ology/Specific/ResultT.hs view
@@ -0,0 +1,37 @@+module Control.Monad.Ology.Specific.ResultT where++import Control.Monad.Ology.Data.Exn+import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.ComposeInner+import Control.Monad.Ology.Specific.Result+import Import++type ResultT e = ComposeInner (Result e)++runResultT :: forall m e a. ResultT e m a -> m (Result e a)+runResultT = unComposeInner++-- | Throw the parameterised exception type.+throwR ::+       forall m e a. Monad m+    => e+    -> ResultT e m a+throwR e = liftInner $ throwExc e++-- | Catch the parameterised exception type.+catchR ::+       forall m e e' a. Monad m+    => ResultT e m a+    -> (e -> ResultT e' m a)+    -> ResultT e' m a+catchR (MkComposeInner rma) handler =+    MkComposeInner $ do+        rea <- rma+        case rea of+            SuccessResult a -> return $ SuccessResult a+            FailureResult e -> unComposeInner $ handler e++resultExn ::+       forall m e. Monad m+    => Exn (ResultT e m) e+resultExn = MkExn throwR catchR
+ src/Control/Monad/Ology/Specific/StackT.hs view
@@ -0,0 +1,519 @@+module Control.Monad.Ology.Specific.StackT+    ( witTransStackDict+    , IsStack+    , transStackDict+    , StackT(..)+    , stackLift+    , stackHoist+    , WithTunnelConstraint+    , MonadTransStackTunnel+    , transStackExcept+    , stackUnderliftIO+    , stackBackHoist+    , MonadTransStackUnlift+    , concatMonadTransStackUnliftDict+    , stackLiftWithUnlift+    , stackConcatFst+    , stackConcatSnd+    , stackCommute+    , transStackConcatRefl+    , StackUnlift+    , WStackUnlift(..)+    , consWStackUnlift+    , stackLiftWithStackUnlift+    ) where++import Control.Monad.Ology.General+import Control.Monad.Ology.Specific.ComposeInner+import Control.Monad.Ology.Specific.ExceptT+import Import++witTransStackDict ::+       forall cm tt m. (cm m)+    => ListType (Compose Dict (TransConstraint cm)) tt+    -> Dict (cm (ApplyStack tt m))+witTransStackDict NilListType = Dict+witTransStackDict (ConsListType (Compose Dict) lt) =+    case witTransStackDict @cm @_ @m lt of+        d -> transConstraintDict @cm d++type IsStack :: (TransKind -> Constraint) -> [TransKind] -> Constraint+type IsStack ct = Is (ListType (Compose Dict ct))++transStackDict ::+       forall cm tt m. (IsStack (TransConstraint cm) tt, cm m)+    => Dict (cm (ApplyStack tt m))+transStackDict = witTransStackDict @cm @tt @m $ representative @_ @(ListType (Compose Dict (TransConstraint cm))) @tt++-- | A monad transformer that is the composition of a list of monad transformers.+type StackT :: [TransKind] -> TransKind+newtype StackT (tt :: [TransKind]) m a = MkStackT+    { unStackT :: ApplyStack tt m a+    }++instance (IsStack (TransConstraint Monad) tt, Monad m) => Functor (StackT tt m) where+    fmap =+        case transStackDict @Monad @tt @m of+            Dict -> \ab (MkStackT ma) -> MkStackT $ fmap ab ma++instance (IsStack (TransConstraint Monad) tt, Monad m) => Applicative (StackT tt m) where+    pure =+        case transStackDict @Monad @tt @m of+            Dict -> \a -> MkStackT $ pure a+    (<*>) =+        case transStackDict @Monad @tt @m of+            Dict -> \(MkStackT mab) (MkStackT ma) -> MkStackT $ mab <*> ma++instance (IsStack (TransConstraint Monad) tt, Monad m) => Monad (StackT tt m) where+    return = pure+    (>>=) =+        case transStackDict @Monad @tt @m of+            Dict -> \(MkStackT ma) amb -> MkStackT $ ma >>= \a -> unStackT $ amb a++instance (IsStack (TransConstraint Monad) tt) => TransConstraint Monad (StackT tt) where+    hasTransConstraint = Dict++instance (IsStack (TransConstraint Monad) tt, IsStack MonadTrans tt, MonadFail m) => MonadFail (StackT tt m) where+    fail s = lift $ fail s++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadFail) tt, IsStack MonadTrans tt) =>+             TransConstraint MonadFail (StackT tt) where+    hasTransConstraint = Dict++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadFix) tt, MonadFix m) =>+             MonadFix (StackT tt m) where+    mfix :: forall a. (a -> StackT tt m a) -> StackT tt m a+    mfix =+        case transStackDict @MonadFix @tt @m of+            Dict -> \f -> MkStackT $ mfix $ \a -> unStackT $ f a++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadFix) tt) =>+             TransConstraint MonadFix (StackT tt) where+    hasTransConstraint = Dict++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadIO) tt, MonadIO m) => MonadIO (StackT tt m) where+    liftIO =+        case transStackDict @MonadIO @tt @m of+            Dict -> \ioa -> MkStackT $ liftIO ioa++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadIO) tt) =>+             TransConstraint MonadIO (StackT tt) where+    hasTransConstraint = Dict++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadPlus) tt, MonadPlus m) =>+             Alternative (StackT tt m) where+    empty =+        case transStackDict @MonadPlus @tt @m of+            Dict -> MkStackT empty+    (<|>) =+        case transStackDict @MonadPlus @tt @m of+            Dict -> \(MkStackT a) (MkStackT b) -> MkStackT $ a <|> b++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadPlus) tt, MonadPlus m) =>+             MonadPlus (StackT tt m)++instance (IsStack (TransConstraint Monad) tt, IsStack (TransConstraint MonadPlus) tt) =>+             TransConstraint MonadPlus (StackT tt) where+    hasTransConstraint = Dict++instance (IsStack (TransConstraint Monad) tt, IsStack MonadTrans tt) => MonadTrans (StackT tt) where+    lift ::+           forall m a. Monad m+        => m a+        -> StackT tt m a+    lift = let+        build ::+               forall tt'.+               ListType (Compose Dict (TransConstraint Monad)) tt'+            -> ListType (Compose Dict MonadTrans) tt'+            -> (WRaised m (ApplyStack tt' m), Dict (Monad (ApplyStack tt' m)))+        build NilListType NilListType = (id, Dict)+        build (ConsListType (Compose Dict) wa) (ConsListType (Compose Dict) wb) =+            case build wa wb of+                (wmf, dcm@Dict) -> (wLift . wmf, transConstraintDict @Monad dcm)+        in let+               wa = representative @_ @(ListType (Compose Dict (TransConstraint Monad))) @tt+               wb = representative @_ @(ListType (Compose Dict MonadTrans)) @tt+               in case build wa wb of+                      (wmf, _) -> \ma -> MkStackT $ unWRaised wmf ma++stackLift ::+       forall tt m. (IsStack (TransConstraint Monad) tt, IsStack MonadTrans tt, Monad m)+    => m --> ApplyStack tt m+stackLift ma = unStackT @tt @m $ lift ma++type MonadTransStackTunnel tt+     = ( IsStack (TransConstraint Monad) tt+       , IsStack MonadTransTunnel tt+       , IsStack MonadTrans tt+       , IsStack (WithTunnelConstraint Functor) tt+       , IsStack (WithTunnelConstraint Applicative) tt+       , IsStack (WithTunnelConstraint Monad) tt+       , IsStack (WithTunnelConstraint Traversable) tt+       , IsStack (WithTunnelConstraint MonadInner) tt)++concatMonadTransStackTunnelDict ::+       forall tt1 tt2. (MonadTransStackTunnel tt1, MonadTransStackTunnel tt2)+    => Dict (MonadTransStackTunnel (Concat tt1 tt2))+concatMonadTransStackTunnelDict =+    withConcatIs @_ @(Compose Dict (TransConstraint Monad)) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict MonadTransTunnel) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict MonadTrans) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict (WithTunnelConstraint Functor)) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict (WithTunnelConstraint Applicative)) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict (WithTunnelConstraint Monad)) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict (WithTunnelConstraint Traversable)) @tt1 @tt2 $+    withConcatIs @_ @(Compose Dict (WithTunnelConstraint MonadInner)) @tt1 @tt2 $ Dict++newtype TunnelWrapper t = MkTunnel+    { unTunnel :: forall m2 r.+                      Monad m2 => ((forall m1 a. Monad m1 => t m1 a -> m1 (Tunnel t a)) -> m2 (Tunnel t r)) -> t m2 r+    }++type WithTunnelConstraint :: ((Type -> Type) -> Constraint) -> TransKind -> Constraint+class (MonadTransTunnel t, c (Tunnel t)) => WithTunnelConstraint c t++instance (MonadTransTunnel t, c (Tunnel t)) => WithTunnelConstraint c t++type ApplyStackTunnel :: [TransKind] -> Type -> Type+type family ApplyStackTunnel tt where+    ApplyStackTunnel '[] = Identity+    ApplyStackTunnel (t ': tt) = ComposeInner (Tunnel t) (ApplyStackTunnel tt)++astIsWithTunnelConstraint ::+       forall (c :: (Type -> Type) -> Constraint) (tt :: [TransKind]).+       (c Identity, forall f1 f2. (c f1, c f2) => c (ComposeInner f1 f2))+    => ListType (Compose Dict (WithTunnelConstraint c)) tt+    -> Dict (c (ApplyStackTunnel tt))+astIsWithTunnelConstraint NilListType = Dict+astIsWithTunnelConstraint (ConsListType (Compose Dict) w) =+    case astIsWithTunnelConstraint w of+        Dict -> Dict++isWithTunnelConstraint ::+       forall (c :: (Type -> Type) -> Constraint) (tt :: [TransKind]).+       (c Identity, forall f1 f2. (c f1, c f2) => c (ComposeInner f1 f2))+    => IsStack (WithTunnelConstraint c) tt => Dict (c (ApplyStackTunnel tt))+isWithTunnelConstraint =+    astIsWithTunnelConstraint @c $ representative @_ @(ListType (Compose Dict (WithTunnelConstraint c))) @tt++type StackTunnel :: [TransKind] -> Type -> Type+newtype StackTunnel tt a = MkStackTunnel+    { unStackTunnel :: ApplyStackTunnel tt a+    }++instance IsStack (WithTunnelConstraint Functor) tt => Functor (StackTunnel tt) where+    fmap =+        case isWithTunnelConstraint @Functor @tt of+            Dict -> \ab (MkStackTunnel st) -> MkStackTunnel $ fmap ab st++instance (IsStack (WithTunnelConstraint Functor) tt, IsStack (WithTunnelConstraint MonadInner) tt) =>+             Applicative (StackTunnel tt) where+    pure =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> \a -> MkStackTunnel $ pure a+    (<*>) =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> \(MkStackTunnel mab) (MkStackTunnel ma) -> MkStackTunnel $ mab <*> ma++instance (IsStack (WithTunnelConstraint Functor) tt, IsStack (WithTunnelConstraint MonadInner) tt) =>+             Foldable (StackTunnel tt) where+    foldMap =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> \ab (MkStackTunnel st) -> foldMap ab st++instance (IsStack (WithTunnelConstraint Functor) tt, IsStack (WithTunnelConstraint MonadInner) tt) =>+             Traversable (StackTunnel tt) where+    traverse =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> \ab (MkStackTunnel st) -> MkStackTunnel <$> traverse ab st++instance (IsStack (WithTunnelConstraint Functor) tt, IsStack (WithTunnelConstraint MonadInner) tt) =>+             Monad (StackTunnel tt) where+    return = pure+    (>>=) =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> \(MkStackTunnel ma) q -> MkStackTunnel $ ma >>= unStackTunnel . q++instance (IsStack (WithTunnelConstraint Functor) tt, IsStack (WithTunnelConstraint MonadInner) tt) =>+             MonadException (StackTunnel tt) where+    type Exc (StackTunnel tt) = Exc (ApplyStackTunnel tt)+    throwExc e =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> MkStackTunnel $ throwExc e+    catchExc (MkStackTunnel st) q =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> MkStackTunnel $ catchExc st (unStackTunnel . q)++instance (IsStack (WithTunnelConstraint Functor) tt, IsStack (WithTunnelConstraint MonadInner) tt) =>+             MonadInner (StackTunnel tt) where+    retrieveInner =+        case isWithTunnelConstraint @MonadInner @tt of+            Dict -> \(MkStackTunnel st) -> retrieveInner st++instance ( IsStack (WithTunnelConstraint Functor) tt+         , IsStack (WithTunnelConstraint MonadInner) tt+         , IsStack (WithTunnelConstraint MonadExtract) tt+         , IsStack MonadTransUnlift tt+         ) => MonadExtract (StackTunnel tt) where+    mToValue =+        case isWithTunnelConstraint @MonadExtract @tt of+            Dict -> \(MkStackTunnel st) -> mToValue st++instance MonadTransStackTunnel tt => MonadTransHoist (StackT tt) where+    hoist = tunnelHoist++instance MonadTransStackTunnel tt => MonadTransTunnel (StackT tt) where+    type Tunnel (StackT tt) = StackTunnel tt+    tunnel ::+           forall m2 r. Monad m2+        => ((forall m1 a. Monad m1 => StackT tt m1 a -> m1 (Tunnel (StackT tt) a)) -> m2 (Tunnel (StackT tt) r))+        -> StackT tt m2 r+    tunnel = let+        build :: forall tt'. ListType (Compose Dict MonadTransTunnel) tt' -> TunnelWrapper (StackT tt')+        build NilListType =+            MkTunnel $ \call ->+                MkStackT $ fmap (runIdentity . unStackTunnel) $ call $ fmap (MkStackTunnel . Identity) . unStackT+        build (ConsListType (Compose Dict) (w :: ListType _ tt0)) =+            case build w of+                MkTunnel tunnel' -> let+                    tunnel'' ::+                           forall m2' r'. Monad m2'+                        => ((forall m1 a. Monad m1 => StackT tt' m1 a -> m1 (Tunnel (StackT tt') a)) -> m2' (Tunnel (StackT tt') r'))+                        -> StackT tt' m2' r'+                    tunnel'' call =+                        case (witTransStackDict @Monad @tt0 @m2' $ mapListType (\(Compose Dict) -> Compose Dict) w) of+                            Dict ->+                                MkStackT $+                                tunnel $ \unlift1 ->+                                    unStackT $+                                    tunnel' $ \unlift2 ->+                                        fmap (MkStackTunnel . unComposeInner . unStackTunnel) $+                                        call $ \(MkStackT stt :: _ m1 _) ->+                                            case (witTransStackDict @Monad @tt0 @m1 $+                                                  mapListType (\(Compose Dict) -> Compose Dict) w) of+                                                Dict ->+                                                    fmap (MkStackTunnel . MkComposeInner . unStackTunnel) $+                                                    unlift2 $ MkStackT $ unlift1 stt+                    in MkTunnel tunnel''+        in unTunnel $ build $ representative @_ @(ListType (Compose Dict MonadTransTunnel)) @tt++stackHoist ::+       forall tt ma mb. (MonadTransStackTunnel tt, Monad ma, Monad mb)+    => (ma --> mb)+    -> ApplyStack tt ma --> ApplyStack tt mb+stackHoist mf asta = unStackT $ hoist mf $ MkStackT @tt asta++transStackExcept ::+       forall tt m e a. (MonadTransStackTunnel tt, Monad m)+    => ApplyStack tt (ExceptT e m) a+    -> ApplyStack tt m (Either e a)+transStackExcept ata = unStackT $ transExcept $ MkStackT @tt @(ExceptT e m) ata++stackUnderliftIO ::+       forall tt m. (MonadTransStackTunnel tt, MonadIO m)+    => ApplyStack tt IO --> ApplyStack tt m+stackUnderliftIO = stackHoist @tt @IO @m liftIO++stackWBackHoist ::+       forall tt ma mb. (MonadTransStackUnlift tt, Monad ma, Monad mb)+    => WBackraised ma mb+    -> WBackraised (ApplyStack tt ma) (ApplyStack tt mb)+stackWBackHoist mab = coerce $ wBackHoist @(StackT tt) mab++stackBackHoist ::+       forall tt ma mb. (MonadTransStackUnlift tt, Monad ma, Monad mb)+    => (ma -/-> mb)+    -> ApplyStack tt ma -/-> ApplyStack tt mb+stackBackHoist f = unWBackraised $ stackWBackHoist @tt $ MkWBackraised f++type MonadTransStackUnlift tt+     = ( IsStack (TransConstraint MonadFail) tt+       , IsStack (TransConstraint MonadIO) tt+       , IsStack (TransConstraint MonadFix) tt+       , IsStack (TransConstraint MonadTunnelIO) tt+       , IsStack (TransConstraint MonadTunnelIOInner) tt+       , IsStack (TransConstraint MonadUnliftIO) tt+       , MonadTransStackTunnel tt+       , IsStack (WithTunnelConstraint MonadExtract) tt+       , IsStack MonadTransUnlift tt)++concatMonadTransStackUnliftDict ::+       forall tt1 tt2. (MonadTransStackUnlift tt1, MonadTransStackUnlift tt2)+    => Dict (MonadTransStackUnlift (Concat tt1 tt2))+concatMonadTransStackUnliftDict =+    case concatIsDict @_ @(Compose Dict (TransConstraint MonadFail)) @tt1 @tt2 of+        Dict ->+            case concatIsDict @_ @(Compose Dict (TransConstraint MonadIO)) @tt1 @tt2 of+                Dict ->+                    case concatIsDict @_ @(Compose Dict (TransConstraint MonadFix)) @tt1 @tt2 of+                        Dict ->+                            case concatIsDict @_ @(Compose Dict (TransConstraint MonadTunnelIO)) @tt1 @tt2 of+                                Dict ->+                                    case concatIsDict @_ @(Compose Dict (TransConstraint MonadTunnelIOInner)) @tt1 @tt2 of+                                        Dict ->+                                            case concatIsDict+                                                     @_+                                                     @(Compose Dict (TransConstraint MonadUnliftIO))+                                                     @tt1+                                                     @tt2 of+                                                Dict ->+                                                    case concatMonadTransStackTunnelDict @tt1 @tt2 of+                                                        Dict ->+                                                            case concatIsDict+                                                                     @_+                                                                     @(Compose Dict MonadTransTunnel)+                                                                     @tt1+                                                                     @tt2 of+                                                                Dict ->+                                                                    case concatIsDict+                                                                             @_+                                                                             @(Compose Dict MonadTransUnlift)+                                                                             @tt1+                                                                             @tt2 of+                                                                        Dict ->+                                                                            case concatIsDict+                                                                                     @_+                                                                                     @(Compose Dict (WithTunnelConstraint MonadExtract))+                                                                                     @tt1+                                                                                     @tt2 of+                                                                                Dict -> Dict++stackLiftWithUnlift ::+       forall tt m. (MonadTransStackUnlift tt, MonadTunnelIOInner m)+    => m -/-> ApplyStack tt m+stackLiftWithUnlift = unWBackraised $ coerce $ wLiftWithUnlift @(StackT tt) @m++newtype LiftWithUnlift t = MkLiftWithUnlift+    { unLiftWithUnlift :: forall m r. MonadIO m => (Unlift MonadTunnelIOInner t -> m r) -> t m r+    }++witFunctorOneTunnelIOStackDict ::+       forall tt m. MonadInner (TunnelIO m)+    => ListType (Compose Dict MonadTransUnlift) tt+    -> Dict (MonadInner (TunnelIO (ApplyStack tt m)))+witFunctorOneTunnelIOStackDict NilListType = Dict+witFunctorOneTunnelIOStackDict (ConsListType (Compose Dict) lt) =+    case witFunctorOneTunnelIOStackDict @_ @m lt of+        Dict -> Dict++stackJoinUnlift ::+       ListType (Compose Dict MonadTransUnlift) tt+    -> Unlift MonadTunnelIOInner t+    -> Unlift MonadTunnelIOInner (StackT tt)+    -> Unlift MonadTunnelIOInner (StackT (t ': tt))+stackJoinUnlift w tmm stmm (stma :: StackT (t ': tt) m a) =+    case witTransStackDict @MonadTunnelIOInner @tt @m $ mapListType (\(Compose Dict) -> Compose Dict) w of+        Dict ->+            case witFunctorOneTunnelIOStackDict @tt @m w of+                Dict -> stmm $ MkStackT $ tmm $ unStackT stma++newtype GetDiscardingUnlift t = MkGetDiscardingUnlift+    { unGetDiscardingUnlift :: forall m. Monad m => t m (WUnlift MonadTunnelIOInner t)+    }++instance MonadTransStackUnlift tt => MonadTransUnlift (StackT tt) where+    liftWithUnlift ::+           forall m r. MonadIO m+        => (Unlift MonadTunnelIOInner (StackT tt) -> m r)+        -> StackT tt m r+    liftWithUnlift = let+        build :: forall tt'. ListType (Compose Dict MonadTransUnlift) tt' -> LiftWithUnlift (StackT tt')+        build NilListType = MkLiftWithUnlift $ \call -> MkStackT $ call unStackT+        build (ConsListType (Compose Dict) (w :: ListType _ tt0)) =+            case build w of+                MkLiftWithUnlift liftWithUnlift' -> let+                    liftWithUnlift'' ::+                           forall m' r'. MonadIO m'+                        => (Unlift MonadTunnelIOInner (StackT tt') -> m' r')+                        -> StackT tt' m' r'+                    liftWithUnlift'' call =+                        MkStackT $+                        case witTransStackDict @MonadIO @tt0 @m' $ mapListType (\(Compose Dict) -> Compose Dict) w of+                            Dict ->+                                liftWithUnlift $ \unlift1 ->+                                    unStackT $ liftWithUnlift' $ \unlift2 -> call $ stackJoinUnlift w unlift1 unlift2+                    in MkLiftWithUnlift liftWithUnlift''+        in unLiftWithUnlift $ build $ representative @_ @(ListType (Compose Dict MonadTransUnlift)) @tt+    getDiscardingUnlift ::+           forall m. Monad m+        => StackT tt m (WUnlift MonadTunnelIOInner (StackT tt))+    getDiscardingUnlift = let+        build :: forall tt'. ListType (Compose Dict MonadTransUnlift) tt' -> GetDiscardingUnlift (StackT tt')+        build NilListType = MkGetDiscardingUnlift $ MkStackT $ return $ MkWUnlift unStackT+        build (ConsListType (Compose (Dict :: Dict (MonadTransUnlift t))) (w :: ListType _ tt0)) =+            case build w of+                MkGetDiscardingUnlift getDiscardingUnlift' -> let+                    getDiscardingUnlift'' ::+                           forall m'. Monad m'+                        => StackT tt' m' (WUnlift MonadTunnelIOInner (StackT tt'))+                    getDiscardingUnlift'' =+                        MkStackT $+                        case witTransStackDict @Monad @tt0 @m' $ mapListType (\(Compose Dict) -> Compose Dict) w of+                            Dict ->+                                withTransConstraintTM @Monad $ do+                                    MkWUnlift unlift1 <- getDiscardingUnlift+                                    MkWUnlift unlift2 <- lift $ unStackT $ getDiscardingUnlift' @m'+                                    return $ MkWUnlift $ stackJoinUnlift w unlift1 unlift2+                    in MkGetDiscardingUnlift getDiscardingUnlift''+        in unGetDiscardingUnlift $ build $ representative @_ @(ListType (Compose Dict MonadTransUnlift)) @tt++stackConcatFst ::+       forall tt1 tt2 m. (MonadTransStackUnlift tt1, MonadTransStackUnlift tt2, Monad m)+    => ApplyStack tt1 m --> ApplyStack (Concat tt1 tt2) m+stackConcatFst =+    case transStackConcatRefl @tt1 @tt2 @m of+        Refl ->+            case transStackDict @Monad @tt2 @m of+                Dict -> stackHoist @tt1 $ stackLift @tt2 @m++stackConcatSnd ::+       forall tt1 tt2 m. (MonadTransStackUnlift tt1, MonadTransStackUnlift tt2, Monad m)+    => ApplyStack tt2 m --> ApplyStack (Concat tt1 tt2) m+stackConcatSnd =+    case transStackConcatRefl @tt1 @tt2 @m of+        Refl ->+            case transStackDict @Monad @tt2 @m of+                Dict -> stackLift @tt1++stackCommute ::+       forall tta ttb m r. (MonadTransStackUnlift tta, MonadTransStackUnlift ttb, MonadTunnelIO m)+    => ApplyStack tta (ApplyStack ttb m) r+    -> ApplyStack ttb (ApplyStack tta m) r+stackCommute aar =+    case (transStackDict @MonadTunnelIO @tta @m, transStackDict @MonadTunnelIO @ttb @m) of+        (Dict, Dict) -> let+            ssr :: StackT tta (StackT ttb m) r+            ssr = MkStackT $ stackHoist @tta @(ApplyStack ttb m) @(StackT ttb m) MkStackT aar+            in stackHoist @ttb @(StackT tta m) @(ApplyStack tta m) unStackT $ unStackT $ commuteT ssr++transStackConcatRefl ::+       forall (tt1 :: [TransKind]) (tt2 :: [TransKind]) m. MonadTransStackUnlift tt1+    => (ApplyStack (Concat tt1 tt2) m) :~: (ApplyStack tt1 (ApplyStack tt2 m))+transStackConcatRefl = applyConcatRefl @_ @tt1 @tt2 @m @(Compose Dict MonadTransUnlift)++type StackUnlift (tt :: [TransKind]) = forall m. MonadUnliftIO m => ApplyStack tt m --> m++newtype WStackUnlift (tt :: [TransKind]) = MkWStackUnlift+    { unWStackUnlift :: StackUnlift tt+    }++consWStackUnlift ::+       forall t tt. IsStack (TransConstraint MonadUnliftIO) tt+    => WUnlift MonadUnliftIO t+    -> WStackUnlift tt+    -> WStackUnlift (t ': tt)+consWStackUnlift (MkWUnlift unlift1) (MkWStackUnlift unliftr) = let+    unlift ::+           forall m. MonadUnliftIO m+        => t (ApplyStack tt m) --> m+    unlift =+        case transStackDict @MonadUnliftIO @tt @m of+            Dict -> unliftr . unlift1+    in MkWStackUnlift unlift++stackLiftWithStackUnlift ::+       forall tt m r. (MonadTransStackUnlift tt, MonadIO m)+    => (StackUnlift tt -> m r)+    -> ApplyStack tt m r+stackLiftWithStackUnlift call = unStackT @tt $ liftWithUnlift $ \unlift -> call $ \astm -> unlift $ MkStackT astm
+ src/Control/Monad/Ology/Specific/StateT.hs view
@@ -0,0 +1,99 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.StateT+    ( module Control.Monad.Trans.State+    , module Control.Monad.Ology.Specific.StateT+    ) where++import Control.Monad.Ology.General+import Control.Monad.Trans.State hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Import++instance TransConstraint Functor (StateT s) where+    hasTransConstraint = Dict++instance TransConstraint Monad (StateT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadIO (StateT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadFail (StateT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadFix (StateT s) where+    hasTransConstraint = Dict++instance TransConstraint MonadPlus (StateT s) where+    hasTransConstraint = Dict++instance MonadTransCoerce (StateT a) where+    transCoerce = Dict++instance MonadException m => MonadException (StateT s m) where+    type Exc (StateT s m) = Exc m+    throwExc e = lift $ throwExc e+    catchExc tma handler = tunnel $ \unlift -> catchExc (unlift tma) $ \e -> unlift $ handler e++instance TransConstraint MonadException (StateT s) where+    hasTransConstraint = Dict++instance MonadThrow e m => MonadThrow e (StateT s m) where+    throw e = lift $ throw e++instance TransConstraint (MonadThrow e) (StateT s) where+    hasTransConstraint = Dict++instance MonadCatch e m => MonadCatch e (StateT s m) where+    catch ma handler = tunnel $ \unlift -> catch (unlift ma) $ \e -> unlift $ handler e++instance TransConstraint (MonadCatch e) (StateT s) where+    hasTransConstraint = Dict++instance MonadTransHoist (StateT s) where+    hoist = tunnelHoist++instance MonadTransTunnel (StateT s) where+    type Tunnel (StateT s) = (,) (Endo s)+    tunnel call =+        StateT $ \olds ->+            fmap (\(Endo sf, r) -> (r, sf olds)) $+            call $ \(StateT smrs) -> fmap (\(a, s) -> (Endo $ pure s, a)) $ smrs olds++instance MonadTransUnlift (StateT s) where+    liftWithUnlift call = liftWithMVarStateT $ \var -> call $ mVarRunStateT var++-- | Run the 'StateT' on an 'MVar', taking the initial state and putting the final state.+mVarRunStateT :: MVar s -> Unlift MonadTunnelIOInner (StateT s)+mVarRunStateT var (StateT smr) =+    tunnelIO $ \unlift ->+        modifyMVar var $ \olds ->+            fmap (\fas -> (fromMaybe olds $ mToMaybe $ fmap snd fas, fmap fst fas)) $ unlift $ smr olds++-- | Take the 'MVar' before and put it back after.+mVarRunLocked :: MonadTunnelIOInner m => MVar s -> m --> m+mVarRunLocked var ma = mVarRunStateT var $ lift ma++discardingStateTUnlift :: s -> Unlift MonadIO (StateT s)+discardingStateTUnlift s mr = do+    (r, _discarded) <- runStateT mr s+    return r++-- | Dangerous, because the MVar won't be released on exception.+dangerousMVarRunStateT :: MVar s -> Unlift MonadIO (StateT s)+dangerousMVarRunStateT var (StateT smr) = do+    olds <- liftIO $ takeMVar var+    (a, news) <- smr olds+    liftIO $ putMVar var news+    return a++liftStateT :: (Traversable f, Applicative m) => StateT s m a -> StateT (f s) m (f a)+liftStateT (StateT smas) = StateT $ \fs -> fmap (\fas -> (fmap fst fas, fmap snd fas)) $ traverse smas fs++liftWithMVarStateT :: MonadIO m => (MVar s -> m a) -> StateT s m a+liftWithMVarStateT vma =+    StateT $ \initialstate -> do+        var <- liftIO $ newMVar initialstate+        r <- vma var+        finalstate <- liftIO $ takeMVar var+        return (r, finalstate)
+ src/Control/Monad/Ology/Specific/StepT.hs view
@@ -0,0 +1,62 @@+module Control.Monad.Ology.Specific.StepT where++import Control.Monad.Ology.General.Function+import Control.Monad.Ology.General.IO+import Control.Monad.Ology.General.Trans.Constraint+import Control.Monad.Ology.General.Trans.Hoist+import Control.Monad.Ology.General.Trans.Trans+import Import++-- | A monad that can be run step-by-step until the result.+newtype StepT f m a = MkStepT+    { unStepT :: m (Either a (f (StepT f m a)))+    }++instance (Functor f, Functor m) => Functor (StepT f m) where+    fmap ab (MkStepT ma) = MkStepT $ fmap (bimap ab $ fmap $ fmap ab) ma++instance Functor f => TransConstraint Functor (StepT f) where+    hasTransConstraint = Dict++instance (Functor f, Monad m) => Applicative (StepT f m) where+    pure a = MkStepT $ pure $ Left a+    mab <*> ma = do+        ab <- mab+        a <- ma+        return $ ab a++instance (Functor f, Monad m) => Monad (StepT f m) where+    return = pure+    MkStepT mea >>= f =+        MkStepT $ do+            ea <- mea+            case ea of+                Left a -> unStepT $ f a+                Right fsa -> return $ Right $ fmap (\sa -> sa >>= f) fsa++instance Functor f => TransConstraint Monad (StepT f) where+    hasTransConstraint = Dict++instance (Functor f, MonadIO m) => MonadIO (StepT f m) where+    liftIO ioa = lift $ liftIO ioa++instance Functor f => TransConstraint MonadIO (StepT f) where+    hasTransConstraint = Dict++instance Functor f => MonadTrans (StepT f) where+    lift ma = MkStepT $ fmap Left ma++instance Functor f => MonadTransHoist (StepT f) where+    hoist f (MkStepT ma) = MkStepT $ (fmap $ fmap $ fmap $ hoist f) $ f ma++-- | Run all the steps until done.+runSteps :: Monad m => Extract f -> StepT f m --> m+runSteps fxx step = do+    eap <- unStepT step+    case eap of+        Left a -> return a+        Right sc -> runSteps fxx $ fxx sc++-- | A pending step for this result.+pendingStep :: (Functor f, Monad m) => f --> StepT f m+pendingStep fa = MkStepT $ pure $ Right $ fmap pure fa
+ src/Control/Monad/Ology/Specific/TransformT.hs view
@@ -0,0 +1,92 @@+module Control.Monad.Ology.Specific.TransformT where++import Control.Monad.Ology.Data+import Control.Monad.Ology.General+import Import++type TransformT :: forall k. (k -> Type) -> Type -> Type+newtype TransformT f a = MkTransformT+    { unTransformT :: forall r. (a -> f r) -> f r+    }++instance Functor (TransformT f) where+    fmap ab (MkTransformT aff) = MkTransformT $ \bf -> aff $ bf . ab++instance TransConstraint Functor TransformT where+    hasTransConstraint = Dict++instance Applicative (TransformT f) where+    pure a = MkTransformT $ \af -> af a+    MkTransformT f <*> MkTransformT x = MkTransformT $ \bf -> f $ \ab -> x (bf . ab)++instance TransConstraint Applicative TransformT where+    hasTransConstraint = Dict++instance Monad (TransformT f) where+    return = pure+    MkTransformT m >>= f = MkTransformT $ \bf -> m (\a -> unTransformT (f a) bf)++instance TransConstraint Monad TransformT where+    hasTransConstraint = Dict++instance MonadTrans TransformT where+    lift m = MkTransformT $ \af -> m >>= af++instance MonadIO m => MonadIO (TransformT m) where+    liftIO = lift . liftIO++instance TransConstraint MonadIO TransformT where+    hasTransConstraint = Dict++instance Semigroup a => Semigroup (TransformT f a) where+    (<>) = liftA2 (<>)++instance Monoid a => Monoid (TransformT f a) where+    mempty = pure mempty++instance MonadFix m => MonadFix (TransformT m) where+    mfix ama =+        MkTransformT $ \amr -> do+            rec+                (~(olda, r')) <-+                    unTransformT (ama olda) $ \newa -> do+                        r <- amr newa+                        return (newa, r)+            return r'++mapTransformT :: (f --> f) -> TransformT f ()+mapTransformT ff = MkTransformT $ \uf -> ff $ uf ()++postTransformT :: Monad m => m () -> TransformT m ()+postTransformT mu =+    mapTransformT $ \mr -> do+        r <- mr+        mu+        return r++transformTMap :: TransformT f () -> f --> f+transformTMap (MkTransformT uff) f = uff $ \() -> f++execMapTransformT :: Monad f => f (TransformT f a) -> TransformT f a+execMapTransformT ffa =+    MkTransformT $ \af -> do+        MkTransformT aff <- ffa+        aff af++transformParamRef ::+       forall m. Monad m+    => Param m --> Ref (TransformT m)+transformParamRef (param :: _ a) = let+    refGet :: TransformT m a+    refGet =+        MkTransformT $ \afr -> do+            a <- paramAsk param+            afr a+    refPut :: a -> TransformT m ()+    refPut a = MkTransformT $ \ufr -> paramWith param a $ ufr ()+    in MkRef {..}++liftTransformT ::+       forall t m. (MonadTransUnlift t, MonadTunnelIOInner m)+    => TransformT m --> TransformT (t m)+liftTransformT (MkTransformT aff) = MkTransformT $ \atf -> liftWithUnlift $ \unlift -> aff $ unlift . atf
+ src/Control/Monad/Ology/Specific/WriterT.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS -fno-warn-orphans #-}++module Control.Monad.Ology.Specific.WriterT+    ( module Control.Monad.Trans.Writer+    ) where++import Control.Monad.Ology.General+import Control.Monad.Trans.Writer hiding (liftCallCC, liftCatch)+import Import++instance Monoid w => TransConstraint Functor (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => TransConstraint Applicative (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => TransConstraint Monad (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => TransConstraint MonadIO (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => TransConstraint MonadFail (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => TransConstraint MonadFix (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => TransConstraint MonadPlus (WriterT w) where+    hasTransConstraint = Dict++instance (MonadExtract m, Monoid w) => MonadExtract (WriterT w m) where+    mToValue (WriterT maw) = fst $ mToValue maw++instance Monoid w => TransConstraint MonadExtract (WriterT w) where+    hasTransConstraint = Dict++instance (MonadInner m, Monoid w) => MonadInner (WriterT w m) where+    retrieveInner (WriterT maw) = fmap fst $ retrieveInner maw++instance Monoid w => TransConstraint MonadInner (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => MonadTransCoerce (WriterT w) where+    transCoerce = Dict++instance (Monoid w, MonadException m) => MonadException (WriterT w m) where+    type Exc (WriterT w m) = Exc m+    throwExc e = lift $ throwExc e+    catchExc tma handler = tunnel $ \unlift -> catchExc (unlift tma) $ \e -> unlift $ handler e++instance Monoid w => TransConstraint MonadException (WriterT w) where+    hasTransConstraint = Dict++instance (MonadThrow e m, Monoid w) => MonadThrow e (WriterT w m) where+    throw e = lift $ throw e++instance Monoid w => TransConstraint (MonadThrow e) (WriterT w) where+    hasTransConstraint = Dict++instance (MonadCatch e m, Monoid w) => MonadCatch e (WriterT w m) where+    catch ma handler = tunnel $ \unlift -> catch (unlift ma) $ \e -> unlift $ handler e++instance Monoid w => TransConstraint (MonadCatch e) (WriterT w) where+    hasTransConstraint = Dict++instance Monoid w => MonadTransHoist (WriterT w) where+    hoist = tunnelHoist++instance Monoid w => MonadTransTunnel (WriterT w) where+    type Tunnel (WriterT w) = (,) w+    tunnel call = WriterT $ fmap swap $ call $ \(WriterT mrs) -> fmap swap $ mrs++instance Monoid w => MonadTransUnlift (WriterT w) where+    liftWithUnlift call = do+        var <- liftIO $ newMVar mempty+        r <-+            lift $+            call $ \(WriterT mrs) -> do+                (r, output) <- mrs+                liftIO $ modifyMVar_ var $ \oldoutput -> return $ mappend oldoutput output+                return r+        totaloutput <- liftIO $ takeMVar var+        tell totaloutput+        return r
+ src/Import.hs view
@@ -0,0 +1,28 @@+module Import+    ( module I+    ) where++import Control.Applicative as I+import Control.Category as I+import Control.Concurrent as I+import Control.Monad as I hiding (fail)+import Control.Monad.Fail as I+import Control.Monad.Fix as I+import Data.Bifunctor as I+import Data.Coerce as I+import Data.Constraint as I hiding (trans)+import Data.Foldable as I+import Data.Functor.Compose as I+import Data.Functor.Identity as I+import Data.Functor.Invariant as I+import Data.IORef as I+import Data.Kind as I+import Data.Maybe as I+import Data.Monoid as I+import Data.String as I (IsString(..))+import Data.Traversable as I+import Data.Tuple as I+import Data.Type.Witness as I+import Data.TypeRig as I+import Data.Void as I+import Prelude as I hiding ((.), fail, id)
+ test/Compose.hs view
@@ -0,0 +1,47 @@+module Compose+    ( testComposeInner+    ) where++import Control.Applicative+import Control.Monad.Ology+import Data.IORef+import Prelude+import Test.Tasty+import Test.Tasty.HUnit++testComposeInnerApplicative :: TestTree+testComposeInnerApplicative =+    testCase "Applicative" $ do+        r1 <- newIORef False+        r2 <- newIORef False+        let+            c1 :: ComposeInner Maybe IO ()+            c1 = do+                lift $ writeIORef r1 True+                liftInner Nothing+            c2 :: ComposeInner Maybe IO ()+            c2 = lift $ writeIORef r2 True+        _ <- unComposeInner $ liftA2 (,) c1 c2+        v1 <- readIORef r1+        v2 <- readIORef r2+        assertEqual "v1" True v1+        assertEqual "v2" False v2++testComposeInnerAlternative :: TestTree+testComposeInnerAlternative =+    testCase "Alternative" $ do+        r1 <- newIORef False+        r2 <- newIORef False+        let+            c1 :: ComposeInner Maybe IO ()+            c1 = lift $ writeIORef r1 True+            c2 :: ComposeInner Maybe IO ()+            c2 = lift $ writeIORef r2 True+        _ <- unComposeInner $ c1 <|> c2+        v1 <- readIORef r1+        v2 <- readIORef r2+        assertEqual "v1" True v1+        assertEqual "v2" False v2++testComposeInner :: TestTree+testComposeInner = testGroup "composeInner" [testComposeInnerApplicative, testComposeInnerAlternative]
+ test/Coroutine.hs view
@@ -0,0 +1,34 @@+module Coroutine+    ( testCoroutine+    ) where++import Control.Monad.Ology+import Prelude+import Test.Tasty+import Test.Tasty.HUnit+import Useful++testCoroutineM ::+       forall m. (MonadIO m, MonadCoroutine m)+    => String+    -> (m () -> IO ())+    -> TestTree+testCoroutineM name run =+    testCase name $+    compareTest "+A+X-A+B-X" $ \appendStr -> do+        let+            output :: String -> m ()+            output s = liftIO $ appendStr s+            f1 :: (() -> m ()) -> m ()+            f1 y = do+                withMessage output "A" $ y ()+                withMessage output "B" $ y ()+            f2 :: (() -> m ()) -> m ()+            f2 y = withMessage output "X" $ y ()+        run $ runCoroutine $ joinCoroutines (coroutineSuspend f1) (\() -> coroutineSuspend f2)++testCoroutine :: TestTree+testCoroutine =+    testGroup+        "coroutine"+        [testCoroutineM @IO "IO" id] {-, testCoroutineM @(ContT () IO) "ContT () IO" $ \c -> runContT c return -}
+ test/Exception.hs view
@@ -0,0 +1,66 @@+module Exception+    ( testException+    ) where++import Control.Applicative+import Control.Monad.Ology+import Data.IORef+import Prelude+import Test.Tasty+import Test.Tasty.HUnit++testACatch ::+       forall m e. (Eq e, Show e, MonadCatch e m)+    => m --> IO -> e -> TestTree+testACatch runM ex =+    testCase "catchExc" $ do+        r <- runM $ try @m @e $ throw @e @m @() ex+        assertEqual "caught" (FailureResult ex) r++testABracket ::+       forall m. (MonadTunnelIO m, MonadException m)+    => m --> IO -> (forall a. m a) -> TestTree+testABracket runM th =+    testCase "bracket" $ do+        ref <- newIORef False+        _ <- tryExc $ runM $ finally @m th (liftIO $ writeIORef ref True)+        b <- readIORef ref+        assertEqual "finally" True b++testAnException ::+       forall m e. (Eq e, Show e, MonadException m, MonadCatch e m, MonadTunnelIO m)+    => String+    -> m --> IO -> e -> TestTree+testAnException name runM ex = testGroup name [testACatch runM ex, testABracket runM $ throw ex]++runComposeInner :: ComposeInner Maybe IO --> IO+runComposeInner (MkComposeInner ima) = do+    ma <- ima+    case ma of+        Just a -> return a+        Nothing -> fail "Nothing"++runExceptT' :: ExceptT () IO --> IO+runExceptT' eia = do+    ea <- runExceptT eia+    case ea of+        Right a -> return a+        Left _ -> fail "Left"++runResultT' :: ResultT () IO --> IO+runResultT' eia = do+    ea <- runResultT eia+    case ea of+        SuccessResult a -> return a+        FailureResult _ -> fail "Left"++testException :: TestTree+testException =+    testGroup+        "Exception"+        [ testAnException "IO" id $ ErrorCall "test"+        , testGroup "ExceptT () IO" $ pure $ testABracket @(ExceptT () IO) runExceptT' $ throwE ()+        , testGroup "ResultT () IO" $ pure $ testABracket @(ResultT () IO) runResultT' $ throwR ()+        , testGroup "ComposeInner Maybe IO" $+          pure $ testABracket @(ComposeInner Maybe IO) runComposeInner $ liftInner Nothing+        ]
+ test/Lifecycle.hs view
@@ -0,0 +1,44 @@+module Lifecycle+    ( testLifecycle+    ) where++import Control.Monad.Ology+import Prelude+import Test.Tasty+import Test.Tasty.HUnit+import Useful++testLifecycleRun :: TestTree+testLifecycleRun =+    testCase "run" $+    compareTest "ACDB" $ \appendStr -> do+        let+            lc :: Lifecycle ()+            lc = do+                liftIO $ appendStr "A"+                lifecycleOnClose $ appendStr "B"+                liftIO $ appendStr "C"+                lifecycleOnClose $ appendStr "D"+        runLifecycle lc++testLifecycleWith :: TestTree+testLifecycleWith =+    testCase "with" $+    compareTest "ABECFD" $ \appendStr -> do+        let+            lc :: Lifecycle ()+            lc = do+                liftIO $ appendStr "A"+                s <-+                    lifecycleWith $ \call -> do+                        appendStr "B"+                        v <- call "C"+                        appendStr "D"+                        return v+                liftIO $ appendStr "E"+                liftIO $ appendStr s+                liftIO $ appendStr "F"+        runLifecycle lc++testLifecycle :: TestTree+testLifecycle = testGroup "lifecycle" [testLifecycleRun, testLifecycleWith]
+ test/Main.hs view
@@ -0,0 +1,16 @@+module Main+    ( main+    ) where++import Compose+import Coroutine+import Exception+import Lifecycle+import Prelude+import Test.Tasty++tests :: TestTree+tests = testGroup "monadology" [testCoroutine, testLifecycle, testComposeInner, testException]++main :: IO ()+main = defaultMain tests
+ test/Useful.hs view
@@ -0,0 +1,23 @@+module Useful where++import Data.IORef+import Prelude+import Test.Tasty.HUnit++compareTest :: String -> ((String -> IO ()) -> IO r) -> IO r+compareTest expected action = do+    resultsRef <- newIORef ""+    let+        appendStr :: String -> IO ()+        appendStr s = modifyIORef resultsRef $ \t -> t ++ s+    r <- action appendStr+    found <- readIORef resultsRef+    assertEqual "" expected found+    return r++withMessage :: Monad m => (String -> m ()) -> String -> m r -> m r+withMessage appendStr s m = do+    appendStr $ "+" <> s+    r <- m+    appendStr $ "-" <> s+    return r