extra 0.3 → 0.3.1

raw patch · 9 files changed

+149/−23 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.txt +2/−0
• extra.cabal +2/−1
• src/Control/Concurrent/Extra.hs +82/−8
• src/Control/Exception/Extra.hs +3/−1
• src/Data/List/Extra.hs +12/−4
• src/System/Time/Extra.hs +16/−3
• test/Test.hs +0/−1
• test/TestGen.hs +9/−3
• test/TestUtil.hs +23/−2

@@ -1,5 +1,7 @@ Changelog for Extra +0.3.1+    Fix a bug in breakEnd/spanEnd 0.3     Rename showTime to showDuration     Add stringException

@@ -1,7 +1,7 @@ cabal-version:      >= 1.10 build-type:         Simple name:               extra-version:            0.3+version:            0.3.1 license:            BSD3 license-file:       LICENSE category:           Development@@ -60,6 +60,7 @@     build-depends:         base == 4.*,         extra,+        time,         QuickCheck     if !os(windows)         build-depends: unix

@@ -1,14 +1,26 @@ {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fno-warn-duplicate-exports #-} --- | Extra functions for "Control.Concurrent".---   These functions manipulate the number of capabilities and new types of lock.+-- | Extra functions for "Control.Concurrent". These fall into a few categories:+--+-- * Some functions manipulate the number of capabilities.+--+-- * The 'forkFinally' function - if you need greater control of exceptions and threads+--   see the <http://hackage.haskell.org/package/slave-thread slave-thread> package.+--+-- * Three new types of 'MVar', namely 'Lock' (no associated value), 'Var' (never empty)+--   and 'Barrier' (filled at most once). See+--   <http://neilmitchell.blogspot.co.uk/2012/06/flavours-of-mvar_04.html this blog post>+--   for more examples. module Control.Concurrent.Extra(     module Control.Concurrent,     withNumCapabilities, setNumCapabilities,     forkFinally,+    -- * Lock     Lock, newLock, withLock, withLockTry,+    -- * Var     Var, newVar, readVar, modifyVar, modifyVar_, withVar,+    -- * Barrier     Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe,     ) where @@ -38,9 +50,11 @@ -- to terminate, with an exception or a returned value.  The function is -- called with asynchronous exceptions masked. ----- >> forkFinally action and_then =--- >>   mask $ \restore ->--- >>     forkIO $ try (restore action) >>= and_then+-- @+-- forkFinally action and_then =+--    mask $ \restore ->+--      forkIO $ try (restore action) >>= and_then+-- @ -- -- This function is useful for informing the parent when a child -- terminates, for example.@@ -54,15 +68,35 @@ --------------------------------------------------------------------- -- LOCK --- | Like an MVar, but has no value+-- | Like an MVar, but has no value.+--   Used to guarantees single-threaded access, typically to some system resource. +--   As an example:+--+-- @+-- lock <- 'newLock'+-- let output = 'withLock' . putStrLn+-- forkIO $ do ...; output \"hello\"+-- forkIO $ do ...; output \"world\"+-- @+--+--   Here we are creating a lock to ensure that when writing output our messages+--   do not get interleaved. This use of MVar never blocks on a put. It is permissible,+--   but rare, that a withLock contains a withLock inside it - but if so,+--   watch out for deadlocks.+ newtype Lock = Lock (MVar ()) +-- | Create a 'newLock'. newLock :: IO Lock newLock = fmap Lock $ newMVar () +-- | Perform some operation while holding 'Lock'. Will prevent all other+--   operations from using the 'Lock' while the action is ongoing. withLock :: Lock -> IO a -> IO a withLock (Lock x) = withMVar x . const +-- | 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@@ -75,21 +109,43 @@ --------------------------------------------------------------------- -- VAR --- | Like an MVar, but must always be full+-- | Like an MVar, but must always be full.+--   Used to on a mutable variable in a thread-safe way.+--   As an example:+--+-- @+-- hits <- 'newVar' 0+-- forkIO $ do ...; 'modifyVar_' hits (+1); ...+-- i <- 'readVar' hits+-- print ("HITS",i)+-- @+--+--   Here we have a variable which we modify atomically, so modifications are+--   not interleaved. This use of MVar never blocks on a put. No modifyVar+--   operation should ever block, and they should always complete in a reasonable+--   timeframe. A Var should not be used to protect some external resource, only+--   the variable contained within. Information from a readVar should not be subsequently+--   inserted back into the Var. newtype Var a = Var (MVar a) +-- | Create a new 'Var' with a value. newVar :: a -> IO (Var a) newVar = fmap Var . newMVar +-- | Read the current value of the 'Var'. readVar :: Var a -> IO a readVar (Var x) = readMVar x +-- | Modify a 'Var' producing a new value and a return result. modifyVar :: Var a -> (a -> IO (a, b)) -> IO b modifyVar (Var x) f = modifyMVar x f +-- | Modify a 'Var', a restricted version of 'modifyVar'. modifyVar_ :: Var a -> (a -> IO a) -> IO () modifyVar_ (Var x) f = modifyMVar_ x f +-- | Perform some operation using the value in the 'Var',+--   a restricted version of 'modifyVar'. withVar :: Var a -> (a -> IO b) -> IO b withVar (Var x) f = withMVar x f @@ -97,18 +153,36 @@ --------------------------------------------------------------------- -- BARRIER --- | Starts out empty, then is filled exactly once+-- | Starts out empty, then is filled exactly once. As an example:+--+-- @+-- bar <- 'newBarrier'+-- forkIO $ do ...; val <- ...; 'signalBarrier' bar val+-- print =<< waitBarrier bar+-- @+--+--   Here we create a barrier which will contain some computed value.+--   A thread is forked to fill the barrier, while the main thread waits+--   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) +-- | Create a new 'Barrier'. newBarrier :: IO (Barrier a) newBarrier = fmap Barrier newEmptyMVar +-- | Write a value into the Barrier, releasing anyone at 'waitBarrier'.+--   Any subsequent attempts to signal the 'Barrier' will be silently ignored. signalBarrier :: Barrier a -> a -> IO () signalBarrier (Barrier x) = void . tryPutMVar x +-- | Wait until a barrier has been signaled with 'signalBarrier'. waitBarrier :: Barrier a -> IO a waitBarrier (Barrier x) = readMVar x +-- | 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

@@ -90,7 +90,9 @@ -- | Catch an exception if the predicate passes, then call the handler with the original exception. --   As an example: ----- >> readFileExists x == catchBool isDoesNotExistError (readFile "myfile") (const $ return "")+-- @+-- readFileExists x == catchBool isDoesNotExistError (readFile \"myfile\") (const $ return \"\")+-- @ catchBool :: Exception e => (e -> Bool) -> IO a -> (e -> IO a) -> IO a catchBool f a b = catchJust (bool f) a b 

@@ -159,13 +159,21 @@ replace from to [] = []  +-- | Break, but from the end.+--+-- > breakEnd isLower "youRE" === ("you","RE")+-- > breakEnd isLower "youre" === ("youre","")+-- > breakEnd isLower "YOURE" === ("","YOURE") breakEnd :: (a -> Bool) -> [a] -> ([a], [a])-breakEnd f xs = case break f $ reverse xs of-    (_, []) -> (xs, [])-    (as, b:bs) -> (reverse bs, b:reverse as)+breakEnd f = swap . both reverse . break f . reverse +-- | Span, but from the end.+--+-- > spanEnd isUpper "youRE" == ("you","RE")+-- > spanEnd (not . isSpace) "x y z" == ("x y ","z")+-- > \f xs-> spanEnd f xs == swap (both reverse (span f (reverse xs))) spanEnd :: (a -> Bool) -> [a] -> ([a], [a])-spanEnd f xs = breakEnd (not . f) xs+spanEnd f = breakEnd (not . f)   wordsBy :: (a -> Bool) -> [a] -> [[a]]

@@ -12,12 +12,21 @@ import Numeric.Extra import Data.IORef +-- | A type alias for seconds, which are stored as 'Double'. type Seconds = Double +-- | Sleep for a number of seconds.+--+-- > fmap (round . fst) (duration $ sleep 1) == return 1 sleep :: Seconds -> IO () sleep x = threadDelay $ ceiling $ x * 1000000  +-- | Calculate the difference between two times in seconds.+--   Usually the first time will be the end of an event, and the+--   second time will be the beginning.+--+-- > \a b -> a > b ==> subtractTime a b > 0 subtractTime :: UTCTime -> UTCTime -> Seconds subtractTime end start = fromRational $ toRational $ end `diffUTCTime` start @@ -39,7 +48,9 @@             where (ms,ss) = round x `divMod` 60  --- | Call once at the start, then call repeatedly to get Time values out+-- | Call once to start, then call repeatedly to get the elapsed time since the first+--   call. Values will usually increase, unless the system clock is updated+--   (if you need the guarantee, see 'offsetTimeIncrease'). offsetTime :: IO (IO Seconds) offsetTime = do     start <- getCurrentTime@@ -47,7 +58,9 @@         end <- getCurrentTime         return $ end `subtractTime` start --- | Like offsetTime, but results will never decrease (though they may stay the same)+-- | Like 'offsetTime', but results will never decrease (though they may stay the same).+--+-- > do f <- offsetTimeIncrease; xs <- replicateM 10 f; return $ xs == sort xs offsetTimeIncrease :: IO (IO Seconds) offsetTimeIncrease = do     t <- offsetTime@@ -56,7 +69,7 @@         t <- t         atomicModifyIORef ref $ \o -> let m = max t o in m `seq` (m, m) -+-- | Record how long a computation takes in 'Seconds'. duration :: IO a -> IO (Seconds, a) duration act = do     time <- offsetTime

@@ -5,7 +5,6 @@ import TestUtil  -- Check that we managed to export everything-import Extra(Seconds, whenJust, (&&^), system_, word1, readFile') _unused1 x = whenJust _unused2 x = (&&^) _unused3 x = system_

@@ -1,9 +1,6 @@ {-# LANGUAGE ExtendedDefaultRules, ScopedTypeVariables #-} module TestGen(tests) where import TestUtil-import Extra-import Data.List-import Test.QuickCheck default(Maybe Bool,Int,Double) tests :: IO () tests = do@@ -34,6 +31,12 @@     testGen "allSame []      == True" $ allSame []      == True     testGen "lower \"This is A TEST\" == \"this is a test\"" $ lower "This is A TEST" == "this is a test"     testGen "lower \"\" == \"\"" $ lower "" == ""+    testGen "breakEnd isLower \"youRE\" === (\"you\",\"RE\")" $ breakEnd isLower "youRE" === ("you","RE")+    testGen "breakEnd isLower \"youre\" === (\"youre\",\"\")" $ breakEnd isLower "youre" === ("youre","")+    testGen "breakEnd isLower \"YOURE\" === (\"\",\"YOURE\")" $ breakEnd isLower "YOURE" === ("","YOURE")+    testGen "spanEnd isUpper \"youRE\" == (\"you\",\"RE\")" $ spanEnd isUpper "youRE" == ("you","RE")+    testGen "spanEnd (not . isSpace) \"x y z\" == (\"x y \",\"z\")" $ spanEnd (not . isSpace) "x y z" == ("x y ","z")+    testGen "\\f xs-> spanEnd f xs == swap (both reverse (span f (reverse xs)))" $ \f xs-> spanEnd f xs == swap (both reverse (span f (reverse xs)))     testGen "breakOn \"::\" \"a::b::c\" == (\"a\", \"::b::c\")" $ breakOn "::" "a::b::c" == ("a", "::b::c")     testGen "breakOn \"/\" \"foobar\"   == (\"foobar\", \"\")" $ breakOn "/" "foobar"   == ("foobar", "")     testGen "\\needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack" $ \needle haystack -> let (prefix,match) = breakOn needle haystack in prefix ++ match == haystack@@ -57,7 +60,10 @@     testGen "showDP 0 pi == \"3\"" $ showDP 0 pi == "3"     testGen "showDP 2 3  == \"3.00\"" $ showDP 2 3  == "3.00"     testGen "captureOutput (print 1) == return (\"1\\n\",())" $ captureOutput (print 1) == return ("1\n",())+    testGen "fmap (round . fst) (duration $ sleep 1) == return 1" $ fmap (round . fst) (duration $ sleep 1) == return 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"     testGen "showDuration 62003.8 == \"17h13m\"" $ showDuration 62003.8 == "17h13m"     testGen "showDuration 1e8     == \"27777h47m\"" $ showDuration 1e8     == "27777h47m"+    testGen "do f <- offsetTimeIncrease; xs <- replicateM 10 f; return $ xs == sort xs" $ do f <- offsetTimeIncrease; xs <- replicateM 10 f; return $ xs == sort xs

@@ -1,16 +1,25 @@ -module TestUtil(runTests, testGen, erroneous) where+module TestUtil(runTests, testGen, erroneous, module X) where  import Test.QuickCheck import Test.QuickCheck.Test-import Control.Monad import Control.Exception.Extra import Data.Either.Extra import System.IO.Extra import Data.IORef import System.IO.Unsafe+import Data.Time.Clock+import Data.Time.Calendar+import Text.Show.Functions() +import Extra as X+import Control.Monad as X+import Data.List as X+import Data.Char as X+import Data.Tuple as X+import Test.QuickCheck as X + {-# NOINLINE testCount #-} testCount :: IORef Int testCount = unsafePerformIO $ newIORef 0@@ -34,6 +43,9 @@     n <- readIORef testCount     putStrLn $ "Success (" ++ show n ++ " tests)" +instance Testable a => Testable (IO a) where+    property = property . unsafePerformIO+    exhaustive = exhaustive . unsafePerformIO  instance Eq a => Eq (IO a) where     a == b = unsafePerformIO $ do@@ -43,3 +55,12 @@  instance Eq SomeException where     a == b = show a == show b++instance Arbitrary UTCTime where+    arbitrary = liftM2 UTCTime arbitrary arbitrary++instance Arbitrary Day where+    arbitrary = fmap ModifiedJulianDay arbitrary++instance Arbitrary DiffTime where+    arbitrary = fmap realToFrac $ choose (0 :: Double, 86401)