monadology 0.1 → 0.2

raw patch · 20 files changed

+428/−176 lines, 20 filesdep +textPVP ok

version bump matches the API change (PVP)

Dependencies added: text

API changes (from Hackage documentation)

Files

• changelog.md +7/−0
• monadology.cabal +12/−4
• src/Control/Monad/Ology.hs +1/−1
• src/Control/Monad/Ology/Data/Param.hs +11/−3
• src/Control/Monad/Ology/Data/Prod.hs +55/−12
• src/Control/Monad/Ology/Data/Ref.hs +6/−6
• src/Control/Monad/Ology/General/Coroutine.hs +12/−2
• src/Control/Monad/Ology/General/Exception.hs +26/−0
• src/Control/Monad/Ology/General/Trans/Tunnel.hs +4/−13
• src/Control/Monad/Ology/General/Trans/Unlift.hs +4/−4
• src/Control/Monad/Ology/Specific/ComposeT.hs +6/−7
• src/Control/Monad/Ology/Specific/ReaderT.hs +1/−1
• src/Control/Monad/Ology/Specific/StackT.hs +17/−28
• src/Control/Monad/Ology/Specific/StateT.hs +2/−2
• src/Control/Monad/Ology/Specific/TransformT.hs +0/−92
• src/Control/Monad/Ology/Specific/WithT.hs +118/−0
• src/Control/Monad/Ology/Specific/WriterT.hs +7/−0
• test/Data.hs +90/−0
• test/Exception.hs +47/−0
• test/Main.hs +2/−1

@@ -1,3 +1,10 @@+## [0.2] - 2023-07-31++- fix "Prod" type, add more functions+- WithT: rename from TransformT, add more instances & functions+- refRestore etc.: more general because no masking of async exceptions+- remove some unnecessary classes and constraints+ ## [0.1] - 2022-09-12  - initial release

@@ -1,20 +1,26 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           monadology-version:        0.1+version:        0.2+synopsis:       The best ideas in monad-related classes and types. 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.+category:       Monads 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+copyright:      (c) 2017-2023 Ashley Yakeley license:        BSD-2-Clause license-file:   LICENSE build-type:     Simple+tested-with:+    GHC == 9.2.8+  , GHC == 9.4.5+  , GHC == 9.6.2 extra-source-files:     changelog.md @@ -56,7 +62,7 @@       Control.Monad.Ology.Specific.ContT       Control.Monad.Ology.Specific.ReaderStateT       Control.Monad.Ology.Specific.StackT-      Control.Monad.Ology.Specific.TransformT+      Control.Monad.Ology.Specific.WithT       Control.Monad.Ology.Specific.ResultT       Control.Monad.Ology.Specific.StepT       Control.Monad.Ology.Specific.CoroutineT@@ -137,6 +143,7 @@       Compose       Coroutine       Lifecycle+      Data   hs-source-dirs:       test   default-extensions:@@ -191,5 +198,6 @@     , monadology     , tasty >=1.4     , tasty-hunit >=0.10+    , text >=2.0     , transformers >=0.5   default-language: Haskell2010

@@ -20,5 +20,5 @@ 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.WithT as I import Control.Monad.Ology.Specific.WriterT as I

@@ -20,14 +20,22 @@     rUnit = MkParam (pure ()) (\() -> id)     pa <***> pb = MkParam (liftA2 (,) (paramAsk pa) (paramAsk pb)) (\(a, b) -> paramWith pa a . paramWith pb b) +paramLocalM ::+       forall m a. Monad m+    => Param m a+    -> (a -> m a)+    -> m --> m+paramLocalM param f mr = do+    a <- paramAsk param+    a' <- f a+    paramWith param a' mr+ 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+paramLocal param f mr = paramLocalM param (return . f) mr  lensMapParam ::        forall m a b. Monad m

