Soostone#69 switching from using unliftio

.gitignore

@@ -7,4 +7,6 @@ cabal-dev
 *.swp
 TAGS
 .stack-work
-stack.yaml.lock
+stack.yaml.lock
+*.idea
+*.iml

retry.cabal

@@ -41,6 +41,7 @@ library
     , ghc-prim
     , random               >= 1
     , transformers
+    , unliftio             >=0.2.14
   hs-source-dirs:      src
   default-language:    Haskell2010
 
@@ -71,6 +72,7 @@ test-suite test
       , stm
       , ghc-prim
       , mtl
+      , unliftio             >=0.2.14
     default-language: Haskell2010
 
     if flag(lib-Werror)

src/Control/Retry.hs

@@ -81,14 +81,11 @@ module Control.Retry
 -------------------------------------------------------------------------------
 import           Control.Applicative
 import           Control.Concurrent
-#if MIN_VERSION_base(4, 7, 0)
-import           Control.Exception (AsyncException, SomeAsyncException)
-#else
+
 import           Control.Exception (AsyncException)
-#endif
 import           Control.Monad
-import           Control.Monad.Catch
-import           Control.Monad.IO.Class
+import           Control.Monad.Catch (throwM, MonadThrow)
+import           UnliftIO (MonadUnliftIO, MonadIO, SomeException, SomeAsyncException, Handler(..), Exception, liftIO, mask, try, fromException)
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Maybe
 import           Control.Monad.Trans.State
