diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,10 @@ Changelog for Extra +1.2 + Add onceFork + Make once async exception safe + Fix a deadlock in once when two people request in parallel + Fix a missing hClose in captureOutput 1.1 #7, add nubOrd, nubOrdOn, nubOrdBy #6, add groupSortOn and groupSortBy diff --git a/Generate.hs b/Generate.hs --- a/Generate.hs +++ b/Generate.hs @@ -9,6 +9,7 @@ import System.Directory import Data.Char import Data.Maybe +import Prelude main :: IO () 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: 1.1 +version: 1.2 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.10.1, GHC==7.8.3, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 +tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2 extra-source-files: CHANGES.txt 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 @@ -15,7 +15,7 @@ module Control.Concurrent.Extra( module Control.Concurrent, getNumCapabilities, setNumCapabilities, withNumCapabilities, - forkFinally, once, + forkFinally, once, onceFork, -- * Lock Lock, newLock, withLock, withLockTry, -- * Var @@ -73,24 +73,41 @@ #endif -data Once a = OncePending | OnceRunning (Barrier a) | OnceDone a - - -- | Given an action, produce a wrapped action that runs at most once. -- If the function raises an exception, the same exception will be reraised each time. +-- +-- > let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2 +-- > \(x :: IO Int) -> void (once x) == return () +-- > \(x :: IO Int) -> join (once x) == x +-- > \(x :: IO Int) -> (do y <- once x; y; y) == x +-- > \(x :: IO Int) -> (do y <- once x; y ||| y) == x once :: IO a -> IO (IO a) once act = do var <- newVar OncePending - let run = either throw return - return $ join $ modifyVar var $ \v -> case v of - OnceDone x -> return (v, run x) - OnceRunning x -> return (v, run =<< waitBarrier x) + let run = either throwIO return + return $ mask $ \unmask -> join $ modifyVar var $ \v -> case v of + OnceDone x -> return (v, unmask $ run x) + OnceRunning x -> return (v, unmask $ run =<< waitBarrier x) OncePending -> do b <- newBarrier return $ (OnceRunning b,) $ do - res <- try_ act + res <- try_ $ unmask act + signalBarrier b res modifyVar_ var $ \_ -> return $ OnceDone res run res + +data Once a = OncePending | OnceRunning (Barrier a) | OnceDone a + + +-- | Like 'once', but immediately starts running the computation on a background thread. +-- +-- > \(x :: IO Int) -> join (onceFork x) == x +-- > \(x :: IO Int) -> (do a <- onceFork x; a; a) == x +onceFork :: IO a -> IO (IO a) +onceFork act = do + bar <- newBarrier + forkFinally act $ signalBarrier bar + return $ either throwIO return =<< waitBarrier bar --------------------------------------------------------------------- diff --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -5,7 +5,7 @@ module Extra( -- * Control.Concurrent.Extra -- | Extra functions available in @"Control.Concurrent.Extra"@. - getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, once, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, + getNumCapabilities, setNumCapabilities, withNumCapabilities, forkFinally, once, onceFork, Lock, newLock, withLock, withLockTry, Var, newVar, readVar, modifyVar, modifyVar_, withVar, Barrier, newBarrier, signalBarrier, waitBarrier, waitBarrierMaybe, -- * Control.Exception.Extra -- | Extra functions available in @"Control.Exception.Extra"@. retry, showException, stringException, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, diff --git a/src/System/IO/Extra.hs b/src/System/IO/Extra.hs --- a/src/System/IO/Extra.hs +++ b/src/System/IO/Extra.hs @@ -120,6 +120,7 @@ hDuplicateTo h out act `finally` do hDuplicateTo out2 out + hClose out2 hSetBuffering out buf diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -4,6 +4,13 @@ default(Maybe Bool,Int,Double,Maybe (Maybe Bool),Maybe (Maybe Char)) tests :: IO () tests = do + let x ||| y = do t1 <- onceFork x; t2 <- onceFork y; t1; t2 + testGen "\\(x :: IO Int) -> void (once x) == return ()" $ \(x :: IO Int) -> void (once x) == return () + testGen "\\(x :: IO Int) -> join (once x) == x" $ \(x :: IO Int) -> join (once x) == x + testGen "\\(x :: IO Int) -> (do y <- once x; y; y) == x" $ \(x :: IO Int) -> (do y <- once x; y; y) == x + testGen "\\(x :: IO Int) -> (do y <- once x; y ||| y) == x" $ \(x :: IO Int) -> (do y <- once x; y ||| y) == x + testGen "\\(x :: IO Int) -> join (onceFork x) == x" $ \(x :: IO Int) -> join (onceFork x) == x + testGen "\\(x :: IO Int) -> (do a <- onceFork x; a; a) == x" $ \(x :: IO Int) -> (do a <- onceFork x; a; a) == x testGen "stringException \"test\" == return \"test\"" $ stringException "test" == return "test" testGen "stringException (\"test\" ++ undefined) == return \"test\"" $ stringException ("test" ++ undefined) == return "test" testGen "stringException (\"test\" ++ undefined ++ \"hello\") == return \"test\"" $ stringException ("test" ++ undefined ++ "hello") == return "test" diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module TestUtil(runTests, testGen, erroneous, (====), module X) where @@ -59,6 +60,17 @@ a <- try_ $ captureOutput a b <- try_ $ captureOutput b return $ a == b + +instance Show (IO a) where + show _ = "<>" + +instance Arbitrary a => Arbitrary (IO a) where + arbitrary = do + (prnt :: Maybe Int, thrw :: Maybe Int, res) <- arbitrary + return $ do + whenJust prnt print + whenJust thrw (fail . show) + return res instance Eq SomeException where a == b = show a == show b