packages feed

hspec-core 2.11.15 → 2.11.16

raw patch · 26 files changed

+1103/−1087 lines, 26 filesdep ~hspec-meta

Dependency ranges changed: hspec-meta

Files

hspec-core.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.3.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:             hspec-core-version:          2.11.15+version:          2.11.16 license:          MIT license-file:     LICENSE copyright:        (c) 2011-2025 Simon Hengel,@@ -60,11 +60,8 @@       Test.Hspec.Core.Extension.Option       Test.Hspec.Core.Extension.Config       Test.Hspec.Core.Spec-      Test.Hspec.Core.Hooks       Test.Hspec.Core.Runner       Test.Hspec.Core.Format-      Test.Hspec.Core.Formatters-      Test.Hspec.Core.Formatters.V1       Test.Hspec.Core.Formatters.V2       Test.Hspec.Core.QuickCheck       Test.Hspec.Core.Util@@ -74,7 +71,6 @@       GetOpt.Declarative.Interpret       GetOpt.Declarative.Types       GetOpt.Declarative.Util-      NonEmpty       Test.Hspec.Core.Annotations       Test.Hspec.Core.Clock       Test.Hspec.Core.Compat@@ -90,9 +86,6 @@       Test.Hspec.Core.Formatters.Pretty       Test.Hspec.Core.Formatters.Pretty.Parser       Test.Hspec.Core.Formatters.Pretty.Unicode-      Test.Hspec.Core.Formatters.V1.Free-      Test.Hspec.Core.Formatters.V1.Internal-      Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.QuickCheck.Util       Test.Hspec.Core.Runner.Eval       Test.Hspec.Core.Runner.JobQueue@@ -102,18 +95,32 @@       Test.Hspec.Core.Spec.Monad       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree-      Control.Concurrent.Async       Data.Algorithm.Diff       Paths_hspec_core   default-language: Haskell2010-  if impl(ghc >= 8.4.1)-    build-depends:-        stm >=2.2-  else+  if impl(ghc)     other-modules:-        Control.Concurrent.STM.TMVar+        Control.Concurrent.Async     hs-source-dirs:-        vendor/stm-2.5.0.1/+        vendor/async-2.2.5/+    cpp-options: -DENABLE_SPEC_HOOKS -DENABLE_SPEC_HOOK_ARGS -DENABLE_LEGACY_V1_FORMATTERS+    if impl(ghc >= 8.4.1)+      build-depends:+          stm >=2.2+    else+      other-modules:+          Control.Concurrent.STM.TMVar+      hs-source-dirs:+          vendor/stm-2.5.0.1/+  if impl(ghc)+    exposed-modules:+        Test.Hspec.Core.Hooks+        Test.Hspec.Core.Formatters+        Test.Hspec.Core.Formatters.V1+    other-modules:+        Test.Hspec.Core.Formatters.V1.Free+        Test.Hspec.Core.Formatters.V1.Internal+        Test.Hspec.Core.Formatters.V1.Monad  test-suite spec   type: exitcode-stdio-1.0@@ -138,7 +145,7 @@     , filepath     , haskell-lexer     , hspec-expectations ==0.8.4.*-    , hspec-meta ==2.11.15+    , hspec-meta ==2.11.16     , process     , quickcheck-io >=0.2.0     , random@@ -154,7 +161,6 @@       GetOpt.Declarative.Interpret       GetOpt.Declarative.Types       GetOpt.Declarative.Util-      NonEmpty       Test.Hspec.Core.Annotations       Test.Hspec.Core.Clock       Test.Hspec.Core.Compat@@ -172,18 +178,12 @@       Test.Hspec.Core.Extension.Tree       Test.Hspec.Core.FailureReport       Test.Hspec.Core.Format-      Test.Hspec.Core.Formatters       Test.Hspec.Core.Formatters.Diff       Test.Hspec.Core.Formatters.Internal       Test.Hspec.Core.Formatters.Pretty       Test.Hspec.Core.Formatters.Pretty.Parser       Test.Hspec.Core.Formatters.Pretty.Unicode-      Test.Hspec.Core.Formatters.V1-      Test.Hspec.Core.Formatters.V1.Free-      Test.Hspec.Core.Formatters.V1.Internal-      Test.Hspec.Core.Formatters.V1.Monad       Test.Hspec.Core.Formatters.V2-      Test.Hspec.Core.Hooks       Test.Hspec.Core.QuickCheck       Test.Hspec.Core.QuickCheck.Util       Test.Hspec.Core.Runner@@ -197,7 +197,6 @@       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util-      Control.Concurrent.Async       Data.Algorithm.Diff       GetOpt.Declarative.EnvironmentSpec       GetOpt.Declarative.UtilSpec@@ -235,11 +234,25 @@       Test.Hspec.Core.UtilSpec       Paths_hspec_core   default-language: Haskell2010-  if impl(ghc >= 8.4.1)-    build-depends:-        stm >=2.2-  else+  if impl(ghc)     other-modules:-        Control.Concurrent.STM.TMVar+        Control.Concurrent.Async     hs-source-dirs:-        vendor/stm-2.5.0.1/+        vendor/async-2.2.5/+    cpp-options: -DENABLE_SPEC_HOOKS -DENABLE_SPEC_HOOK_ARGS -DENABLE_LEGACY_V1_FORMATTERS+    if impl(ghc >= 8.4.1)+      build-depends:+          stm >=2.2+    else+      other-modules:+          Control.Concurrent.STM.TMVar+      hs-source-dirs:+          vendor/stm-2.5.0.1/+  if impl(ghc)+    other-modules:+        Test.Hspec.Core.Hooks+        Test.Hspec.Core.Formatters+        Test.Hspec.Core.Formatters.V1+        Test.Hspec.Core.Formatters.V1.Free+        Test.Hspec.Core.Formatters.V1.Internal+        Test.Hspec.Core.Formatters.V1.Monad
− src/NonEmpty.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-module NonEmpty (-  NonEmpty(..)-, nonEmpty-, reverse-#ifdef TEST-, fromList-#endif-) where--import           Prelude ()-import           Test.Hspec.Core.Compat hiding (reverse)--import qualified Data.List as List-import qualified Data.Foldable as Foldable--data NonEmpty a = a :| [a]-  deriving (Eq, Show, Functor, Foldable, Traversable)--infixr 5 :|--nonEmpty :: [a] -> Maybe (NonEmpty a)-nonEmpty []     = Nothing-nonEmpty (a:as) = Just (a :| as)--reverse :: NonEmpty a -> NonEmpty a-reverse = lift List.reverse--lift :: Foldable f => ([a] -> [b]) -> f a -> NonEmpty b-lift f = fromList . f . Foldable.toList--fromList :: [a] -> NonEmpty a-fromList (a:as) = a :| as-fromList [] = error "NonEmpty.fromList: empty list"
src/Test/Hspec/Core/Clock.hs view
@@ -10,6 +10,10 @@ , timeout ) where +#if MIN_VERSION_base(4,11,0) && !defined(__MHS__)+#define HAS_GET_MONOTONIC_TIME+#endif+ import           Prelude () import           Test.Hspec.Core.Compat @@ -17,7 +21,7 @@ import           Control.Concurrent import qualified System.Timeout as System -#if MIN_VERSION_base(4,11,0)+#ifdef HAS_GET_MONOTONIC_TIME import qualified GHC.Clock as GHC #else import           Data.Time.Clock.POSIX@@ -33,7 +37,7 @@ toMicroseconds (Seconds s) = floor (s * 1000000)  getMonotonicTime :: IO Seconds-#if MIN_VERSION_base(4,11,0)+#ifdef HAS_GET_MONOTONIC_TIME getMonotonicTime = Seconds <$> GHC.getMonotonicTime #else getMonotonicTime = do
src/Test/Hspec/Core/Compat.hs view
@@ -2,6 +2,7 @@ module Test.Hspec.Core.Compat (   module Imports , module Test.Hspec.Core.Compat+, Typeable ) where  import           Control.Exception as Imports@@ -19,7 +20,6 @@ import           Data.Maybe as Imports import           Data.Foldable as Imports import           GHC.Stack as Imports (HasCallStack, withFrozenCallStack)-import           Data.Typeable as Imports (Typeable)  import           System.IO import           System.Exit@@ -30,7 +30,11 @@ #endif  import           Data.Traversable as Imports-import           Data.Monoid as Imports+#ifndef __MHS__+import           Data.Monoid as Imports hiding (First)+#else+import           Data.Monoid as Imports (Endo(..), Sum(..))+#endif import           Data.List as Imports (     stripPrefix   , isPrefixOf@@ -64,9 +68,11 @@   , sequence   , sequence_   , sum+  , length+  , null   ) -import           Data.Typeable (typeOf, typeRepTyCon, tyConModule, tyConName)+import           Data.Typeable import           Data.IORef as Imports  #if MIN_VERSION_base(4,12,0)@@ -83,14 +89,19 @@  import           Control.Concurrent -showType :: Typeable a => a -> String-showType a = let t = typeRepTyCon (typeOf a) in-  show t+#ifndef __MHS__+import           GHC.IO.Exception+#else+import           System.IO.Error+#endif+  ( ioe_type, IOErrorType(..) ) -showFullType :: Typeable a => a -> String-showFullType a = let t = typeRepTyCon (typeOf a) in-  tyConModule t ++ "." ++ tyConName t+isUnsupportedOperation :: IOError -> Bool+isUnsupportedOperation e = ioe_type e == UnsupportedOperation +showType :: Typeable a => a -> String+showType = show . typeRepTyCon . typeOf+ getDefaultConcurrentJobs :: IO Int getDefaultConcurrentJobs = getNumCapabilities @@ -146,4 +157,15 @@         | '\'' == c              = go cs SngQ  False a     as         | '"'  == c              = go cs DblQ  False a     as         | otherwise              = go cs NoneQ False (c:a) as+#endif++unicodeOutputSupported :: Handle -> IO Bool+unicodeOutputSupported _h = do+#ifndef __MHS__+  (== Just "UTF-8") . fmap show <$> hGetEncoding _h+#else+  return True++canonicalizePath :: FilePath -> IO FilePath+canonicalizePath = return #endif
src/Test/Hspec/Core/Config.hs view
@@ -18,7 +18,6 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           GHC.IO.Exception (IOErrorType(UnsupportedOperation)) import           System.IO import           System.IO.Error import           System.Exit@@ -149,13 +148,13 @@  readGlobalConfigFile :: IO (Maybe ConfigFile) readGlobalConfigFile = do-  mHome <- tryJust (guard . isPotentialHomeDirError) getHomeDirectory+  mHome <- tryJust (guard . unavailable) getHomeDirectory   case mHome of     Left _ -> return Nothing     Right home -> readConfigFile (home </> ".hspec")   where-    isPotentialHomeDirError e =-      isDoesNotExistError e || ioeGetErrorType e == UnsupportedOperation+    unavailable :: IOError -> Bool+    unavailable e = isDoesNotExistError e || isUnsupportedOperation e  readLocalConfigFile :: IO (Maybe ConfigFile) readLocalConfigFile = do
src/Test/Hspec/Core/Config/Definition.hs view
@@ -14,7 +14,9 @@ , getExtensionOptions  , getSeed+#ifdef ENABLE_LEGACY_V1_FORMATTERS , getFormatter+#endif  , commandLineOnlyOptions , formatterOptions@@ -42,8 +44,10 @@  import           Test.Hspec.Core.Format (Format, FormatConfig) import           Test.Hspec.Core.Formatters.Pretty (pretty2)+#ifdef ENABLE_LEGACY_V1_FORMATTERS import qualified Test.Hspec.Core.Formatters.V1.Monad as V1 import qualified Test.Hspec.Core.Formatters.V1.Internal as V1 (formatterToFormat)+#endif import           Test.Hspec.Core.Util  import           GetOpt.Declarative@@ -65,8 +69,10 @@ getExtensionOptions :: Config -> [(String, [Option Config])] getExtensionOptions = maybe [] unExtensionOptions . getConfigAnnotation +#ifdef ENABLE_LEGACY_V1_FORMATTERS getFormatter :: Config -> Maybe (FormatConfig -> IO Format) getFormatter config = configFormat config <|> V1.formatterToFormat <$> configFormatter config+#endif  getSeed :: Config -> Maybe Integer getSeed config = configSeed config <|> configQuickCheckSeed config@@ -125,12 +131,16 @@ , configExpertMode :: Bool -- ^ @since 2.11.2 , configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0 , configFormat :: Maybe (FormatConfig -> IO Format)+#ifdef ENABLE_LEGACY_V1_FORMATTERS , configFormatter :: Maybe V1.Formatter+#endif , configHtmlOutput :: Bool , configConcurrentJobs :: Maybe Int , configAnnotations :: Annotations }+#ifdef ENABLE_LEGACY_V1_FORMATTERS {-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-}+#endif {-# DEPRECATED configQuickCheckSeed "Use `configSeed` instead." #-}  mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config@@ -170,7 +180,9 @@ , configExpertMode = False , configAvailableFormatters = formatters , configFormat = Nothing+#ifdef ENABLE_LEGACY_V1_FORMATTERS , configFormatter = Nothing+#endif , configHtmlOutput = False , configConcurrentJobs = Nothing , configAnnotations = mempty
src/Test/Hspec/Core/Example.hs view
@@ -7,6 +7,9 @@ module Test.Hspec.Core.Example ( -- RE-EXPORTED from Test.Hspec.Core.Spec   Example (..)+#ifndef ENABLE_SPEC_HOOK_ARGS+, Arg+#endif , Params (..) , defaultParams , ActionWith@@ -40,6 +43,7 @@ import           Test.Hspec.Core.QuickCheck.Util (liftHook) import           Test.Hspec.Core.Example.Location +#ifdef ENABLE_SPEC_HOOK_ARGS -- | A type class for examples, that is to say, test bodies as used in -- `Test.Hspec.Core.Spec.it` and similar functions. class Example e where@@ -58,7 +62,14 @@   -- similar.   type Arg e   type Arg e = ()+#else+type Arg e = () +-- | A type class for examples, that is to say, test bodies as used in+-- `Test.Hspec.Core.Spec.it` and similar functions.+class Example e where+#endif+   -- | Evaluates an example.   --   -- `evaluateExample` is expected to execute the test body inside the IO action@@ -190,20 +201,32 @@       | otherwise = Failure Nothing $ Error Nothing e  instance Example Result where+#ifdef ENABLE_SPEC_HOOK_ARGS   type Arg Result = ()+#endif   evaluateExample e = evaluateExample (\() -> e) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Result) where   type Arg (a -> Result) = a+#else+instance Example (() -> Result) where+#endif   evaluateExample example _params hook _callback = do     liftHook (Result "" Success) hook (evaluate . example)  instance Example Bool where+#ifdef ENABLE_SPEC_HOOK_ARGS   type Arg Bool = ()+#endif   evaluateExample e = evaluateExample (\() -> e) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Bool) where   type Arg (a -> Bool) = a+#else+instance Example (() -> Bool) where+#endif   evaluateExample p _params hook _callback = do     liftHook (Result "" Success) hook (evaluate . example)     where@@ -212,7 +235,9 @@         | otherwise = Result "" $ Failure Nothing NoReason  instance Example Expectation where+#ifdef ENABLE_SPEC_HOOK_ARGS   type Arg Expectation = ()+#endif   evaluateExample e = evaluateExample (\() -> e)  hunitFailureToResult :: Maybe String -> HUnit.HUnitFailure -> ResultStatus@@ -239,6 +264,10 @@ toLocation :: SrcLoc -> Location toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> Expectation) where   type Arg (a -> Expectation) = a+#else+instance Example (() -> Expectation) where+#endif   evaluateExample e _params hook _ = hook e >> return (Result "" Success)
src/Test/Hspec/Core/Example/Location.hs view
@@ -37,6 +37,9 @@ } deriving (Eq, Show, Read)  extractLocation :: SomeException -> Maybe Location+#ifdef __MHS__+extractLocation _ = Nothing+#else extractLocation e =       locationFromErrorCall e   <|> locationFromPatternMatchFail e@@ -154,4 +157,5 @@   joinPath . splitDirectories #else   id+#endif #endif
src/Test/Hspec/Core/FailureReport.hs view
@@ -5,13 +5,24 @@ , readFailureReport ) where +#if !defined(__GHCJS__) && !defined(__MHS__)+-- ghcjs currently does not support setting environment variables+-- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report+-- into the environment is a non-essential feature we just disable this to be+-- able to run hspec test-suites with ghcjs at all. Should be reverted once+-- the issue is fixed.+#define HAS_SET_ENV+#endif++ import           Prelude () import           Test.Hspec.Core.Compat -#ifndef __GHCJS__+#ifdef HAS_SET_ENV import           System.Environment (setEnv) import           Test.Hspec.Core.Util (safeTry) #endif+ import           System.IO import           System.Directory import           Test.Hspec.Core.Util (Path)@@ -29,20 +40,15 @@ writeFailureReport config report = case configFailureReport config of   Just file -> writeFile file (show report)   Nothing -> do-#ifdef __GHCJS__-    -- ghcjs currently does not support setting environment variables-    -- (https://github.com/ghcjs/ghcjs/issues/263). Since writing a failure report-    -- into the environment is a non-essential feature we just disable this to be-    -- able to run hspec test-suites with ghcjs at all. Should be reverted once-    -- the issue is fixed.-    pass-#else+#ifdef HAS_SET_ENV     -- on Windows this can throw an exception when the input is too large, hence     -- we use `safeTry` here     safeTry (setEnv "HSPEC_FAILURES" $ show report) >>= either onError return     where       onError err = do         hPutStrLn stderr ("WARNING: Could not write environment variable HSPEC_FAILURES (" ++ show err ++ ")")+#else+    pass #endif  readFailureReport :: Config -> IO (Maybe FailureReport)
src/Test/Hspec/Core/Formatters/Diff.hs view
@@ -17,7 +17,7 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)+import           Test.Hspec.Core.Compat  import           Data.Char import qualified Data.Algorithm.Diff as Diff
src/Test/Hspec/Core/Formatters/Pretty/Parser.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -29,7 +30,11 @@  type TokenType = Lexer.Token +#ifndef __MHS__ newtype Parser a = Parser {+#else+data Parser a = Parser {+#endif   runParser :: [Token] -> Maybe (a, [Token]) } deriving Functor
src/Test/Hspec/Core/Formatters/V1/Internal.hs view
@@ -55,7 +55,7 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)+import           Test.Hspec.Core.Compat  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Clock
src/Test/Hspec/Core/Formatters/V2.hs view
@@ -90,7 +90,7 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)+import           Test.Hspec.Core.Compat import           System.IO (hFlush, stdout)  import           Test.Hspec.Core.Util hiding (formatException)
src/Test/Hspec/Core/QuickCheck.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-}@@ -60,11 +61,17 @@     modify f p = p {paramsQuickCheckArgs = f (paramsQuickCheckArgs p)}  instance Example QC.Property where+#ifdef ENABLE_SPEC_HOOK_ARGS   type Arg QC.Property = ()+#endif   evaluateExample e = evaluateExample (\() -> e) +#ifdef ENABLE_SPEC_HOOK_ARGS instance Example (a -> QC.Property) where   type Arg (a -> QC.Property) = a+#else+instance Example (() -> QC.Property) where+#endif   evaluateExample p params hook progressCallback = do     let args = paramsQuickCheckArgs params     r <- QC.quickCheckWithResult args {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p)
src/Test/Hspec/Core/Runner.hs view
@@ -99,9 +99,10 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat+import           Test.Hspec.Core.Compat hiding (unicodeOutputSupported)+import qualified Test.Hspec.Core.Compat as Compat -import           NonEmpty (nonEmpty)+import           Data.List.NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs) import           System.Exit (exitFailure)@@ -117,7 +118,12 @@ import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest) import           Test.Hspec.Core.Tree (formatDefaultDescription) import           Test.Hspec.Core.Config-import           Test.Hspec.Core.Config.Definition as Config (getSeed, getFormatter)+import           Test.Hspec.Core.Config.Definition as Config (getSeed)++#ifdef ENABLE_LEGACY_V1_FORMATTERS+import           Test.Hspec.Core.Config.Definition as Config (getFormatter)+#endif+ import           Test.Hspec.Core.Extension.Config.Type as Extension (applySpecTransformation) import           Test.Hspec.Core.Format (Format, FormatConfig(..)) import qualified Test.Hspec.Core.Formatters.V2 as V2@@ -392,7 +398,12 @@       , formatConfigExpertMode = configExpertMode config       } +      formatter :: FormatConfig -> IO Format+#ifdef ENABLE_LEGACY_V1_FORMATTERS       formatter = fromMaybe (V2.formatterToFormat V2.checks) (Config.getFormatter config)+#else+      formatter = V2.formatterToFormat V2.checks+#endif      format <- maybe id printSlowSpecItems (configPrintSlowItems config) <$> formatter formatConfig @@ -524,7 +535,7 @@  unicodeOutputSupported :: UnicodeMode -> Handle -> IO Bool unicodeOutputSupported mode h = case mode of-  UnicodeAuto -> (== Just "UTF-8") . fmap show <$> hGetEncoding h+  UnicodeAuto -> Compat.unicodeOutputSupported h   UnicodeNever -> return False   UnicodeAlways -> return True
src/Test/Hspec/Core/Runner/Eval.hs view
@@ -32,8 +32,8 @@ import           Test.Hspec.Core.Example.Location import           Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus) -import qualified NonEmpty-import           NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.List.NonEmpty (NonEmpty(..))  import           Test.Hspec.Core.Runner.JobQueue
src/Test/Hspec/Core/Runner/JobQueue.hs view
@@ -16,7 +16,7 @@ import qualified Test.Hspec.Core.Compat as M  import           Control.Concurrent-import           Control.Concurrent.Async (Async, AsyncCancelled(..), async, waitCatch, asyncThreadId)+import           Control.Concurrent.Async (Async, async, waitCatch, cancelMany)  import           Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as M@@ -49,14 +49,6 @@      cancelAll :: JobQueue -> IO ()     cancelAll (JobQueue _ cancelQueue) = readIORef cancelQueue >>= cancelMany--    cancelMany :: [Async a] -> IO ()-    cancelMany jobs = do-      mapM_ notifyCancel jobs-      mapM_ waitCatch jobs--    notifyCancel :: Async a -> IO ()-    notifyCancel = flip throwTo AsyncCancelled . asyncThreadId  newSemaphore :: Int -> IO Semaphore newSemaphore capacity = do
src/Test/Hspec/Core/Spec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ConstraintKinds #-} -- |@@ -48,6 +49,9 @@  -- * A type class for examples , Test.Hspec.Core.Example.Example (..)+#ifndef ENABLE_SPEC_HOOK_ARGS+, Test.Hspec.Core.Example.Arg+#endif , Test.Hspec.Core.Example.Params (..) , Test.Hspec.Core.Example.defaultParams , Test.Hspec.Core.Example.ActionWith@@ -92,7 +96,9 @@ import           Test.Hspec.Expectations (Expectation)  import           Test.Hspec.Core.Example+#ifdef ENABLE_SPEC_HOOKS import           Test.Hspec.Core.Hooks+#endif import           Test.Hspec.Core.Tree import           Test.Hspec.Core.Spec.Monad import           Test.Hspec.Core.QuickCheck ()@@ -112,7 +118,11 @@ -- -- This can be used to temporarily disable spec items. xdescribe :: HasCallStack => String -> SpecWith a -> SpecWith a+#ifdef ENABLE_SPEC_HOOKS xdescribe label spec = before_ pending_ $ describe label spec+#else+xdescribe = describe+#endif  -- | @xcontext@ is an alias for `xdescribe`. xcontext :: HasCallStack => String -> SpecWith a -> SpecWith a@@ -151,7 +161,11 @@ -- -- This can be used to temporarily disable a spec item. xit :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)+#ifdef ENABLE_SPEC_HOOKS xit label action = before_ pending_ $ it label action+#else+xit = it+#endif  -- | @xspecify@ is an alias for `xit`. xspecify :: (HasCallStack, Example a) => String -> a -> SpecWith (Arg a)@@ -208,8 +222,10 @@ pending :: HasCallStack => Expectation pending = throwIO (Pending location Nothing) +#ifdef ENABLE_SPEC_HOOKS pending_ :: Expectation pending_ = (throwIO (Pending Nothing Nothing))+#endif  -- | -- `pendingWith` is similar to `pending`, but it takes an additional string
src/Test/Hspec/Core/Spec/Monad.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Test.Hspec.Core.Spec.Monad ( -- RE-EXPORTED from Test.Hspec.Core.Spec@@ -64,8 +65,20 @@ -- -- It allows for dynamically generated spec trees, for example, by using data -- obtained by performing IO actions with 'runIO'.+#ifndef __MHS__ newtype SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r }   deriving (Functor, Applicative, Monad)+#else+data SpecM a r = SpecM { unSpecM :: WriterT (Endo Config, [SpecTree a]) (ReaderT Env IO) r }+  deriving Functor++instance Applicative (SpecM a) where+  pure x = SpecM $ pure x+  SpecM f <*> SpecM x = SpecM $ f <*> x++instance Monad (SpecM a) where+  SpecM m >>= k = SpecM $ m >>= unSpecM . k+#endif  -- | Convert a `Spec` to a forest of `SpecTree`s. runSpecM :: SpecWith a -> IO (Endo Config, [SpecTree a])
src/Test/Hspec/Core/Util.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE  ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions@@ -23,7 +24,13 @@ import           Test.Hspec.Core.Compat hiding (join)  import           Data.Char (isSpace)++#ifndef __MHS__ import           GHC.IO.Exception+#else+import           System.IO.Error+#endif+ import           Control.Concurrent.Async  -- |@@ -79,11 +86,18 @@ stripAnsi :: String -> String stripAnsi = go   where+    go :: String -> String     go input = case input of-      '\ESC' : '[' : (dropWhile (`elem` "0123456789;") -> 'm' : xs) -> go xs+      '\ESC' : '[' : (parameters -> 'm' : xs) -> go xs       x : xs -> x : go xs       [] -> [] +    parameters :: String -> String+    parameters = dropWhile p+      where+        p :: Char -> Bool+        p c = c >= '0' && c <= '9' || c == ';'+ -- | -- A `Path` describes the location of a spec item within a spec tree. --@@ -120,9 +134,9 @@ -- -- @since 2.0.0 filterPredicate :: String -> Path -> Bool-filterPredicate pattern path =-     pattern `isInfixOf` plain-  || pattern `isInfixOf` formatted+filterPredicate pattern_ path =+     pattern_ `isInfixOf` plain+  || pattern_ `isInfixOf` formatted   where     plain = joinPath path     formatted = formatRequirement path@@ -142,9 +156,9 @@  -- | @since 2.11.5 formatExceptionWith :: (SomeException -> String) -> SomeException -> String-formatExceptionWith showException err@(SomeException e) = case fromException err of+formatExceptionWith showException err = case fromException err of+  Nothing  -> showExceptionType err ++ "\n" ++ showException err   Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\n" ++ showException (toException ioe)-  Nothing  -> showType e ++ "\n" ++ showException (SomeException e)   where     showIOErrorType :: IOException -> String     showIOErrorType ioe = case ioe_type ioe of@@ -167,6 +181,9 @@       TimeExpired -> "TimeExpired"       ResourceVanished -> "ResourceVanished"       Interrupted -> "Interrupted"++showExceptionType :: SomeException -> String+showExceptionType (SomeException e) = showType e  -- | @safeTry@ evaluates given action and returns its result.  If an exception -- occurs, the exception is returned instead.  Unlike `try` it is agnostic to
test/Test/Hspec/Core/CompatSpec.hs view
@@ -14,10 +14,6 @@     it "shows unqualified name of type" $ do       showType SomeType `shouldBe` "SomeType" -  describe "showFullType (currently unused)" $ do-    it "shows fully qualified name of type" $ do-      showFullType SomeType `shouldBe` "Test.Hspec.Core.CompatSpec.SomeType"-   describe "lookupEnv" $ do     it "returns value of specified environment variable" $ do       setEnv "FOO" "bar"
test/Test/Hspec/Core/Formatters/DiffSpec.hs view
@@ -2,7 +2,7 @@ module Test.Hspec.Core.Formatters.DiffSpec (spec) where  import           Prelude ()-import           Helper hiding (First)+import           Helper import           Data.Char  import           Test.Hspec.Core.Formatters.Diff as Diff
test/Test/Hspec/Core/Runner/EvalSpec.hs view
@@ -4,7 +4,7 @@ import           Prelude () import           Helper -import           NonEmpty (fromList)+import           Data.List.NonEmpty (fromList)  import           Test.Hspec.Core.Spec (FailureReason(..), Result(..), ResultStatus(..), Location(..))
− vendor/Control/Concurrent/Async.hs 
@@ -1,963 +0,0 @@-{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes,-    ExistentialQuantification #-}-#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif-#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE DeriveDataTypeable #-}-#endif-{-# OPTIONS -Wall -fno-warn-implicit-prelude -fno-warn-unused-imports #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.Async--- Copyright   :  (c) Simon Marlow 2012--- License     :  BSD3 (see the file LICENSE)------ Maintainer  :  Simon Marlow <marlowsd@gmail.com>--- Stability   :  provisional--- Portability :  non-portable (requires concurrency)------ This module provides a set of operations for running IO operations--- asynchronously and waiting for their results.  It is a thin layer--- over the basic concurrency operations provided by--- "Control.Concurrent".  The main additional functionality it--- provides is the ability to wait for the return value of a thread,--- but the interface also provides some additional safety and--- robustness over using 'forkIO' threads and @MVar@ directly.------ == High-level API------ @async@'s high-level API spawns /lexically scoped/ threads,--- ensuring the following key poperties that make it safer to use--- than using plain 'forkIO':------ 1. No exception is swallowed (waiting for results propagates exceptions).--- 2. No thread is leaked (left running unintentionally).------ (This is done using the 'Control.Exception.bracket' pattern to work in presence--- of synchornous and asynchronous exceptions.)------ __Most practical/production code should only use the high-level API__.------ The basic type is @'Async' a@, which represents an asynchronous--- @IO@ action that will return a value of type @a@, or die with an--- exception.  An 'Async' is a wrapper around a low-level 'forkIO' thread.------ The fundamental function to spawn threads with the high-level API is--- 'withAsync'.------ For example, to fetch two web pages at the same time, we could do--- this (assuming a suitable @getURL@ function):------ > withAsync (getURL url1) $ \a1 -> do--- >   withAsync (getURL url2) $ \a2 -> do--- >     page1 <- wait a1--- >     page2 <- wait a2--- >     ...------ where 'withAsync' starts the operation in a separate thread, and--- 'wait' waits for and returns the result.------ * If the operation throws an exception, then that exception is re-thrown---   by 'wait'. This ensures property (1): No exception is swallowed.--- * If an exception bubbles up through a 'withAsync', then the 'Async'---   it spawned is 'cancel'ed. This ensures property (2): No thread is leaked.------ Often we do not care to work manually with 'Async' handles like--- @a1@ and @a2@. Instead, we want to express high-level objectives like--- performing two or more tasks concurrently, and waiting for one or all--- of them to finish.------ For example, the pattern of performing two IO actions concurrently and--- waiting for both their results is packaged up in a combinator 'concurrently',--- so we can further shorten the above example to:------ > (page1, page2) <- concurrently (getURL url1) (getURL url2)--- > ...------ The section __/High-level utilities/__ covers the most--- common high-level objectives, including:------ * Waiting for 2 results ('concurrently').--- * Waiting for many results ('mapConcurrently' / 'forConcurrently').--- * Waiting for the first of 2 results ('race').--- * Waiting for arbitrary nestings of "all of /N/" and "the first of /N/"---   results with the 'Concurrently' newtype and its 'Applicative' and---   'Alternative' instances.------ Click here to scroll to that section:--- "Control.Concurrent.Async#high-level-utilities".------ == Low-level API------ Some use cases require parallelism that is not lexically scoped.------ For those, the low-level function 'async' can be used as a direct--- equivalent of 'forkIO':------ > -- Do NOT use this code in production, it has a flaw (explained below).--- > do--- >   a1 <- async (getURL url1)--- >   a2 <- async (getURL url2)--- >   page1 <- wait a1--- >   page2 <- wait a2--- >   ...------ In contrast to 'withAsync', this code has a problem.------ It still fulfills property (1) in that an exception arising from--- @getUrl@ will be re-thrown by 'wait', but it does not fulfill--- property (2).--- Consider the case when the first 'wait' throws an exception; then the--- second 'wait' will not happen, and the second 'async' may be left--- running in the background, possibly indefinitely.------ 'withAsync' is like 'async', except that the 'Async' is--- automatically killed (using 'uninterruptibleCancel') if the--- enclosing IO operation returns before it has completed.--- Furthermore, 'withAsync' allows a tree of threads to be built, such--- that children are automatically killed if their parents die for any--- reason.------ If you need to use the low-level API, ensure that you gurantee--- property (2) by other means, such as 'link'ing asyncs that need--- to die together, and protecting against asynchronous exceptions--- using 'Control.Exception.bracket', 'Control.Exception.mask',--- or other functions from "Control.Exception".------ == Miscellaneous------ The 'Functor' instance can be used to change the result of an--- 'Async'.  For example:------ > ghci> withAsync (return 3) (\a -> wait (fmap (+1) a))--- > 4------ === Resource exhaustion------ As with all concurrent programming, keep in mind that while--- Haskell's cooperative ("green") multithreading carries low overhead,--- spawning too many of them at the same time may lead to resource exhaustion--- (of memory, file descriptors, or other limited resources), given that the--- actions running in the threads consume these resources.---------------------------------------------------------------------------------module Control.Concurrent.Async (--    -- * Asynchronous actions-    Async,--    -- * High-level API--    -- ** Spawning with automatic 'cancel'ation-    withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask,-    withAsyncOnWithUnmask,--    -- ** Querying 'Async's-    wait, poll, waitCatch, asyncThreadId,-    cancel, uninterruptibleCancel, cancelWith, AsyncCancelled(..),--    -- ** #high-level-utilities# High-level utilities-    race, race_,-    concurrently, concurrently_,-    mapConcurrently, forConcurrently,-    mapConcurrently_, forConcurrently_,-    replicateConcurrently, replicateConcurrently_,-    Concurrently(..),-    compareAsyncs,--    -- ** Specialised operations--    -- *** STM operations-    waitSTM, pollSTM, waitCatchSTM,--    -- *** Waiting for multiple 'Async's-    waitAny, waitAnyCatch, waitAnyCancel, waitAnyCatchCancel,-    waitEither, waitEitherCatch, waitEitherCancel, waitEitherCatchCancel,-    waitEither_,-    waitBoth,--    -- *** Waiting for multiple 'Async's in STM-    waitAnySTM, waitAnyCatchSTM,-    waitEitherSTM, waitEitherCatchSTM,-    waitEitherSTM_,-    waitBothSTM,--    -- * Low-level API--    -- ** Spawning (low-level API)-    async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask,--    -- ** Linking-    link, linkOnly, link2, link2Only, ExceptionInLinkedThread(..),--  ) where--import Control.Concurrent.STM.TMVar-import Control.Exception-import Control.Concurrent-import qualified Data.Foldable as F-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import Control.Monad-import Control.Applicative-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid (Monoid(mempty,mappend))-import Data.Traversable-#endif-#if __GLASGOW_HASKELL__ < 710-import Data.Typeable-#endif-#if MIN_VERSION_base(4,9,0)-import Data.Semigroup (Semigroup((<>)))-#endif--import Data.IORef--import GHC.Exts-import GHC.IO hiding (finally, onException)-import GHC.Conc---- -------------------------------------------------------------------------------- STM Async API----- | An asynchronous action spawned by 'async' or 'withAsync'.--- Asynchronous actions are executed in a separate thread, and--- operations are provided for waiting for asynchronous actions to--- complete and obtaining their results (see e.g. 'wait').----data Async a = Async-  { asyncThreadId :: {-# UNPACK #-} !ThreadId-                  -- ^ Returns the 'ThreadId' of the thread running-                  -- the given 'Async'.-  , _asyncWait    :: STM (Either SomeException a)-  }--instance Eq (Async a) where-  Async a _ == Async b _  =  a == b--instance Ord (Async a) where-  Async a _ `compare` Async b _  =  a `compare` b--instance Functor Async where-  fmap f (Async a w) = Async a (fmap (fmap f) w)---- | Compare two Asyncs that may have different types by their 'ThreadId'.-compareAsyncs :: Async a -> Async b -> Ordering-compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2---- | Spawn an asynchronous action in a separate thread.------ Like for 'forkIO', the action may be left running unintentinally--- (see module-level documentation for details).------ __Use 'withAsync' style functions wherever you can instead!__-async :: IO a -> IO (Async a)-async = inline asyncUsing rawForkIO---- | Like 'async' but using 'forkOS' internally.-asyncBound :: IO a -> IO (Async a)-asyncBound = asyncUsing forkOS---- | Like 'async' but using 'forkOn' internally.-asyncOn :: Int -> IO a -> IO (Async a)-asyncOn = asyncUsing . rawForkOn---- | Like 'async' but using 'forkIOWithUnmask' internally.  The child--- thread is passed a function that can be used to unmask asynchronous--- exceptions.-asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)-asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask)---- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.  The--- child thread is passed a function that can be used to unmask--- asynchronous exceptions.-asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)-asyncOnWithUnmask cpu actionWith =-  asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)--asyncUsing :: (IO () -> IO ThreadId)-           -> IO a -> IO (Async a)-asyncUsing doFork = \action -> do-   var <- newEmptyTMVarIO-   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)-   -- slightly faster:-   t <- mask $ \restore ->-          doFork $ try (restore action) >>= atomically . putTMVar var-   return (Async t (readTMVar var))---- | Spawn an asynchronous action in a separate thread, and pass its--- @Async@ handle to the supplied function.  When the function returns--- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.------ > withAsync action inner = mask $ \restore -> do--- >   a <- async (restore action)--- >   restore (inner a) `finally` uninterruptibleCancel a------ This is a useful variant of 'async' that ensures an @Async@ is--- never left running unintentionally.------ Note: a reference to the child thread is kept alive until the call--- to `withAsync` returns, so nesting many `withAsync` calls requires--- linear memory.----withAsync :: IO a -> (Async a -> IO b) -> IO b-withAsync = inline withAsyncUsing rawForkIO---- | Like 'withAsync' but uses 'forkOS' internally.-withAsyncBound :: IO a -> (Async a -> IO b) -> IO b-withAsyncBound = withAsyncUsing forkOS---- | Like 'withAsync' but uses 'forkOn' internally.-withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b-withAsyncOn = withAsyncUsing . rawForkOn---- | Like 'withAsync' but uses 'forkIOWithUnmask' internally.  The--- child thread is passed a function that can be used to unmask--- asynchronous exceptions.-withAsyncWithUnmask-  :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b-withAsyncWithUnmask actionWith =-  withAsyncUsing rawForkIO (actionWith unsafeUnmask)---- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally.  The--- child thread is passed a function that can be used to unmask--- asynchronous exceptions-withAsyncOnWithUnmask-  :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b-withAsyncOnWithUnmask cpu actionWith =-  withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)--withAsyncUsing :: (IO () -> IO ThreadId)-               -> IO a -> (Async a -> IO b) -> IO b--- The bracket version works, but is slow.  We can do better by--- hand-coding it:-withAsyncUsing doFork = \action inner -> do-  var <- newEmptyTMVarIO-  mask $ \restore -> do-    t <- doFork $ try (restore action) >>= atomically . putTMVar var-    let a = Async t (readTMVar var)-    r <- restore (inner a) `catchAll` \e -> do-      uninterruptibleCancel a-      throwIO e-    uninterruptibleCancel a-    return r---- | Wait for an asynchronous action to complete, and return its--- value.  If the asynchronous action threw an exception, then the--- exception is re-thrown by 'wait'.------ > wait = atomically . waitSTM----{-# INLINE wait #-}-wait :: Async a -> IO a-wait = tryAgain . atomically . waitSTM-  where-    -- See: https://github.com/simonmar/async/issues/14-    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f---- | Wait for an asynchronous action to complete, and return either--- @Left e@ if the action raised an exception @e@, or @Right a@ if it--- returned a value @a@.------ > waitCatch = atomically . waitCatchSTM----{-# INLINE waitCatch #-}-waitCatch :: Async a -> IO (Either SomeException a)-waitCatch = tryAgain . atomically . waitCatchSTM-  where-    -- See: https://github.com/simonmar/async/issues/14-    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f---- | Check whether an 'Async' has completed yet.  If it has not--- completed yet, then the result is @Nothing@, otherwise the result--- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an--- exception @x@, or @Right a@ if it returned a value @a@.------ > poll = atomically . pollSTM----{-# INLINE poll #-}-poll :: Async a -> IO (Maybe (Either SomeException a))-poll = atomically . pollSTM---- | A version of 'wait' that can be used inside an STM transaction.----waitSTM :: Async a -> STM a-waitSTM a = do-   r <- waitCatchSTM a-   either throwSTM return r---- | A version of 'waitCatch' that can be used inside an STM transaction.----{-# INLINE waitCatchSTM #-}-waitCatchSTM :: Async a -> STM (Either SomeException a)-waitCatchSTM (Async _ w) = w---- | A version of 'poll' that can be used inside an STM transaction.----{-# INLINE pollSTM #-}-pollSTM :: Async a -> STM (Maybe (Either SomeException a))-pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing---- | Cancel an asynchronous action by throwing the @AsyncCancelled@--- exception to it, and waiting for the `Async` thread to quit.--- Has no effect if the 'Async' has already completed.------ > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a------ Note that 'cancel' will not terminate until the thread the 'Async'--- refers to has terminated. This means that 'cancel' will block for--- as long said thread blocks when receiving an asynchronous exception.------ For example, it could block if:------ * It's executing a foreign call, and thus cannot receive the asynchronous--- exception;--- * It's executing some cleanup handler after having received the exception,--- and the handler is blocking.-{-# INLINE cancel #-}-cancel :: Async a -> IO ()-cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a---- | The exception thrown by `cancel` to terminate a thread.-data AsyncCancelled = AsyncCancelled-  deriving (Show, Eq-#if __GLASGOW_HASKELL__ < 710-    ,Typeable-#endif-    )--instance Exception AsyncCancelled where-#if __GLASGOW_HASKELL__ >= 708-  fromException = asyncExceptionFromException-  toException = asyncExceptionToException-#endif---- | Cancel an asynchronous action------ This is a variant of `cancel`, but it is not interruptible.-{-# INLINE uninterruptibleCancel #-}-uninterruptibleCancel :: Async a -> IO ()-uninterruptibleCancel = uninterruptibleMask_ . cancel---- | Cancel an asynchronous action by throwing the supplied exception--- to it.------ > cancelWith a x = throwTo (asyncThreadId a) x------ The notes about the synchronous nature of 'cancel' also apply to--- 'cancelWith'.-cancelWith :: Exception e => Async a -> e -> IO ()-cancelWith a@(Async t _) e = throwTo t e <* waitCatch a---- | Wait for any of the supplied asynchronous operations to complete.--- The value returned is a pair of the 'Async' that completed, and the--- result that would be returned by 'wait' on that 'Async'.------ If multiple 'Async's complete or have completed, then the value--- returned corresponds to the first completed 'Async' in the list.----{-# INLINE waitAnyCatch #-}-waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a)-waitAnyCatch = atomically . waitAnyCatchSTM---- | A version of 'waitAnyCatch' that can be used inside an STM transaction.------ @since 2.1.0-waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a)-waitAnyCatchSTM asyncs =-    foldr orElse retry $-      map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs---- | Like 'waitAnyCatch', but also cancels the other asynchronous--- operations as soon as one has completed.----waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a)-waitAnyCatchCancel asyncs =-  waitAnyCatch asyncs `finally` mapM_ cancel asyncs---- | Wait for any of the supplied @Async@s to complete.  If the first--- to complete throws an exception, then that exception is re-thrown--- by 'waitAny'.------ If multiple 'Async's complete or have completed, then the value--- returned corresponds to the first completed 'Async' in the list.----{-# INLINE waitAny #-}-waitAny :: [Async a] -> IO (Async a, a)-waitAny = atomically . waitAnySTM---- | A version of 'waitAny' that can be used inside an STM transaction.------ @since 2.1.0-waitAnySTM :: [Async a] -> STM (Async a, a)-waitAnySTM asyncs =-    foldr orElse retry $-      map (\a -> do r <- waitSTM a; return (a, r)) asyncs---- | Like 'waitAny', but also cancels the other asynchronous--- operations as soon as one has completed.----waitAnyCancel :: [Async a] -> IO (Async a, a)-waitAnyCancel asyncs =-  waitAny asyncs `finally` mapM_ cancel asyncs---- | Wait for the first of two @Async@s to finish.-{-# INLINE waitEitherCatch #-}-waitEitherCatch :: Async a -> Async b-                -> IO (Either (Either SomeException a)-                              (Either SomeException b))-waitEitherCatch left right =-  tryAgain $ atomically (waitEitherCatchSTM left right)-  where-    -- See: https://github.com/simonmar/async/issues/14-    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f---- | A version of 'waitEitherCatch' that can be used inside an STM transaction.------ @since 2.1.0-waitEitherCatchSTM :: Async a -> Async b-                -> STM (Either (Either SomeException a)-                               (Either SomeException b))-waitEitherCatchSTM left right =-    (Left  <$> waitCatchSTM left)-      `orElse`-    (Right <$> waitCatchSTM right)---- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before--- returning.----waitEitherCatchCancel :: Async a -> Async b-                      -> IO (Either (Either SomeException a)-                                    (Either SomeException b))-waitEitherCatchCancel left right =-  waitEitherCatch left right `finally` (cancel left >> cancel right)---- | Wait for the first of two @Async@s to finish.  If the @Async@--- that finished first raised an exception, then the exception is--- re-thrown by 'waitEither'.----{-# INLINE waitEither #-}-waitEither :: Async a -> Async b -> IO (Either a b)-waitEither left right = atomically (waitEitherSTM left right)---- | A version of 'waitEither' that can be used inside an STM transaction.------ @since 2.1.0-waitEitherSTM :: Async a -> Async b -> STM (Either a b)-waitEitherSTM left right =-    (Left  <$> waitSTM left)-      `orElse`-    (Right <$> waitSTM right)---- | Like 'waitEither', but the result is ignored.----{-# INLINE waitEither_ #-}-waitEither_ :: Async a -> Async b -> IO ()-waitEither_ left right = atomically (waitEitherSTM_ left right)---- | A version of 'waitEither_' that can be used inside an STM transaction.------ @since 2.1.0-waitEitherSTM_:: Async a -> Async b -> STM ()-waitEitherSTM_ left right =-    (void $ waitSTM left)-      `orElse`-    (void $ waitSTM right)---- | Like 'waitEither', but also 'cancel's both @Async@s before--- returning.----waitEitherCancel :: Async a -> Async b -> IO (Either a b)-waitEitherCancel left right =-  waitEither left right `finally` (cancel left >> cancel right)---- | Waits for both @Async@s to finish, but if either of them throws--- an exception before they have both finished, then the exception is--- re-thrown by 'waitBoth'.----{-# INLINE waitBoth #-}-waitBoth :: Async a -> Async b -> IO (a,b)-waitBoth left right = tryAgain $ atomically (waitBothSTM left right)-  where-    -- See: https://github.com/simonmar/async/issues/14-    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f---- | A version of 'waitBoth' that can be used inside an STM transaction.------ @since 2.1.0-waitBothSTM :: Async a -> Async b -> STM (a,b)-waitBothSTM left right = do-    a <- waitSTM left-           `orElse`-         (waitSTM right >> retry)-    b <- waitSTM right-    return (a,b)----- -------------------------------------------------------------------------------- Linking threads--data ExceptionInLinkedThread =-  forall a . ExceptionInLinkedThread (Async a) SomeException-#if __GLASGOW_HASKELL__ < 710-  deriving Typeable-#endif--instance Show ExceptionInLinkedThread where-  showsPrec p (ExceptionInLinkedThread (Async t _) e) =-    showParen (p >= 11) $-      showString "ExceptionInLinkedThread " .-      showsPrec 11 t .-      showString " " .-      showsPrec 11 e--instance Exception ExceptionInLinkedThread where-#if __GLASGOW_HASKELL__ >= 708-  fromException = asyncExceptionFromException-  toException = asyncExceptionToException-#endif---- | Link the given @Async@ to the current thread, such that if the--- @Async@ raises an exception, that exception will be re-thrown in--- the current thread, wrapped in 'ExceptionInLinkedThread'.------ 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread,--- so that it's safe to 'cancel' a thread you're linked to.  If you want--- different behaviour, use 'linkOnly'.----link :: Async a -> IO ()-link = linkOnly (not . isCancel)---- | Link the given @Async@ to the current thread, such that if the--- @Async@ raises an exception, that exception will be re-thrown in--- the current thread, wrapped in 'ExceptionInLinkedThread'.------ The supplied predicate determines which exceptions in the target--- thread should be propagated to the source thread.----linkOnly-  :: (SomeException -> Bool)  -- ^ return 'True' if the exception-                              -- should be propagated, 'False'-                              -- otherwise.-  -> Async a-  -> IO ()-linkOnly shouldThrow a = do-  me <- myThreadId-  void $ forkRepeat $ do-    r <- waitCatch a-    case r of-      Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e)-      _otherwise -> return ()---- | Link two @Async@s together, such that if either raises an--- exception, the same exception is re-thrown in the other @Async@,--- wrapped in 'ExceptionInLinkedThread'.------ 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible--- to 'cancel' either thread without cancelling the other.  If you--- want different behaviour, use 'link2Only'.----link2 :: Async a -> Async b -> IO ()-link2 = link2Only (not . isCancel)---- | Link two @Async@s together, such that if either raises an--- exception, the same exception is re-thrown in the other @Async@,--- wrapped in 'ExceptionInLinkedThread'.------ The supplied predicate determines which exceptions in the target--- thread should be propagated to the source thread.----link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO ()-link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =-  void $ forkRepeat $ do-    r <- waitEitherCatch left right-    case r of-      Left  (Left e) | shouldThrow e ->-        throwTo tr (ExceptionInLinkedThread left e)-      Right (Left e) | shouldThrow e ->-        throwTo tl (ExceptionInLinkedThread right e)-      _ -> return ()--isCancel :: SomeException -> Bool-isCancel e-  | Just AsyncCancelled <- fromException e = True-  | otherwise = False----- --------------------------------------------------------------------------------- | Run two @IO@ actions concurrently, and return the first to--- finish.  The loser of the race is 'cancel'led.------ > race left right =--- >   withAsync left $ \a ->--- >   withAsync right $ \b ->--- >   waitEither a b----race :: IO a -> IO b -> IO (Either a b)---- | Like 'race', but the result is ignored.----race_ :: IO a -> IO b -> IO ()---- | Run two @IO@ actions concurrently, and return both results.  If--- either action throws an exception at any time, then the other--- action is 'cancel'led, and the exception is re-thrown by--- 'concurrently'.------ > concurrently left right =--- >   withAsync left $ \a ->--- >   withAsync right $ \b ->--- >   waitBoth a b-concurrently :: IO a -> IO b -> IO (a,b)---- | 'concurrently', but ignore the result values------ @since 2.1.1-concurrently_ :: IO a -> IO b -> IO ()--#define USE_ASYNC_VERSIONS 0--#if USE_ASYNC_VERSIONS--race left right =-  withAsync left $ \a ->-  withAsync right $ \b ->-  waitEither a b--race_ left right = void $ race left right--concurrently left right =-  withAsync left $ \a ->-  withAsync right $ \b ->-  waitBoth a b--concurrently_ left right = void $ concurrently left right--#else---- MVar versions of race/concurrently--- More ugly than the Async versions, but quite a bit faster.---- race :: IO a -> IO b -> IO (Either a b)-race left right = concurrently' left right collect-  where-    collect m = do-        e <- m-        case e of-            Left ex -> throwIO ex-            Right r -> return r---- race_ :: IO a -> IO b -> IO ()-race_ left right = void $ race left right---- concurrently :: IO a -> IO b -> IO (a,b)-concurrently left right = concurrently' left right (collect [])-  where-    collect [Left a, Right b] _ = return (a,b)-    collect [Right b, Left a] _ = return (a,b)-    collect xs m = do-        e <- m-        case e of-            Left ex -> throwIO ex-            Right r -> collect (r:xs) m--concurrently' :: IO a -> IO b-             -> (IO (Either SomeException (Either a b)) -> IO r)-             -> IO r-concurrently' left right collect = do-    done <- newEmptyMVar-    mask $ \restore -> do-        -- Note: uninterruptibleMask here is because we must not allow-        -- the putMVar in the exception handler to be interrupted,-        -- otherwise the parent thread will deadlock when it waits for-        -- the thread to terminate.-        lid <- forkIO $ uninterruptibleMask_ $-          restore (left >>= putMVar done . Right . Left)-            `catchAll` (putMVar done . Left)-        rid <- forkIO $ uninterruptibleMask_ $-          restore (right >>= putMVar done . Right . Right)-            `catchAll` (putMVar done . Left)--        count <- newIORef (2 :: Int)-        let takeDone = do-                r <- takeMVar done      -- interruptible-                -- Decrement the counter so we know how many takes are left.-                -- Since only the parent thread is calling this, we can-                -- use non-atomic modifications.-                -- NB. do this *after* takeMVar, because takeMVar might be-                -- interrupted.-                modifyIORef count (subtract 1)-                return r--        let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f--            stop = do-                -- kill right before left, to match the semantics of-                -- the version using withAsync. (#27)-                uninterruptibleMask_ $ do-                  count' <- readIORef count-                  -- we only need to use killThread if there are still-                  -- children alive.  Note: forkIO here is because the-                  -- child thread could be in an uninterruptible-                  -- putMVar.-                  when (count' > 0) $-                    void $ forkIO $ do-                      throwTo rid AsyncCancelled-                      throwTo lid AsyncCancelled-                  -- ensure the children are really dead-                  replicateM_ count' (tryAgain $ takeMVar done)--        r <- collect (tryAgain $ takeDone) `onException` stop-        stop-        return r--concurrently_ left right = concurrently' left right (collect 0)-  where-    collect 2 _ = return ()-    collect i m = do-        e <- m-        case e of-            Left ex -> throwIO ex-            Right _ -> collect (i + 1 :: Int) m---#endif---- | Maps an 'IO'-performing function over any 'Traversable' data--- type, performing all the @IO@ actions concurrently, and returning--- the original data structure with the arguments replaced by the--- results.------ If any of the actions throw an exception, then all other actions are--- cancelled and the exception is re-thrown.------ For example, @mapConcurrently@ works with lists:------ > pages <- mapConcurrently getURL ["url1", "url2", "url3"]------ Take into account that @async@ will try to immediately spawn a thread--- for each element of the @Traversable@, so running this on large--- inputs without care may lead to resource exhaustion (of memory,--- file descriptors, or other limited resources).-mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b)-mapConcurrently f = runConcurrently . traverse (Concurrently . f)---- | `forConcurrently` is `mapConcurrently` with its arguments flipped------ > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url------ @since 2.1.0-forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b)-forConcurrently = flip mapConcurrently---- | `mapConcurrently_` is `mapConcurrently` with the return value discarded;--- a concurrent equivalent of 'mapM_'.-mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO ()-mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f)---- | `forConcurrently_` is `forConcurrently` with the return value discarded;--- a concurrent equivalent of 'forM_'.-forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO ()-forConcurrently_ = flip mapConcurrently_---- | Perform the action in the given number of threads.------ @since 2.1.1-replicateConcurrently :: Int -> IO a -> IO [a]-replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently---- | Same as 'replicateConcurrently', but ignore the results.------ @since 2.1.1-replicateConcurrently_ :: Int -> IO a -> IO ()-replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void---- --------------------------------------------------------------------------------- | A value of type @Concurrently a@ is an @IO@ operation that can be--- composed with other @Concurrently@ values, using the @Applicative@--- and @Alternative@ instances.------ Calling @runConcurrently@ on a value of type @Concurrently a@ will--- execute the @IO@ operations it contains concurrently, before--- delivering the result of type @a@.------ For example------ > (page1, page2, page3)--- >     <- runConcurrently $ (,,)--- >     <$> Concurrently (getURL "url1")--- >     <*> Concurrently (getURL "url2")--- >     <*> Concurrently (getURL "url3")----newtype Concurrently a = Concurrently { runConcurrently :: IO a }--instance Functor Concurrently where-  fmap f (Concurrently a) = Concurrently $ f <$> a--instance Applicative Concurrently where-  pure = Concurrently . return-  Concurrently fs <*> Concurrently as =-    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as--instance Alternative Concurrently where-  empty = Concurrently $ forever (threadDelay maxBound)-  Concurrently as <|> Concurrently bs =-    Concurrently $ either id id <$> race as bs--#if MIN_VERSION_base(4,9,0)--- | Only defined by @async@ for @base >= 4.9@------ @since 2.1.0-instance Semigroup a => Semigroup (Concurrently a) where-  (<>) = liftA2 (<>)---- | @since 2.1.0-instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where-  mempty = pure mempty-  mappend = (<>)-#else--- | @since 2.1.0-instance Monoid a => Monoid (Concurrently a) where-  mempty = pure mempty-  mappend = liftA2 mappend-#endif---- -------------------------------------------------------------------------------- | Fork a thread that runs the supplied action, and if it raises an--- exception, re-runs the action.  The thread terminates only when the--- action runs to completion without raising an exception.-forkRepeat :: IO a -> IO ThreadId-forkRepeat action =-  mask $ \restore ->-    let go = do r <- tryAll (restore action)-                case r of-                  Left _ -> go-                  _      -> return ()-    in forkIO go--catchAll :: IO a -> (SomeException -> IO a) -> IO a-catchAll = catch--tryAll :: IO a -> IO (Either SomeException a)-tryAll = try---- A version of forkIO that does not include the outer exception--- handler: saves a bit of time when we will be installing our own--- exception handler.-{-# INLINE rawForkIO #-}-rawForkIO :: IO () -> IO ThreadId-rawForkIO (IO action) = IO $ \ s ->-   case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)--{-# INLINE rawForkOn #-}-rawForkOn :: Int -> IO () -> IO ThreadId-rawForkOn (I# cpu) (IO action) = IO $ \ s ->-   case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #)
+ vendor/async-2.2.5/Control/Concurrent/Async.hs view
@@ -0,0 +1,870 @@+{-# LANGUAGE CPP, MagicHash, UnboxedTuples, RankNTypes,+    ExistentialQuantification #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE DeriveDataTypeable #-}+#endif+{-# OPTIONS -Wall -fno-warn-implicit-prelude -fno-warn-unused-imports #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.Async.Internal+-- Copyright   :  (c) Simon Marlow 2012+-- License     :  BSD3 (see the file LICENSE)+--+-- Maintainer  :  Simon Marlow <marlowsd@gmail.com>+-- Stability   :  provisional+-- Portability :  non-portable (requires concurrency)+--+-- This module is an internal module. The public API is provided in+-- "Control.Concurrent.Async". Breaking changes to this module will not be+-- reflected in a major bump, and using this module may break your code+-- unless you are extremely careful.+--+-----------------------------------------------------------------------------++module Control.Concurrent.Async where++import Control.Concurrent.STM.TMVar+import Control.Exception+import Control.Concurrent+import qualified Data.Foldable as F+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif+import Control.Monad+import Control.Applicative+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(mempty,mappend))+import Data.Traversable+#endif+#if __GLASGOW_HASKELL__ < 710+import Data.Typeable+#endif+#if MIN_VERSION_base(4,8,0)+import Data.Bifunctor+#endif+#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (Semigroup((<>)))+#endif++import Data.IORef++import GHC.Exts+import GHC.IO hiding (finally, onException)+import GHC.Conc++-- -----------------------------------------------------------------------------+-- STM Async API+++-- | An asynchronous action spawned by 'async' or 'withAsync'.+-- Asynchronous actions are executed in a separate thread, and+-- operations are provided for waiting for asynchronous actions to+-- complete and obtaining their results (see e.g. 'wait').+--+data Async a = Async+  { asyncThreadId :: {-# UNPACK #-} !ThreadId+                  -- ^ Returns the 'ThreadId' of the thread running+                  -- the given 'Async'.+  , _asyncWait    :: STM (Either SomeException a)+  }++instance Eq (Async a) where+  Async a _ == Async b _  =  a == b++instance Ord (Async a) where+  Async a _ `compare` Async b _  =  a `compare` b++instance Functor Async where+  fmap f (Async a w) = Async a (fmap (fmap f) w)++-- | Compare two Asyncs that may have different types by their 'ThreadId'.+compareAsyncs :: Async a -> Async b -> Ordering+compareAsyncs (Async t1 _) (Async t2 _) = compare t1 t2++-- | Spawn an asynchronous action in a separate thread.+--+-- Like for 'forkIO', the action may be left running unintentionally+-- (see module-level documentation for details).+--+-- __Use 'withAsync' style functions wherever you can instead!__+async :: IO a -> IO (Async a)+async = inline asyncUsing rawForkIO++-- | Like 'async' but using 'forkOS' internally.+asyncBound :: IO a -> IO (Async a)+asyncBound = asyncUsing forkOS++-- | Like 'async' but using 'forkOn' internally.+asyncOn :: Int -> IO a -> IO (Async a)+asyncOn = asyncUsing . rawForkOn++-- | Like 'async' but using 'forkIOWithUnmask' internally.  The child+-- thread is passed a function that can be used to unmask asynchronous+-- exceptions.+asyncWithUnmask :: ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)+asyncWithUnmask actionWith = asyncUsing rawForkIO (actionWith unsafeUnmask)++-- | Like 'asyncOn' but using 'forkOnWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions.+asyncOnWithUnmask :: Int -> ((forall b . IO b -> IO b) -> IO a) -> IO (Async a)+asyncOnWithUnmask cpu actionWith =+  asyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)++asyncUsing :: (IO () -> IO ThreadId)+           -> IO a -> IO (Async a)+asyncUsing doFork = \action -> do+   var <- newEmptyTMVarIO+   -- t <- forkFinally action (\r -> atomically $ putTMVar var r)+   -- slightly faster:+   t <- mask $ \restore ->+          doFork $ try (restore action) >>= atomically . putTMVar var+   return (Async t (readTMVar var))++-- | Spawn an asynchronous action in a separate thread, and pass its+-- @Async@ handle to the supplied function.  When the function returns+-- or throws an exception, 'uninterruptibleCancel' is called on the @Async@.+--+-- > withAsync action inner = mask $ \restore -> do+-- >   a <- async (restore action)+-- >   restore (inner a) `finally` uninterruptibleCancel a+--+-- This is a useful variant of 'async' that ensures an @Async@ is+-- never left running unintentionally.+--+-- Note: a reference to the child thread is kept alive until the call+-- to `withAsync` returns, so nesting many `withAsync` calls requires+-- linear memory.+--+withAsync :: IO a -> (Async a -> IO b) -> IO b+withAsync = inline withAsyncUsing rawForkIO++-- | Like 'withAsync' but uses 'forkOS' internally.+withAsyncBound :: IO a -> (Async a -> IO b) -> IO b+withAsyncBound = withAsyncUsing forkOS++-- | Like 'withAsync' but uses 'forkOn' internally.+withAsyncOn :: Int -> IO a -> (Async a -> IO b) -> IO b+withAsyncOn = withAsyncUsing . rawForkOn++-- | Like 'withAsync' but uses 'forkIOWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions.+withAsyncWithUnmask+  :: ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b+withAsyncWithUnmask actionWith =+  withAsyncUsing rawForkIO (actionWith unsafeUnmask)++-- | Like 'withAsyncOn' but uses 'forkOnWithUnmask' internally.  The+-- child thread is passed a function that can be used to unmask+-- asynchronous exceptions+withAsyncOnWithUnmask+  :: Int -> ((forall c. IO c -> IO c) -> IO a) -> (Async a -> IO b) -> IO b+withAsyncOnWithUnmask cpu actionWith =+  withAsyncUsing (rawForkOn cpu) (actionWith unsafeUnmask)++withAsyncUsing :: (IO () -> IO ThreadId)+               -> IO a -> (Async a -> IO b) -> IO b+-- The bracket version works, but is slow.  We can do better by+-- hand-coding it:+withAsyncUsing doFork = \action inner -> do+  var <- newEmptyTMVarIO+  mask $ \restore -> do+    t <- doFork $ try (restore action) >>= atomically . putTMVar var+    let a = Async t (readTMVar var)+    r <- restore (inner a) `catchAll` \e -> do+      uninterruptibleCancel a+      throwIO e+    uninterruptibleCancel a+    return r++-- | Wait for an asynchronous action to complete, and return its+-- value.  If the asynchronous action threw an exception, then the+-- exception is re-thrown by 'wait'.+--+-- > wait = atomically . waitSTM+--+{-# INLINE wait #-}+wait :: Async a -> IO a+wait = tryAgain . atomically . waitSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | Wait for an asynchronous action to complete, and return either+-- @Left e@ if the action raised an exception @e@, or @Right a@ if it+-- returned a value @a@.+--+-- > waitCatch = atomically . waitCatchSTM+--+{-# INLINE waitCatch #-}+waitCatch :: Async a -> IO (Either SomeException a)+waitCatch = tryAgain . atomically . waitCatchSTM+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | Check whether an 'Async' has completed yet.  If it has not+-- completed yet, then the result is @Nothing@, otherwise the result+-- is @Just e@ where @e@ is @Left x@ if the @Async@ raised an+-- exception @x@, or @Right a@ if it returned a value @a@.+--+-- > poll = atomically . pollSTM+--+{-# INLINE poll #-}+poll :: Async a -> IO (Maybe (Either SomeException a))+poll = atomically . pollSTM++-- | A version of 'wait' that can be used inside an STM transaction.+--+waitSTM :: Async a -> STM a+waitSTM a = do+   r <- waitCatchSTM a+   either throwSTM return r++-- | A version of 'waitCatch' that can be used inside an STM transaction.+--+{-# INLINE waitCatchSTM #-}+waitCatchSTM :: Async a -> STM (Either SomeException a)+waitCatchSTM (Async _ w) = w++-- | A version of 'poll' that can be used inside an STM transaction.+--+{-# INLINE pollSTM #-}+pollSTM :: Async a -> STM (Maybe (Either SomeException a))+pollSTM (Async _ w) = (Just <$> w) `orElse` return Nothing++-- | Cancel an asynchronous action by throwing the @AsyncCancelled@+-- exception to it, and waiting for the `Async` thread to quit.+-- Has no effect if the 'Async' has already completed.+--+-- > cancel a = throwTo (asyncThreadId a) AsyncCancelled <* waitCatch a+--+-- Note that 'cancel' will not terminate until the thread the 'Async'+-- refers to has terminated. This means that 'cancel' will block for+-- as long said thread blocks when receiving an asynchronous exception.+--+-- For example, it could block if:+--+-- * It's executing a foreign call, and thus cannot receive the asynchronous+-- exception;+-- * It's executing some cleanup handler after having received the exception,+-- and the handler is blocking.+{-# INLINE cancel #-}+cancel :: Async a -> IO ()+cancel a@(Async t _) = throwTo t AsyncCancelled <* waitCatch a++-- | Cancel multiple asynchronous actions by throwing the @AsyncCancelled@+-- exception to each of them in turn, then waiting for all the `Async` threads+-- to complete.+cancelMany :: [Async a] -> IO ()+cancelMany as = do+  mapM_ (\(Async t _) -> throwTo t AsyncCancelled) as+  mapM_ waitCatch as++-- | The exception thrown by `cancel` to terminate a thread.+data AsyncCancelled = AsyncCancelled+  deriving (Show, Eq+#if __GLASGOW_HASKELL__ < 710+    ,Typeable+#endif+    )++instance Exception AsyncCancelled where+#if __GLASGOW_HASKELL__ >= 708+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Cancel an asynchronous action+--+-- This is a variant of `cancel`, but it is not interruptible.+{-# INLINE uninterruptibleCancel #-}+uninterruptibleCancel :: Async a -> IO ()+uninterruptibleCancel = uninterruptibleMask_ . cancel++-- | Cancel an asynchronous action by throwing the supplied exception+-- to it.+--+-- > cancelWith a x = throwTo (asyncThreadId a) x+--+-- The notes about the synchronous nature of 'cancel' also apply to+-- 'cancelWith'.+cancelWith :: Exception e => Async a -> e -> IO ()+cancelWith a@(Async t _) e = throwTo t e <* waitCatch a++-- | Wait for any of the supplied asynchronous operations to complete.+-- The value returned is a pair of the 'Async' that completed, and the+-- result that would be returned by 'wait' on that 'Async'.+-- The input list must be non-empty.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+--+{-# INLINE waitAnyCatch #-}+waitAnyCatch :: [Async a] -> IO (Async a, Either SomeException a)+waitAnyCatch = atomically . waitAnyCatchSTM++-- | A version of 'waitAnyCatch' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitAnyCatchSTM :: [Async a] -> STM (Async a, Either SomeException a)+waitAnyCatchSTM [] =+    throwSTM $ ErrorCall+      "waitAnyCatchSTM: invalid argument: input list must be non-empty"+waitAnyCatchSTM asyncs =+    foldr orElse retry $+      map (\a -> do r <- waitCatchSTM a; return (a, r)) asyncs++-- | Like 'waitAnyCatch', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCatchCancel :: [Async a] -> IO (Async a, Either SomeException a)+waitAnyCatchCancel asyncs =+  waitAnyCatch asyncs `finally` cancelMany asyncs++-- | Wait for any of the supplied @Async@s to complete.  If the first+-- to complete throws an exception, then that exception is re-thrown+-- by 'waitAny'.+-- The input list must be non-empty.+--+-- If multiple 'Async's complete or have completed, then the value+-- returned corresponds to the first completed 'Async' in the list.+--+{-# INLINE waitAny #-}+waitAny :: [Async a] -> IO (Async a, a)+waitAny = atomically . waitAnySTM++-- | A version of 'waitAny' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitAnySTM :: [Async a] -> STM (Async a, a)+waitAnySTM [] =+    throwSTM $ ErrorCall+      "waitAnySTM: invalid argument: input list must be non-empty"+waitAnySTM asyncs =+    foldr orElse retry $+      map (\a -> do r <- waitSTM a; return (a, r)) asyncs++-- | Like 'waitAny', but also cancels the other asynchronous+-- operations as soon as one has completed.+--+waitAnyCancel :: [Async a] -> IO (Async a, a)+waitAnyCancel asyncs =+  waitAny asyncs `finally` cancelMany asyncs++-- | Wait for the first of two @Async@s to finish.+{-# INLINE waitEitherCatch #-}+waitEitherCatch :: Async a -> Async b+                -> IO (Either (Either SomeException a)+                              (Either SomeException b))+waitEitherCatch left right =+  tryAgain $ atomically (waitEitherCatchSTM left right)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'waitEitherCatch' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherCatchSTM :: Async a -> Async b+                -> STM (Either (Either SomeException a)+                               (Either SomeException b))+waitEitherCatchSTM left right =+    (Left  <$> waitCatchSTM left)+      `orElse`+    (Right <$> waitCatchSTM right)++-- | Like 'waitEitherCatch', but also 'cancel's both @Async@s before+-- returning.+--+waitEitherCatchCancel :: Async a -> Async b+                      -> IO (Either (Either SomeException a)+                                    (Either SomeException b))+waitEitherCatchCancel left right =+  waitEitherCatch left right `finally` cancelMany [() <$ left, () <$ right]++-- | Wait for the first of two @Async@s to finish.  If the @Async@+-- that finished first raised an exception, then the exception is+-- re-thrown by 'waitEither'.+--+{-# INLINE waitEither #-}+waitEither :: Async a -> Async b -> IO (Either a b)+waitEither left right = atomically (waitEitherSTM left right)++-- | A version of 'waitEither' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherSTM :: Async a -> Async b -> STM (Either a b)+waitEitherSTM left right =+    (Left  <$> waitSTM left)+      `orElse`+    (Right <$> waitSTM right)++-- | Like 'waitEither', but the result is ignored.+--+{-# INLINE waitEither_ #-}+waitEither_ :: Async a -> Async b -> IO ()+waitEither_ left right = atomically (waitEitherSTM_ left right)++-- | A version of 'waitEither_' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitEitherSTM_:: Async a -> Async b -> STM ()+waitEitherSTM_ left right =+    (void $ waitSTM left)+      `orElse`+    (void $ waitSTM right)++-- | Like 'waitEither', but also 'cancel's both @Async@s before+-- returning.+--+waitEitherCancel :: Async a -> Async b -> IO (Either a b)+waitEitherCancel left right =+  waitEither left right `finally` cancelMany [() <$ left, () <$ right]++-- | Waits for both @Async@s to finish, but if either of them throws+-- an exception before they have both finished, then the exception is+-- re-thrown by 'waitBoth'.+--+{-# INLINE waitBoth #-}+waitBoth :: Async a -> Async b -> IO (a,b)+waitBoth left right = tryAgain $ atomically (waitBothSTM left right)+  where+    -- See: https://github.com/simonmar/async/issues/14+    tryAgain f = f `catch` \BlockedIndefinitelyOnSTM -> f++-- | A version of 'waitBoth' that can be used inside an STM transaction.+--+-- @since 2.1.0+waitBothSTM :: Async a -> Async b -> STM (a,b)+waitBothSTM left right = do+    a <- waitSTM left+           `orElse`+         (waitSTM right >> retry)+    b <- waitSTM right+    return (a,b)+++-- -----------------------------------------------------------------------------+-- Linking threads++data ExceptionInLinkedThread =+  forall a . ExceptionInLinkedThread (Async a) SomeException+#if __GLASGOW_HASKELL__ < 710+  deriving Typeable+#endif++instance Show ExceptionInLinkedThread where+  showsPrec p (ExceptionInLinkedThread (Async t _) e) =+    showParen (p >= 11) $+      showString "ExceptionInLinkedThread " .+      showsPrec 11 t .+      showString " " .+      showsPrec 11 e++instance Exception ExceptionInLinkedThread where+#if __GLASGOW_HASKELL__ >= 708+  fromException = asyncExceptionFromException+  toException = asyncExceptionToException+#endif++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread, wrapped in 'ExceptionInLinkedThread'.+--+-- 'link' ignores 'AsyncCancelled' exceptions thrown in the other thread,+-- so that it's safe to 'cancel' a thread you're linked to.  If you want+-- different behaviour, use 'linkOnly'.+--+link :: Async a -> IO ()+link = linkOnly (not . isCancel)++-- | Link the given @Async@ to the current thread, such that if the+-- @Async@ raises an exception, that exception will be re-thrown in+-- the current thread, wrapped in 'ExceptionInLinkedThread'.+--+-- The supplied predicate determines which exceptions in the target+-- thread should be propagated to the source thread.+--+linkOnly+  :: (SomeException -> Bool)  -- ^ return 'True' if the exception+                              -- should be propagated, 'False'+                              -- otherwise.+  -> Async a+  -> IO ()+linkOnly shouldThrow a = do+  me <- myThreadId+  void $ forkRepeat $ do+    r <- waitCatch a+    case r of+      Left e | shouldThrow e -> throwTo me (ExceptionInLinkedThread a e)+      _otherwise -> return ()++-- | Link two @Async@s together, such that if either raises an+-- exception, the same exception is re-thrown in the other @Async@,+-- wrapped in 'ExceptionInLinkedThread'.+--+-- 'link2' ignores 'AsyncCancelled' exceptions, so that it's possible+-- to 'cancel' either thread without cancelling the other.  If you+-- want different behaviour, use 'link2Only'.+--+link2 :: Async a -> Async b -> IO ()+link2 = link2Only (not . isCancel)++-- | Link two @Async@s together, such that if either raises an+-- exception, the same exception is re-thrown in the other @Async@,+-- wrapped in 'ExceptionInLinkedThread'.+--+-- The supplied predicate determines which exceptions in the target+-- thread should be propagated to the source thread.+--+link2Only :: (SomeException -> Bool) -> Async a -> Async b -> IO ()+link2Only shouldThrow left@(Async tl _)  right@(Async tr _) =+  void $ forkRepeat $ do+    r <- waitEitherCatch left right+    case r of+      Left  (Left e) | shouldThrow e ->+        throwTo tr (ExceptionInLinkedThread left e)+      Right (Left e) | shouldThrow e ->+        throwTo tl (ExceptionInLinkedThread right e)+      _ -> return ()++isCancel :: SomeException -> Bool+isCancel e+  | Just AsyncCancelled <- fromException e = True+  | otherwise = False+++-- -----------------------------------------------------------------------------++-- | Run two @IO@ actions concurrently, and return the first to+-- finish.  The loser of the race is 'cancel'led.+--+-- > race left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitEither a b+--+race :: IO a -> IO b -> IO (Either a b)++-- | Like 'race', but the result is ignored.+--+race_ :: IO a -> IO b -> IO ()+++-- | Run two @IO@ actions concurrently, and return both results.  If+-- either action throws an exception at any time, then the other+-- action is 'cancel'led, and the exception is re-thrown by+-- 'concurrently'.+--+-- > concurrently left right =+-- >   withAsync left $ \a ->+-- >   withAsync right $ \b ->+-- >   waitBoth a b+concurrently :: IO a -> IO b -> IO (a,b)+++-- | Run two @IO@ actions concurrently. If both of them end with @Right@,+-- return both results.  If one of then ends with @Left@, interrupt the other+-- action and return the @Left@.+--+concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))++-- | 'concurrently', but ignore the result values+--+-- @since 2.1.1+concurrently_ :: IO a -> IO b -> IO ()++#define USE_ASYNC_VERSIONS 0++#if USE_ASYNC_VERSIONS++race left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitEither a b++race_ left right = void $ race left right++concurrently left right =+  withAsync left $ \a ->+  withAsync right $ \b ->+  waitBoth a b++concurrently_ left right = void $ concurrently left right++#else++-- MVar versions of race/concurrently+-- More ugly than the Async versions, but quite a bit faster.++-- race :: IO a -> IO b -> IO (Either a b)+race left right = concurrently' left right collect+  where+    collect m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> return r++-- race_ :: IO a -> IO b -> IO ()+race_ left right = void $ race left right++-- concurrently :: IO a -> IO b -> IO (a,b)+concurrently left right = concurrently' left right (collect [])+  where+    collect [Left a, Right b] _ = return (a,b)+    collect [Right b, Left a] _ = return (a,b)+    collect xs m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++-- concurrentlyE :: IO (Either e a) -> IO (Either e b) -> IO (Either e (a, b))+concurrentlyE left right = concurrently' left right (collect [])+  where+    collect [Left (Right a), Right (Right b)] _ = return $ Right (a,b)+    collect [Right (Right b), Left (Right a)] _ = return $ Right (a,b)+    collect (Left (Left ea):_) _ = return $ Left ea+    collect (Right (Left eb):_) _ = return $ Left eb+    collect xs m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right r -> collect (r:xs) m++concurrently' :: IO a -> IO b+             -> (IO (Either SomeException (Either a b)) -> IO r)+             -> IO r+concurrently' left right collect = do+    done <- newEmptyMVar+    mask $ \restore -> do+        -- Note: uninterruptibleMask here is because we must not allow+        -- the putMVar in the exception handler to be interrupted,+        -- otherwise the parent thread will deadlock when it waits for+        -- the thread to terminate.+        lid <- forkIO $ uninterruptibleMask_ $+          restore (left >>= putMVar done . Right . Left)+            `catchAll` (putMVar done . Left)+        rid <- forkIO $ uninterruptibleMask_ $+          restore (right >>= putMVar done . Right . Right)+            `catchAll` (putMVar done . Left)++        count <- newIORef (2 :: Int)+        let takeDone = do+                r <- takeMVar done      -- interruptible+                -- Decrement the counter so we know how many takes are left.+                -- Since only the parent thread is calling this, we can+                -- use non-atomic modifications.+                -- NB. do this *after* takeMVar, because takeMVar might be+                -- interrupted.+                modifyIORef count (subtract 1)+                return r++        let tryAgain f = f `catch` \BlockedIndefinitelyOnMVar -> f++            stop = do+                -- kill right before left, to match the semantics of+                -- the version using withAsync. (#27)+                uninterruptibleMask_ $ do+                  count' <- readIORef count+                  -- we only need to use killThread if there are still+                  -- children alive.  Note: forkIO here is because the+                  -- child thread could be in an uninterruptible+                  -- putMVar.+                  when (count' > 0) $+                    void $ forkIO $ do+                      throwTo rid AsyncCancelled+                      throwTo lid AsyncCancelled+                  -- ensure the children are really dead+                  replicateM_ count' (tryAgain $ takeMVar done)++        r <- collect (tryAgain $ takeDone) `onException` stop+        stop+        return r++concurrently_ left right = concurrently' left right (collect 0)+  where+    collect 2 _ = return ()+    collect i m = do+        e <- m+        case e of+            Left ex -> throwIO ex+            Right _ -> collect (i + 1 :: Int) m+++#endif++-- | Maps an 'IO'-performing function over any 'Traversable' data+-- type, performing all the @IO@ actions concurrently, and returning+-- the original data structure with the arguments replaced by the+-- results.+--+-- If any of the actions throw an exception, then all other actions are+-- cancelled and the exception is re-thrown.+--+-- For example, @mapConcurrently@ works with lists:+--+-- > pages <- mapConcurrently getURL ["url1", "url2", "url3"]+--+-- Take into account that @async@ will try to immediately spawn a thread+-- for each element of the @Traversable@, so running this on large+-- inputs without care may lead to resource exhaustion (of memory,+-- file descriptors, or other limited resources).+mapConcurrently :: Traversable t => (a -> IO b) -> t a -> IO (t b)+mapConcurrently f = runConcurrently . traverse (Concurrently . f)++-- | `forConcurrently` is `mapConcurrently` with its arguments flipped+--+-- > pages <- forConcurrently ["url1", "url2", "url3"] $ \url -> getURL url+--+-- @since 2.1.0+forConcurrently :: Traversable t => t a -> (a -> IO b) -> IO (t b)+forConcurrently = flip mapConcurrently++-- | `mapConcurrently_` is `mapConcurrently` with the return value discarded;+-- a concurrent equivalent of 'mapM_'.+mapConcurrently_ :: F.Foldable f => (a -> IO b) -> f a -> IO ()+mapConcurrently_ f = runConcurrently . F.foldMap (Concurrently . void . f)++-- | `forConcurrently_` is `forConcurrently` with the return value discarded;+-- a concurrent equivalent of 'forM_'.+forConcurrently_ :: F.Foldable f => f a -> (a -> IO b) -> IO ()+forConcurrently_ = flip mapConcurrently_++-- | Perform the action in the given number of threads.+--+-- @since 2.1.1+replicateConcurrently :: Int -> IO a -> IO [a]+replicateConcurrently cnt = runConcurrently . sequenceA . replicate cnt . Concurrently++-- | Same as 'replicateConcurrently', but ignore the results.+--+-- @since 2.1.1+replicateConcurrently_ :: Int -> IO a -> IO ()+replicateConcurrently_ cnt = runConcurrently . F.fold . replicate cnt . Concurrently . void++-- -----------------------------------------------------------------------------++-- | A value of type @Concurrently a@ is an @IO@ operation that can be+-- composed with other @Concurrently@ values, using the @Applicative@+-- and @Alternative@ instances.+--+-- Calling @runConcurrently@ on a value of type @Concurrently a@ will+-- execute the @IO@ operations it contains concurrently, before+-- delivering the result of type @a@.+--+-- For example+--+-- > (page1, page2, page3)+-- >     <- runConcurrently $ (,,)+-- >     <$> Concurrently (getURL "url1")+-- >     <*> Concurrently (getURL "url2")+-- >     <*> Concurrently (getURL "url3")+--+newtype Concurrently a = Concurrently { runConcurrently :: IO a }++instance Functor Concurrently where+  fmap f (Concurrently a) = Concurrently $ f <$> a++instance Applicative Concurrently where+  pure = Concurrently . return+  Concurrently fs <*> Concurrently as =+    Concurrently $ (\(f, a) -> f a) <$> concurrently fs as++-- | 'Control.Alternative.empty' waits forever. 'Control.Alternative.<|>' returns the first to finish and 'cancel's the other.+instance Alternative Concurrently where+  empty = Concurrently $ forever (threadDelay maxBound)+  Concurrently as <|> Concurrently bs =+    Concurrently $ either id id <$> race as bs++#if MIN_VERSION_base(4,9,0)+-- | Only defined by @async@ for @base >= 4.9@+--+-- @since 2.1.0+instance Semigroup a => Semigroup (Concurrently a) where+  (<>) = liftA2 (<>)++-- | @since 2.1.0+instance (Semigroup a, Monoid a) => Monoid (Concurrently a) where+  mempty = pure mempty+  mappend = (<>)+#else+-- | @since 2.1.0+instance Monoid a => Monoid (Concurrently a) where+  mempty = pure mempty+  mappend = liftA2 mappend+#endif++-- | A value of type @ConcurrentlyE e a@ is an @IO@ operation that can be+-- composed with other @ConcurrentlyE@ values, using the @Applicative@ instance.+--+-- Calling @runConcurrentlyE@ on a value of type @ConcurrentlyE e a@ will+-- execute the @IO@ operations it contains concurrently, before delivering+-- either the result of type @a@, or an error of type @e@ if one of the actions+-- returns @Left@.+--+-- | @since 2.2.5+newtype ConcurrentlyE e a = ConcurrentlyE { runConcurrentlyE :: IO (Either e a) }++instance Functor (ConcurrentlyE e) where+  fmap f (ConcurrentlyE ea) = ConcurrentlyE $ fmap (fmap f) ea++#if MIN_VERSION_base(4,8,0)+instance Bifunctor ConcurrentlyE where+  bimap f g (ConcurrentlyE ea) = ConcurrentlyE $ fmap (bimap f g) ea+#endif++instance Applicative (ConcurrentlyE e) where+  pure = ConcurrentlyE . return . return+  ConcurrentlyE fs <*> ConcurrentlyE eas =+    ConcurrentlyE $ fmap (\(f, a) -> f a) <$> concurrentlyE fs eas++#if MIN_VERSION_base(4,9,0)+-- | Either the combination of the successful results, or the first failure.+instance Semigroup a => Semigroup (ConcurrentlyE e a) where+  (<>) = liftA2 (<>)++instance (Semigroup a, Monoid a) => Monoid (ConcurrentlyE e a) where+  mempty = pure mempty+  mappend = (<>)+#endif++-- ----------------------------------------------------------------------------++-- | Fork a thread that runs the supplied action, and if it raises an+-- exception, re-runs the action.  The thread terminates only when the+-- action runs to completion without raising an exception.+forkRepeat :: IO a -> IO ThreadId+forkRepeat action =+  mask $ \restore ->+    let go = do r <- tryAll (restore action)+                case r of+                  Left _ -> go+                  _      -> return ()+    in forkIO go++catchAll :: IO a -> (SomeException -> IO a) -> IO a+catchAll = catch++tryAll :: IO a -> IO (Either SomeException a)+tryAll = try++-- A version of forkIO that does not include the outer exception+-- handler: saves a bit of time when we will be installing our own+-- exception handler.+{-# INLINE rawForkIO #-}+rawForkIO :: IO () -> IO ThreadId+rawForkIO (IO action) = IO $ \ s ->+   case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)++{-# INLINE rawForkOn #-}+rawForkOn :: Int -> IO () -> IO ThreadId+rawForkOn (I# cpu) (IO action) = IO $ \ s ->+   case (forkOn# cpu action s) of (# s1, tid #) -> (# s1, ThreadId tid #)
version.yaml view
@@ -1,4 +1,4 @@-version: &version 2.11.15+version: &version 2.11.16 synopsis: A Testing Framework for Haskell author: Simon Hengel <sol@typeful.net> maintainer: Simon Hengel <sol@typeful.net>