extra 0.5.1 → 0.6

raw patch · 6 files changed

+86/−21 lines, 6 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGES.txt +5/−0
• extra.cabal +3/−3
• src/Control/Concurrent/Extra.hs +26/−15
• src/Extra.hs +1/−1
• src/System/Time/Extra.hs +47/−2
• test/TestGen.hs +4/−0

@@ -1,5 +1,10 @@ Changelog for Extra +0.6+    Ensure barrier is thread-safe+    Make subsequent signalBarrier calls throw an exception+    Add timeout function+    Make sure sleep never wraps round an Int 0.5.1     Use uncons from GHC 7.9 and above 0.5

@@ -1,7 +1,7 @@ cabal-version:      >= 1.10 build-type:         Simple name:               extra-version:            0.5.1+version:            0.6 license:            BSD3 license-file:       LICENSE category:           Development@@ -15,7 +15,7 @@     The module "Extra" documents all functions provided by this library. Modules such as "Data.List.Extra" provide extra functions over "Data.List" and also reexport "Data.List". Users are recommended to replace "Data.List" imports with "Data.List.Extra" if they need the extra functionality. homepage:           https://github.com/ndmitchell/extra#readme bug-reports:        https://github.com/ndmitchell/extra/issues-tested-with:        GHC==7.8.2, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2+tested-with:        GHC==7.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2  extra-source-files:     CHANGES.txt@@ -68,7 +68,7 @@     if !os(windows)         build-depends: unix     hs-source-dirs: test-    ghc-options: -main-is Test.main+    ghc-options: -main-is Test     main-is:        Test.hs     other-modules:         TestUtil

@@ -27,6 +27,7 @@ import Control.Concurrent import Control.Exception.Extra import Control.Monad.Extra+import Data.Maybe   -- | On GHC 7.6 and above with the @-threaded@ flag, brackets a call to 'setNumCapabilities'.@@ -124,12 +125,10 @@ -- | Like 'withLock' but will never block. If the operation cannot be executed --   immediately it will return 'Nothing'. withLockTry :: Lock -> IO a -> IO (Maybe a)-withLockTry (Lock m) act =-    mask $ \restore -> do-        a <- tryTakeMVar m-        case a of-            Nothing -> return Nothing-            Just _ -> restore (fmap Just act) `finally` putMVar m ()+withLockTry (Lock m) act = bracket+    (tryTakeMVar m)+    (\v -> when (isJust v) $ putMVar m ())+    (\v -> if isJust v then fmap Just act else return Nothing)   ---------------------------------------------------------------------@@ -192,25 +191,37 @@ --   for it to complete. A barrier has similarities to a future or promise --   from other languages, has been known as an IVar in other Haskell work, --   and in some ways is like a manually managed thunk.-newtype Barrier a = Barrier (MVar a)+newtype Barrier a = Barrier (Var (Either (MVar ()) a))+    -- Either a Left empty MVar you should wait or a Right result  -- | Create a new 'Barrier'. newBarrier :: IO (Barrier a)-newBarrier = fmap Barrier newEmptyMVar+newBarrier = fmap Barrier $ newVar . Left =<< newEmptyMVar  -- | Write a value into the Barrier, releasing anyone at 'waitBarrier'.---   Any subsequent attempts to signal the 'Barrier' will be silently ignored.+--   Any subsequent attempts to signal the 'Barrier' will throw an exception. signalBarrier :: Barrier a -> a -> IO ()-signalBarrier (Barrier x) = void . tryPutMVar x+signalBarrier (Barrier var) v = mask_ $ do -- use mask so never in an inconsistent state+    join $ modifyVar var $ \x -> case x of+        Left bar -> return (Right v, putMVar bar ())+        Right res -> error "Control.Concurrent.Extra.signalBarrier, attempt to signal a barrier that has already been signaled" + -- | Wait until a barrier has been signaled with 'signalBarrier'. waitBarrier :: Barrier a -> IO a-waitBarrier (Barrier x) = readMVar x+waitBarrier (Barrier var) = do+    x <- readVar var+    case x of+        Right res -> return res+        Left bar -> do+            readMVar bar+            x <- readVar var+            case x of+                Right res -> return res+                Left bar -> error "Cortex.Concurrent.Extra, internal invariant violated in Barrier" + -- | A version of 'waitBarrier' that never blocks, returning 'Nothing' --   if the barrier has not yet been signaled. waitBarrierMaybe :: Barrier a -> IO (Maybe a)-waitBarrierMaybe (Barrier x) = do-    res <- tryTakeMVar x-    whenJust res $ void . tryPutMVar x-    return res+waitBarrierMaybe (Barrier bar) = fmap (either (const Nothing) Just) $ readVar bar

