diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,7 @@ Changelog for Extra +0.3.1 + Fix a bug in breakEnd/spanEnd 0.3 Rename showTime to showDuration Add stringException diff --git a/extra.cabal b/extra.cabal --- a/extra.cabal +++ b/extra.cabal @@ -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 diff --git a/src/Control/Concurrent/Extra.hs b/src/Control/Concurrent/Extra.hs --- a/src/Control/Concurrent/Extra.hs +++ b/src/Control/Concurrent/Extra.hs @@ -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 package. +-- +-- * Three new types of 'MVar', namely 'Lock' (no associated value), 'Var' (never empty) +-- and 'Barrier' (filled at most once). See +-- +-- 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 diff --git a/src/Control/Exception/Extra.hs b/src/Control/Exception/Extra.hs --- a/src/Control/Exception/Extra.hs +++ b/src/Control/Exception/Extra.hs @@ -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 diff --git a/src/Data/List/Extra.hs b/src/Data/List/Extra.hs --- a/src/Data/List/Extra.hs +++ b/src/Data/List/Extra.hs @@ -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]] diff --git a/src/System/Time/Extra.hs b/src/System/Time/Extra.hs --- a/src/System/Time/Extra.hs +++ b/src/System/Time/Extra.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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_ diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -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 diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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)