monadology 0.2 → 0.3

raw patch · 5 files changed

+87/−24 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• changelog.md +5/−0
• monadology.cabal +2/−2
• src/Control/Monad/Ology/General/Exception.hs +10/−2
• src/Control/Monad/Ology/Specific/LifecycleT.hs +49/−19
• test/Lifecycle.hs +21/−1

@@ -1,3 +1,8 @@+## [0.3] - 2023-07-25++- LifecycleT: improve to make closing more robust+- add bracketNoMask_+ ## [0.2] - 2023-07-31  - fix "Prod" type, add more functions

@@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack  name:           monadology-version:        0.2+version:        0.3 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

@@ -50,7 +50,7 @@     -> m --> m bracket_ before after thing = bracket before (const after) (const thing) --- | Like 'bracket", but doesn\'t mask asynchronous exceptions.+-- | Like 'bracket', but doesn\'t mask asynchronous exceptions. bracketNoMask ::        forall m a b. MonadException m     => m a@@ -63,7 +63,15 @@     after a     return b --- | Like 'bracketNoMask", but doesn\'t catch any exceptions.+-- | Variant of 'bracketNoMask'.+bracketNoMask_ ::+       forall m. MonadException m+    => m ()+    -> m ()+    -> m --> m+bracketNoMask_ before after thing = bracketNoMask before (const after) (const thing)++-- | Like 'bracketNoMask', but doesn\'t catch any exceptions. bracketFake ::        forall m a b. Monad m     => m a

@@ -12,7 +12,9 @@     , withLifecycle     , lifecycleWith     -- * LifeState-    , LifeState(..)+    , LifeState+    , pattern NoLifeState+    , lifeStateModify     , closeLifeState     , getLifeState     , addLifeState@@ -24,18 +26,49 @@ 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-    }+newtype LifeState =+    MkLifeState (Maybe (IO (IO Any))) +pattern NoLifeState :: LifeState++pattern NoLifeState = MkLifeState Nothing++lifeStateModify :: (IO --> IO) -> LifeState -> LifeState+lifeStateModify _ (MkLifeState Nothing) = MkLifeState Nothing+lifeStateModify m (MkLifeState (Just ioioa)) = MkLifeState $ Just $ m $ fmap m ioioa++closeIOAny :: IO Any -> IO ()+closeIOAny ioa = do+    Any b <- ioa+    if b+        then closeIOAny ioa+        else return ()++closeLifeState' :: LifeState -> IO Any+closeLifeState' (MkLifeState (Just ioioa)) = do+    ioa <- ioioa+    closeIOAny ioa+    return $ Any True+closeLifeState' (MkLifeState Nothing) = return $ Any False+ closeLifeState :: LifeState -> IO ()-closeLifeState (MkLifeState (Just c)) = c-closeLifeState (MkLifeState Nothing) = return ()+closeLifeState ls = do+    _ <- closeLifeState' ls+    return () +varLifeState :: MVar LifeState -> LifeState+varLifeState var =+    MkLifeState $+    Just $+    return $ do+        ls <- takeMVar var+        putMVar var mempty+        closeLifeState' ls+ instance Semigroup LifeState where     MkLifeState Nothing <> q = q     p <> MkLifeState Nothing = p-    MkLifeState (Just p) <> MkLifeState (Just q) = MkLifeState $ Just $ p >> q+    MkLifeState (Just p) <> MkLifeState (Just q) = MkLifeState $ Just $ p <> q  instance Monoid LifeState where     mempty = MkLifeState Nothing@@ -130,6 +163,7 @@             f var  addLifeState :: MonadIO m => LifeState -> LifecycleT m ()+addLifeState (MkLifeState Nothing) = return () addLifeState ls =     MkLifecycleT $ \var -> do         dangerousMVarRunStateT var $ do@@ -138,7 +172,12 @@  -- | Add a closing action. lifecycleOnCloseIO :: MonadIO m => IO () -> LifecycleT m ()-lifecycleOnCloseIO closer = addLifeState $ MkLifeState $ Just closer+lifecycleOnCloseIO closer =+    addLifeState $+    MkLifeState $+    Just $ do+        closer+        return $ return $ Any False  -- | Add a closing action. lifecycleOnClose :: MonadAskUnliftIO m => m () -> LifecycleT m ()@@ -153,10 +192,7 @@     -> With m a withLifecycle (MkLifecycleT f) run = do     var <- liftIO $ newMVar mempty-    finally (f var >>= run) $-        liftIO $ do-            ls <- takeMVar var-            closeLifeState ls+    finally (f var >>= run) $ liftIO $ closeLifeState $ varLifeState var  -- | Run the lifecycle, then close all resources in reverse order they were opened. runLifecycle ::@@ -179,13 +215,7 @@ getLifeState (MkLifecycleT f) = do     var <- liftIO $ newMVar mempty     t <- f var-    let-        ls =-            MkLifeState $-            Just $ do-                ls0 <- takeMVar var-                closeLifeState ls0-    return (t, ls)+    return (t, varLifeState var)  modifyLifeState ::        forall m. MonadIO m

@@ -40,5 +40,25 @@                 liftIO $ appendStr "F"         runLifecycle lc +testLifeCycleGetState :: TestTree+testLifeCycleGetState =+    testCase "with" $+    compareTest "ACEFDB" $ \appendStr -> do+        let+            lc1 :: Lifecycle ()+            lc1 = do+                liftIO $ appendStr "A"+                lifecycleOnClose $ appendStr "B"+                liftIO $ appendStr "C"+                lifecycleOnClose $ appendStr "D"+        ((), ls) <- getLifeState lc1+        let+            lc2 :: Lifecycle ()+            lc2 = do+                liftIO $ appendStr "E"+                addLifeState ls+                liftIO $ appendStr "F"+        runLifecycle lc2+ testLifecycle :: TestTree-testLifecycle = testGroup "lifecycle" [testLifecycleRun, testLifecycleWith]+testLifecycle = testGroup "lifecycle" [testLifecycleRun, testLifecycleWith, testLifeCycleGetState]