@@ -1,5 +1,6 @@ module Control.Monad.Ology.Data.Prod where +import Control.Monad.Ology.Data.Param import Control.Monad.Ology.General import Control.Monad.Ology.Specific.WriterT import Import@@ -7,7 +8,7 @@ -- | A product of a monad (as in 'WriterT'). data Prod m a = MkProd     { prodTell :: a -> m ()-    , prodListen :: forall r. m r -> m (r, a)+    , prodCollect :: forall r. m r -> m (r, a)     }  instance Functor m => Invariant (Prod m) where@@ -16,30 +17,72 @@ 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+    MkProd tellA collectA <***> MkProd tellB collectB = 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+        collectAB :: m r -> m (r, (a, b))+        collectAB m = fmap (\((r, a), b) -> (r, (a, b))) $ collectB (collectA m)+        in MkProd tellAB collectAB -prodListen_ :: Functor m => Prod m a -> m () -> m a+prodCollect_ :: Functor m => Prod m a -> m () -> m a+prodCollect_ p mu = fmap snd $ prodCollect p mu++prodListen :: Monad m => Prod m a -> forall r. m r -> m (r, a)+prodListen p mr = do+    (r, a) <- prodCollect p mr+    prodTell p a+    return (r, a)++prodListen_ :: Monad m => Prod m a -> m () -> m a prodListen_ p mu = fmap snd $ prodListen p mu +prodPass :: Monad m => Prod m a -> m (r, a -> a) -> m r+prodPass p mraa = do+    ((r, f), a) <- prodCollect p mraa+    prodTell p $ f a+    return r++prodCensor :: Monad m => Prod m a -> (a -> a) -> m --> m+prodCensor p f mr = do+    (r, a) <- prodCollect p mr+    prodTell p $ f a+    return r++prodTellItem :: Applicative f => Prod m (f a) -> a -> m ()+prodTellItem p a = prodTell p $ pure a++prodCensorItems :: (Monad f, Monad m) => Prod m (f a) -> (a -> f a) -> m --> m+prodCensorItems p afa = prodCensor p $ \fa -> fa >>= afa++lensMapProd ::+       forall m a b. (Monad m, Monoid a, Monoid b)+    => Lens' a b+    -> Prod m a+    -> Prod m b+lensMapProd l p = let+    prodTell' :: b -> m ()+    prodTell' b = prodTell p $ runIdentity $ l (\_ -> Identity b) mempty+    prodCollect' :: forall r. m r -> m (r, b)+    prodCollect' mr = do+        (r, a) <- prodCollect p mr+        prodTell p $ runIdentity $ l (\_ -> Identity mempty) a+        return (r, getConst $ l Const a)+    in MkProd prodTell' prodCollect'+ 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}+writerProd :: (Monad m, Monoid w) => Prod (WriterT w m) w+writerProd = MkProd {prodTell = tell, prodCollect = collect}  foldProd ::        forall f m a. (Applicative f, Foldable f, Applicative m)     => Prod m a     -> Prod m (f a)-foldProd (MkProd prodTell prodListen) = let+foldProd (MkProd prodTell prodCollect) = 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'+    prodCollect' :: forall r. m r -> m (r, f a)+    prodCollect' mr = fmap (\(r, a) -> (r, pure a)) $ prodCollect mr+    in MkProd prodTell' prodCollect'

