diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,8 @@ Changelog for Extra +1.3 + Add whenJustM + Add errorIO 1.2 Add onceFork Make once async exception safe 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.2 +version: 1.3 license: BSD3 license-file: LICENSE category: Development 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 @@ -211,6 +211,7 @@ -- and in some ways is like a manually managed thunk. newtype Barrier a = Barrier (Var (Either (MVar ()) a)) -- Either a Left empty MVar you should wait or a Right result + -- With base 4.7 and above readMVar is atomic so you probably can implement Barrier directly on MVar a -- | Create a new 'Barrier'. newBarrier :: IO (Barrier a) 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 @@ -6,6 +6,7 @@ module Control.Exception, retry, showException, stringException, + errorIO, -- * Exception catching/ignoring ignore, catch_, handle_, try_, @@ -47,6 +48,14 @@ -- > ignore (fail "die") == return () ignore :: IO () -> IO () ignore = void . try_ + + +-- | Like error, but in the 'IO' monad. +-- Note that while 'fail' in 'IO' raises an 'IOException', this function raises an 'ErrorCall' exception. +-- +-- > try (errorIO "Hello") == return (Left (ErrorCall "Hello")) +errorIO :: String -> IO a +errorIO = throwIO . ErrorCall -- | Retry an operation at most /n/ times (/n/ must be positive). diff --git a/src/Control/Monad/Extra.hs b/src/Control/Monad/Extra.hs --- a/src/Control/Monad/Extra.hs +++ b/src/Control/Monad/Extra.hs @@ -6,7 +6,7 @@ -- see . module Control.Monad.Extra( module Control.Monad, - whenJust, + whenJust, whenJustM, unit, -- * Loops loopM, whileM, @@ -30,6 +30,10 @@ -- > whenJust (Just 1) print == print 1 whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust mg f = maybe (pure ()) f mg + +-- | Like 'whenJust', but where the test can be monadic. +whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () +whenJustM mg f = maybe (return ()) f =<< mg -- | The identity function which requires the inner argument to be @()@. Useful for functions -- with overloaded return types. 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 @@ -317,6 +317,7 @@ -- > breakEnd isLower "youRE" == ("you","RE") -- > breakEnd isLower "youre" == ("youre","") -- > breakEnd isLower "YOURE" == ("","YOURE") +-- > \f xs -> breakEnd (not . f) xs == spanEnd f xs breakEnd :: (a -> Bool) -> [a] -> ([a], [a]) breakEnd f = swap . both reverse . break f . reverse @@ -324,7 +325,8 @@ -- -- > 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))) +-- > \f xs -> uncurry (++) (spanEnd f xs) == xs +-- > \f xs -> spanEnd f xs == swap (both reverse (span f (reverse xs))) spanEnd :: (a -> Bool) -> [a] -> ([a], [a]) spanEnd f = breakEnd (not . f) diff --git a/src/Extra.hs b/src/Extra.hs --- a/src/Extra.hs +++ b/src/Extra.hs @@ -8,10 +8,10 @@ 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, + retry, showException, stringException, errorIO, ignore, catch_, handle_, try_, catchJust_, handleJust_, tryJust_, catchBool, handleBool, tryBool, -- * Control.Monad.Extra -- | Extra functions available in @"Control.Monad.Extra"@. - whenJust, unit, loopM, whileM, partitionM, concatMapM, mapMaybeM, findM, firstJustM, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, + whenJust, whenJustM, unit, loopM, whileM, partitionM, concatMapM, mapMaybeM, findM, firstJustM, whenM, unlessM, ifM, notM, (||^), (&&^), orM, andM, anyM, allM, -- * Data.Either.Extra -- | Extra functions available in @"Data.Either.Extra"@. isLeft, isRight, fromLeft, fromRight, fromEither, diff --git a/test/TestGen.hs b/test/TestGen.hs --- a/test/TestGen.hs +++ b/test/TestGen.hs @@ -17,6 +17,7 @@ testGen "stringException ['t','e','s','t',undefined] == return \"test\"" $ stringException ['t','e','s','t',undefined] == return "test" testGen "ignore (print 1) == print 1" $ ignore (print 1) == print 1 testGen "ignore (fail \"die\") == return ()" $ ignore (fail "die") == return () + testGen "try (errorIO \"Hello\") == return (Left (ErrorCall \"Hello\"))" $ try (errorIO "Hello") == return (Left (ErrorCall "Hello")) testGen "retry 1 (print \"x\") == print \"x\"" $ retry 1 (print "x") == print "x" testGen "retry 3 (fail \"die\") == fail \"die\"" $ retry 3 (fail "die") == fail "die" testGen "whenJust Nothing print == return ()" $ whenJust Nothing print == return () @@ -126,9 +127,11 @@ 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 "\\f xs -> breakEnd (not . f) xs == spanEnd f xs" $ \f xs -> breakEnd (not . f) xs == spanEnd f xs 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 "\\f xs -> uncurry (++) (spanEnd f xs) == xs" $ \f xs -> uncurry (++) (spanEnd f xs) == xs + 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 "wordsBy (== ':') \"::xyz:abc::123::\" == [\"xyz\",\"abc\",\"123\"]" $ wordsBy (== ':') "::xyz:abc::123::" == ["xyz","abc","123"] testGen "\\s -> wordsBy isSpace s == words s" $ \s -> wordsBy isSpace s == words s testGen "linesBy (== ':') \"::xyz:abc::123::\" == [\"\",\"\",\"xyz\",\"abc\",\"\",\"123\",\"\"]" $ linesBy (== ':') "::xyz:abc::123::" == ["","","xyz","abc","","123",""] diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, CPP #-} module TestUtil(runTests, testGen, erroneous, (====), module X) where @@ -23,6 +23,7 @@ import System.Directory as X import System.FilePath as X import System.Info as X +import Control.Exception as X import Test.QuickCheck as X((==>)) @@ -43,6 +44,11 @@ (====) :: (Show a, Eq a) => a -> a -> Bool a ==== b = if a == b then True else error $ "Not equal!\n" ++ show a ++ "\n" ++ show b + +#if __GLASGOW_HASKELL__ < 707 +instance Eq ErrorCall where + ErrorCall x == ErrorCall y = x == y +#endif runTests :: IO () -> IO () runTests t = do