@@ -98,11 +95,7 @@ import           GHC.Generics
 import           GHC.Prim
 import           GHC.Types (Int(I#))
 import           System.Random
-# if MIN_VERSION_base(4, 9, 0)
 import           Data.Semigroup
-# else
-import           Data.Monoid
-# endif
 import           Prelude
 -------------------------------------------------------------------------------
 
@@ -160,7 +153,7 @@ retryPolicyDefault = constantDelay 50000 <> limitRetries 5
 -- Base 4.9.0 adds a Data.Semigroup module. This has fewer
 -- dependencies than the semigroups package, so we're using base's
 -- only if its available.
-# if MIN_VERSION_base(4, 9, 0)
+
 instance Monad m => Semigroup (RetryPolicyM m) where
   (RetryPolicyM a) <> (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do
     a' <- MaybeT $ a n
@@ -171,14 +164,6 @@ instance Monad m => Semigroup (RetryPolicyM m) where
 instance Monad m => Monoid (RetryPolicyM m) where
     mempty = retryPolicy $ const (Just 0)
     mappend = (<>)
-# else
-instance Monad m => Monoid (RetryPolicyM m) where
-    mempty = retryPolicy $ const (Just 0)
-    (RetryPolicyM a) `mappend` (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do
-      a' <- MaybeT $ a n
-      b' <- MaybeT $ b n
-      return $! max a' b'
-#endif
 
 
 -------------------------------------------------------------------------------
@@ -525,11 +510,7 @@ retryingDynamic policy chk f = go defaultRetryStatus
 -- Running action
 -- *** Exception: this is an error
 recoverAll
-#if MIN_VERSION_exceptions(0, 6, 0)
-         :: (MonadIO m, MonadMask m)
-#else
-         :: (MonadIO m, MonadCatch m)
-#endif
+         :: (MonadUnliftIO m, MonadThrow m)
          => RetryPolicyM m
          -> (RetryStatus -> m a)
          -> m a
@@ -551,12 +532,12 @@ skipAsyncExceptions
 skipAsyncExceptions = handlers
   where
     asyncH _ = Handler $ \ (_ :: AsyncException) -> return False
-#if MIN_VERSION_base(4, 7, 0)
+
     someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False
     handlers = [asyncH, someAsyncH]
-#else
-    handlers = [asyncH]
-#endif
+
+
+
 
 
 -------------------------------------------------------------------------------
@@ -569,37 +550,29 @@ skipAsyncExceptions = handlers
 -- just plan on catching 'SomeException', you may as well ues
 -- 'recoverAll'
 recovering
-#if MIN_VERSION_exceptions(0, 6, 0)
-    :: (MonadIO m, MonadMask m)
-#else
-    :: (MonadIO m, MonadCatch m)
-#endif
+    :: (MonadUnliftIO m, MonadThrow m)
     => RetryPolicyM m
     -- ^ Just use 'retryPolicyDefault' for default settings
-    -> [(RetryStatus -> Handler m Bool)]
+    -> [RetryStatus -> Handler m Bool]
     -- ^ Should a given exception be retried? Action will be
     -- retried if this returns True *and* the policy allows it.
     -- This action will be consulted first even if the policy
     -- later blocks it.
     -> (RetryStatus -> m a)
     -- ^ Action to perform
     -> m a
-recovering policy hs f =
-    recoveringDynamic policy hs' f
+recovering policy hs = recoveringDynamic policy hs'
   where
-    hs' = map (fmap toRetryAction .) hs
+    hs' = map (fmap' toRetryAction .) hs
+    fmap' f (Handler h) = Handler (liftM f . h)
 
 -- | The difference between this and 'recovering' is the same as
 --  the difference between 'retryingDynamic' and 'retrying'.
 recoveringDynamic
-#if MIN_VERSION_exceptions(0, 6, 0)
-    :: (MonadIO m, MonadMask m)
-#else
-    :: (MonadIO m, MonadCatch m)
-#endif
+    :: (MonadUnliftIO m, MonadThrow m)
     => RetryPolicyM m
     -- ^ Just use 'retryPolicyDefault' for default settings
-    -> [(RetryStatus -> Handler m RetryAction)]
+    -> [RetryStatus -> Handler m RetryAction]
     -- ^ Should a given exception be retried? Action will be
     -- retried if this returns either 'ConsultPolicy' or
     -- 'ConsultPolicyOverrideDelay' *and* the policy allows it.
@@ -642,11 +615,7 @@ recoveringDynamic policy hs f = mask $ \restore -> go restore defaultRetryStatus
 -- and failure. Useful for implementing retry logic in distributed
 -- queues and similar external-interfacing systems.
 stepping
-#if MIN_VERSION_exceptions(0, 6, 0)
-    :: (MonadIO m, MonadMask m)
-#else
-    :: (MonadIO m, MonadCatch m)
-#endif
+    :: (MonadUnliftIO m, MonadThrow m)
     => RetryPolicyM m
     -- ^ Just use 'retryPolicyDefault' for default settings
     -> [(RetryStatus -> Handler m Bool)]
@@ -671,15 +640,13 @@ stepping policy hs schedule f s = do
       recover e ((($ s) -> Handler h) : hs')
         | Just e' <- fromException e = do
             chk <- h e'
-            case chk of
-              True -> do
-                res <- applyPolicy policy s
-                case res of
-                  Just rs -> do
-                    schedule $! rs
-                    return Nothing
-                  Nothing -> throwM e'
-              False -> throwM e'
+            if chk then (do
+              res <- applyPolicy policy s
+              case res of
+                Just rs -> do
+                  schedule $! rs
+                  return Nothing
+                Nothing -> throwM e') else throwM e'
         | otherwise = recover e hs'
 
 

test/Tests/Control/Retry.hs

@@ -7,16 +7,13 @@ module Tests.Control.Retry
 
 -------------------------------------------------------------------------------
 import           Control.Applicative
-import           Control.Concurrent
-import           Control.Concurrent.STM      as STM
 import qualified Control.Exception           as EX
-import           Control.Monad.Catch
+import           Control.Monad.Catch         (throwM)
 import           Control.Monad.Identity
 import           Control.Monad.IO.Class
 import           Control.Monad.Writer.Strict
 import           Data.Either
-import           Data.IORef
-import           Data.List
+import           Data.List                  (sort, group)
 import           Data.Maybe
 import           Data.Time.Clock
 import           Data.Time.LocalTime         ()
@@ -25,6 +22,8 @@ import           Hedgehog                    as HH
 import qualified Hedgehog.Gen                as Gen
 import qualified Hedgehog.Range              as Range
 import           System.IO.Error
+import           UnliftIO                    hiding (timeout)
+import           UnliftIO.Concurrent
 import           Test.Tasty
 import           Test.Tasty.Hedgehog
 import           Test.Tasty.HUnit            (assertBool, testCase, (@?=))
@@ -52,15 +51,15 @@ recoveringTests :: TestTree
 recoveringTests = testGroup "recovering"
   [ testProperty "recovering test without quadratic retry delay" $ property $ do
       startTime <- liftIO getCurrentTime
-      timeout <- forAll (Gen.int (Range.linear 0 15))
+      timeout' <- forAll (Gen.int (Range.linear 0 15))
       retries <- forAll (Gen.int (Range.linear 0 50))
       res <- liftIO $ try $ recovering
-        (constantDelay timeout <> limitRetries retries)
+        (constantDelay timeout' <> limitRetries retries)
         testHandlers
         (const $ throwM (userError "booo"))
       endTime <- liftIO getCurrentTime
       HH.assert (isLeftAnd isUserError res)
-      let ms' = (fromInteger . toInteger $ (timeout * retries)) / 1000000.0
+      let ms' = (fromInteger . toInteger $ (timeout' * retries)) / 1000000.0
       HH.assert (diffUTCTime endTime startTime >= ms')
   , testGroup "exception hierarchy semantics"
       [ testCase "does not catch async exceptions" $ do
@@ -71,7 +70,7 @@ recoveringTests = testGroup "recovering"
           tid <- forkIO $
             recoverAll (limitRetries 2) (const work) `finally` putMVar done ()
 
-          atomically (STM.check . (== 1) =<< readTVar counter)
+          atomically (checkSTM . (== 1) =<< readTVar counter)
           EX.throwTo tid EX.UserInterrupt
 
           takeMVar done
@@ -182,7 +181,7 @@ monoidTests = testGroup "Policy is a monoid"
       delayC <- forAll genDelay
       let applyPolicy' f = liftIO $ getRetryPolicyM (f (retryPolicy (const delayA)) (retryPolicy (const delayB)) (retryPolicy (const delayC))) retryStatus
       res <- liftIO (liftA2 (==) (applyPolicy' left) (applyPolicy' right))
-      assert res
+      HH.assert res
 
 
 -------------------------------------------------------------------------------
@@ -322,17 +321,15 @@ overridingDelayTests = testGroup "overriding delay"
         testOverride
           retryingDynamic
           (\delays rs _ -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))
-          (\_ _ -> liftIO getCurrentTime >>= \time -> tell [time])
-    , testProperty "recoveringDynamic" $
-        testOverride
-          recoveringDynamic
-          (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))])
-          (\delays rs -> do
-              liftIO getCurrentTime >>= \time -> tell [time]
-              if rsIterNumber rs < length delays
-                then throwM (userError "booo")
-                else return ()
-          )
+          (\_ ref _ -> liftIO getCurrentTime >>= \time -> modifyIORef' ref (++[time]))
+   , testProperty "recoveringDynamic" $
+       testOverride
+         recoveringDynamic
+         (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))])
+         (\delays ref rs -> do
+             liftIO getCurrentTime >>= \time -> modifyIORef' ref (++[time])
+             when (rsIterNumber rs < length delays) $ throwM (userError "booo")
+         )
     ]
   ]
   where
@@ -344,13 +341,15 @@ overridingDelayTests = testGroup "overriding delay"
     toNominal = realToFrac
     -- Generic test case used to test both "retryingDynamic" and "recoveringDynamic"
     testOverride retryer handler action = property $ do
+      ref <- newIORef []
       retryPolicy' <- forAll $ genPolicyNoLimit (Range.linear 1 1000000)
       delays <- forAll $ Gen.list (Range.linear 1 10) (Gen.int (Range.linear 10 1000))
-      (_, measuredTimestamps) <- liftIO $ runWriterT $ retryer
+      _ <- liftIO  $ retryer
         -- Stop retrying when we run out of delays
         (retryPolicy' <> limitRetries (length delays))
         (handler delays)
-        (action delays)
+        (action delays ref)
+      measuredTimestamps <- readIORef ref
       let expectedDelays = map microsToNominalDiffTime delays
       forM_ (zip (diffTimes measuredTimestamps) expectedDelays) $
         \(actual, expected) -> diff actual (>=) expected