@@ -36,8 +36,8 @@     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+refRestore :: MonadException m => Ref m a -> m --> m+refRestore ref mr = bracketNoMask (refGet ref) (refPut ref) $ \_ -> mr  lensMapRef ::        forall m a b. Monad m@@ -76,7 +76,7 @@  -- | Use a reference as a parameter. refParam ::-       forall m a. (MonadUnliftIO m, MonadException m)+       forall m a. MonadException m     => Ref m a     -> Param m a refParam ref = let@@ -90,13 +90,13 @@  -- | Use a reference as a product. refProd ::-       forall m a. (MonadUnliftIO m, MonadException m, Monoid a)+       forall m a. (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 =+    prodCollect :: forall r. m r -> m (r, a)+    prodCollect mr =         refRestore ref $ do             refPut ref mempty             r <- mr

@@ -33,7 +33,7 @@                     putMVar outvar $ Left r             takeMVar outvar -instance (MonadTransUnlift t, MonadCoroutine m, MonadTunnelIOInner m, Monad (t m)) => MonadCoroutine (t m) where+instance (MonadTransUnlift t, MonadCoroutine m, MonadTunnelIO m, Monad (t m)) => MonadCoroutine (t m) where     coroutineSuspend call =         MkStepT $         liftWithUnlift $ \unlift ->@@ -43,7 +43,7 @@ -- 'System.IO.withFile', -- 'System.IO.withBinaryFile', -- etc.-type With (m :: Type -> Type) (t :: Type) = forall (r :: Type). (t -> m r) -> m r+type With (m :: k -> Type) (t :: Type) = forall (r :: k). (t -> m r) -> m r  unpickWith ::        forall m a. MonadCoroutine m@@ -54,3 +54,13 @@     case etp of         Left a -> return (a, return ())         Right (MkTurn a f) -> return (a, fmap (\_ -> ()) $ runCoroutine $ f a)++pickWith ::+       forall m a. Monad m+    => m (a, m ())+    -> With m a+pickWith mac amr = do+    (a, closer) <- mac+    r <- amr a+    closer+    return r

@@ -49,3 +49,29 @@     -> m ()     -> m --> m bracket_ before after thing = bracket before (const after) (const thing)++-- | Like 'bracket", but doesn\'t mask asynchronous exceptions.+bracketNoMask ::+       forall m a b. MonadException m+    => m a+    -> (a -> m ())+    -> (a -> m b)+    -> m b+bracketNoMask before after thing = do+    a <- before+    b <- onException (thing a) (after a)+    after a+    return b++-- | Like 'bracketNoMask", but doesn\'t catch any exceptions.+bracketFake ::+       forall m a b. Monad m+    => m a+    -> (a -> m ())+    -> (a -> m b)+    -> m b+bracketFake before after thing = do+    a <- before+    b <- thing a+    after a+    return b

@@ -43,13 +43,12 @@  -- | Commute two transformers in a transformer stack. commuteT ::-       forall ta tb m. (MonadTransTunnel ta, MonadTransTunnel tb, Monad (Tunnel ta), MonadInner (Tunnel tb), Monad m)+       forall ta tb m. (MonadTransTunnel ta, MonadTransTunnel 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)+       forall ta tb m. (MonadTransTunnel ta, MonadTransTunnel tb, Monad m)     => ta (tb m) -/-> tb (ta m) commuteTBack call = commuteT $ call commuteT @@ -65,18 +64,10 @@     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+instance (MonadTransTunnel 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+instance (MonadTransTunnel t, TransConstraint MonadIO t) => TransConstraint MonadTunnelIO t where     hasTransConstraint = withTransConstraintDict @MonadIO Dict

@@ -20,12 +20,12 @@     -- | 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)+        => (Unlift MonadTunnelIO 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)+        => t m (WUnlift MonadTunnelIO t)     getDiscardingUnlift = tunnel $ \unlift -> pure $ pure $ MkWUnlift $ \tma -> fmap mToValue $ unlift tma  toDiscardingUnlift ::@@ -37,7 +37,7 @@     du tmr  wLiftWithUnlift ::-       forall t m. (MonadTransUnlift t, MonadTunnelIOInner m)+       forall t m. (MonadTransUnlift t, MonadTunnelIO m)     => WBackraised m (t m) wLiftWithUnlift = MkWBackraised $ \call -> liftWithUnlift $ \unlift -> call unlift @@ -75,7 +75,7 @@             return $ call $ extract . unComposeOuter  monoHoist ::-       forall (t :: TransKind) ma mb a b. (MonadTransUnlift t, MonadTunnelIOInner ma, MonadIO mb)+       forall (t :: TransKind) ma mb a b. (MonadTransUnlift t, MonadTunnelIO ma, MonadIO mb)     => (ma a -> mb b)     -> (t ma a -> t mb b) monoHoist f tma = liftWithUnlift $ \unlift -> f $ unlift tma

@@ -35,7 +35,7 @@         Dict -> MkComposeT $ lift ima  liftOuterComposeTWithUnlift ::-       forall outerT innerT m r. (MonadTransTunnel outerT, MonadTransUnlift innerT, MonadTunnelIOInner m)+       forall outerT innerT m r. (MonadTransTunnel outerT, MonadTransUnlift innerT, MonadTunnelIO m)     => ((forall a. ComposeT outerT innerT m a -> outerT m a) -> outerT m r)     -> ComposeT outerT innerT m r liftOuterComposeTWithUnlift call =@@ -45,11 +45,11 @@             tunnel $ \tun -> liftWithUnlift $ \unlift -> tun $ call $ \(MkComposeT ttma) -> hoist unlift ttma  liftInnerComposeTWithUnlift ::-       forall outerT innerT m r. (MonadTransUnlift outerT, MonadTransUnlift innerT, MonadTunnelIOInner m)+       forall outerT innerT m r. (MonadTransUnlift outerT, MonadTransUnlift innerT, MonadTunnelIO 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+    case hasTransConstraint @MonadTunnelIO @innerT @m of         Dict -> MkComposeT $ liftWithUnlift $ \unlift -> call $ \(MkComposeT ttma) -> unlift ttma  composeTUnlift ::@@ -189,7 +189,7 @@ instance (MonadTransUnlift outerT, MonadTransUnlift innerT) => MonadTransUnlift (ComposeT outerT innerT) where     liftWithUnlift ::            forall m r. MonadIO m-        => (Unlift MonadTunnelIOInner (ComposeT outerT innerT) -> m r)+        => (Unlift MonadTunnelIO (ComposeT outerT innerT) -> m r)         -> ComposeT outerT innerT m r     liftWithUnlift call =         case hasTransConstraint @MonadIO @innerT @m of@@ -197,11 +197,10 @@                 MkComposeT $                 liftWithUnlift $ \unlift1 ->                     liftWithUnlift $ \unlift2 ->-                        call $ \(MkComposeT t1t2ma) ->-                            unlift2 $ withTransConstraintTM @MonadTunnelIOInner $ unlift1 t1t2ma+                        call $ \(MkComposeT t1t2ma) -> unlift2 $ withTransConstraintTM @MonadTunnelIO $ unlift1 t1t2ma     getDiscardingUnlift ::            forall m. Monad m-        => ComposeT outerT innerT m (WUnlift MonadTunnelIOInner (ComposeT outerT innerT))+        => ComposeT outerT innerT m (WUnlift MonadTunnelIO (ComposeT outerT innerT))     getDiscardingUnlift =         case hasTransConstraint @Monad @innerT @m of             Dict ->

@@ -79,7 +79,7 @@  readerTUnliftToT ::        forall t m. (MonadTransUnlift t, MonadTunnelIO m)-    => ReaderT (WUnlift MonadTunnelIOInner t) m --> t m+    => ReaderT (WUnlift MonadTunnelIO t) m --> t m readerTUnliftToT rma = liftWithUnlift $ \tr -> runReaderT rma $ MkWUnlift tr  tToReaderTUnlift :: MonadTunnelIO m => t m --> ReaderT (WUnlift Monad t) m

@@ -332,7 +332,6 @@        , 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@@ -350,42 +349,32 @@                         Dict ->                             case concatIsDict @_ @(Compose Dict (TransConstraint MonadTunnelIO)) @tt1 @tt2 of                                 Dict ->-                                    case concatIsDict @_ @(Compose Dict (TransConstraint MonadTunnelIOInner)) @tt1 @tt2 of+                                    case concatIsDict @_ @(Compose Dict (TransConstraint MonadUnliftIO)) @tt1 @tt2 of                                         Dict ->-                                            case concatIsDict-                                                     @_-                                                     @(Compose Dict (TransConstraint MonadUnliftIO))-                                                     @tt1-                                                     @tt2 of+                                            case concatMonadTransStackTunnelDict @tt1 @tt2 of                                                 Dict ->-                                                    case concatMonadTransStackTunnelDict @tt1 @tt2 of+                                                    case concatIsDict @_ @(Compose Dict MonadTransTunnel) @tt1 @tt2 of                                                         Dict ->                                                             case concatIsDict                                                                      @_-                                                                     @(Compose Dict MonadTransTunnel)+                                                                     @(Compose Dict MonadTransUnlift)                                                                      @tt1                                                                      @tt2 of                                                                 Dict ->                                                                     case concatIsDict                                                                              @_-                                                                             @(Compose Dict MonadTransUnlift)+                                                                             @(Compose Dict (WithTunnelConstraint MonadExtract))                                                                              @tt1                                                                              @tt2 of-                                                                        Dict ->-                                                                            case concatIsDict-                                                                                     @_-                                                                                     @(Compose Dict (WithTunnelConstraint MonadExtract))-                                                                                     @tt1-                                                                                     @tt2 of-                                                                                Dict -> Dict+                                                                        Dict -> Dict  stackLiftWithUnlift ::-       forall tt m. (MonadTransStackUnlift tt, MonadTunnelIOInner m)+       forall tt m. (MonadTransStackUnlift tt, MonadTunnelIO 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+    { unLiftWithUnlift :: forall m r. MonadIO m => (Unlift MonadTunnelIO t -> m r) -> t m r     }  witFunctorOneTunnelIOStackDict ::@@ -399,23 +388,23 @@  stackJoinUnlift ::        ListType (Compose Dict MonadTransUnlift) tt-    -> Unlift MonadTunnelIOInner t-    -> Unlift MonadTunnelIOInner (StackT tt)-    -> Unlift MonadTunnelIOInner (StackT (t ': tt))+    -> Unlift MonadTunnelIO t+    -> Unlift MonadTunnelIO (StackT tt)+    -> Unlift MonadTunnelIO (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+    case witTransStackDict @MonadTunnelIO @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)+    { unGetDiscardingUnlift :: forall m. Monad m => t m (WUnlift MonadTunnelIO t)     }  instance MonadTransStackUnlift tt => MonadTransUnlift (StackT tt) where     liftWithUnlift ::            forall m r. MonadIO m-        => (Unlift MonadTunnelIOInner (StackT tt) -> m r)+        => (Unlift MonadTunnelIO (StackT tt) -> m r)         -> StackT tt m r     liftWithUnlift = let         build :: forall tt'. ListType (Compose Dict MonadTransUnlift) tt' -> LiftWithUnlift (StackT tt')@@ -425,7 +414,7 @@                 MkLiftWithUnlift liftWithUnlift' -> let                     liftWithUnlift'' ::                            forall m' r'. MonadIO m'-                        => (Unlift MonadTunnelIOInner (StackT tt') -> m' r')+                        => (Unlift MonadTunnelIO (StackT tt') -> m' r')                         -> StackT tt' m' r'                     liftWithUnlift'' call =                         MkStackT $@@ -437,7 +426,7 @@         in unLiftWithUnlift $ build $ representative @_ @(ListType (Compose Dict MonadTransUnlift)) @tt     getDiscardingUnlift ::            forall m. Monad m-        => StackT tt m (WUnlift MonadTunnelIOInner (StackT tt))+        => StackT tt m (WUnlift MonadTunnelIO (StackT tt))     getDiscardingUnlift = let         build :: forall tt'. ListType (Compose Dict MonadTransUnlift) tt' -> GetDiscardingUnlift (StackT tt')         build NilListType = MkGetDiscardingUnlift $ MkStackT $ return $ MkWUnlift unStackT@@ -446,7 +435,7 @@                 MkGetDiscardingUnlift getDiscardingUnlift' -> let                     getDiscardingUnlift'' ::                            forall m'. Monad m'-                        => StackT tt' m' (WUnlift MonadTunnelIOInner (StackT tt'))+                        => StackT tt' m' (WUnlift MonadTunnelIO (StackT tt'))                     getDiscardingUnlift'' =                         MkStackT $                         case witTransStackDict @Monad @tt0 @m' $ mapListType (\(Compose Dict) -> Compose Dict) w of

@@ -64,14 +64,14 @@     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 :: MVar s -> Unlift MonadTunnelIO (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 :: MonadTunnelIO m => MVar s -> m --> m mVarRunLocked var ma = mVarRunStateT var $ lift ma  discardingStateTUnlift :: s -> Unlift MonadIO (StateT s)

@@ -1,92 +0,0 @@-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

@@ -0,0 +1,118 @@+module Control.Monad.Ology.Specific.WithT where++import Control.Monad.Ology.Data+import Control.Monad.Ology.General+import Import++type WithT :: forall k. (k -> Type) -> Type -> Type+newtype WithT m a = MkWithT+    { unWithT :: With m a+    }++instance Functor (WithT m) where+    fmap ab (MkWithT aff) = MkWithT $ \bf -> aff $ bf . ab++instance TransConstraint Functor WithT where+    hasTransConstraint = Dict++instance Applicative (WithT m) where+    pure a = MkWithT $ \af -> af a+    MkWithT f <*> MkWithT x = MkWithT $ \bf -> f $ \ab -> x (bf . ab)++instance TransConstraint Applicative WithT where+    hasTransConstraint = Dict++instance Monad (WithT m) where+    return = pure+    MkWithT m >>= f = MkWithT $ \bf -> m (\a -> unWithT (f a) bf)++instance TransConstraint Monad WithT where+    hasTransConstraint = Dict++instance MonadTrans WithT where+    lift m = MkWithT $ \af -> m >>= af++instance MonadIO m => MonadIO (WithT m) where+    liftIO = lift . liftIO++instance TransConstraint MonadIO WithT where+    hasTransConstraint = Dict++instance Semigroup a => Semigroup (WithT m a) where+    (<>) = liftA2 (<>)++instance Monoid a => Monoid (WithT m a) where+    mempty = pure mempty++instance MonadFix m => MonadFix (WithT m) where+    mfix ama =+        MkWithT $ \amr -> do+            rec+                (~(olda, r')) <-+                    unWithT (ama olda) $ \newa -> do+                        r <- amr newa+                        return (newa, r)+            return r'++instance MonadException m => MonadException (WithT m) where+    type Exc (WithT m) = Exc m+    throwExc e = MkWithT $ \_ -> throwExc e+    catchExc (MkWithT afrfr) cc = MkWithT $ \afr -> catchExc (afrfr afr) $ \e -> unWithT (cc e) afr++instance MonadThrow e m => MonadThrow e (WithT m) where+    throw e = MkWithT $ \_ -> throw e++instance MonadCatch e m => MonadCatch e (WithT m) where+    catch (MkWithT afrfr) cc = MkWithT $ \afr -> catch (afrfr afr) $ \e -> unWithT (cc e) afr++unpickWithT ::+       forall m a. MonadCoroutine m+    => WithT m a+    -> m (a, m ())+unpickWithT (MkWithT w) = unpickWith w++pickWithT ::+       forall m a. Monad m+    => m (a, m ())+    -> WithT m a+pickWithT mm = MkWithT $ pickWith mm++instance {-# OVERLAPPING #-} (MonadHoistIO m, MonadCoroutine m) => MonadHoistIO (WithT m) where+    hoistIO f wma = pickWithT $ fmap (fmap $ hoistIO f) $ hoistIO f $ unpickWithT wma++mapWithT :: (m --> m) -> WithT m ()+mapWithT ff = MkWithT $ \uf -> ff $ uf ()++postWithT :: Monad m => m () -> WithT m ()+postWithT mu =+    mapWithT $ \mr -> do+        r <- mr+        mu+        return r++withTMap :: WithT m () -> m --> m+withTMap (MkWithT uff) f = uff $ \() -> f++execMapWithT :: Monad m => m (WithT m a) -> WithT m a+execMapWithT ffa =+    MkWithT $ \af -> do+        MkWithT aff <- ffa+        aff af++withParamRef ::+       forall m. Monad m+    => Param m --> Ref (WithT m)+withParamRef (param :: _ a) = let+    refGet :: WithT m a+    refGet =+        MkWithT $ \afr -> do+            a <- paramAsk param+            afr a+    refPut :: a -> WithT m ()+    refPut a = MkWithT $ \ufr -> paramWith param a $ ufr ()+    in MkRef {..}++liftWithT ::+       forall t m. (MonadTransUnlift t, MonadTunnelIO m)+    => WithT m --> WithT (t m)+liftWithT (MkWithT aff) = MkWithT $ \atf -> liftWithUnlift $ \unlift -> aff $ unlift . atf

@@ -2,11 +2,18 @@  module Control.Monad.Ology.Specific.WriterT     ( module Control.Monad.Trans.Writer+    , module Control.Monad.Ology.Specific.WriterT     ) where  import Control.Monad.Ology.General import Control.Monad.Trans.Writer hiding (liftCallCC, liftCatch) import Import++collect :: (Monad m, Monoid w) => WriterT w m a -> WriterT w m (a, w)+collect wmr = censor (\_ -> mempty) $ listen wmr++evalWriterT :: Monad m => WriterT w m a -> m a+evalWriterT wma = fmap fst $ runWriterT wma  instance Monoid w => TransConstraint Functor (WriterT w) where     hasTransConstraint = Dict

@@ -0,0 +1,90 @@+module Data+    ( testData+    ) where++import Control.Monad.Ology+import Data.Text+import Prelude+import Test.Tasty+import Test.Tasty.HUnit++lensFst :: Lens' (a, b) a+lensFst afa (a, b) = fmap (\a' -> (a', b)) $ afa a++lensSnd :: Lens' (a, b) b+lensSnd bfb (a, b) = fmap (\b' -> (a, b')) $ bfb b++type WM = WriterT ([Int], Text) IO++wmProd :: Prod WM ([Int], Text)+wmProd = writerProd++intsProd :: Prod WM [Int]+intsProd = lensMapProd lensFst wmProd++textProd :: Prod WM Text+textProd = lensMapProd lensSnd wmProd++testProdTell :: TestTree+testProdTell =+    testCase "tell" $ do+        found <-+            execWriterT $ do+                prodTell intsProd [34]+                prodTell textProd "abc"+                prodTell wmProd ([1, 2], "PQ")+                prodTell intsProd [17]+                prodTell textProd "def"+        assertEqual "" ([34, 1, 2, 17], "abcPQdef") found++testProdListen :: TestTree+testProdListen =+    testCase "listen" $ do+        ((fi, ft), found) <-+            runWriterT $ do+                prodTell wmProd ([0], "XYZ")+                fi <-+                    prodListen_ intsProd $ do+                        prodTell intsProd [34]+                        prodTell textProd "abc"+                        prodTell wmProd ([1, 2], "PQ")+                prodTell intsProd [17]+                ft <-+                    prodListen_ textProd $ do+                        prodTell intsProd [8]+                        prodTell textProd "ijk"+                        prodTell wmProd ([9, 10], "MN")+                prodTell textProd "def"+                return (fi, ft)+        assertEqual "output" ([0, 34, 1, 2, 17, 8, 9, 10], "XYZabcPQijkMNdef") found+        assertEqual "fi" [34, 1, 2] fi+        assertEqual "ft" "ijkMN" ft++testProdCollect :: TestTree+testProdCollect =+    testCase "collect" $ do+        ((fi, ft), found) <-+            runWriterT $ do+                prodTell wmProd ([0], "XYZ")+                fi <-+                    prodCollect_ intsProd $ do+                        prodTell intsProd [34]+                        prodTell textProd "abc"+                        prodTell wmProd ([1, 2], "PQ")+                prodTell intsProd [17]+                ft <-+                    prodCollect_ textProd $ do+                        prodTell intsProd [8]+                        prodTell textProd "ijk"+                        prodTell wmProd ([9, 10], "MN")+                prodTell textProd "def"+                return (fi, ft)+        assertEqual "output" ([0, 17, 8, 9, 10], "XYZabcPQdef") found+        assertEqual "fi" [34, 1, 2] fi+        assertEqual "ft" "ijkMN" ft++testProd :: TestTree+testProd = testGroup "prod" [testProdTell, testProdListen, testProdCollect]++testData :: TestTree+testData = testGroup "data" [testProd]

@@ -8,6 +8,7 @@ import Prelude import Test.Tasty import Test.Tasty.HUnit+import Useful  testACatch ::        forall m e. (Eq e, Show e, MonadCatch e m)@@ -54,6 +55,51 @@         SuccessResult a -> return a         FailureResult _ -> fail "Left" +data Info = forall m e. (MonadCatch e m, MonadIO m, Eq e, Show e) =>+                            MkInfo+    { iName :: String+    , iRun :: m --> IO+    , iExc :: Int -> e+    }++newtype TestExc =+    MkTestExc Int+    deriving (Eq, Show)++instance Exception TestExc++ioInfo :: Info+ioInfo = MkInfo {iName = "IO", iRun = \ioa -> ioa, iExc = MkTestExc}++iRunWithT :: WithT IO --> IO+iRunWithT tia = unWithT tia return++transformInfo :: Info+transformInfo = MkInfo {iName = "WithT IO", iRun = iRunWithT, iExc = MkTestExc}++testCatch :: Info -> TestTree+testCatch MkInfo {..} =+    testCase iName $+    compareTest "ABCE" $ \post -> do+        post "A"+        found <-+            iRun $+            try $ do+                liftIO $ post "B"+                reu <-+                    try $ do+                        liftIO $ post "C"+                        () <- throw $ iExc 52+                        liftIO $ post "D"+                liftIO $ assertEqual "exc1" (FailureResult $ iExc 52) reu+                liftIO $ post "E"+                () <- throw $ iExc 74+                liftIO $ post "F"+        assertEqual "exc2" (FailureResult $ iExc 74) found++testCatches :: TestTree+testCatches = testGroup "catch" [testCatch ioInfo, testCatch transformInfo]+ testException :: TestTree testException =     testGroup@@ -63,4 +109,5 @@         , testGroup "ResultT () IO" $ pure $ testABracket @(ResultT () IO) runResultT' $ throwR ()         , testGroup "ComposeInner Maybe IO" $           pure $ testABracket @(ComposeInner Maybe IO) runComposeInner $ liftInner Nothing+        , testCatches         ]

@@ -4,13 +4,14 @@  import Compose import Coroutine+import Data import Exception import Lifecycle import Prelude import Test.Tasty  tests :: TestTree-tests = testGroup "monadology" [testCoroutine, testLifecycle, testComposeInner, testException]+tests = testGroup "monadology" [testCoroutine, testLifecycle, testComposeInner, testException, testData]  main :: IO () main = defaultMain tests