@@ -44,7 +44,7 @@     system_, systemOutput, systemOutput_,     -- * System.Time.Extra     -- | Extra functions available in @"System.Time.Extra"@.-    Seconds, sleep, subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration,+    Seconds, sleep, timeout, subtractTime, showDuration, offsetTime, offsetTimeIncrease, duration,     ) where  import Control.Concurrent.Extra

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-}  -- | Extra functions for working with times. Unlike the other modules in this package, there is no --   corresponding @System.Time@ module. This module enhances the functionality@@ -6,7 +7,7 @@ --   Throughout, time is measured in 'Seconds', which is a type alias for 'Double'. module System.Time.Extra(     Seconds,-    sleep,+    sleep, timeout,     subtractTime,     showDuration,     offsetTime, offsetTimeIncrease, duration@@ -16,7 +17,12 @@ import Data.Time.Clock import Numeric.Extra import Data.IORef+import Control.Monad.Extra+import Control.Exception.Extra+import Data.Typeable+import Data.Unique + -- | A type alias for seconds, which are stored as 'Double'. type Seconds = Double @@ -24,7 +30,46 @@ -- -- > fmap (round . fst) (duration $ sleep 1) == return 1 sleep :: Seconds -> IO ()-sleep x = threadDelay $ ceiling $ x * 1000000+sleep = loopM $ \s ->+    -- important to handle both overflow and underflow vs Int+    if s < 0 then+        return $ Right ()+    else if s > 2000 then do+        threadDelay 2000000000 -- 2000 * 1e6+        return $ Left $ s - 2000+    else do+        threadDelay $ ceiling $ s * 1000000+        return $ Right ()+++-- An internal type that is thrown as a dynamic exception to+-- interrupt the running IO computation when the timeout has+-- expired.+newtype Timeout = Timeout Unique deriving (Eq,Typeable)+instance Show Timeout where show _ = "<<timeout>>"+instance Exception Timeout+++-- | A version of 'System.Timeout.timeout' that takes 'Seconds' and never+--   overflows the bounds of an 'Int'. In addition, the bug that negative+--   timeouts run for ever has been fixed.+--+-- > timeout (-3) (print 1) == return Nothing+-- > timeout 0.1  (print 1) == fmap Just (print 1)+-- > timeout 0.1  (sleep 2 >> print 1) == return Nothing+-- > do (t, _) <- duration $ timeout 0.1 $ sleep 1000; return $ t < 1+timeout :: Seconds -> IO a -> IO (Maybe a)+-- Copied from GHC with a few tweaks.+timeout n f+    | n <= 0 = return Nothing+    | otherwise = do+        pid <- myThreadId+        ex  <- fmap Timeout newUnique+        handleBool (== ex) +                   (const $ return Nothing)+                   (bracket (forkIOWithUnmask $ \unmask -> unmask $ sleep n >> throwTo pid ex)+                            (killThread)+                            (\_ -> fmap Just f))   -- | Calculate the difference between two times in seconds.

@@ -180,6 +180,10 @@     testGen "(doesDirectoryExist =<< withTempDir return) == return False" $ (doesDirectoryExist =<< withTempDir return) == return False     testGen "withTempDir listFiles == return []" $ withTempDir listFiles == return []     testGen "fmap (round . fst) (duration $ sleep 1) == return 1" $ fmap (round . fst) (duration $ sleep 1) == return 1+    testGen "timeout (-3) (print 1) == return Nothing" $ timeout (-3) (print 1) == return Nothing+    testGen "timeout 0.1  (print 1) == fmap Just (print 1)" $ timeout 0.1  (print 1) == fmap Just (print 1)+    testGen "timeout 0.1  (sleep 2 >> print 1) == return Nothing" $ timeout 0.1  (sleep 2 >> print 1) == return Nothing+    testGen "do (t, _) <- duration $ timeout 0.1 $ sleep 1000; return $ t < 1" $ do (t, _) <- duration $ timeout 0.1 $ sleep 1000; return $ t < 1     testGen "\\a b -> a > b ==> subtractTime a b > 0" $ \a b -> a > b ==> subtractTime a b > 0     testGen "showDuration 3.435   == \"3.44s\"" $ showDuration 3.435   == "3.44s"     testGen "showDuration 623.8   == \"10m24s\"" $ showDuration 623.8   == "10m24s"