packages feed

hspec-meta 2.10.5 → 2.11.2

raw patch · 64 files changed

+3071/−3681 lines, 64 filesdep +HUnitdep +haskell-lexerdep +hspec-expectationsdep −clockdep −ghcdep −ghc-boot-thdep ~QuickCheckdep ~ansi-terminaldep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, haskell-lexer, hspec-expectations, process, tf-random

Dependencies removed: clock, ghc, ghc-boot-th, setenv

Dependency ranges changed: QuickCheck, ansi-terminal, base, call-stack, quickcheck-io

API changes (from Hackage documentation)

- Test.Hspec.Meta: anyArithException :: Selector ArithException
- Test.Hspec.Meta: anyErrorCall :: Selector ErrorCall
- Test.Hspec.Meta: anyException :: Selector SomeException
- Test.Hspec.Meta: anyIOException :: Selector IOException
- Test.Hspec.Meta: errorCall :: String -> Selector ErrorCall
- Test.Hspec.Meta: expectationFailure :: HasCallStack => String -> Expectation
- Test.Hspec.Meta: infix 1 `shouldThrow`
- Test.Hspec.Meta: shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation
- Test.Hspec.Meta: shouldContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation
- Test.Hspec.Meta: shouldEndWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation
- Test.Hspec.Meta: shouldMatchList :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation
- Test.Hspec.Meta: shouldNotBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation
- Test.Hspec.Meta: shouldNotContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation
- Test.Hspec.Meta: shouldNotReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
- Test.Hspec.Meta: shouldNotSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
- Test.Hspec.Meta: shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation
- Test.Hspec.Meta: shouldSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation
- Test.Hspec.Meta: shouldStartWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation
- Test.Hspec.Meta: shouldThrow :: (HasCallStack, Exception e) => IO a -> Selector e -> Expectation
- Test.Hspec.Meta: type Expectation = Assertion
- Test.Hspec.Meta: type HasCallStack = ?callStack :: CallStack
- Test.Hspec.Meta: type Selector a = (a -> Bool)
+ Test.Hspec.Meta: sequential :: SpecWith a -> SpecWith a

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2011-2022 Simon Hengel <sol@typeful.net>+Copyright (c) 2011-2023 Simon Hengel <sol@typeful.net> Copyright (c) 2011-2012 Trystan Spangler <trystan.s@comcast.net> Copyright (c) 2011-2011 Greg Weber <greg@gregweber.info>
hspec-core/src/GetOpt/Declarative/Interpret.hs view
@@ -7,13 +7,12 @@  import           Prelude () import           Test.Hspec.Core.Compat-import           Data.Maybe  import           System.Console.GetOpt (OptDescr, ArgOrder(..), getOpt) import qualified System.Console.GetOpt as GetOpt  import           GetOpt.Declarative.Types-import           GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr)+import           GetOpt.Declarative.Util (mkUsageInfo)  data InvalidArgument = InvalidArgument String String @@ -31,7 +30,7 @@      usage :: String     usage = "Usage: " ++ prog ++ " [OPTION]...\n\n"-      ++ (intercalate "\n" $ map (uncurry mkUsageInfo) documentedOptions)+      ++ intercalate "\n" (map (uncurry mkUsageInfo) documentedOptions)  addHelpFlag :: [(a, [OptDescr a1])] -> [(a, [OptDescr (Maybe a1)])] addHelpFlag opts = case opts of@@ -41,7 +40,7 @@     help = Nothing      noHelp :: [OptDescr a] -> [OptDescr (Maybe a)]-    noHelp = map (mapOptDescr Just)+    noHelp = map (fmap Just)  parseWithHelp :: [OptDescr (Maybe (config -> Either InvalidArgument config))] -> config -> [String] -> Maybe (Either String config) parseWithHelp options config args = case getOpt Permute options args of
hspec-core/src/GetOpt/Declarative/Util.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-module GetOpt.Declarative.Util (mkUsageInfo, mapOptDescr) where+module GetOpt.Declarative.Util (mkUsageInfo) where  import           Prelude () import           Test.Hspec.Core.Compat@@ -31,17 +31,3 @@     Option "" ["[no-]" ++ optionA] arg help : condenseNoOptions ys   x : xs -> x : condenseNoOptions xs   [] -> []--mapOptDescr :: (a -> b) -> OptDescr a -> OptDescr b-#if MIN_VERSION_base(4,7,0)-mapOptDescr = fmap-#else-mapOptDescr f opt = case opt of-  Option short long arg help -> Option short long (mapArgDescr f arg) help--mapArgDescr :: (a -> b) -> ArgDescr a -> ArgDescr b-mapArgDescr f arg = case arg of-  NoArg a -> NoArg (f a)-  ReqArg parse name -> ReqArg (fmap f parse) name-  OptArg parse name -> OptArg (fmap f parse) name-#endif
hspec-core/src/Test/Hspec/Core/Compat.hs view
@@ -4,6 +4,7 @@ , module Test.Hspec.Core.Compat ) where +import           Control.Exception as Imports import           Control.Arrow as Imports ((>>>), (&&&), first, second) import           Control.Applicative as Imports import           Control.Monad as Imports hiding (@@ -15,10 +16,16 @@   , sequence   , sequence_   )+import           Data.Maybe as Imports import           Data.Foldable as Imports+import           Data.CallStack as Imports (HasCallStack) +import           System.IO+import           System.Exit+import           System.Environment+ #if MIN_VERSION_base(4,11,0)-import           Data.Functor as Imports+import           Data.Functor as Imports ((<&>)) #endif  import           Data.Traversable as Imports@@ -27,13 +34,12 @@     stripPrefix   , isPrefixOf   , isInfixOf+  , isSuffixOf   , intercalate   , inits   , tails   , sortBy-#if MIN_VERSION_base(4,8,0)   , sortOn-#endif   )  import           Prelude as Imports hiding (@@ -57,21 +63,22 @@   , sequence   , sequence_   , sum-#if !MIN_VERSION_base(4,6,0)-  , catch-#endif   ) -import           Data.Typeable (Typeable, typeOf, typeRepTyCon)+import           Data.Typeable (Typeable, typeOf, typeRepTyCon, tyConModule, tyConName) import           Data.IORef as Imports +#if MIN_VERSION_base(4,12,0)+import           GHC.ResponseFile as Imports (unescapeArgs)+#else+import           Data.Char+#endif+ #if MIN_VERSION_base(4,6,0) import           Text.Read as Imports (readMaybe) import           System.Environment as Imports (lookupEnv) #else-import           Control.Exception import           Text.Read-import           System.Environment import qualified Text.ParserCombinators.ReadP as P #endif @@ -79,12 +86,13 @@ import           Data.Ord (comparing) #endif -import           Data.Typeable (tyConModule, tyConName)+#if MIN_VERSION_base(4,7,0)+import           Data.Bool as Imports (bool)+#endif+ import           Control.Concurrent -#if MIN_VERSION_base(4,9,0)-import           Control.Exception as Imports (interruptible)-#else+#if !MIN_VERSION_base(4,9,0) import           GHC.IO #endif @@ -104,7 +112,7 @@ atomicWriteIORef :: IORef a -> a -> IO () atomicWriteIORef ref a = do     x <- atomicModifyIORef ref (\_ -> (a, ()))-    x `seq` return ()+    x `seq` pass  -- | Parse a string using the 'Read' instance. -- Succeeds if there is exactly one valid result.@@ -160,14 +168,53 @@ guarded :: Alternative m => (a -> Bool) -> a -> m a guarded p a = if p a then pure a else empty -#if !MIN_VERSION_base(4,8,0)-sortOn :: Ord b => (a -> b) -> [a] -> [a]-sortOn f =-  map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))-#endif- #if !MIN_VERSION_base(4,11,0) infixl 1 <&> (<&>) :: Functor f => f a -> (a -> b) -> f b (<&>) = flip (<$>)+#endif++endsWith :: Eq a => [a] -> [a] -> Bool+endsWith = flip isSuffixOf++pass :: Applicative m => m ()+pass = pure ()++die :: String -> IO a+die err = do+  name <- getProgName+  hPutStrLn stderr $ name <> ": " <> err+  exitFailure++#if !MIN_VERSION_base(4,12,0)+unescapeArgs :: String -> [String]+unescapeArgs = filter (not . null) . unescape++data Quoting = NoneQ | SngQ | DblQ++unescape :: String -> [String]+unescape args = reverse . map reverse $ go args NoneQ False [] []+    where+      -- n.b., the order of these cases matters; these are cribbed from gcc+      -- case 1: end of input+      go []     _q    _bs   a as = a:as+      -- case 2: back-slash escape in progress+      go (c:cs) q     True  a as = go cs q     False (c:a) as+      -- case 3: no back-slash escape in progress, but got a back-slash+      go (c:cs) q     False a as+        | '\\' == c              = go cs q     True  a     as+      -- case 4: single-quote escaping in progress+      go (c:cs) SngQ  False a as+        | '\'' == c              = go cs NoneQ False a     as+        | otherwise              = go cs SngQ  False (c:a) as+      -- case 5: double-quote escaping in progress+      go (c:cs) DblQ  False a as+        | '"' == c               = go cs NoneQ False a     as+        | otherwise              = go cs DblQ  False (c:a) as+      -- case 6: no escaping is in progress+      go (c:cs) NoneQ False a as+        | isSpace c              = go cs NoneQ False []    (a:as)+        | '\'' == c              = go cs SngQ  False a     as+        | '"'  == c              = go cs DblQ  False a     as+        | otherwise              = go cs NoneQ False (c:a) as #endif
hspec-core/src/Test/Hspec/Core/Config.hs view
@@ -18,8 +18,7 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception-import           Data.Maybe+import           GHC.IO.Exception (IOErrorType(UnsupportedOperation)) import           System.IO import           System.IO.Error import           System.Exit@@ -30,11 +29,21 @@  import           Test.Hspec.Core.Util import           Test.Hspec.Core.Config.Options-import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), defaultConfig, filterOr)+import           Test.Hspec.Core.Config.Definition (Config(..), ColorMode(..), UnicodeMode(..), mkDefaultConfig, filterOr) import           Test.Hspec.Core.FailureReport import           Test.Hspec.Core.QuickCheckUtil (mkGen) import           Test.Hspec.Core.Example (Params(..), defaultParams)+import qualified Test.Hspec.Core.Formatters.V2 as V2 +defaultConfig :: Config+defaultConfig = mkDefaultConfig $ map (fmap V2.formatterToFormat) [+    ("checks", V2.checks)+  , ("specdoc", V2.specdoc)+  , ("progress", V2.progress)+  , ("failed-examples", V2.failed_examples)+  , ("silent", V2.silent)+  ]+ -- | Add a filter predicate to config.  If there is already a filter predicate, -- then combine them with `||`. configAddFilter :: (Path -> Bool) -> Config -> Config@@ -95,7 +104,7 @@ -- -- 1. @~/.hspec@ (a config file in the user's home directory) -- 1. @.hspec@ (a config file in the current working directory)--- 1. the environment variable @HSPEC_OPTIONS@+-- 1. [environment variables starting with @HSPEC_@](https://hspec.github.io/options.html#specifying-options-through-environment-variables) -- 1. the provided list of command-line options (the second argument to @readConfig@) -- -- (precedence from low to high)@@ -140,10 +149,13 @@  readGlobalConfigFile :: IO (Maybe ConfigFile) readGlobalConfigFile = do-  mHome <- tryJust (guard . isDoesNotExistError) getHomeDirectory+  mHome <- tryJust (guard . isPotentialHomeDirError) getHomeDirectory   case mHome of     Left _ -> return Nothing     Right home -> readConfigFile (home </> ".hspec")+  where+    isPotentialHomeDirError e =+      isDoesNotExistError e || ioeGetErrorType e == UnsupportedOperation  readLocalConfigFile :: IO (Maybe ConfigFile) readLocalConfigFile = do@@ -155,7 +167,7 @@ readConfigFile :: FilePath -> IO (Maybe ConfigFile) readConfigFile name = do   exists <- doesFileExist name-  if exists then Just . (,) name . words <$> readFile name else return Nothing+  if exists then Just . (,) name . unescapeArgs <$> readFile name else return Nothing  exitWithMessage :: ExitCode -> String -> IO a exitWithMessage err msg = do
hspec-core/src/Test/Hspec/Core/Config/Definition.hs view
@@ -4,7 +4,7 @@ , ColorMode(..) , UnicodeMode(..) , filterOr-, defaultConfig+, mkDefaultConfig  , commandLineOnlyOptions , formatterOptions@@ -20,11 +20,14 @@ import           Prelude () import           Test.Hspec.Core.Compat +import           System.Directory (getTemporaryDirectory, removeFile)+import           System.IO (openTempFile, hClose)+import           System.Process (system)+ import           Test.Hspec.Core.Example (Params(..), defaultParams) import           Test.Hspec.Core.Format (Format, FormatConfig) import           Test.Hspec.Core.Formatters.Pretty (pretty2)-import qualified Test.Hspec.Core.Formatters.V1 as V1-import qualified Test.Hspec.Core.Formatters.V2 as V2+import qualified Test.Hspec.Core.Formatters.V1.Monad as V1 import           Test.Hspec.Core.Util  import           GetOpt.Declarative@@ -43,6 +46,7 @@ , configFailOnEmpty :: Bool , configFailOnFocused :: Bool , configFailOnPending :: Bool+, configFailOnEmptyDescription :: Bool , configPrintSlowItems :: Maybe Int , configPrintCpuTime :: Bool , configFailFast :: Bool@@ -65,24 +69,37 @@ , configColorMode :: ColorMode , configUnicodeMode :: UnicodeMode , configDiff :: Bool+, configDiffContext :: Maybe Int++-- |+-- An action that is used to print diffs.  The first argument is the value of+-- `configDiffContext`.  The remaining two arguments are the @expected@ and+-- @actual@ value.+--+-- @since 2.10.6+, configExternalDiff :: Maybe (Maybe Int -> String -> String -> IO ())+ , configPrettyPrint :: Bool , configPrettyPrintFunction :: Bool -> String -> String -> (String, String) , configTimes :: Bool-, configAvailableFormatters :: [(String, FormatConfig -> IO Format)]+, configExpertMode :: Bool -- ^ @since 2.11.2+, configAvailableFormatters :: [(String, FormatConfig -> IO Format)] -- ^ @since 2.9.0 , configFormat :: Maybe (FormatConfig -> IO Format)-, configFormatter :: Maybe V1.Formatter -- ^ deprecated, use `configFormat` instead+, configFormatter :: Maybe V1.Formatter , configHtmlOutput :: Bool , configConcurrentJobs :: Maybe Int }+{-# DEPRECATED configFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html#v:useFormatter) instead." #-} -defaultConfig :: Config-defaultConfig = Config {+mkDefaultConfig :: [(String, FormatConfig -> IO Format)] -> Config+mkDefaultConfig formatters = Config {   configIgnoreConfigFile = False , configDryRun = False , configFocusedOnly = False , configFailOnEmpty = False , configFailOnFocused = False , configFailOnPending = False+, configFailOnEmptyDescription = False , configPrintSlowItems = Nothing , configPrintCpuTime = False , configFailFast = False@@ -101,22 +118,36 @@ , configColorMode = ColorAuto , configUnicodeMode = UnicodeAuto , configDiff = True+, configDiffContext = Just defaultDiffContext+, configExternalDiff = Nothing , configPrettyPrint = True , configPrettyPrintFunction = pretty2 , configTimes = False-, configAvailableFormatters = map (fmap V2.formatterToFormat) [-    ("checks", V2.checks)-  , ("specdoc", V2.specdoc)-  , ("progress", V2.progress)-  , ("failed-examples", V2.failed_examples)-  , ("silent", V2.silent)-  ]+, configExpertMode = False+, configAvailableFormatters = formatters , configFormat = Nothing , configFormatter = Nothing , configHtmlOutput = False , configConcurrentJobs = Nothing } +defaultDiffContext :: Int+defaultDiffContext = 3++externalDiff :: String -> String -> String -> IO ()+externalDiff command expected actual = do+  tmp <- getTemporaryDirectory+  withTempFile tmp "hspec-expected" expected $ \ expectedFile -> do+    withTempFile tmp "hspec-actual" actual $ \ actualFile -> do+      void . system $ unwords [command, expectedFile, actualFile]++withTempFile :: FilePath -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempFile dir file contents action = do+  bracket (openTempFile dir file) (removeFile . fst) $ \ (path, h) -> do+    hClose h+    writeFile path contents+    action path+ option :: String -> OptionSetter config -> String -> Option config option name arg help = Option name Nothing arg help True @@ -137,20 +168,33 @@  formatterOptions :: [(String, FormatConfig -> IO Format)] -> [Option Config] formatterOptions formatters = [-    mkOption "format" (Just 'f') (argument "FORMATTER" readFormatter setFormatter) helpForFormat+    mkOption "format" (Just 'f') (argument "NAME" readFormatter setFormatter) helpForFormat   , mkFlag "color" setColor "colorize the output"   , mkFlag "unicode" setUnicode "output unicode"   , mkFlag "diff" setDiff "show colorized diffs"+  , option "diff-context" (argument "N" readDiffContext setDiffContext) $ unlines [+        "output N lines of diff context (default: " <> show defaultDiffContext <> ")"+      , "use a value of 'full' to see the full context"+      ]+  , option "diff-command" (argument "CMD" return setDiffCommand) "use an external diff command\nexample: --diff-command=\"git diff\""   , mkFlag "pretty" setPretty "try to pretty-print diff values"   , mkFlag "times" setTimes "report times for individual spec items"   , mkOptionNoArg "print-cpu-time" Nothing setPrintCpuTime "include used CPU time in summary"   , printSlowItemsOption+  , mkFlag "expert" setExpertMode "be less verbose"      -- undocumented for now, as we probably want to change this to produce a     -- standalone HTML report in the future   , undocumented $ mkOptionNoArg "html" Nothing setHtml "produce HTML output"   ]   where+    setDiffCommand :: String -> Config -> Config+    setDiffCommand command config = config {+      configExternalDiff = case strip command of+        "" -> Nothing+        _ -> Just $ \ _context -> externalDiff command+    }+     setHtml config = config {configHtmlOutput = True}      helpForFormat :: String@@ -171,6 +215,16 @@     setDiff :: Bool -> Config -> Config     setDiff v config = config {configDiff = v} +    readDiffContext :: String -> Maybe (Maybe Int)+    readDiffContext input = case input of+      "full" -> Just Nothing+      _ -> case readMaybe input of+        Nothing -> Nothing+        mn -> Just (find (>= 0) mn)++    setDiffContext :: Maybe Int -> Config -> Config+    setDiffContext value c = c { configDiffContext = value }+     setPretty :: Bool -> Config -> Config     setPretty v config = config {configPrettyPrint = v} @@ -179,6 +233,9 @@      setPrintCpuTime config = config {configPrintCpuTime = True} +    setExpertMode :: Bool -> Config -> Config+    setExpertMode v config = config {configExpertMode = v}+ printSlowItemsOption :: Option Config printSlowItemsOption = Option name (Just 'p') (OptArg "N" arg) "print the N slowest spec items (default: 10)" True   where@@ -192,9 +249,8 @@      parseArg :: String -> Config -> Maybe Config     parseArg input c = case readMaybe input of-      Just 0 -> Just (setter Nothing c)-      Just n -> Just (setter (Just n) c)       Nothing -> Nothing+      mn -> Just (setter (find (> 0) mn) c)  smallCheckOptions :: [Option Config] smallCheckOptions = [@@ -235,6 +291,7 @@     FailOnEmpty   | FailOnFocused   | FailOnPending+  | FailOnEmptyDescription   deriving (Bounded, Enum)  allFailOnItems :: [FailOn]@@ -245,6 +302,7 @@   FailOnEmpty -> "empty"   FailOnFocused -> "focused"   FailOnPending -> "pending"+  FailOnEmptyDescription -> "empty-description"  readFailOn :: String -> Maybe FailOn readFailOn = (`lookup` items)@@ -279,7 +337,7 @@   , mkOption "jobs" (Just 'j') (argument "N" readMaxJobs setMaxJobs) "run at most N parallelizable tests simultaneously (default: number of available processors)"   ]   where-    strict = allFailOnItems+    strict = [FailOnFocused, FailOnPending]      readFailOnItems :: String -> Maybe [FailOn]     readFailOnItems = mapM readFailOn . splitOn ','@@ -292,9 +350,10 @@       showFailOn item <> ": " <> help item       where         help item = case item of-          FailOnEmpty -> "fail if no spec items have been run"+          FailOnEmpty -> "fail if all spec items have been filtered"           FailOnFocused -> "fail on focused spec items"           FailOnPending -> "fail on pending spec items"+          FailOnEmptyDescription -> "fail on empty descriptions"      setFailOnItems :: Bool -> [FailOn] -> Config -> Config     setFailOnItems value = flip $ foldr (`setItem` value)@@ -303,6 +362,7 @@           FailOnEmpty -> setFailOnEmpty           FailOnFocused -> setFailOnFocused           FailOnPending -> setFailOnPending+          FailOnEmptyDescription -> setFailOnEmptyDescription      readMaxJobs :: String -> Maybe Int     readMaxJobs s = do@@ -330,6 +390,9 @@      setFailOnPending :: Bool -> Config -> Config     setFailOnPending value config = config {configFailOnPending = value}++    setFailOnEmptyDescription :: Bool -> Config -> Config+    setFailOnEmptyDescription value config = config {configFailOnEmptyDescription = value}      setStrict :: Bool -> Config -> Config     setStrict = (`setFailOnItems` strict)
hspec-core/src/Test/Hspec/Core/Config/Options.hs view
@@ -49,14 +49,7 @@       foldM (parseFileOptions prog) config configFiles   >>= maybe return (parseEnvVarOptions prog) envVar   >>= parseEnvironmentOptions env-  >>= traverseTuple (parseCommandLineOptions prog args)--traverseTuple :: Applicative f => (a -> f b) -> (c, a) -> f (c, b)-#if MIN_VERSION_base(4,7,0)-traverseTuple = traverse-#else-traverseTuple f (c, a) = (,) c <$> f a-#endif+  >>= traverse (parseCommandLineOptions prog args)  parseCommandLineOptions :: String -> [String] -> Config -> Either (ExitCode, String) Config parseCommandLineOptions prog args config = case Declarative.parseCommandLineOptions (commandLineOptions formatters) prog args config of
hspec-core/src/Test/Hspec/Core/Example.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -21,6 +20,8 @@ , safeEvaluateExample -- END RE-EXPORTED from Test.Hspec.Core.Spec , safeEvaluateResultStatus+, exceptionToResultStatus+, toLocation ) where  import           Prelude ()@@ -28,11 +29,9 @@  import qualified Test.HUnit.Lang as HUnit -import           Data.CallStack+import           Data.CallStack (SrcLoc(..)) -import           Control.Exception import           Control.DeepSeq-import           Data.Typeable (Typeable) import qualified Test.QuickCheck as QC import           Test.Hspec.Expectations (Expectation) @@ -70,57 +69,66 @@ data Result = Result {   resultInfo :: String , resultStatus :: ResultStatus-} deriving (Show, Typeable)+} deriving Show  data ResultStatus =     Success   | Pending (Maybe Location) (Maybe String)   | Failure (Maybe Location) FailureReason-  deriving (Show, Typeable)+  deriving Show  data FailureReason =     NoReason   | Reason String+  | ColorizedReason String   | ExpectedButGot (Maybe String) String String   | Error (Maybe String) SomeException-  deriving (Show, Typeable)+  deriving Show  instance NFData FailureReason where   rnf reason = case reason of     NoReason -> ()     Reason r -> r `deepseq` ()+    ColorizedReason r -> r `deepseq` ()     ExpectedButGot p e a  -> p `deepseq` e `deepseq` a `deepseq` ()-    Error m e -> m `deepseq` e `seq` ()+    Error m e -> m `deepseq` show e `deepseq` ()  instance Exception ResultStatus -safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result-safeEvaluateExample example params around progress = safeEvaluate $ forceResult <$> evaluateExample example params around progress-  where-    forceResult :: Result -> Result-    forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r+forceResult :: Result -> Result+forceResult r@(Result info status) = info `deepseq` (forceResultStatus status) `seq` r -    forceResultStatus :: ResultStatus -> ResultStatus-    forceResultStatus r = case r of-      Success -> r-      Pending _ m -> m `deepseq` r-      Failure _ m -> m `deepseq` r+forceResultStatus :: ResultStatus -> ResultStatus+forceResultStatus r = case r of+  Success -> r+  Pending _ m -> m `deepseq` r+  Failure _ m -> m `deepseq` r +safeEvaluateExample :: Example e => e -> Params -> (ActionWith (Arg e) -> IO ()) -> ProgressCallback -> IO Result+safeEvaluateExample example params around progress = safeEvaluate $ evaluateExample example params around progress+ safeEvaluate :: IO Result -> IO Result safeEvaluate action = do-  r <- safeTry action-  return $ case r of-    Left e -> Result "" (toResultStatus e)-    Right result -> result+  r <- safeTry $ forceResult <$> action+  case r of+    Left e -> Result "" <$> exceptionToResultStatus e+    Right result -> return result  safeEvaluateResultStatus :: IO ResultStatus -> IO ResultStatus-safeEvaluateResultStatus action = either toResultStatus id <$> safeTry action+safeEvaluateResultStatus action = do+  r <- safeTry $ forceResultStatus <$> action+  case r of+    Left e -> exceptionToResultStatus e+    Right status -> return status -toResultStatus :: SomeException -> ResultStatus-toResultStatus e-  | Just result <- fromException e = result-  | Just hunit <- fromException e = hunitFailureToResult Nothing hunit-  | otherwise = Failure Nothing $ Error Nothing e+exceptionToResultStatus :: SomeException -> IO ResultStatus+exceptionToResultStatus = safeEvaluateResultStatus . pure . toResultStatus+  where+    toResultStatus :: SomeException -> ResultStatus+    toResultStatus e+      | Just result <- fromException e = result+      | Just hunit <- fromException e = hunitFailureToResult Nothing hunit+      | otherwise = Failure Nothing $ Error Nothing e  instance Example Result where   type Arg Result = ()@@ -128,10 +136,8 @@  instance Example (a -> Result) where   type Arg (a -> Result) = a-  evaluateExample example _params action _callback = do-    ref <- newIORef (Result "" Success)-    action (evaluate . example >=> writeIORef ref)-    readIORef ref+  evaluateExample example _params hook _callback = do+    liftHook (Result "" Success) hook (evaluate . example)  instance Example Bool where   type Arg Bool = ()@@ -139,10 +145,8 @@  instance Example (a -> Bool) where   type Arg (a -> Bool) = a-  evaluateExample p _params action _callback = do-    ref <- newIORef (Result "" Success)-    action (evaluate . example >=> writeIORef ref)-    readIORef ref+  evaluateExample p _params hook _callback = do+    liftHook (Result "" Success) hook (evaluate . example)     where       example a         | p a = Result "" Success@@ -166,16 +170,19 @@     where       location = case mLoc of         Nothing -> Nothing-        Just loc -> Just $ Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)+        Just loc -> Just $ toLocation loc   where     addPre :: String -> String     addPre xs = case pre of       Just x -> x ++ "\n" ++ xs       Nothing -> xs +toLocation :: SrcLoc -> Location+toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)+ instance Example (a -> Expectation) where   type Arg (a -> Expectation) = a-  evaluateExample e _ action _ = action e >> return (Result "" Success)+  evaluateExample e _ hook _ = hook e >> return (Result "" Success)  instance Example QC.Property where   type Arg QC.Property = ()@@ -183,8 +190,8 @@  instance Example (a -> QC.Property) where   type Arg (a -> QC.Property) = a-  evaluateExample p c action progressCallback = do-    r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty action p)+  evaluateExample p c hook progressCallback = do+    r <- QC.quickCheckWithResult (paramsQuickCheckArgs c) {QC.chatty = False} (QCP.callback qcProgressCallback $ aroundProperty hook p)     return $ fromQuickCheckResult r     where       qcProgressCallback = QCP.PostTest QCP.NotCounterexample $
hspec-core/src/Test/Hspec/Core/Example/Location.hs view
@@ -16,9 +16,7 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception import           Data.Char-import           Data.Maybe import           GHC.IO.Exception  #ifdef mingw32_HOST_OS
hspec-core/src/Test/Hspec/Core/FailureReport.hs view
@@ -9,7 +9,7 @@ import           Test.Hspec.Core.Compat  #ifndef __GHCJS__-import           System.SetEnv (setEnv)+import           System.Environment (setEnv) import           Test.Hspec.Core.Util (safeTry) #endif import           System.IO@@ -35,7 +35,7 @@     -- 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.-    return ()+    pass #else     -- on Windows this can throw an exception when the input is too large, hence     -- we use `safeTry` here
hspec-core/src/Test/Hspec/Core/Format.hs view
@@ -1,8 +1,14 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ExistentialQuantification #-} -- |--- Stability: experimental-module Test.Hspec.Core.Format (+-- Stability: unstable+--+-- This is an unstable API.  Use+-- [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html)+-- instead.+module Test.Hspec.Core.Format+-- {-# WARNING "Use [Test.Hspec.Api.Format.V2](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html) instead." #-}+(   Format , FormatConfig(..) , Event(..)@@ -19,9 +25,8 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception import           Control.Concurrent-import           Control.Concurrent.Async (async)+import           Control.Concurrent.Async (Async, async) import qualified Control.Concurrent.Async as Async import           Control.Monad.IO.Class @@ -59,15 +64,20 @@ , formatConfigReportProgress :: Bool , formatConfigOutputUnicode :: Bool , formatConfigUseDiff :: Bool-, formatConfigPrettyPrint :: Bool -- ^ Deprecated: use `formatConfigPrettyPrintFunction` instead+, formatConfigDiffContext :: Maybe Int+, formatConfigExternalDiff :: Maybe (String -> String -> IO ())+, formatConfigPrettyPrint :: Bool , formatConfigPrettyPrintFunction :: Maybe (String -> String -> (String, String)) , formatConfigPrintTimes :: Bool , formatConfigHtmlOutput :: Bool , formatConfigPrintCpuTime :: Bool , formatConfigUsedSeed :: Integer , formatConfigExpectedTotalCount :: Int+, formatConfigExpertMode :: Bool } +{-# DEPRECATED formatConfigPrettyPrint "Use `formatConfigPrettyPrintFunction` instead" #-}+ data Signal = Ok | NotOk SomeException  monadic :: MonadIO m => (m () -> IO ()) -> (Event -> m ()) -> IO Format@@ -92,23 +102,24 @@       event <- takeEvent       format event       case event of-        Done {} -> return ()+        Done {} -> pass         _ -> do           signal Ok           go -  t <- async $ do+  worker <- async $ do     (run go >> signal Ok) `catch` (signal . NotOk)    return $ \ event -> do-    running <- Async.poll t-    case running of-      Just _ -> return ()-      Nothing -> do-        putEvent event-        r <- wait-        case r of-          Ok -> return ()-          NotOk err -> do-            Async.wait t-            throwIO err+    running <- asyncRunning worker+    when running $ do+      putEvent event+      r <- wait+      case r of+        Ok -> pass+        NotOk err -> do+          Async.wait worker+          throwIO err++asyncRunning :: Async () -> IO Bool+asyncRunning worker = maybe True (const False) <$> Async.poll worker
hspec-core/src/Test/Hspec/Core/Formatters.hs view
@@ -1,6 +1,5 @@--- |--- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead.+{-# OPTIONS_GHC -fno-warn-deprecations #-} module Test.Hspec.Core.Formatters--- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-}+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-} (module V1) where import           Test.Hspec.Core.Formatters.V1 as V1
hspec-core/src/Test/Hspec/Core/Formatters/Diff.hs view
@@ -15,12 +15,74 @@ import           Data.Char import qualified Data.Algorithm.Diff as Diff -data Diff = First String | Second String | Both String+data Diff = First String | Second String | Both String | Omitted Int   deriving (Eq, Show) -diff :: String -> String -> [Diff]-diff expected actual = map (toDiff . fmap concat) $ Diff.getGroupedDiff (partition expected) (partition actual)+-- |+-- Split a string at line boundaries.+--+-- >>> splitLines "foo\nbar\nbaz"+-- ["foo\n","bar\n","baz"]+--+-- prop> concat (splitLines xs) == xs+splitLines :: String -> [String]+splitLines = go+  where+    go xs = case break (== '\n') xs of+      (ys, '\n' : zs) -> (ys ++ ['\n']) : go zs+      ("", "") -> []+      _ -> [xs] +data TrimMode = FirstChunck | Chunck | LastChunck++trim :: Int -> [Diff] -> [Diff]+trim context = \ chunks -> case chunks of+  [] -> []+  x : xs -> trimChunk FirstChunck x (go xs)+  where+    omitThreshold = 3++    go chunks = case chunks of+      [] -> []+      [x] -> trimChunk LastChunck x []+      x : xs -> trimChunk Chunck x (go xs)++    trimChunk mode chunk = case chunk of+      Both xs | omitted >= omitThreshold -> keep start . (Omitted omitted :) . keep end+        where+          omitted :: Int+          omitted = n - keepStart - keepEnd++          keepStart :: Int+          keepStart = case mode of+            FirstChunck -> 0+            _ -> succ context++          keepEnd :: Int+          keepEnd = case mode of+            LastChunck -> 0+            _ -> if xs `endsWith` "\n" then context else succ context++          n :: Int+          n = length allLines++          allLines :: [String]+          allLines = splitLines xs++          start :: [String]+          start = take keepStart allLines++          end :: [String]+          end = drop (keepStart + omitted) allLines+      _ -> (chunk :)++    keep xs+      | null xs = id+      | otherwise = (Both (concat xs) :)++diff :: Maybe Int -> String -> String -> [Diff]+diff context expected actual = maybe id trim context $ map (toDiff . fmap concat) $ Diff.getGroupedDiff (partition expected) (partition actual)+ toDiff :: Diff.Diff String -> Diff toDiff d = case d of   Diff.First xs -> First xs@@ -47,7 +109,7 @@       | otherwise = (x :)  splitEscape :: String -> Maybe (String, String)-splitEscape xs = splitNumericEscape xs <|> (msum $ map split escapes)+splitEscape xs = splitNumericEscape xs <|> msum (map split escapes)   where     split :: String -> Maybe (String, String)     split escape = (,) escape <$> stripPrefix escape xs
hspec-core/src/Test/Hspec/Core/Formatters/Internal.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-} module Test.Hspec.Core.Formatters.Internal (   Formatter(..) , Item(..)@@ -35,11 +36,15 @@ , outputUnicode  , useDiff+, diffContext+, externalDiffAction , prettyPrint , prettyPrintFunction , extraChunk , missingChunk +, unlessExpert+ #ifdef TEST , runFormatM , splitLines@@ -50,16 +55,14 @@ import           Test.Hspec.Core.Compat  import qualified System.IO as IO-import           System.IO (Handle, stdout)-import           Control.Exception (bracket_, bracket)+import           System.IO (stdout) import           System.Console.ANSI-import           Control.Monad.Trans.State hiding (state, gets, modify)+import           Control.Monad.Trans.Reader (ReaderT(..), ask) import           Control.Monad.IO.Class import           Data.Char (isSpace) import           Data.List (groupBy) import qualified System.CPUTime as CPUTime -import           Test.Hspec.Core.Formatters.V1.Monad (FailureRecord(..)) import           Test.Hspec.Core.Format import           Test.Hspec.Core.Clock @@ -86,8 +89,14 @@ , formatterDone :: FormatM () } +data FailureRecord = FailureRecord {+  failureRecordLocation :: Maybe Location+, failureRecordPath     :: Path+, failureRecordMessage  :: FailureReason+}+ formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ event -> case event of+formatterToFormat Formatter{..} config = monadic (runFormatM config) $ \ case   Started -> formatterStarted   GroupStarted path -> formatterGroupStarted path   GroupDone path -> formatterGroupDone path@@ -111,6 +120,33 @@ useDiff :: FormatM Bool useDiff = getConfig formatConfigUseDiff +-- | Do nothing on `--expert`, otherwise run the given action.+--+-- @since 2.11.2+unlessExpert :: FormatM () -> FormatM ()+unlessExpert action = getConfig formatConfigExpertMode >>= \ case+  False -> action+  True -> return ()++-- |+-- Return the value of `Test.Hspec.Core.Runner.configDiffContext`.+--+-- @since 2.10.6+diffContext :: FormatM (Maybe Int)+diffContext = getConfig formatConfigDiffContext++-- | An action for printing diffs.+--+-- The action takes @expected@ and @actual@ as arguments.+--+-- When this is a `Just`-value then it should be used instead of any built-in+-- diff implementation.  A `Just`-value also implies that `useDiff` returns+-- `True`.+--+-- @since 2.10.6+externalDiffAction :: FormatM (Maybe (String -> String -> IO ()))+externalDiffAction = getConfig formatConfigExternalDiff+ -- | Return `True` if the user requested pretty diffs, `False` otherwise. prettyPrint :: FormatM Bool prettyPrint = maybe False (const True) <$> getConfig formatConfigPrettyPrintFunction@@ -124,6 +160,8 @@ prettyPrintFunction = getConfig formatConfigPrettyPrintFunction  -- | Return `True` if the user requested unicode output, `False` otherwise.+--+-- @since 2.9.0 outputUnicode :: FormatM Bool outputUnicode = getConfig formatConfigOutputUnicode @@ -143,12 +181,12 @@ -- | A lifted version of `Control.Monad.Trans.State.gets` gets :: (FormatterState -> a) -> FormatM a gets f = FormatM $ do-  f <$> (get >>= liftIO . readIORef)+  f <$> (ask >>= liftIO . readIORef)  -- | A lifted version of `Control.Monad.Trans.State.modify` modify :: (FormatterState -> FormatterState) -> FormatM () modify f = FormatM $ do-  get >>= liftIO . (`modifyIORef'` f)+  ask >>= liftIO . (`modifyIORef'` f)  data FormatterState = FormatterState {   stateSuccessCount    :: !Int@@ -163,22 +201,19 @@ getConfig :: (FormatConfig -> a) -> FormatM a getConfig f = gets (f . stateConfig) -getHandle :: FormatM Handle-getHandle = return stdout- -- | The random seed that is used for QuickCheck. usedSeed :: FormatM Integer usedSeed = getConfig formatConfigUsedSeed  -- NOTE: We use an IORef here, so that the state persists when UserInterrupt is -- thrown.-newtype FormatM a = FormatM (StateT (IORef FormatterState) IO a)+newtype FormatM a = FormatM (ReaderT (IORef FormatterState) IO a)   deriving (Functor, Applicative, Monad, MonadIO)  runFormatM :: FormatConfig -> FormatM a -> IO a runFormatM config (FormatM action) = withLineBuffering $ do   time <- getMonotonicTime-  cpuTime <- if (formatConfigPrintCpuTime config) then Just <$> CPUTime.getCPUTime else pure Nothing+  cpuTime <- if formatConfigPrintCpuTime config then Just <$> CPUTime.getCPUTime else pure Nothing    let     progress = formatConfigReportProgress config && not (formatConfigHtmlOutput config)@@ -191,7 +226,7 @@     , stateConfig = config { formatConfigReportProgress = progress }     , stateColor = Nothing     }-  newIORef state >>= evalStateT action+  newIORef state >>= runReaderT action  withLineBuffering :: IO a -> IO a withLineBuffering action = bracket (IO.hGetBuffering stdout) (IO.hSetBuffering stdout) $ \ _ -> do@@ -219,16 +254,17 @@  -- | Get the number of spec items that will have been encountered when this run -- completes (if it is not terminated early).+--+-- @since 2.9.0 getExpectedTotalCount :: FormatM Int getExpectedTotalCount = getConfig formatConfigExpectedTotalCount  writeTransient :: String -> FormatM () writeTransient new = do   reportProgress <- getConfig formatConfigReportProgress-  when (reportProgress) $ do-    h <- getHandle-    write $ new-    liftIO $ IO.hFlush h+  when reportProgress $ do+    write new+    liftIO $ IO.hFlush stdout     write $ "\r" ++ replicate (length new) ' ' ++ "\r"  -- | Append some output to the report.@@ -242,10 +278,9 @@  writeChunk :: String -> FormatM () writeChunk str = do-  h <- getHandle   let-    plainOutput = IO.hPutStr h str-    colorOutput color = bracket_ (hSetSGR h [color]) (hSetSGR h [Reset]) plainOutput+    plainOutput = IO.hPutStr stdout str+    colorOutput color = bracket_ (hSetSGR stdout [color]) (hSetSGR stdout [Reset]) plainOutput   mColor <- gets stateColor   liftIO $ case mColor of     Just (SetColor Foreground _ _) | all isSpace str -> plainOutput@@ -327,7 +362,7 @@ getCPUTime = do   t1  <- liftIO CPUTime.getCPUTime   mt0 <- gets stateCpuStartTime-  return $ toSeconds <$> ((-) <$> pure t1 <*> mt0)+  return $ toSeconds <$> ((t1 -) <$> mt0)   where     toSeconds x = Seconds (fromIntegral x / (10.0 ^ (12 :: Integer)))
hspec-core/src/Test/Hspec/Core/Formatters/Pretty.hs view
@@ -5,6 +5,7 @@ #ifdef TEST , pretty , recoverString+, recoverMultiLineString #endif ) where @@ -20,49 +21,46 @@ import           Test.Hspec.Core.Formatters.Pretty.Parser  pretty2 :: Bool -> String -> String -> (String, String)-pretty2 unicode expected actual = case (recoverString unicode expected, recoverString unicode actual) of+pretty2 unicode expected actual = case (recoverMultiLineString unicode expected, recoverMultiLineString unicode actual) of   (Just expected_, Just actual_) -> (expected_, actual_)   _ -> case (pretty unicode expected, pretty unicode actual) of-    (Just expected_, Just actual_) -> (expected_, actual_)-#if __GLASGOW_HASKELL__ >= 802+    (Just expected_, Just actual_) | expected_ /= actual_ -> (expected_, actual_)     _ -> (expected, actual)-#else-    _ -> (rec expected, rec actual)-  where-    rec = if unicode then urecover else id -    urecover :: String -> String-    urecover xs = maybe xs ushow $ readMaybe xs-#endif+recoverString :: String -> Maybe String+recoverString xs = case xs of+  '"' : _ -> case reverse xs of+    '"' : _ -> readMaybe xs+    _ -> Nothing+  _ -> Nothing -recoverString :: Bool -> String -> Maybe String-recoverString unicode input = case readMaybe input of+recoverMultiLineString :: Bool -> String -> Maybe String+recoverMultiLineString unicode input = case recoverString input of   Just r | shouldParseBack r -> Just r   _ -> Nothing   where     shouldParseBack = (&&) <$> all isSafe <*> isMultiLine     isMultiLine = lines >>> length >>> (> 1)-    isSafe c = (unicode || isAscii c) && (not $ isControl c) || c == '\n'+    isSafe c = (unicode || isAscii c) && not (isControl c) || c == '\n'  pretty :: Bool -> String -> Maybe String-pretty unicode = parseExpression >=> render_+pretty unicode = parseValue >=> render_   where-    render_ :: Expression -> Maybe String-    render_ expr = guard (shouldParseBack expr) >> Just (renderExpression unicode expr)+    render_ :: Value -> Maybe String+    render_ value = guard (shouldParseBack value) >> Just (renderValue unicode value) -    shouldParseBack :: Expression -> Bool+    shouldParseBack :: Value -> Bool     shouldParseBack = go       where-        go expr = case expr of-          Literal (String _) -> True-          Literal _ -> False-          Id _ -> False-          App (Id _) e -> go e-          App _ _ -> False-          Parentheses e -> go e+        go value = case value of+          Char _ -> False+          String _ -> True+          Rational _ _ -> False+          Number _ -> False+          Record _ _ -> True+          Constructor _ xs -> any go xs           Tuple xs -> any go xs           List xs -> any go xs-          Record _ _ -> True  newtype Builder = Builder ShowS @@ -91,24 +89,19 @@ instance IsString Builder where   fromString = Builder . showString -renderExpression :: Bool -> Expression -> String-renderExpression unicode = runBuilder . render+renderValue :: Bool -> Value -> String+renderValue unicode = runBuilder . render   where-    renderLiteral lit = case lit of+    render :: Value -> Builder+    render value = case value of       Char c -> shows c       String str -> if unicode then Builder $ ushows str else shows str-      Integer n -> shows n-      Rational n -> fromString n--    render :: Expression -> Builder-    render expr = case expr of-      Literal lit -> renderLiteral lit-      Id name -> fromString name-      App a b -> render a <> " " <> render b-      Parentheses e@Record{} -> render e-      Parentheses e -> "(" <> render e <> ")"+      Rational n d -> render n <> " % " <> render d+      Number n -> fromString n+      Record name fields -> fromString name <> " {\n  " <> (intercalate ",\n  " $ map renderField fields) <> "\n}"+      Constructor name values -> intercalate " " (fromString name : map render values)+      Tuple [e@Record{}] -> render e       Tuple xs -> "(" <> intercalate ", " (map render xs) <> ")"       List xs -> "[" <> intercalate ", " (map render xs) <> "]"-      Record name fields -> fromString name <> " {\n  " <> (intercalate ",\n  " $ map renderField fields) <> "\n}"      renderField (name, value) = fromString name <> " = " <> render value
hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser.hs view
@@ -1,395 +1,107 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-#if __GLASGOW_HASKELL__ >= 810-{-# LANGUAGE EmptyCase #-}-#endif module Test.Hspec.Core.Formatters.Pretty.Parser (-  Expression(..)-, Literal(..)-, parseExpression-, unsafeParseExpression+  Value(..)+, parseValue ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (fail)-import           Test.Hspec.Core.Formatters.Pretty.Parser.Types--#ifndef __GHCJS__-#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ <= 904-#define PRETTY_PRINTING_SUPPORTED-#endif-#endif--#ifndef PRETTY_PRINTING_SUPPORTED--parseExpression :: String -> Maybe Expression-parseExpression _ = Nothing--unsafeParseExpression :: String -> Maybe Expression-unsafeParseExpression _ = Nothing--#else--import           GHC.Stack-import           GHC.Exception (throw, errorCallWithCallStackException)--#if __GLASGOW_HASKELL__ >= 904-import           GHC.Utils.Error-import           GHC.Utils.Outputable-#endif--#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904-import           GHC.LanguageExtensions.Type-#endif--#if __GLASGOW_HASKELL__ >= 902-import           GHC.Types.SourceText-#elif __GLASGOW_HASKELL__ >= 900-import           GHC.Types.Basic-import           GHC.Unit.Types-#endif--#if __GLASGOW_HASKELL__ >= 900-import qualified GHC.Parser as GHC-import           GHC.Parser.Lexer-import           GHC.Data.StringBuffer-import           GHC.Data.FastString-import           GHC.Types.SrcLoc-import           GHC.Types.Name-import           GHC.Types.Name.Reader-import           GHC.Parser.PostProcess hiding (Tuple)-#else-import           Lexer-import qualified Parser as GHC-import           StringBuffer-import           FastString-import           SrcLoc-import           Name-import           RdrName-import           BasicTypes-import           Module-#endif--#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904-#if __GLASGOW_HASKELL__ >= 900-import qualified GHC.Data.EnumSet as EnumSet-#else-import qualified EnumSet-#endif-#endif--#if __GLASGOW_HASKELL__ == 810-import           RdrHsSyn hiding (Tuple)-#endif--#if __GLASGOW_HASKELL__ >= 810-import           GHC.Hs-#else-import           HsSyn-#endif--#if __GLASGOW_HASKELL__ <= 806-import           Data.Bits-import           Control.Exception-#endif--parseExpression :: String -> Maybe Expression-parseExpression = parseWith (const Nothing)--unsafeParseExpression :: String -> Maybe Expression-unsafeParseExpression = parseWith throwError--parseWith :: (Error -> Maybe Expression) -> String -> Maybe Expression-parseWith err = parse >=> either err Just . toExpression--data Error = Error CallStack String--throwError :: Error -> a-throwError (Error stack err) = throw $ errorCallWithCallStackException err stack--fail :: HasCallStack => String -> Either Error a-fail = Left . Error callStack--class ToExpression a where-  toExpression :: a -> Either Error Expression--#if __GLASGOW_HASKELL__ < 806-#define _x-#endif--#if __GLASGOW_HASKELL__ >= 900-#define X(name, expr)-#elif __GLASGOW_HASKELL__ == 810-#define X(name, expr) name none -> case none of-#elif __GLASGOW_HASKELL__ >= 806-#define X(name, expr) name none -> case none of NoExt -> expr-#else-#define X(name, expr)-#endif--#if __GLASGOW_HASKELL__ >= 804-#define GhcPsHsLit GhcPs-#else-type GhcPs = RdrName-#define GhcPsHsLit-#endif--#if __GLASGOW_HASKELL__ >= 902-#define _listSynExpr-#endif--#if __GLASGOW_HASKELL__ >= 806-#define RecCon(name, fields) RecordCon _ (L _ name) fields-#else-#define RecCon(name, fields) RecordCon (L _ name) _ _ fields-#endif+import           Test.Hspec.Core.Compat -#define REJECT(name) name{} -> fail "name"+import           Test.Hspec.Core.Formatters.Pretty.Parser.Parser hiding (Parser)+import qualified Test.Hspec.Core.Formatters.Pretty.Parser.Parser as P -instance ToExpression (HsExpr GhcPs) where-  toExpression expr = case expr of-    HsVar _x name -> toExpression name-    HsLit _x lit -> toExpression lit-    HsOverLit _x lit -> toExpression lit-    HsApp _x f x -> App <$> toExpression f <*> toExpression x-    NegApp _x e _ -> toExpression e >>= \ x -> case x of-      Literal (Rational n) -> return $ Literal (Rational $ '-' : n)-      Literal (Integer n) -> return $ Literal (Integer $ negate n)-      _ -> fail "NegApp"+import           Language.Haskell.Lexer hiding (Pos(..)) -    HsPar _x-#if __GLASGOW_HASKELL__ >= 904-      _ e _ ->-#else-      e ->-#endif-        Parentheses <$> toExpression e-    ExplicitTuple _x xs _ -> Tuple <$> mapM toExpression xs-    ExplicitList _ _listSynExpr xs -> List <$> mapM toExpression xs-    RecCon(name, fields) -> Record (showRdrName name) <$> (recordFields $ rec_flds fields)-      where-#if __GLASGOW_HASKELL__ >= 904-        hsRecFieldLbl = hfbLHS-        hsRecFieldArg = hfbRHS-#endif-        fieldName = showFieldLabel . unLoc . hsRecFieldLbl-        recordFields = mapM (recordField . unLoc)-        recordField field = (,) (fieldName field) <$> toExpression (hsRecFieldArg field)+type Name = String -    REJECT(HsUnboundVar)-    REJECT(HsOverLabel)-    REJECT(HsIPVar)-    REJECT(HsLam)-    REJECT(HsLamCase)-    REJECT(HsAppType)-    REJECT(OpApp)-    REJECT(SectionL)-    REJECT(SectionR)-    REJECT(ExplicitSum)-    REJECT(HsCase)-    REJECT(HsIf)-    REJECT(HsMultiIf)-    REJECT(HsLet)-    REJECT(HsDo)-    REJECT(RecordUpd)-    REJECT(ExprWithTySig)-    REJECT(ArithSeq)-    REJECT(HsSpliceE)-    REJECT(HsProc)-    REJECT(HsStatic)+data Value =+    Char Char+  | String String+  | Rational Value Value+  | Number String+  | Record Name [(Name, Value)]+  | Constructor Name [Value]+  | Tuple [Value]+  | List [Value]+  deriving (Eq, Show) -#if __GLASGOW_HASKELL__ >= 904-    REJECT(HsRecSel)-    REJECT(HsTypedBracket)-    REJECT(HsUntypedBracket)-#endif-#if __GLASGOW_HASKELL__ >= 902-    REJECT(HsGetField)-    REJECT(HsProjection)-#endif-#if __GLASGOW_HASKELL__ >= 900-    REJECT(HsPragE)-#endif+type Parser = P.Parser (Token, String) -#if __GLASGOW_HASKELL__ < 904-    REJECT(HsConLikeOut)-    REJECT(HsRecFld)-    REJECT(HsBracket)-    REJECT(HsRnBracketOut)-    REJECT(HsTcBracketOut)-    REJECT(HsTick)-    REJECT(HsBinTick)-#endif-#if __GLASGOW_HASKELL__ < 900-    REJECT(HsSCC)-    REJECT(HsCoreAnn)-    REJECT(HsTickPragma)-    REJECT(HsWrap)-#endif-#if __GLASGOW_HASKELL__ < 810-    REJECT(HsArrApp)-    REJECT(HsArrForm)-    REJECT(EWildPat)-    REJECT(EAsPat)-    REJECT(EViewPat)-    REJECT(ELazyPat)-#endif-#if __GLASGOW_HASKELL__ < 806-    REJECT(HsAppTypeOut)-    REJECT(ExplicitPArr)-    REJECT(ExprWithTySigOut)-    REJECT(PArrSeq)-#endif-    X(XExpr, fail "XExpr")+parseValue :: String -> Maybe Value+parseValue input = case runParser value (tokenize input) of+  Just (v, []) -> Just v+  _ -> Nothing -instance ToExpression RdrName where-  toExpression = return . Id . showRdrName+value :: Parser Value+value =+      char+  <|> string+  <|> rational+  <|> number+  <|> record+  <|> constructor+  <|> tuple+  <|> list -instance ToExpression (HsTupArg GhcPs) where-  toExpression t = case t of-    Present _x expr -> toExpression expr-    Missing _ -> fail "Missing (tuple section)"-    X(XTupArg, fail "XTupArg")+char :: Parser Value+char = Char <$> (token CharLit >>= readA) -instance ToExpression e => ToExpression (GenLocated l e) where-  toExpression (L _ e) = toExpression e+string :: Parser Value+string = String <$> (token StringLit >>= readA) -instance ToExpression (HsOverLit GhcPs) where-  toExpression = toExpression . ol_val+rational :: Parser Value+rational = Rational <$> (number <|> tuple) <* require (Varsym, "%") <*> number -#if __GLASGOW_HASKELL__ > 802-#define _integralSource+number :: Parser Value+number = integer <|> float+  where+    integer :: Parser Value+    integer = Number <$> token IntLit -instance ToExpression IntegralLit where-  toExpression il = toExpression (il_value il)-#endif+    float :: Parser Value+    float = Number <$> token FloatLit -instance ToExpression OverLitVal where-  toExpression lit = case lit of-    HsIntegral _integralSource il -> toExpression il-    HsFractional fl -> toExpression fl-    HsIsString _ str -> toExpression str+record :: Parser Value+record = Record <$> token Conid <* special "{" <*> fields <* special "}"+  where+    fields :: Parser [(Name, Value)]+    fields = field `sepBy1` comma -instance ToExpression FractionalLit where-  toExpression fl = case fl_text fl of-#if __GLASGOW_HASKELL__ > 802-    REJECT(NoSourceText)-    SourceText n-#else-    n-#endif-      -> return . Literal $ Rational n+    field :: Parser (Name, Value)+    field = (,) <$> token Varid <* equals <*> value -instance ToExpression FastString where-  toExpression = return . Literal . String . unpackFS+constructor :: Parser Value+constructor = Constructor <$> token Conid <*> many value -instance ToExpression Integer where-  toExpression = return . Literal . Integer+tuple :: Parser Value+tuple = Tuple <$> (special "(" *> items) <* special ")" -instance ToExpression Char where-  toExpression = return . Literal . Char+list :: Parser Value+list = List <$> (special "[" *> items) <* special "]" -instance ToExpression (HsLit GhcPsHsLit) where-  toExpression lit = case lit of-    HsChar _ c -> toExpression c-    HsString _ str -> toExpression str-    REJECT(HsCharPrim)-    REJECT(HsStringPrim)-    REJECT(HsInt)-    REJECT(HsIntPrim)-    REJECT(HsWordPrim)-    REJECT(HsInt64Prim)-    REJECT(HsWord64Prim)-    REJECT(HsInteger)-    REJECT(HsRat)-    REJECT(HsFloatPrim)-    REJECT(HsDoublePrim)-    X(XLit, fail "XLit")+items :: Parser [Value]+items = value `sepBy` comma -showFieldLabel :: FieldOcc GhcPs -> String-showFieldLabel label = case label of-#if __GLASGOW_HASKELL__ >= 806-  FieldOcc _ (L _ name) -> showRdrName name-#else-  FieldOcc (L _ name) _ -> showRdrName name-#endif-  X(XFieldOcc, "")+special :: String -> Parser ()+special s = require (Special, s) -showRdrName :: RdrName -> String-showRdrName n = case n of-  Unqual name -> showOccName name-  Qual _ name -> showOccName name-  Orig _ name -> showOccName name-  Exact name -> showOccName (nameOccName name)+comma :: Parser ()+comma = special "," -showOccName :: OccName -> String-showOccName = unpackFS . occNameFS+equals :: Parser ()+equals = require (Reservedop, "=") -parse :: String -> Maybe (HsExpr GhcPs)-parse input = case runParser input pHsExpr of-  POk _ (L _ x) -> Just x-  PFailed {} -> Nothing-  where-    pHsExpr = do-      r <- GHC.parseExpression-      runPV (unECP r)+token :: Token -> Parser String+token t = snd <$> satisfy (fst >>> (== t)) -#if __GLASGOW_HASKELL__ <= 900-#if __GLASGOW_HASKELL__ >= 810-    unECP = runECP_PV-#else-    unECP = return-    runPV = id-#endif-#endif+require :: (Token, String) -> Parser ()+require t = void $ satisfy (== t) -runParser :: String -> P a -> ParseResult a-runParser str parser = unP parser parseState+tokenize :: String -> [(Token, String)]+tokenize = go . map (fmap snd) . rmSpace . lexerPass0   where-    location = mkRealSrcLoc "" 1 1-    input = stringToStringBuffer str-    parseState = initParserState opts input location-    opts = mkParserOpts warn-#if __GLASGOW_HASKELL__ >= 904-      (DiagOpts mempty mempty False False Nothing defaultSDocContext)-#endif-      extensions False False False True--#if __GLASGOW_HASKELL__ >= 804 && __GLASGOW_HASKELL__ < 904-    warn = EnumSet.empty-#else-    warn = mempty-#endif--#if __GLASGOW_HASKELL__ >= 904-    extensions = ["TraditionalRecordSyntax"]-#elif __GLASGOW_HASKELL__ >= 804-    extensions = EnumSet.fromList [TraditionalRecordSyntax]-#else-    extensions = mempty-#endif--#if __GLASGOW_HASKELL__ <= 900-    initParserState = mkPStatePure-    mkParserOpts warningFlags extensionFlags = mkParserFlags' warningFlags extensionFlags unit-#if __GLASGOW_HASKELL__ == 900-    unit = UnitId ""-#else-    unit = fsToUnitId ""-#endif-#endif--#if __GLASGOW_HASKELL__ <= 806-    mkParserFlags' ws es u _ _ _ _ = assert (traditionalRecordSyntaxEnabled extensionsBitmap) $-      ParserFlags ws es u extensionsBitmap-    extensionsBitmap = shift 1 traditionalRecordSyntaxBit-#if __GLASGOW_HASKELL__ == 806-    traditionalRecordSyntaxBit = 28-#else-    traditionalRecordSyntaxBit = 29-#endif-#endif--#endif+    go :: [(Token, String)] -> [(Token, String)]+    go tokens = case tokens of+      [] -> []+      (Varsym, "-") : (IntLit, n) : xs -> (IntLit, "-" ++ n) : go xs+      (Varsym, "-") : (FloatLit, n) : xs -> (FloatLit, "-" ++ n) : go xs+      x : xs -> x : go xs
+ hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Parser.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveFunctor #-}+module Test.Hspec.Core.Formatters.Pretty.Parser.Parser where++import           Prelude ()+import           Test.Hspec.Core.Compat++newtype Parser token a = Parser { runParser :: [token] -> Maybe (a, [token]) }+  deriving Functor++instance Applicative (Parser token) where+  pure a = Parser $ \ input -> Just (a, input)+  (<*>) = ap++instance Monad (Parser token) where+  return = pure+  p1 >>= p2 = Parser $ runParser p1 >=> uncurry (runParser . p2)++instance Alternative (Parser token) where+  empty = Parser $ const Nothing+  p1 <|> p2 = Parser $ \ input -> runParser p1 input <|> runParser p2 input++satisfy :: (token -> Bool) -> Parser token token+satisfy p = Parser $ \ input -> case input of+  t : ts | p t -> Just (t, ts)+  _ -> Nothing++sepBy :: Alternative m => m a -> m sep -> m [a]+sepBy p sep = sepBy1 p sep <|> pure []++sepBy1 :: Alternative m => m a -> m sep -> m [a]+sepBy1 p sep = (:) <$> p <*> many (sep *> p)++readA :: (Alternative m, Read a) => String -> m a+readA = maybe empty pure . readMaybe
− hspec-core/src/Test/Hspec/Core/Formatters/Pretty/Parser/Types.hs 
@@ -1,21 +0,0 @@-module Test.Hspec.Core.Formatters.Pretty.Parser.Types where--import           Prelude ()-import           Test.Hspec.Core.Compat--data Expression =-    Literal Literal-  | Id String-  | App Expression Expression-  | Parentheses Expression-  | Tuple [Expression]-  | List [Expression]-  | Record String [(String, Expression)]-  deriving (Eq, Show)--data Literal =-    Char Char-  | String String-  | Integer Integer-  | Rational String-  deriving (Eq, Show)
hspec-core/src/Test/Hspec/Core/Formatters/V1.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-} -- | -- Stability: deprecated -- -- This module contains formatters that can be used with -- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters.V1 (-+module Test.Hspec.Core.Formatters.V1+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-}+( -- * Formatters   silent , checks@@ -60,290 +59,4 @@ ) where  import           Prelude ()-import           Test.Hspec.Core.Compat hiding (First)--import           Data.Maybe-import           Test.Hspec.Core.Util-import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Example (Location(..))-import           Text.Printf-import           Control.Monad.IO.Class-import           Control.Exception---- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make--- sure, that we only use the public API to implement formatters.------ Everything imported here has to be re-exported, so that users can implement--- their own formatters.-import Test.Hspec.Core.Formatters.V1.Monad (-    Formatter(..)-  , FailureReason(..)-  , FormatM--  , getSuccessCount-  , getPendingCount-  , getFailCount-  , getTotalCount--  , FailureRecord(..)-  , getFailMessages-  , usedSeed--  , getCPUTime-  , getRealTime--  , write-  , writeLine-  , writeTransient--  , withInfoColor-  , withSuccessColor-  , withPendingColor-  , withFailColor--  , useDiff-  , extraChunk-  , missingChunk-  )--import           Test.Hspec.Core.Format (FormatConfig, Format)--import           Test.Hspec.Core.Formatters.Diff-import qualified Test.Hspec.Core.Formatters.V2 as V2-import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)--formatterToFormat :: Formatter -> FormatConfig -> IO Format-formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter--legacyFormatterToFormatter :: Formatter -> V2.Formatter-legacyFormatterToFormatter Formatter{..} = V2.Formatter {-  V2.formatterStarted = interpret headerFormatter-, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted-, V2.formatterGroupDone = interpret . const exampleGroupDone-, V2.formatterProgress = \ path -> interpret . exampleProgress path-, V2.formatterItemStarted = interpret . exampleStarted-, V2.formatterItemDone = \ path item -> interpret $ do-    case itemResult item of-      Success -> exampleSucceeded path (itemInfo item)-      Pending _ reason -> examplePending path (itemInfo item) reason-      Failure _ reason -> exampleFailed path (itemInfo item) reason-, V2.formatterDone = interpret $ failedFormatter >> footerFormatter-}--interpret :: FormatM a -> V2.FormatM a-interpret = interpretWith Environment {-  environmentGetSuccessCount = V2.getSuccessCount-, environmentGetPendingCount = V2.getPendingCount-, environmentGetFailMessages = V2.getFailMessages-, environmentUsedSeed = V2.usedSeed-, environmentPrintTimes = V2.printTimes-, environmentGetCPUTime = V2.getCPUTime-, environmentGetRealTime = V2.getRealTime-, environmentWrite = V2.write-, environmentWriteTransient = V2.writeTransient-, environmentWithFailColor = V2.withFailColor-, environmentWithSuccessColor = V2.withSuccessColor-, environmentWithPendingColor = V2.withPendingColor-, environmentWithInfoColor = V2.withInfoColor-, environmentUseDiff = V2.useDiff-, environmentExtraChunk = V2.extraChunk-, environmentMissingChunk = V2.missingChunk-, environmentLiftIO = liftIO-}--silent :: Formatter-silent = Formatter {-  headerFormatter     = return ()-, exampleGroupStarted = \_ _ -> return ()-, exampleGroupDone    = return ()-, exampleStarted      = \_ -> return ()-, exampleProgress     = \_ _ -> return ()-, exampleSucceeded    = \ _ _ -> return ()-, exampleFailed       = \_ _ _ -> return ()-, examplePending      = \_ _ _ -> return ()-, failedFormatter     = return ()-, footerFormatter     = return ()-}--checks :: Formatter-checks = specdoc {-  exampleStarted = \(nesting, requirement) -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"--, exampleProgress = \(nesting, requirement) p -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"--, exampleSucceeded = \(nesting, requirement) info -> do-    writeResult nesting requirement info $ withSuccessColor $ write "✔"--, exampleFailed = \(nesting, requirement) info _ -> do-    writeResult nesting requirement info $ withFailColor $ write "✘"--, examplePending = \(nesting, requirement) info reason -> do-    writeResult nesting requirement info $ withPendingColor $ write "‐"--    withPendingColor $ do-      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason-} where-    indentationFor nesting = replicate (length nesting * 2) ' '--    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()-    writeResult nesting requirement info action = do-      write $ indentationFor nesting ++ requirement ++ " ["-      action-      writeLine "]"-      forM_ (lines info) $ \ s ->-        writeLine $ indentationFor ("" : nesting) ++ s--    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total--specdoc :: Formatter-specdoc = silent {--  headerFormatter = do-    writeLine ""--, exampleGroupStarted = \nesting name -> do-    writeLine (indentationFor nesting ++ name)--, exampleProgress = \_ p -> do-    writeTransient (formatProgress p)--, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do-    n <- getFailCount-    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s--, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do-    writeLine $ indentationFor nesting ++ requirement-    forM_ (lines info) $ \ s ->-      writeLine $ indentationFor ("" : nesting) ++ s-    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason--, failedFormatter = defaultFailedFormatter--, footerFormatter = defaultFooter-} where-    indentationFor nesting = replicate (length nesting * 2) ' '-    formatProgress (current, total)-      | total == 0 = show current-      | otherwise  = show current ++ "/" ++ show total---progress :: Formatter-progress = silent {-  exampleSucceeded = \_ _ -> withSuccessColor $ write "."-, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"-, examplePending   = \_ _ _ -> withPendingColor $ write "."-, failedFormatter  = defaultFailedFormatter-, footerFormatter  = defaultFooter-}---failed_examples :: Formatter-failed_examples   = silent {-  failedFormatter = defaultFailedFormatter-, footerFormatter = defaultFooter-}--defaultFailedFormatter :: FormatM ()-defaultFailedFormatter = do-  writeLine ""--  failures <- getFailMessages--  unless (null failures) $ do-    writeLine "Failures:"-    writeLine ""--    forM_ (zip [1..] failures) $ \x -> do-      formatFailure x-      writeLine ""--    write "Randomized with seed " >> usedSeed >>= writeLine . show-    writeLine ""-  where-    formatFailure :: (Int, FailureRecord) -> FormatM ()-    formatFailure (n, FailureRecord mLoc path reason) = do-      forM_ mLoc $ \loc -> do-        withInfoColor $ writeLine (formatLoc loc)-      write ("  " ++ show n ++ ") ")-      writeLine (formatRequirement path)-      case reason of-        NoReason -> return ()-        Reason err -> withFailColor $ indent err-        ExpectedButGot preface expected actual -> do-          mapM_ indent preface--          b <- useDiff--          let threshold = 2 :: Seconds--          mchunks <- liftIO $ if b-            then timeout threshold (evaluate $ diff expected actual)-            else return Nothing--          case mchunks of-            Just chunks -> do-              writeDiff chunks extraChunk missingChunk-            Nothing -> do-              writeDiff [First expected, Second actual] write write-          where-            indented output text = case break (== '\n') text of-              (xs, "") -> output xs-              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys--            writeDiff chunks extra missing = do-              withFailColor $ write (indentation ++ "expected: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a -> indented write a-                First a -> indented extra a-                Second _ -> return ()-              writeLine ""--              withFailColor $ write (indentation ++ " but got: ")-              forM_ chunks $ \ chunk -> case chunk of-                Both a -> indented write a-                First _ -> return ()-                Second a -> indented missing a-              writeLine ""--        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e--      writeLine ""-      writeLine ("  To rerun use: --match " ++ show (joinPath path))-      where-        indentation = "       "-        indent message = do-          forM_ (lines message) $ \line -> do-            writeLine (indentation ++ line)-        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "--defaultFooter :: FormatM ()-defaultFooter = do--  writeLine =<< (++)-    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)-    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)--  fails   <- getFailCount-  pending <- getPendingCount-  total   <- getTotalCount--  let-    output =-         pluralize total   "example"-      ++ ", " ++ pluralize fails "failure"-      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor-      | pending /= 0 = withPendingColor-      | otherwise    = withSuccessColor-  c $ writeLine output+import           Test.Hspec.Core.Formatters.V1.Internal
+ hspec-core/src/Test/Hspec/Core/Formatters/V1/Internal.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+module Test.Hspec.Core.Formatters.V1.Internal (+-- * Formatters+  silent+, checks+, specdoc+, progress+, failed_examples++-- * Implementing a custom Formatter+-- |+-- A formatter is a set of actions.  Each action is evaluated when a certain+-- situation is encountered during a test run.+--+-- Actions live in the `FormatM` monad.  It provides access to the runner state+-- and primitives for appending to the generated report.+, Formatter (..)+, FailureReason (..)+, FormatM+, formatterToFormat++-- ** Accessing the runner state+, getSuccessCount+, getPendingCount+, getFailCount+, getTotalCount++, FailureRecord (..)+, getFailMessages+, usedSeed++, Seconds(..)+, getCPUTime+, getRealTime++-- ** Appending to the generated report+, write+, writeLine+, writeTransient++-- ** Dealing with colors+, withInfoColor+, withSuccessColor+, withPendingColor+, withFailColor++, useDiff+, extraChunk+, missingChunk++-- ** Helpers+, formatException+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (First)++import           Test.Hspec.Core.Util+import           Test.Hspec.Core.Clock+import           Test.Hspec.Core.Example (Location(..))+import           Text.Printf+import           Control.Monad.IO.Class++-- We use an explicit import list for "Test.Hspec.Formatters.Internal", to make+-- sure, that we only use the public API to implement formatters.+--+-- Everything imported here has to be re-exported, so that users can implement+-- their own formatters.+import Test.Hspec.Core.Formatters.V1.Monad (+    Formatter(..)+  , FailureReason(..)+  , FormatM++  , getSuccessCount+  , getPendingCount+  , getFailCount+  , getTotalCount++  , FailureRecord(..)+  , getFailMessages+  , usedSeed++  , getCPUTime+  , getRealTime++  , write+  , writeLine+  , writeTransient++  , withInfoColor+  , withSuccessColor+  , withPendingColor+  , withFailColor++  , useDiff+  , extraChunk+  , missingChunk+  )++import           Test.Hspec.Core.Format (FormatConfig, Format)++import           Test.Hspec.Core.Formatters.Diff+import qualified Test.Hspec.Core.Formatters.V2 as V2+import           Test.Hspec.Core.Formatters.V1.Monad (Item(..), Result(..), Environment(..), interpretWith)++formatterToFormat :: Formatter -> FormatConfig -> IO Format+formatterToFormat = V2.formatterToFormat . legacyFormatterToFormatter++legacyFormatterToFormatter :: Formatter -> V2.Formatter+legacyFormatterToFormatter Formatter{..} = V2.Formatter {+  V2.formatterStarted = interpret headerFormatter+, V2.formatterGroupStarted = interpret . uncurry exampleGroupStarted+, V2.formatterGroupDone = interpret . const exampleGroupDone+, V2.formatterProgress = \ path -> interpret . exampleProgress path+, V2.formatterItemStarted = interpret . exampleStarted+, V2.formatterItemDone = \ path item -> interpret $ do+    case itemResult item of+      Success -> exampleSucceeded path (itemInfo item)+      Pending _ reason -> examplePending path (itemInfo item) reason+      Failure _ reason -> exampleFailed path (itemInfo item) (unliftFailureReason reason)+, V2.formatterDone = interpret $ failedFormatter >> footerFormatter+}++unliftFailureRecord :: V2.FailureRecord -> FailureRecord+unliftFailureRecord V2.FailureRecord{..} = FailureRecord {+  failureRecordLocation+, failureRecordPath+, failureRecordMessage = unliftFailureReason failureRecordMessage+}++unliftFailureReason :: V2.FailureReason -> FailureReason+unliftFailureReason = \ case+  V2.NoReason -> NoReason+  V2.Reason reason -> Reason reason+  V2.ColorizedReason reason -> Reason (stripAnsi reason)+  V2.ExpectedButGot preface expected actual -> ExpectedButGot preface expected actual+  V2.Error info e -> Error info e++interpret :: FormatM a -> V2.FormatM a+interpret = interpretWith Environment {+  environmentGetSuccessCount = V2.getSuccessCount+, environmentGetPendingCount = V2.getPendingCount+, environmentGetFailMessages = map unliftFailureRecord <$> V2.getFailMessages+, environmentUsedSeed = V2.usedSeed+, environmentPrintTimes = V2.printTimes+, environmentGetCPUTime = V2.getCPUTime+, environmentGetRealTime = V2.getRealTime+, environmentWrite = V2.write+, environmentWriteTransient = V2.writeTransient+, environmentWithFailColor = V2.withFailColor+, environmentWithSuccessColor = V2.withSuccessColor+, environmentWithPendingColor = V2.withPendingColor+, environmentWithInfoColor = V2.withInfoColor+, environmentUseDiff = V2.useDiff+, environmentExtraChunk = V2.extraChunk+, environmentMissingChunk = V2.missingChunk+, environmentLiftIO = liftIO+}++silent :: Formatter+silent = Formatter {+  headerFormatter     = pass+, exampleGroupStarted = \_ _ -> pass+, exampleGroupDone    = pass+, exampleStarted      = \_ -> pass+, exampleProgress     = \_ _ -> pass+, exampleSucceeded    = \ _ _ -> pass+, exampleFailed       = \_ _ _ -> pass+, examplePending      = \_ _ _ -> pass+, failedFormatter     = pass+, footerFormatter     = pass+}++checks :: Formatter+checks = specdoc {+  exampleStarted = \(nesting, requirement) -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"++, exampleProgress = \(nesting, requirement) p -> do+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"++, exampleSucceeded = \(nesting, requirement) info -> do+    writeResult nesting requirement info $ withSuccessColor $ write "✔"++, exampleFailed = \(nesting, requirement) info _ -> do+    writeResult nesting requirement info $ withFailColor $ write "✘"++, examplePending = \(nesting, requirement) info reason -> do+    writeResult nesting requirement info $ withPendingColor $ write "‐"++    withPendingColor $ do+      writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason+} where+    indentationFor nesting = replicate (length nesting * 2) ' '++    writeResult :: [String] -> String -> String -> FormatM () -> FormatM ()+    writeResult nesting requirement info action = do+      write $ indentationFor nesting ++ requirement ++ " ["+      action+      writeLine "]"+      forM_ (lines info) $ \ s ->+        writeLine $ indentationFor ("" : nesting) ++ s++    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total++specdoc :: Formatter+specdoc = silent {++  headerFormatter = do+    writeLine ""++, exampleGroupStarted = \nesting name -> do+    writeLine (indentationFor nesting ++ name)++, exampleProgress = \_ p -> do+    writeTransient (formatProgress p)++, exampleSucceeded = \(nesting, requirement) info -> withSuccessColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, exampleFailed = \(nesting, requirement) info _ -> withFailColor $ do+    n <- getFailCount+    writeLine $ indentationFor nesting ++ requirement ++ " FAILED [" ++ show n ++ "]"+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s++, examplePending = \(nesting, requirement) info reason -> withPendingColor $ do+    writeLine $ indentationFor nesting ++ requirement+    forM_ (lines info) $ \ s ->+      writeLine $ indentationFor ("" : nesting) ++ s+    writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason++, failedFormatter = defaultFailedFormatter++, footerFormatter = defaultFooter+} where+    indentationFor nesting = replicate (length nesting * 2) ' '+    formatProgress (current, total)+      | total == 0 = show current+      | otherwise  = show current ++ "/" ++ show total+++progress :: Formatter+progress = silent {+  exampleSucceeded = \_ _ -> withSuccessColor $ write "."+, exampleFailed    = \_ _ _ -> withFailColor    $ write "F"+, examplePending   = \_ _ _ -> withPendingColor $ write "."+, failedFormatter  = defaultFailedFormatter+, footerFormatter  = defaultFooter+}+++failed_examples :: Formatter+failed_examples   = silent {+  failedFormatter = defaultFailedFormatter+, footerFormatter = defaultFooter+}++defaultFailedFormatter :: FormatM ()+defaultFailedFormatter = do+  writeLine ""++  failures <- getFailMessages++  unless (null failures) $ do+    writeLine "Failures:"+    writeLine ""++    forM_ (zip [1..] failures) $ \x -> do+      formatFailure x+      writeLine ""++    write "Randomized with seed " >> usedSeed >>= writeLine . show+    writeLine ""+  where+    formatFailure :: (Int, FailureRecord) -> FormatM ()+    formatFailure (n, FailureRecord mLoc path reason) = do+      forM_ mLoc $ \loc -> do+        withInfoColor $ writeLine (formatLoc loc)+      write ("  " ++ show n ++ ") ")+      writeLine (formatRequirement path)+      case reason of+        NoReason -> pass+        Reason err -> withFailColor $ indent err+        ExpectedButGot preface expected actual -> do+          mapM_ indent preface++          b <- useDiff++          let threshold = 2 :: Seconds++          mchunks <- liftIO $ if b+            then timeout threshold (evaluate $ diff Nothing expected actual)+            else return Nothing++          case mchunks of+            Just chunks -> do+              writeDiff chunks extraChunk missingChunk+            Nothing -> do+              writeDiff [First expected, Second actual] write write+          where+            indented output text = case break (== '\n') text of+              (xs, "") -> output xs+              (xs, _ : ys) -> output (xs ++ "\n") >> write (indentation ++ "          ") >> indented output ys++            writeDiff chunks extra missing = do+              withFailColor $ write (indentation ++ "expected: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First a -> indented extra a+                Second _ -> pass+                Omitted _ -> pass+              writeLine ""++              withFailColor $ write (indentation ++ " but got: ")+              forM_ chunks $ \ case+                Both a -> indented write a+                First _ -> pass+                Second a -> indented missing a+                Omitted _ -> pass+              writeLine ""++        Error _ e -> withFailColor . indent $ (("uncaught exception: " ++) . formatException) e++      writeLine ""+      writeLine ("  To rerun use: --match " ++ show (joinPath path))+      where+        indentation = "       "+        indent message = do+          forM_ (lines message) $ \line -> do+            writeLine (indentation ++ line)+        formatLoc (Location file line column) = "  " ++ file ++ ":" ++ show line ++ ":" ++ show column ++ ": "++defaultFooter :: FormatM ()+defaultFooter = do++  writeLine =<< (++)+    <$> (printf "Finished in %1.4f seconds" <$> getRealTime)+    <*> (maybe "" (printf ", used %1.4f seconds of CPU time") <$> getCPUTime)++  fails   <- getFailCount+  pending <- getPendingCount+  total   <- getTotalCount++  let+    output =+         pluralize total   "example"+      ++ ", " ++ pluralize fails "failure"+      ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"+    c | fails /= 0   = withFailColor+      | pending /= 0 = withPendingColor+      | otherwise    = withSuccessColor+  c $ writeLine output
hspec-core/src/Test/Hspec/Core/Formatters/V1/Monad.hs view
@@ -2,7 +2,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ExistentialQuantification #-} module Test.Hspec.Core.Formatters.V1.Monad (   Formatter(..)@@ -48,7 +47,14 @@  import           Test.Hspec.Core.Formatters.V1.Free import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Format+import           Test.Hspec.Core.Format hiding (FailureReason)++data FailureReason =+    NoReason+  | Reason String+  | ExpectedButGot (Maybe String) String String+  | Error (Maybe String) SomeException+  deriving Show  data Formatter = Formatter {
hspec-core/src/Test/Hspec/Core/Formatters/V2.hs view
@@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-} -- |--- Stability: experimental+-- Stability: unstable ----- This module contains formatters that can be used with--- `Test.Hspec.Core.Runner.hspecWith`.-module Test.Hspec.Core.Formatters.V2 (-+-- This is an unstable API.  Use+-- [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html)+-- instead.+module Test.Hspec.Core.Formatters.V2+-- {-# WARNING "Use [Test.Hspec.Api.Formatters.V3](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V3.html) instead." #-}+( -- * Formatters   silent , checks@@ -21,6 +24,9 @@ -- Actions live in the `FormatM` monad.  It provides access to the runner state -- and primitives for appending to the generated report. , Formatter (..)+, Path+, Progress+, Location(..) , Item(..) , Result(..) , FailureReason (..)@@ -58,11 +64,16 @@ , outputUnicode  , useDiff+, diffContext+, externalDiffAction , prettyPrint , prettyPrintFunction , extraChunk , missingChunk +-- ** expert mode+, unlessExpert+ -- ** Helpers , formatLocation , formatException@@ -76,16 +87,15 @@  import           Prelude () import           Test.Hspec.Core.Compat hiding (First)+import           System.IO (hFlush, stdout)  import           Data.Char-import           Data.Maybe import           Test.Hspec.Core.Util import           Test.Hspec.Core.Clock-import           Test.Hspec.Core.Example (Location(..))+import           Test.Hspec.Core.Example (Location(..), Progress) import           Text.Printf import           Test.Hspec.Core.Formatters.Pretty.Unicode (ushow) import           Control.Monad.IO.Class-import           Control.Exception  -- We use an explicit import list for "Test.Hspec.Formatters.Monad", to make -- sure, that we only use the public API to implement formatters.@@ -126,29 +136,33 @@   , outputUnicode    , useDiff+  , diffContext+  , externalDiffAction   , prettyPrint   , prettyPrintFunction   , extraChunk   , missingChunk++  , unlessExpert   )  import           Test.Hspec.Core.Formatters.Diff  silent :: Formatter silent = Formatter {-  formatterStarted      = return ()-, formatterGroupStarted = \ _ -> return ()-, formatterGroupDone    = \ _ -> return ()-, formatterProgress     = \ _ _ -> return ()-, formatterItemStarted  = \ _ -> return ()-, formatterItemDone     = \ _ _ -> return ()-, formatterDone         = return ()+  formatterStarted      = pass+, formatterGroupStarted = \ _ -> pass+, formatterGroupDone    = \ _ -> pass+, formatterProgress     = \ _ _ -> pass+, formatterItemStarted  = \ _ -> pass+, formatterItemDone     = \ _ _ -> pass+, formatterDone         = pass }  checks :: Formatter checks = specdoc {   formatterProgress = \(nesting, requirement) p -> do-    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ (formatProgress p) ++ "]"+    writeTransient $ indentationFor nesting ++ requirement ++ " [" ++ formatProgress p ++ "]"  , formatterItemStarted = \(nesting, requirement) -> do     writeTransient $ indentationFor nesting ++ requirement ++ " [ ]"@@ -161,8 +175,8 @@       Pending {} -> (withPendingColor, fallback "‐" "-")       Failure {} -> (withFailColor,    fallback "✘" "x")     case itemResult item of-      Success {} -> return ()-      Failure {} -> return ()+      Success {} -> pass+      Failure {} -> pass       Pending _ reason -> withPendingColor $ do         writeLine $ indentationFor ("" : nesting) ++ "# PENDING: " ++ fromMaybe "No reason given" reason } where@@ -237,10 +251,12 @@  progress :: Formatter progress = failed_examples {-  formatterItemDone = \ _ item -> case itemResult item of-    Success{} -> withSuccessColor $ write "."-    Pending{} -> withPendingColor $ write "."-    Failure{} -> withFailColor $ write "F"+  formatterItemDone = \ _ item -> do+    case itemResult item of+      Success{} -> withSuccessColor $ write "."+      Pending{} -> withPendingColor $ write "."+      Failure{} -> withFailColor $ write "F"+    liftIO $ hFlush stdout }  failed_examples :: Formatter@@ -273,8 +289,9 @@       write ("  " ++ show n ++ ") ")       writeLine (formatRequirement path)       case reason of-        NoReason -> return ()+        NoReason -> pass         Reason err -> withFailColor $ indent err+        ColorizedReason err -> indent err         ExpectedButGot preface expected_ actual_ -> do           pretty <- prettyPrintFunction           let@@ -288,15 +305,24 @@            let threshold = 2 :: Seconds -          mchunks <- liftIO $ if b-            then timeout threshold (evaluate $ diff expected actual)-            else return Nothing -          case mchunks of-            Just chunks -> do-              writeDiff chunks extraChunk missingChunk+          mExternalDiff <- externalDiffAction++          case mExternalDiff of+            Just externalDiff -> do+              liftIO $ externalDiff expected actual+             Nothing -> do-              writeDiff [First expected, Second actual] write write+              context <- diffContext+              mchunks <- liftIO $ if b+                then timeout threshold (evaluate $ diff context expected actual)+                else return Nothing++              case mchunks of+                Just chunks -> do+                  writeDiff chunks extraChunk missingChunk+                Nothing -> do+                  writeDiff [First expected, Second actual] write write           where             writeDiff chunks extra missing = do               writeChunks "expected: " (expectedChunks chunks) extra@@ -305,9 +331,10 @@             writeChunks :: String -> [Chunk] -> (String -> FormatM ()) -> FormatM ()             writeChunks pre chunks colorize = do               withFailColor $ write (indentation ++ pre)-              forM_ (indentChunks indentation_ chunks) $ \ chunk -> case chunk of+              forM_ (indentChunks indentation_ chunks) $ \ case                 PlainChunk a -> write a                 ColorChunk a -> colorize a+                Informational a -> withInfoColor $ write a               writeLine ""               where                 indentation_ = indentation ++ replicate (length pre) ' '@@ -316,39 +343,65 @@           mapM_ indent info           withFailColor . indent $ "uncaught exception: " ++ formatException e -      writeLine "" -      let path_ = (if unicode then ushow else show) (joinPath path)-      writeLine ("  To rerun use: --match " ++ path_)+      unlessExpert $ do+        let path_ = (if unicode then ushow else show) (joinPath path)+        writeLine ""+        writeLine ("  To rerun use: --match " ++ path_)       where         indentation = "       "         indent message = do           forM_ (lines message) $ \line -> do             writeLine (indentation ++ line) -data Chunk = Original String | Modified String+data Chunk = Original String | Modified String | OmittedLines Int   deriving (Eq, Show)  expectedChunks :: [Diff] -> [Chunk]-expectedChunks = mapMaybe $ \ chunk -> case chunk of+expectedChunks = mapMaybe $ \ case   Both a -> Just $ Original a   First a -> Just $ Modified a   Second _ -> Nothing+  Omitted n -> Just $ OmittedLines n  actualChunks :: [Diff] -> [Chunk]-actualChunks = mapMaybe $ \ chunk -> case chunk of+actualChunks = mapMaybe $ \ case   Both a -> Just $ Original a   First _ -> Nothing   Second a -> Just $ Modified a+  Omitted n -> Just $ OmittedLines n -data ColorChunk = PlainChunk String | ColorChunk String+data ColorChunk = PlainChunk String | ColorChunk String | Informational String   deriving (Eq, Show) +data StartsWith = StartsWithNewline | StartsWithNonNewline+  deriving Eq+ indentChunks :: String -> [Chunk] -> [ColorChunk]-indentChunks indentation = concatMap $ \ chunk -> case chunk of-  Original y -> [indentOriginal indentation y]-  Modified y -> indentModified indentation y+indentChunks indentation = go+  where+    go :: [Chunk] -> [ColorChunk]+    go = \ case+      Original x : xs -> indentOriginal indentation x : go xs+      Modified x : xs -> indentModified (startsWith xs) indentation x ++ go xs+      OmittedLines n : xs -> Informational (formatOmittedLines n) : go xs+      [] -> [] +    startsWith :: [Chunk] -> StartsWith+    startsWith xs+      | all isSpace (takeWhile (/= '\n') $ unChunks xs) = StartsWithNewline+      | otherwise = StartsWithNonNewline++    unChunks :: [Chunk] -> String+    unChunks = \ case+      Original x : xs -> x ++ unChunks xs+      Modified x : xs -> x ++ unChunks xs+      OmittedLines {} : _ -> ""+      [] -> ""++    formatOmittedLines :: Int -> String+    formatOmittedLines n = "@@ " <> show n <> " lines omitted @@\n" <> indentation+ indentOriginal :: String -> String -> ColorChunk indentOriginal indentation = PlainChunk . go   where@@ -356,18 +409,21 @@       (xs, _ : ys) -> xs ++ "\n" ++ indentation ++ go ys       (xs, "") -> xs -indentModified :: String -> String -> [ColorChunk]-indentModified indentation = go+indentModified :: StartsWith -> String -> String -> [ColorChunk]+indentModified nextChunk indentation = go   where-    go text = case text of+    go :: String -> [ColorChunk]+    go = \ case+      "" -> []       "\n" -> [PlainChunk "\n", ColorChunk indentation]       '\n' : ys@('\n' : _) -> PlainChunk "\n" : ColorChunk indentation : go ys-      _ -> case break (== '\n') text of-        (xs, _ : ys) -> segment xs ++ PlainChunk ('\n' : indentation) : go ys-        (xs, "") -> segment xs+      '\n' : xs -> PlainChunk ('\n' : indentation) : go xs+      text -> case break (== '\n') text of+        (xs, "") | nextChunk == StartsWithNonNewline -> [ColorChunk xs]+        (xs, ys) -> segment xs ++ go ys +    segment :: String -> [ColorChunk]     segment xs = case span isSpace $ reverse xs of-      ("", "") -> []       ("", _) -> [ColorChunk xs]       (_, "") -> [ColorChunk xs]       (ys, zs) -> [ColorChunk (reverse zs), ColorChunk (reverse ys)]@@ -388,10 +444,12 @@          pluralize total   "example"       ++ ", " ++ pluralize fails "failure"       ++ if pending == 0 then "" else ", " ++ show pending ++ " pending"-    c | fails /= 0   = withFailColor++    color+      | fails /= 0   = withFailColor       | pending /= 0 = withPendingColor       | otherwise    = withSuccessColor-  c $ writeLine output+  color $ writeLine output  formatLocation :: Location -> String formatLocation (Location file line column) = file ++ ":" ++ show line ++ ":" ++ show column ++ ": "
hspec-core/src/Test/Hspec/Core/Hooks.hs view
@@ -4,7 +4,12 @@ {-# LANGUAGE ConstraintKinds #-} -- | Stability: provisional module Test.Hspec.Core.Hooks (-  before+-- * Types+  Spec+, SpecWith+, ActionWith+-- * Hooks+, before , before_ , beforeWith , beforeAll@@ -31,9 +36,7 @@  import           Prelude () import           Test.Hspec.Core.Compat-import           Data.CallStack (HasCallStack) -import           Control.Exception (SomeException, finally, throwIO, try) import           Control.Concurrent  import           Test.Hspec.Core.Example@@ -111,11 +114,12 @@  -- | Run a custom action before and/or after every spec item. aroundWith :: (ActionWith a -> ActionWith b) -> SpecWith a -> SpecWith b-aroundWith = mapSpecItem_ . modifyAroundAction+aroundWith = mapSpecItem_ . modifyHook -modifyAroundAction :: (ActionWith a -> ActionWith b) -> Item a -> Item b-modifyAroundAction action item@Item{itemExample = e} =-  item{ itemExample = \params aroundAction -> e params (aroundAction . action) }+modifyHook :: (ActionWith a -> ActionWith b) -> Item a -> Item b+modifyHook action item = item {+    itemExample = \ params hook -> itemExample item params (hook . action)+  }  -- | Wrap an action around the given spec. aroundAll :: HasCallStack => (ActionWith a -> IO ()) -> SpecWith a -> Spec@@ -178,7 +182,7 @@         signal doCleanupNow         r <- takeMVar released         case r of-          Released -> return ()+          Released -> pass           ExceptionDuringRelease err -> throwIO err    return (acquire, release)
hspec-core/src/Test/Hspec/Core/QuickCheckUtil.hs view
@@ -1,11 +1,27 @@ {-# LANGUAGE RecordWildCards #-}-module Test.Hspec.Core.QuickCheckUtil where+{-# LANGUAGE CPP #-}+module Test.Hspec.Core.QuickCheckUtil (+  liftHook+, aroundProperty +, QuickCheckResult(..)+, Status(..)+, QuickCheckFailure(..)+, parseQuickCheckResult++, formatNumbers++, mkGen+, newSeed+#ifdef TEST+, stripSuffix+, splitBy+#endif+) where+ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception-import           Data.Maybe import           Data.Int import           System.Random @@ -21,17 +37,21 @@  import           Test.Hspec.Core.Util +liftHook :: r -> ((a -> IO ()) -> IO ()) -> (a -> IO r) -> IO r+liftHook def hook inner = do+  ref <- newIORef def+  hook $ inner >=> writeIORef ref+  readIORef ref+ aroundProperty :: ((a -> IO ()) -> IO ()) -> (a -> Property) -> Property-aroundProperty action p = MkProperty . MkGen $ \r n -> aroundProp action $ \a -> (unGen . unProperty $ p a) r n+aroundProperty hook p = MkProperty . MkGen $ \r n -> aroundProp hook $ \a -> (unGen . unProperty $ p a) r n  aroundProp :: ((a -> IO ()) -> IO ()) -> (a -> Prop) -> Prop-aroundProp action p = MkProp $ aroundRose action (\a -> unProp $ p a)+aroundProp hook p = MkProp $ aroundRose hook (\a -> unProp $ p a)  aroundRose :: ((a -> IO ()) -> IO ()) -> (a -> Rose QCP.Result) -> Rose QCP.Result-aroundRose action r = ioRose $ do-  ref <- newIORef (return QCP.succeeded)-  action $ \a -> reduceRose (r a) >>= writeIORef ref-  readIORef ref+aroundRose hook r = ioRose $ do+  liftHook (return QCP.succeeded) hook $ \ a -> reduceRose (r a)  newSeed :: IO Int newSeed = fst . randomR (0, fromIntegral (maxBound :: Int32)) <$>
hspec-core/src/Test/Hspec/Core/Runner.hs view
@@ -1,9 +1,22 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-} {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | -- Stability: provisional module Test.Hspec.Core.Runner (+-- * Simple interface+  hspec+, hspecWith+, hspecResult+, hspecWithResult++-- ** Summary+, Summary (..)+, isSuccess+, evaluateSummary+ -- * Running a spec {- | To run a spec `hspec` performs a sequence of steps:@@ -16,7 +29,8 @@ The four primitives `evalSpec`, `readConfig`, `runSpecForest` and `evaluateResult` each perform one of these steps respectively. -`hspec` is defined in terms of these primitives:+`hspec` is defined in terms of these primitives. Loosely speaking, a definition+for @hspec@ is:  @ hspec = `evalSpec` `defaultConfig` >=> \\ (config, spec) ->@@ -26,55 +40,57 @@   >>= `evaluateResult` @ -If you need more control over how a spec is run use these primitives individually.+Loosely speaking in the sense that this definition of @hspec@ ignores+@--rerun-all-on-success@. +Using these primitives individually gives you more control over how a spec is+run.  However, if you need support for @--rerun-all-on-success@ then you should+try hard to solve your use case with one of `hspec`, `hspecWith`, `hspecResult`+or `hspecWithResult`.+ -}-  hspec , evalSpec , runSpecForest , evaluateResult --- * Config-, Config (..)-, ColorMode (..)-, UnicodeMode(..)-, Path-, defaultConfig-, registerFormatter-, registerDefaultFormatter-, configAddFilter-, readConfig---- * Result+-- ** Result --- ** Spec Result+-- *** Spec Result , Test.Hspec.Core.Runner.Result.SpecResult , Test.Hspec.Core.Runner.Result.specResultItems , Test.Hspec.Core.Runner.Result.specResultSuccess+, toSummary --- ** Result Item+-- *** Result Item , Test.Hspec.Core.Runner.Result.ResultItem , Test.Hspec.Core.Runner.Result.resultItemPath , Test.Hspec.Core.Runner.Result.resultItemStatus , Test.Hspec.Core.Runner.Result.resultItemIsFailure --- ** Result Item Status+-- *** Result Item Status , Test.Hspec.Core.Runner.Result.ResultItemStatus(..) +-- * Config+, Config (..)+, ColorMode (..)+, UnicodeMode(..)+, Path+, defaultConfig+, registerFormatter+, registerDefaultFormatter+, configAddFilter+, readConfig+ -- * Legacy--- | The following primitives are deprecated.  Use `runSpecForest` instead.-, hspecWith-, hspecResult-, hspecWithResult , runSpec --- ** Summary-, Summary (..)-, toSummary-, isSuccess-, evaluateSummary+-- * Re-exports+, Spec+, SpecWith  #ifdef TEST+, UseColor(..)+, ProgressReporting(..) , rerunAll , specToEvalForest , colorOutputSupported@@ -85,12 +101,10 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Data.Maybe import           NonEmpty (nonEmpty) import           System.IO import           System.Environment (getArgs, withArgs)-import           System.Exit-import qualified Control.Exception as E+import           System.Exit (exitFailure) import           System.Random import           Control.Monad.ST import           Data.STRef@@ -99,7 +113,9 @@ import qualified Test.QuickCheck as QC  import           Test.Hspec.Core.Util (Path)+import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Spec hiding (pruneTree, pruneForest)+import           Test.Hspec.Core.Tree (formatDefaultDescription) import           Test.Hspec.Core.Config import           Test.Hspec.Core.Format (Format, FormatConfig(..)) import qualified Test.Hspec.Core.Formatters.V1 as V1@@ -109,18 +125,24 @@ import           Test.Hspec.Core.Shuffle  import           Test.Hspec.Core.Runner.PrintSlowSpecItems-import           Test.Hspec.Core.Runner.Eval hiding (Tree(..))+import           Test.Hspec.Core.Runner.Eval hiding (ColorMode(..), Tree(..)) import qualified Test.Hspec.Core.Runner.Eval as Eval import           Test.Hspec.Core.Runner.Result  -- | -- Make a formatter available for use with @--format@.+--+-- @since 2.10.5 registerFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+{-# DEPRECATED registerFormatter "Use [@registerFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:registerFormatter) instead." #-} registerFormatter formatter config = config { configAvailableFormatters = formatter : configAvailableFormatters config }  -- | -- Make a formatter available for use with @--format@ and use it by default.+--+-- @since 2.10.5 registerDefaultFormatter :: (String, FormatConfig -> IO Format) -> Config -> Config+{-# DEPRECATED registerDefaultFormatter "Use [@useFormatter@](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Format-V2.html#v:useFormatter) instead." #-} registerDefaultFormatter formatter@(_, format) config = (registerFormatter formatter config) { configFormat = Just format }  applyFilterPredicates :: Config -> [Tree c EvalItem] -> [Tree c EvalItem]@@ -143,10 +165,10 @@   | otherwise = id   where     removeCleanup :: IO () -> IO ()-    removeCleanup _ = return ()+    removeCleanup _ = pass      markSuccess :: EvalItem -> EvalItem-    markSuccess item = item {evalItemAction = \ _ -> return $ Result "" Success}+    markSuccess item = item {evalItemAction = \ _ -> return (0, Result "" Success)}  -- | Run a given spec and write a report to `stdout`. -- Exit with `exitFailure` if at least one spec item fails.@@ -155,11 +177,7 @@ -- is not always desirable.  Use `evalSpec` and `runSpecForest` if you need -- more control over these aspects. hspec :: Spec -> IO ()-hspec = evalSpec defaultConfig >=> \ (config, spec) ->-      getArgs-  >>= readConfig config-  >>= doNotLeakCommandLineArgumentsToExamples . runSpecForest spec-  >>= evaluateResult+hspec = hspecWith defaultConfig  -- | -- Evaluate a `Spec` to a forest of `SpecTree`s.  This does not execute any@@ -187,12 +205,7 @@ -- | Run given spec with custom options. -- This is similar to `hspec`, but more flexible. hspecWith :: Config -> Spec -> IO ()-hspecWith defaults = hspecWithResult defaults >=> evaluateSummary---- | `True` if the given `Summary` indicates that there were no--- failures, `False` otherwise.-isSuccess :: Summary -> Bool-isSuccess summary = summaryFailures summary == 0+hspecWith defaults = hspecWithSpecResult defaults >=> evaluateResult  -- | Exit with `exitFailure` if the given `Summary` indicates that there was at -- least one failure.@@ -216,11 +229,39 @@ -- items.  If you need this, you have to check the `Summary` yourself and act -- accordingly. hspecWithResult :: Config -> Spec -> IO Summary-hspecWithResult defaults = evalSpec defaults >=> \ (config, spec) ->-      getArgs-  >>= readConfig config-  >>= doNotLeakCommandLineArgumentsToExamples . fmap toSummary . runSpecForest spec+hspecWithResult config = fmap toSummary . hspecWithSpecResult config +hspecWithSpecResult :: Config -> Spec -> IO SpecResult+hspecWithSpecResult defaults spec = do+  (c, forest) <- evalSpec defaults spec+  config <- getArgs >>= readConfig c+  oldFailureReport <- readFailureReportOnRerun config++  let+    normalMode :: IO SpecResult+    normalMode = doNotLeakCommandLineArgumentsToExamples $ runSpecForest_ oldFailureReport forest config++    rerunAllMode :: IO SpecResult+    rerunAllMode = do+      result <- normalMode+      if rerunAll config oldFailureReport result then+        hspecWithSpecResult defaults spec+      else+        return result++  -- With --rerun-all we may run the spec twice. For that reason GHC can not+  -- optimize away the spec tree. That means that the whole spec tree has to+  -- be constructed in memory and we loose constant space behavior.+  --+  -- By separating between rerunAllMode and normalMode here, we retain+  -- constant space behavior in normalMode.+  --+  -- see: https://github.com/hspec/hspec/issues/169+  if configRerunAllOnSuccess config then do+    rerunAllMode+  else do+    normalMode+ -- | -- /Note/: `runSpec` is deprecated. It ignores any modifications applied -- through `modifyConfig`.  Use `evalSpec` and `runSpecForest` instead.@@ -241,62 +282,65 @@ -- -- @since 2.10.0 runSpecForest :: [SpecTree ()] -> Config -> IO SpecResult-runSpecForest spec c_ = do-  oldFailureReport <- readFailureReportOnRerun c_+runSpecForest spec config = do+  oldFailureReport <- readFailureReportOnRerun config+  runSpecForest_ oldFailureReport spec config -  c <- ensureSeed (applyFailureReport oldFailureReport c_)+mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]+mapItem f = map (fmap f) -  if configRerunAllOnSuccess c-    -- With --rerun-all we may run the spec twice. For that reason GHC can not-    -- optimize away the spec tree. That means that the whole spec tree has to-    -- be constructed in memory and we loose constant space behavior.-    ---    -- By separating between rerunAllMode and normalMode here, we retain-    -- constant space behavior in normalMode.-    ---    -- see: https://github.com/hspec/hspec/issues/169-    then rerunAllMode c oldFailureReport-    else normalMode c-  where-    normalMode c = runSpecForest_ c spec-    rerunAllMode c oldFailureReport = do-      result <- runSpecForest_ c spec-      if rerunAll c oldFailureReport result-        then runSpecForest spec c_-        else return result+mapItemIf :: (Item a -> Bool) -> (Item a -> Item a) -> [SpecTree a] -> [SpecTree a]+mapItemIf p f = mapItem $ \ item -> if p item then f item else item -runSpecForest_ :: Config -> [SpecTree ()] -> IO SpecResult-runSpecForest_ config spec = runEvalTree config (specToEvalForest config spec)+addDefaultDescriptions :: [SpecTree a] -> [SpecTree a]+addDefaultDescriptions = mapItem addDefaultDescription+  where+    addDefaultDescription :: Item a -> Item a+    addDefaultDescription item+      | null (itemRequirement item) = item { itemRequirement = defaultRequirement }+      | otherwise = item+      where+        defaultRequirement = maybe "(unspecified behavior)" formatDefaultDescription (itemLocation item) -mapItem :: (Item a -> Item b) -> [SpecTree a] -> [SpecTree b]-mapItem f = map (fmap f)+failItemsWithEmptyDescription :: Config -> [SpecTree a] -> [SpecTree a]+failItemsWithEmptyDescription config+  | configFailOnEmptyDescription config = mapItemIf condition (failWith failure)+  | otherwise = id+  where+    condition = null . itemRequirement+    failure = "item has no description; failing due to --fail-on=empty-description"  failFocusedItems :: Config -> [SpecTree a] -> [SpecTree a] failFocusedItems config-  | configFailOnFocused config = mapItem failFocused+  | configFailOnFocused config = mapItemIf condition (failWith failure)   | otherwise = id+  where+    condition = itemIsFocused+    failure = "item is focused; failing due to --fail-on=focused" -failFocused :: Item a -> Item a-failFocused item = item {itemExample = example}+failWith :: forall a. String -> Item a -> Item a+failWith reason item = item {itemExample = example}   where-    failure = Failure Nothing (Reason "item is focused; failing due to --fail-on=focused")-    example-      | itemIsFocused item = \ params hook p -> do-          Result info status <- itemExample item params hook p-          return $ Result info $ case status of-            Success -> failure-            Pending _ _ -> failure-            Failure{} -> status-      | otherwise = itemExample item+    failure :: ResultStatus+    failure = Failure Nothing (Reason reason) +    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result+    example params hook p = do+      Result info status <- itemExample item params hook p+      return $ Result info $ case status of+        Success -> failure+        Pending _ _ -> failure+        Failure{} -> status+ failPendingItems :: Config -> [SpecTree a] -> [SpecTree a] failPendingItems config   | configFailOnPending config = mapItem failPending   | otherwise = id -failPending :: Item a -> Item a+failPending :: forall a. Item a -> Item a failPending item = item {itemExample = example}   where+    example :: Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result     example params hook p = do       Result info status <- itemExample item params hook p       return $ Result info $ case status of@@ -308,28 +352,35 @@   | configFocusedOnly config = spec   | otherwise = focusForest spec -runEvalTree :: Config -> [EvalTree] -> IO SpecResult-runEvalTree config spec = do-  let-      failOnEmpty = configFailOnEmpty config-      seed = (fromJust . configQuickCheckSeed) config-      qcArgs = configQuickCheckArgs config-      !numberOfItems = countSpecItems spec+runSpecForest_ :: Maybe FailureReport -> [SpecTree ()] -> Config -> IO SpecResult+runSpecForest_ oldFailureReport spec c_ = do -  concurrentJobs <- case configConcurrentJobs config of-    Nothing -> getDefaultConcurrentJobs-    Just n -> return n+  config <- ensureSeed (applyFailureReport oldFailureReport c_) -  (reportProgress, useColor) <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)+  colorMode <- colorOutputSupported (configColorMode config) (hSupportsANSI stdout)   outputUnicode <- unicodeOutputSupported (configUnicodeMode config) stdout -  results <- fmap (toSpecResult failOnEmpty) . withHiddenCursor reportProgress stdout $ do+  let+    filteredSpec = specToEvalForest config spec+    seed = (fromJust . configQuickCheckSeed) config+    qcArgs = configQuickCheckArgs config+    !numberOfItems = countEvalItems filteredSpec++  when (configFailOnEmpty config && numberOfItems == 0) $ do+    when (countSpecItems spec /= 0) $ do+      die "all spec items have been filtered; failing due to --fail-on=empty"++  concurrentJobs <- maybe getDefaultConcurrentJobs return $ configConcurrentJobs config++  results <- fmap toSpecResult . withHiddenCursor (progressReporting colorMode) stdout $ do     let       formatConfig = FormatConfig {-        formatConfigUseColor = useColor-      , formatConfigReportProgress = reportProgress+        formatConfigUseColor = shouldUseColor colorMode+      , formatConfigReportProgress = progressReporting colorMode == ProgressReportingEnabled       , formatConfigOutputUnicode = outputUnicode       , formatConfigUseDiff = configDiff config+      , formatConfigDiffContext = configDiffContext config+      , formatConfigExternalDiff = if configDiff config then ($ configDiffContext config) <$> configExternalDiff config else Nothing       , formatConfigPrettyPrint = configPrettyPrint config       , formatConfigPrettyPrintFunction = if configPrettyPrint config then Just (configPrettyPrintFunction config outputUnicode) else Nothing       , formatConfigPrintTimes = configTimes config@@ -337,6 +388,7 @@       , formatConfigPrintCpuTime = configPrintCpuTime config       , formatConfigUsedSeed = seed       , formatConfigExpectedTotalCount = numberOfItems+      , formatConfigExpertMode = configExpertMode config       }        formatter = fromMaybe (V2.formatterToFormat V2.checks) (configFormat config <|> V1.formatterToFormat <$> configFormatter config)@@ -348,8 +400,9 @@         evalConfigFormat = format       , evalConfigConcurrentJobs = concurrentJobs       , evalConfigFailFast = configFailFast config+      , evalConfigColorMode = bool Eval.ColorDisabled Eval.ColorEnabled (shouldUseColor colorMode)       }-    runFormatter evalConfig spec+    runFormatter evalConfig filteredSpec    let     failures :: [Path]@@ -359,17 +412,11 @@    return results -toSummary :: SpecResult -> Summary-toSummary result = Summary {-  summaryExamples = length items-, summaryFailures = length failures-} where-    items = specResultItems result-    failures = filter resultItemIsFailure items- specToEvalForest :: Config -> [SpecTree ()] -> [EvalTree] specToEvalForest config =-      failFocusedItems config+      failItemsWithEmptyDescription config+  >>> addDefaultDescriptions+  >>> failFocusedItems config   >>> failPendingItems config   >>> focusSpec config   >>> toEvalItemForest params@@ -378,8 +425,13 @@   >>> randomize   >>> pruneForest   where+    seed :: Integer     seed = (fromJust . configQuickCheckSeed) config++    params :: Params     params = Params (configQuickCheckArgs config) (configSmallCheckDepth config)++    randomize :: [Tree c a] -> [Tree c a]     randomize       | configRandomize config = randomizeForest seed       | otherwise = id@@ -401,7 +453,12 @@ toEvalItemForest params = bimapForest id toEvalItem . filterForest itemIsFocused   where     toEvalItem :: Item () -> EvalItem-    toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem requirement loc (fromMaybe False isParallelizable) (e params withUnit)+    toEvalItem (Item requirement loc isParallelizable _isFocused e) = EvalItem {+      evalItemDescription = requirement+    , evalItemLocation = loc+    , evalItemConcurrency = if isParallelizable == Just True then Concurrent else Sequential+    , evalItemAction = \ progress -> measure $ e params withUnit progress+    }      withUnit :: ActionWith () -> IO ()     withUnit action = action ()@@ -419,21 +476,43 @@ doNotLeakCommandLineArgumentsToExamples :: IO a -> IO a doNotLeakCommandLineArgumentsToExamples = withArgs [] -withHiddenCursor :: Bool -> Handle -> IO a -> IO a-withHiddenCursor useColor h-  | useColor  = E.bracket_ (hHideCursor h) (hShowCursor h)-  | otherwise = id+withHiddenCursor :: ProgressReporting -> Handle -> IO a -> IO a+withHiddenCursor progress h = case progress of+  ProgressReportingDisabled -> id+  ProgressReportingEnabled -> bracket_ (hHideCursor h) (hShowCursor h) -colorOutputSupported :: ColorMode -> IO Bool -> IO (Bool, Bool)+data UseColor = ColorDisabled | ColorEnabled ProgressReporting+  deriving (Eq, Show)++data ProgressReporting = ProgressReportingDisabled | ProgressReportingEnabled+  deriving (Eq, Show)++shouldUseColor :: UseColor -> Bool+shouldUseColor c = case c of+  ColorDisabled -> False+  ColorEnabled _ -> True++progressReporting :: UseColor -> ProgressReporting+progressReporting c = case c of+  ColorDisabled -> ProgressReportingDisabled+  ColorEnabled r -> r++colorOutputSupported :: ColorMode -> IO Bool -> IO UseColor colorOutputSupported mode isTerminalDevice = do   github <- githubActions   buildkite <- lookupEnv "BUILDKITE" <&> (== Just "true")-  useColor <- case mode of-    ColorAuto  -> (github ||) <$> colorTerminal-    ColorNever -> return False-    ColorAlways -> return True-  let reportProgress = not github && not buildkite && useColor-  return (reportProgress, useColor)+  let+    progress :: ProgressReporting+    progress+      | github || buildkite = ProgressReportingDisabled+      | otherwise = ProgressReportingEnabled++    colorEnabled :: UseColor+    colorEnabled = ColorEnabled progress+  case mode of+    ColorAuto -> bool ColorDisabled colorEnabled . (github ||) <$> colorTerminal+    ColorNever -> return ColorDisabled+    ColorAlways -> return colorEnabled   where     githubActions :: IO Bool     githubActions = lookupEnv "GITHUB_ACTIONS" <&> (== Just "true")@@ -459,29 +538,13 @@     && specResultSuccess result     && (not . null) (failureReportPaths oldFailureReport) --- | Summary of a test run.-data Summary = Summary {-  summaryExamples :: !Int-, summaryFailures :: !Int-} deriving (Eq, Show)--instance Monoid Summary where-  mempty = Summary 0 0-#if MIN_VERSION_base(4,11,0)-instance Semigroup Summary where-#endif-  (Summary x1 x2)-#if MIN_VERSION_base(4,11,0)-    <>-#else-    `mappend`-#endif-    (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)- randomizeForest :: Integer -> [Tree c a] -> [Tree c a] randomizeForest seed t = runST $ do   ref <- newSTRef (mkStdGen $ fromIntegral seed)   shuffleForest ref t -countSpecItems :: [Eval.Tree c a] -> Int+countEvalItems :: [Eval.Tree c a] -> Int+countEvalItems = getSum . foldMap (foldMap . const $ Sum 1)++countSpecItems :: [Tree c a] -> Int countSpecItems = getSum . foldMap (foldMap . const $ Sum 1)
hspec-core/src/Test/Hspec/Core/Runner/Eval.hs view
@@ -1,40 +1,24 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RankNTypes #-}--#if MIN_VERSION_base(4,6,0) && !MIN_VERSION_base(4,7,0)--- Control.Concurrent.QSem is deprecated in base-4.6.0.*-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif- module Test.Hspec.Core.Runner.Eval (   EvalConfig(..)+, ColorMode(..) , EvalTree , Tree(..) , EvalItem(..)+, Concurrency(..) , runFormatter #ifdef TEST , mergeResults-, runSequentially #endif ) where  import           Prelude () import           Test.Hspec.Core.Compat hiding (Monad)-import qualified Test.Hspec.Core.Compat as M -import qualified Control.Exception as E-import           Control.Concurrent-import           Control.Concurrent.Async hiding (cancel)- import           Control.Monad.IO.Class (liftIO)-import qualified Control.Monad.IO.Class as M- import           Control.Monad.Trans.Reader import           Control.Monad.Trans.Class @@ -45,29 +29,31 @@ import qualified Test.Hspec.Core.Format as Format import           Test.Hspec.Core.Clock import           Test.Hspec.Core.Example.Location-import           Test.Hspec.Core.Example (safeEvaluateResultStatus)+import           Test.Hspec.Core.Example (safeEvaluateResultStatus, exceptionToResultStatus)  import qualified NonEmpty import           NonEmpty (NonEmpty(..)) +import           Test.Hspec.Core.Runner.JobQueue+ data Tree c a =     Node String (NonEmpty (Tree c a))   | NodeWithCleanup (Maybe (String, Location)) c (NonEmpty (Tree c a))   | Leaf a   deriving (Eq, Show, Functor, Foldable, Traversable) --- for compatibility with GHC < 7.10.1-type Monad m = (Functor m, Applicative m, M.Monad m)-type MonadIO m = (Monad m, M.MonadIO m)- data EvalConfig = EvalConfig {   evalConfigFormat :: Format , evalConfigConcurrentJobs :: Int , evalConfigFailFast :: Bool+, evalConfigColorMode :: ColorMode } +data ColorMode = ColorDisabled | ColorEnabled+ data Env = Env {   envConfig :: EvalConfig+, envFailed :: IORef Bool , envResults :: IORef [(Path, Format.Item)] } @@ -78,14 +64,21 @@  type EvalM = ReaderT Env IO +setFailed :: EvalM ()+setFailed = do+  ref <- asks envFailed+  liftIO $ writeIORef ref True++hasFailed :: EvalM Bool+hasFailed = do+  ref <- asks envFailed+  liftIO $ readIORef ref+ addResult :: Path -> Format.Item -> EvalM () addResult path item = do   ref <- asks envResults   liftIO $ modifyIORef ref ((path, item) :) -getResults :: EvalM [(Path, Format.Item)]-getResults = reverse <$> (asks envResults >>= liftIO . readIORef)- reportItem :: Path -> Maybe Location -> EvalM (Seconds, Result)  -> EvalM () reportItem path loc action = do   reportItemStarted path@@ -96,17 +89,33 @@  reportItemDone :: Path -> Format.Item -> EvalM () reportItemDone path item = do+  let+    isFailure = case Format.itemResult item of+      Format.Success{} -> False+      Format.Pending{} -> False+      Format.Failure{} -> True+  when isFailure setFailed   addResult path item   formatEvent $ Format.ItemDone path item  reportResult :: Path -> Maybe Location -> (Seconds, Result) -> EvalM () reportResult path loc (duration, result) = do+  mode <- asks (evalConfigColorMode . envConfig)   case result of     Result info status -> reportItemDone path $ Format.Item loc duration info $ case status of       Success                      -> Format.Success       Pending loc_ reason          -> Format.Pending loc_ reason       Failure loc_ err@(Error _ e) -> Format.Failure (loc_ <|> extractLocation e) err-      Failure loc_ err             -> Format.Failure loc_ err+      Failure loc_ err             -> Format.Failure loc_ $ case mode of+        ColorEnabled -> err+        ColorDisabled -> case err of+          NoReason -> err+          Reason _ -> err+          ExpectedButGot _ _ _ -> err+          ColorizedReason r -> Reason (stripAnsi r)+#if __GLASGOW_HASKELL__ < 900+          Error _ _ -> err+#endif  groupStarted :: Path -> EvalM () groupStarted = formatEvent . Format.GroupStarted@@ -117,62 +126,71 @@ data EvalItem = EvalItem {   evalItemDescription :: String , evalItemLocation :: Maybe Location-, evalItemParallelize :: Bool-, evalItemAction :: ProgressCallback -> IO Result+, evalItemConcurrency :: Concurrency+, evalItemAction :: ProgressCallback -> IO (Seconds, Result) }  type EvalTree = Tree (IO ()) EvalItem  -- | Evaluate all examples of a given spec and produce a report.-runFormatter :: EvalConfig -> [EvalTree] -> IO ([(Path, Format.Item)])+runFormatter :: EvalConfig -> [EvalTree] -> IO [(Path, Format.Item)] runFormatter config specs = do-  ref <- newIORef []+  withJobQueue (evalConfigConcurrentJobs config) $ \ queue -> do+    withTimer 0.05 $ \ timer -> do+      env <- mkEnv+      runningSpecs_ <- enqueueItems queue specs -  let-    start = parallelizeTree (evalConfigConcurrentJobs config) specs-    cancel = cancelMany . concatMap toList . map (fmap fst)+      let+        applyReportProgress :: RunningItem_ IO -> RunningItem+        applyReportProgress item = fmap (. reportProgress timer) item -  E.bracket start cancel $ \ runningSpecs -> do-    withTimer 0.05 $ \ timer -> do+        runningSpecs :: [RunningTree ()]+        runningSpecs = applyCleanup $ map (fmap applyReportProgress) runningSpecs_ -      format Format.Started-      runReaderT (run . applyCleanup $ map (fmap (fmap (. reportProgress timer) . snd)) runningSpecs) (Env config ref) `E.finally` do-        results <- reverse <$> readIORef ref-        format (Format.Done results)+        getResults :: IO [(Path, Format.Item)]+        getResults = reverse <$> readIORef (envResults env) -      results <- reverse <$> readIORef ref-      return results+        formatItems :: IO ()+        formatItems = runReaderT (eval runningSpecs) env++        formatDone :: IO ()+        formatDone = getResults >>= format . Format.Done++      format Format.Started+      formatItems `finally` formatDone+      getResults   where+    mkEnv :: IO Env+    mkEnv = Env config <$> newIORef False <*> newIORef []++    format :: Format     format = evalConfigFormat config +    reportProgress :: IO Bool -> Path -> Progress -> IO ()     reportProgress timer path progress = do       r <- timer       when r $ do         format (Format.Progress path progress) -cancelMany :: [Async a] -> IO ()-cancelMany asyncs = do-  mapM_ (killThread . asyncThreadId) asyncs-  mapM_ waitCatch asyncs- data Item a = Item {-  _itemDescription :: String-, _itemLocation :: Maybe Location+  itemDescription :: String+, itemLocation :: Maybe Location , itemAction :: a } deriving Functor -type Job m p a = (p -> m ()) -> m a- type RunningItem = Item (Path -> IO (Seconds, Result)) type RunningTree c = Tree c RunningItem +type RunningItem_ m = Item (Job m Progress (Seconds, Result))+type RunningTree_ m = Tree (IO ()) (RunningItem_ m)+ applyCleanup :: [RunningTree (IO ())] -> [RunningTree ()] applyCleanup = map go   where     go t = case t of-      Leaf a -> Leaf a       Node label xs -> Node label (go <$> xs)       NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc () (addCleanupToLastLeaf loc cleanup $ go <$> xs)+      Leaf a -> Leaf a  addCleanupToLastLeaf :: Maybe (String, Location) -> IO () -> NonEmpty (RunningTree ()) -> NonEmpty (RunningTree ()) addCleanupToLastLeaf loc cleanup = go@@ -180,9 +198,9 @@     go = NonEmpty.reverse . mapHead goNode . NonEmpty.reverse      goNode node = case node of+      Node description xs -> Node description (go xs)+      NodeWithCleanup loc_ () xs -> NodeWithCleanup loc_ () (go xs)       Leaf item -> Leaf (addCleanupToItem loc cleanup item)-      NodeWithCleanup loc_ () zs -> NodeWithCleanup loc_ () (go zs)-      Node description zs -> Node description (go zs)  mapHead :: (a -> a) -> NonEmpty a -> NonEmpty a mapHead f xs = case xs of@@ -212,62 +230,23 @@       Just (name, _) -> Just $ "in " ++ name ++ "-hook:"       Nothing -> Nothing -type RunningItem_ m = (Async (), Item (Job m Progress (Seconds, Result)))-type RunningTree_ m = Tree (IO ()) (RunningItem_ m)--data Semaphore = Semaphore {-  semaphoreWait :: IO ()-, semaphoreSignal :: IO ()-}--parallelizeTree :: MonadIO m => Int -> [EvalTree] -> IO [RunningTree_ m]-parallelizeTree n specs = do-  sem <- newQSem n-  mapM (traverse $ parallelizeItem sem) specs--parallelizeItem :: MonadIO m => QSem -> EvalItem -> IO (RunningItem_ m)-parallelizeItem sem EvalItem{..} = do-  (asyncAction, evalAction) <- parallelize (Semaphore (waitQSem sem) (signalQSem sem)) evalItemParallelize (interruptible . evalItemAction)-  return (asyncAction, Item evalItemDescription evalItemLocation evalAction)--parallelize :: MonadIO m => Semaphore -> Bool -> Job IO p a -> IO (Async (), Job m p (Seconds, a))-parallelize sem isParallelizable-  | isParallelizable = runParallel sem-  | otherwise = runSequentially--runSequentially :: MonadIO m => Job IO p a -> IO (Async (), Job m p (Seconds, a))-runSequentially action = do-  mvar <- newEmptyMVar-  (asyncAction, evalAction) <- runParallel (Semaphore (takeMVar mvar) (return ())) action-  return (asyncAction, \ notifyPartial -> liftIO (putMVar mvar ()) >> evalAction notifyPartial)--data Parallel p a = Partial p | Return a+enqueueItems :: MonadIO m => JobQueue -> [EvalTree] -> IO [RunningTree_ m]+enqueueItems queue = mapM (traverse $ enqueueItem queue) -runParallel :: forall m p a. MonadIO m => Semaphore -> Job IO p a -> IO (Async (), Job m p (Seconds, a))-runParallel Semaphore{..} action = do-  mvar <- newEmptyMVar-  asyncAction <- async $ E.bracket_ semaphoreWait semaphoreSignal (worker mvar)-  return (asyncAction, eval mvar)+enqueueItem :: MonadIO m => JobQueue -> EvalItem -> IO (RunningItem_ m)+enqueueItem queue EvalItem{..} = do+  job <- enqueueJob queue evalItemConcurrency evalItemAction+  return Item {+    itemDescription = evalItemDescription+  , itemLocation = evalItemLocation+  , itemAction = job >=> liftIO . either exceptionToResult return+  }   where-    worker mvar = do-      let partialCallback = replaceMVar mvar . Partial-      result <- measure $ action partialCallback-      replaceMVar mvar (Return result)--    eval :: MVar (Parallel p (Seconds, a)) -> (p -> m ()) -> m (Seconds, a)-    eval mvar notifyPartial = do-      r <- liftIO (takeMVar mvar)-      case r of-        Partial p -> do-          notifyPartial p-          eval mvar notifyPartial-        Return result -> return result--replaceMVar :: MVar a -> a -> IO ()-replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p+    exceptionToResult :: SomeException -> IO (Seconds, Result)+    exceptionToResult err = (,) 0 . Result "" <$> exceptionToResultStatus err -run :: [RunningTree ()] -> EvalM ()-run specs = do+eval :: [RunningTree ()] -> EvalM ()+eval specs = do   failFast <- asks (evalConfigFailFast . envConfig)   sequenceActions failFast (concatMap foldSpec specs)   where@@ -315,18 +294,10 @@ sequenceActions failFast = go   where     go :: [EvalM ()] -> EvalM ()-    go [] = return ()+    go [] = pass     go (action : actions) = do       action       stopNow <- case failFast of         False -> return False-        True -> any itemIsFailure <$> getResults+        True -> hasFailed       unless stopNow (go actions)--    itemIsFailure :: (Path, Format.Item) -> Bool-    itemIsFailure = isFailure . Format.itemResult . snd-      where-        isFailure r = case r of-          Format.Success{} -> False-          Format.Pending{} -> False-          Format.Failure{} -> True
+ hspec-core/src/Test/Hspec/Core/Runner/JobQueue.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}++module Test.Hspec.Core.Runner.JobQueue (+  MonadIO+, Job+, Concurrency(..)+, JobQueue+, withJobQueue+, enqueueJob+) where++import           Prelude ()+import           Test.Hspec.Core.Compat hiding (Monad)+import qualified Test.Hspec.Core.Compat as M++import           Control.Concurrent+import           Control.Concurrent.Async (Async, AsyncCancelled(..), async, waitCatch, asyncThreadId)++import           Control.Monad.IO.Class (liftIO)+import qualified Control.Monad.IO.Class as M++-- for compatibility with GHC < 7.10.1+type Monad m = (Functor m, Applicative m, M.Monad m)+type MonadIO m = (Monad m, M.MonadIO m)++type Job m progress a = (progress -> m ()) -> m a++data Concurrency = Sequential | Concurrent++data JobQueue = JobQueue {+  _semaphore :: Semaphore+, _cancelQueue :: CancelQueue+}++data Semaphore = Semaphore {+  _wait :: IO ()+, _signal :: IO ()+}++type CancelQueue = IORef [Async ()]++withJobQueue :: Int -> (JobQueue -> IO a) -> IO a+withJobQueue concurrency = bracket new cancelAll+  where+    new :: IO JobQueue+    new = JobQueue <$> newSemaphore concurrency <*> newIORef []++    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+  sem <- newQSem capacity+  return $ Semaphore (waitQSem sem) (signalQSem sem)++enqueueJob :: MonadIO m => JobQueue -> Concurrency -> Job IO progress a -> IO (Job m progress (Either SomeException a))+enqueueJob (JobQueue sem cancelQueue) concurrency = case concurrency of+  Sequential -> runSequentially cancelQueue+  Concurrent -> runConcurrently sem cancelQueue++runSequentially :: forall m progress a. MonadIO m => CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a))+runSequentially cancelQueue action = do+  barrier <- newEmptyMVar+  let+    wait :: IO ()+    wait = takeMVar barrier++    signal :: m ()+    signal = liftIO $ putMVar barrier ()++  job <- runConcurrently (Semaphore wait pass) cancelQueue action+  return $ \ notifyPartial -> signal >> job notifyPartial++data Partial progress a = Partial progress | Done++runConcurrently :: forall m progress a. MonadIO m => Semaphore -> CancelQueue -> Job IO progress a -> IO (Job m progress (Either SomeException a))+runConcurrently (Semaphore wait signal) cancelQueue action = do+  result :: MVar (Partial progress a) <- newEmptyMVar+  let+    worker :: IO a+    worker = bracket_ wait signal $ do+      interruptible (action partialResult) `finally` done+      where+        partialResult :: progress -> IO ()+        partialResult = replaceMVar result . Partial++        done :: IO ()+        done = replaceMVar result Done++    pushOnCancelQueue :: Async a -> IO ()+    pushOnCancelQueue = (modifyIORef cancelQueue . (:) . void)++  job <- bracket (async worker) pushOnCancelQueue return++  let+    waitForResult :: (progress -> m ()) -> m (Either SomeException a)+    waitForResult notifyPartial = do+      r <- liftIO (takeMVar result)+      case r of+        Partial progress -> notifyPartial progress >> waitForResult notifyPartial+        Done -> liftIO $ waitCatch job++  return waitForResult++replaceMVar :: MVar a -> a -> IO ()+replaceMVar mvar p = tryTakeMVar mvar >> putMVar mvar p
hspec-core/src/Test/Hspec/Core/Runner/PrintSlowSpecItems.hs view
@@ -7,6 +7,8 @@ import           Prelude () import           Test.Hspec.Core.Compat +import           System.IO (stderr, hPutStrLn)+ import           Test.Hspec.Core.Util import           Test.Hspec.Core.Format @@ -26,9 +28,9 @@     Done items -> do       let xs = slowItems n $ map toSlowItem items       unless (null xs) $ do-        putStrLn "\nSlow spec items:"+        hPutStrLn stderr "\nSlow spec items:"         mapM_ printSlowSpecItem xs-    _ -> return ()+    _ -> pass  toSlowItem :: (Path, Item) -> SlowItem toSlowItem (path, item) = SlowItem (itemLocation item)  path (toMilliseconds $ itemDuration item)@@ -38,4 +40,4 @@  printSlowSpecItem :: SlowItem -> IO () printSlowSpecItem SlowItem{..} = do-  putStrLn $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"+  hPutStrLn stderr $ "  " ++ maybe "" formatLocation location ++ joinPath path ++ " (" ++ show duration ++ "ms)"
hspec-core/src/Test/Hspec/Core/Runner/Result.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Test.Hspec.Core.Runner.Result ( -- RE-EXPORTED from Test.Hspec.Core.Runner   SpecResult(SpecResult)@@ -10,6 +11,10 @@ , resultItemIsFailure  , ResultItemStatus(..)++, Summary(..)+, toSummary+, isSuccess -- END RE-EXPORTED from Test.Hspec.Core.Runner  , toSpecResult@@ -21,16 +26,32 @@ import           Test.Hspec.Core.Util import qualified Test.Hspec.Core.Format as Format +-- |+-- @since 2.10.0 data SpecResult = SpecResult {+  -- |+  -- @since 2.10.0   specResultItems :: [ResultItem]++  -- |+  -- @since 2.10.0 , specResultSuccess :: !Bool } deriving (Eq, Show) +-- |+-- @since 2.10.0 data ResultItem = ResultItem {+  -- |+  -- @since 2.10.0   resultItemPath :: Path++  -- |+  -- @since 2.10.0 , resultItemStatus :: ResultItemStatus } deriving (Eq, Show) +-- |+-- @since 2.10.0 resultItemIsFailure :: ResultItem -> Bool resultItemIsFailure item = case resultItemStatus item of   ResultItemSuccess -> False@@ -43,11 +64,11 @@   | ResultItemFailure   deriving (Eq, Show) -toSpecResult :: Bool -> [(Path, Format.Item)] -> SpecResult-toSpecResult failOnEmpty results = SpecResult items success+toSpecResult :: [(Path, Format.Item)] -> SpecResult+toSpecResult results = SpecResult items success   where     items = map toResultItem results-    success = not (failOnEmpty && null results) && all (not . resultItemIsFailure) items+    success = all (not . resultItemIsFailure) items  toResultItem :: (Path, Format.Item) -> ResultItem toResultItem (path, item) = ResultItem path status@@ -56,3 +77,35 @@       Format.Success{} -> ResultItemSuccess       Format.Pending{} -> ResultItemPending       Format.Failure{} -> ResultItemFailure++-- | Summary of a test run.+data Summary = Summary {+  summaryExamples :: !Int+, summaryFailures :: !Int+} deriving (Eq, Show)++instance Monoid Summary where+  mempty = Summary 0 0+#if MIN_VERSION_base(4,11,0)+instance Semigroup Summary where+#endif+  (Summary x1 x2)+#if MIN_VERSION_base(4,11,0)+    <>+#else+    `mappend`+#endif+    (Summary y1 y2) = Summary (x1 + y1) (x2 + y2)++toSummary :: SpecResult -> Summary+toSummary result = Summary {+  summaryExamples = length items+, summaryFailures = length failures+} where+    items = specResultItems result+    failures = filter resultItemIsFailure items++-- | `True` if the given `Summary` indicates that there were no+-- failures, `False` otherwise.+isSuccess :: Summary -> Bool+isSuccess summary = summaryFailures summary == 0
hspec-core/src/Test/Hspec/Core/Shuffle.hs view
@@ -16,16 +16,16 @@ import           Data.STRef import           Data.Array.ST -shuffleForest :: STRef s StdGen -> [Tree c a] -> ST s [Tree c a]+shuffleForest :: STRef st StdGen -> [Tree c a] -> ST st [Tree c a] shuffleForest ref xs = (shuffle ref xs >>= mapM (shuffleTree ref)) -shuffleTree :: STRef s StdGen -> Tree c a -> ST s (Tree c a)+shuffleTree :: STRef st StdGen -> Tree c a -> ST st (Tree c a) shuffleTree ref t = case t of   Node d xs -> Node d <$> shuffleForest ref xs   NodeWithCleanup loc c xs -> NodeWithCleanup loc c <$> shuffleForest ref xs   Leaf {} -> return t -shuffle :: STRef s StdGen -> [a] -> ST s [a]+shuffle :: STRef st StdGen -> [a] -> ST st [a] shuffle ref xs = do   arr <- mkArray xs   bounds@(_, n) <- getBounds arr@@ -41,5 +41,5 @@       writeSTRef ref gen       return a -mkArray :: [a] -> ST s (STArray s Int a)+mkArray :: [a] -> ST st (STArray st Int a) mkArray xs = newListArray (1, length xs) xs
hspec-core/src/Test/Hspec/Core/Spec.hs view
@@ -73,13 +73,15 @@ , Test.Hspec.Core.Tree.location  , focusForest++-- * Re-exports+, HasCallStack+, Expectation ) where  import           Prelude () import           Test.Hspec.Core.Compat -import qualified Control.Exception as E-import           Data.CallStack import           Control.Monad.Trans.Class (lift) import           Control.Monad.Trans.Reader (asks) @@ -188,16 +190,16 @@ -- >   it "can format text in a way that everyone likes" $ -- >     pending pending :: HasCallStack => Expectation-pending = E.throwIO (Pending location Nothing)+pending = throwIO (Pending location Nothing)  pending_ :: Expectation-pending_ = (E.throwIO (Pending Nothing Nothing))+pending_ = (throwIO (Pending Nothing Nothing))  -- | -- `pendingWith` is similar to `pending`, but it takes an additional string -- argument that can be used to specify the reason for why the spec item is pending. pendingWith :: HasCallStack => String -> Expectation-pendingWith = E.throwIO . Pending location . Just+pendingWith = throwIO . Pending location . Just  -- | Get the path of `describe` labels, from the root all the way in to the -- call-site of this function.
hspec-core/src/Test/Hspec/Core/Spec/Monad.hs view
@@ -71,6 +71,8 @@ mapSpecForest :: ([SpecTree a] -> [SpecTree b]) -> SpecM a r -> SpecM b r mapSpecForest f (SpecM specs) = SpecM (mapWriterT (fmap (fmap (second f))) specs) +-- {-# DEPRECATED mapSpecItem "Use `mapSpecItem_` instead." #-}+-- | Deprecated: Use `mapSpecItem_` instead. mapSpecItem :: (ActionWith a -> ActionWith b) -> (Item a -> Item b) -> SpecWith a -> SpecWith b mapSpecItem _ = mapSpecItem_
hspec-core/src/Test/Hspec/Core/Timer.hs view
@@ -3,7 +3,6 @@ import           Prelude () import           Test.Hspec.Core.Compat -import           Control.Exception import           Control.Concurrent.Async  import           Test.Hspec.Core.Clock
hspec-core/src/Test/Hspec/Core/Tree.hs view
@@ -22,14 +22,16 @@ , location -- END RE-EXPORTED from Test.Hspec.Core.Spec , callSite+, formatDefaultDescription+, toModuleName ) where  import           Prelude () import           Test.Hspec.Core.Compat -import           Data.CallStack (HasCallStack, SrcLoc(..))+import           Data.Char+import           System.FilePath import qualified Data.CallStack as CallStack-import           Data.Maybe  import           Test.Hspec.Core.Example @@ -52,7 +54,7 @@   where     go spec = case spec of       Node d xs -> Node d (map go xs)-      NodeWithCleanup loc cleanup xs -> NodeWithCleanup loc (g cleanup) (map go xs)+      NodeWithCleanup loc action xs -> NodeWithCleanup loc (g action) (map go xs)       Leaf item -> Leaf (f item)  filterTree :: (a -> Bool) -> Tree c a -> Maybe (Tree c a)@@ -122,17 +124,18 @@   where     msg :: HasCallStack => String     msg-      | null s = fromMaybe "(no description given)" defaultDescription+      | null s = maybe "(no description given)" formatDefaultDescription location       | otherwise = s  -- | The @specItem@ function creates a spec item.-specItem :: (HasCallStack, Example a) => String -> a -> SpecTree (Arg a)-specItem s e = Leaf $ Item requirement location Nothing False (safeEvaluateExample e)-  where-    requirement :: HasCallStack => String-    requirement-      | null s = fromMaybe "(unspecified behavior)" defaultDescription-      | otherwise = s+specItem :: (HasCallStack, Example e) => String -> e -> SpecTree (Arg e)+specItem s e = Leaf Item {+    itemRequirement = s+  , itemLocation = location+  , itemIsParallelizable = Nothing+  , itemIsFocused = False+  , itemExample = safeEvaluateExample e+  }  location :: HasCallStack => Maybe Location location = snd <$> callSite@@ -140,10 +143,16 @@ callSite :: HasCallStack => Maybe (String, Location) callSite = fmap toLocation <$> CallStack.callSite -defaultDescription :: HasCallStack => Maybe String-defaultDescription = case CallStack.callSite of-  Just (_, loc) -> Just (srcLocModule loc ++ "[" ++ show (srcLocStartLine loc) ++ ":" ++ show (srcLocStartCol loc) ++ "]")-  Nothing -> Nothing+formatDefaultDescription :: Location -> String+formatDefaultDescription loc = toModuleName (locationFile loc) ++ "[" ++ show (locationLine loc) ++ ":" ++ show (locationColumn loc) ++ "]" -toLocation :: SrcLoc -> Location-toLocation loc = Location (srcLocFile loc) (srcLocStartLine loc) (srcLocStartCol loc)+toModuleName :: FilePath -> String+toModuleName = intercalate "." . reverse . takeWhile isModuleNameComponent . reverse . splitDirectories . dropExtension++isModuleNameComponent :: String -> Bool+isModuleNameComponent name = case name of+  x : xs -> isUpper x && all isIdChar xs+  _ -> False++isIdChar :: Char -> Bool+isIdChar c = isAlphaNum c || c == '_' || c == '\''
hspec-core/src/Test/Hspec/Core/Util.hs view
@@ -1,9 +1,11 @@+{-# LANGUAGE  ViewPatterns #-} -- | Stability: unstable module Test.Hspec.Core.Util ( -- * String functions   pluralize , strip , lineBreaksAt+, stripAnsi  -- * Working with paths , Path@@ -21,7 +23,6 @@  import           Data.Char (isSpace) import           GHC.IO.Exception-import           Control.Exception import           Control.Concurrent.Async  -- |@@ -38,17 +39,23 @@ -- -- >>> pluralize 2 "example" -- "2 examples"+--+-- @since 2.0.0 pluralize :: Int -> String -> String pluralize 1 s = "1 " ++ s pluralize n s = show n ++ " " ++ s ++ "s"  -- | Strip leading and trailing whitespace+--+-- @since 2.0.0 strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse  -- |--- ensure that lines are not longer than given `n`, insert line breaks at word+-- Ensure that lines are not longer than given `n`, insert line breaks at word -- boundaries+--+-- @since 2.0.0 lineBreaksAt :: Int -> String -> [String] lineBreaksAt n = concatMap f . lines   where@@ -65,20 +72,38 @@           else s : go (y, ys)  -- |+-- Remove ANSI color escape sequences.+--+-- @since 2.11.0+stripAnsi :: String -> String+stripAnsi = go+  where+    go input = case input of+      '\ESC' : '[' : (dropWhile (`elem` "0123456789;") -> 'm' : xs) -> go xs+      x : xs -> x : go xs+      [] -> []++-- | -- A `Path` describes the location of a spec item within a spec tree. -- -- It consists of a list of group descriptions and a requirement description.+--+-- @since 2.0.0 type Path = ([String], String)  -- | -- Join a `Path` with slashes.  The result will have a leading and a trailing -- slash.+--+-- @since 2.5.4 joinPath :: Path -> String joinPath (groups, requirement) = "/" ++ intercalate "/" (groups ++ [requirement]) ++ "/"  -- | -- Try to create a proper English sentence from a path by applying some -- heuristics.+--+-- @since 2.0.0 formatRequirement :: Path -> String formatRequirement (groups, requirement) = groups_ ++ requirement   where@@ -91,6 +116,8 @@       ys  -> concatMap (++ ", ") ys  -- | A predicate that can be used to filter a spec tree.+--+-- @since 2.0.0 filterPredicate :: String -> Path -> Bool filterPredicate pattern path =      pattern `isInfixOf` plain@@ -107,6 +134,8 @@ -- "ArithException\ndivide by zero" -- -- For `IOException`s the `IOErrorType` is included, as well.+--+-- @since 2.0.0 formatException :: SomeException -> String formatException err@(SomeException e) = case fromException err of   Just ioe -> showType ioe ++ " of type " ++ showIOErrorType ioe ++ "\n" ++ show ioe@@ -137,5 +166,7 @@ -- | @safeTry@ evaluates given action and returns its result.  If an exception -- occurs, the exception is returned instead.  Unlike `try` it is agnostic to -- asynchronous exceptions.+--+-- @since 2.0.0 safeTry :: IO a -> IO (Either SomeException a) safeTry action = withAsync (action >>= evaluate) waitCatch
− hspec-core/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 #)
− hspec-core/vendor/Data/Algorithm/Diff.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}--------------------------------------------------------------------------------- |--- Module      :  Data.Algorithm.Diff--- Copyright   :  (c) Sterling Clover 2008-2011, Kevin Charter 2011--- License     :  BSD 3 Clause--- Maintainer  :  s.clover@gmail.com--- Stability   :  experimental--- Portability :  portable------ This is an implementation of the O(ND) diff algorithm as described in--- \"An O(ND) Difference Algorithm and Its Variations (1986)\"--- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.4.6927>. It is O(mn) in space.--- The algorithm is the same one used by standared Unix diff.--------------------------------------------------------------------------------module Data.Algorithm.Diff-    ( Diff(..)-    -- * Comparing lists for differences-    , getDiff-    , getDiffBy--    -- * Finding chunks of differences-    , getGroupedDiff-    , getGroupedDiffBy-    ) where--import Prelude hiding (pi)--import Data.Array--data DI = F | S | B deriving (Show, Eq)---- | A value is either from the 'First' list, the 'Second' or from 'Both'.--- 'Both' contains both the left and right values, in case you are using a form--- of equality that doesn't check all data (for example, if you are using a--- newtype to only perform equality on side of a tuple).-data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor)--data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq)--instance Ord DL-        where x <= y = if poi x == poi y-                then  poj x > poj y-                else poi x <= poi y--canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool-canDiag eq as bs lena lenb = \ i j ->-   if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False-    where arAs = listArray (0,lena - 1) as-          arBs = listArray (0,lenb - 1) bs--dstep :: (Int -> Int -> Bool) -> [DL] -> [DL]-dstep cd dls = hd:pairMaxes rst-  where (hd:rst) = nextDLs dls-        nextDLs [] = []-        nextDLs (dl:rest) = dl':dl'':nextDLs rest-          where dl'  = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)}-                dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)}-                pdl = path dl-        pairMaxes [] = []-        pairMaxes [x] = [x]-        pairMaxes (x:y:rest) = max x y:pairMaxes rest--addsnake :: (Int -> Int -> Bool) -> DL -> DL-addsnake cd dl-    | cd pi pj = addsnake cd $-                 dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)}-    | otherwise   = dl-    where pi = poi dl; pj = poj dl--lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI]-lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) .-            concat . iterate (dstep cd) . (:[]) . addsnake cd $-            DL {poi=0,poj=0,path=[]}-            where cd = canDiag eq as bs lena lenb-                  lena = length as; lenb = length bs---- | Takes two lists and returns a list of differences between them. This is--- 'getDiffBy' with '==' used as predicate.-getDiff :: (Eq t) => [t] -> [t] -> [Diff t]-getDiff = getDiffBy (==)---- | Takes two lists and returns a list of differences between them, grouped--- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate.-getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]]-getGroupedDiff = getGroupedDiffBy (==)---- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate--- is taken as the first argument.-getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t]-getDiffBy eq a b = markup a b . reverse $ lcs eq a b-    where markup (x:xs)   ys   (F:ds) = First x  : markup xs ys ds-          markup   xs   (y:ys) (S:ds) = Second y : markup xs ys ds-          markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds-          markup _ _ _ = []--getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]]-getGroupedDiffBy eq a b = go $ getDiffBy eq a b-    where go (First x  : xs) = let (fs, rest) = goFirsts  xs in First  (x:fs)     : go rest-          go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs)     : go rest-          go (Both x y : xs) = let (fs, rest) = goBoth    xs-                                   (fxs, fys) = unzip fs-                               in Both (x:fxs) (y:fys) : go rest-          go [] = []--          goFirsts  (First x  : xs) = let (fs, rest) = goFirsts  xs in (x:fs, rest)-          goFirsts  xs = ([],xs)--          goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest)-          goSeconds xs = ([],xs)--          goBoth    (Both x y : xs) = let (fs, rest) = goBoth xs    in ((x,y):fs, rest)-          goBoth    xs = ([],xs)
− hspec-core/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs 
@@ -1,168 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-}--#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE Trustworthy #-}-#endif--{-# OPTIONS -fno-warn-implicit-prelude #-}---------------------------------------------------------------------------------- |--- Module      :  Control.Concurrent.STM.TMVar--- Copyright   :  (c) The University of Glasgow 2004--- License     :  BSD-style (see the file libraries/base/LICENSE)------ Maintainer  :  libraries@haskell.org--- Stability   :  experimental--- Portability :  non-portable (requires STM)------ TMVar: Transactional MVars, for use in the STM monad--- (GHC only)-----------------------------------------------------------------------------------module Control.Concurrent.STM.TMVar (-#ifdef __GLASGOW_HASKELL__-        -- * TMVars-        TMVar,-        newTMVar,-        newEmptyTMVar,-        newTMVarIO,-        newEmptyTMVarIO,-        takeTMVar,-        putTMVar,-        readTMVar,-        tryReadTMVar,-        swapTMVar,-        tryTakeTMVar,-        tryPutTMVar,-        isEmptyTMVar,-        mkWeakTMVar-#endif-  ) where--#ifdef __GLASGOW_HASKELL__-import GHC.Base-import GHC.Conc-import GHC.Weak--import Data.Typeable (Typeable)--newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable)-{- ^-A 'TMVar' is a synchronising variable, used-for communication between concurrent threads.  It can be thought of-as a box, which may be empty or full.--}---- |Create a 'TMVar' which contains the supplied value.-newTMVar :: a -> STM (TMVar a)-newTMVar a = do-  t <- newTVar (Just a)-  return (TMVar t)---- |@IO@ version of 'newTMVar'.  This is useful for creating top-level--- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using--- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't--- possible.-newTMVarIO :: a -> IO (TMVar a)-newTMVarIO a = do-  t <- newTVarIO (Just a)-  return (TMVar t)---- |Create a 'TMVar' which is initially empty.-newEmptyTMVar :: STM (TMVar a)-newEmptyTMVar = do-  t <- newTVar Nothing-  return (TMVar t)---- |@IO@ version of 'newEmptyTMVar'.  This is useful for creating top-level--- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using--- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't--- possible.-newEmptyTMVarIO :: IO (TMVar a)-newEmptyTMVarIO = do-  t <- newTVarIO Nothing-  return (TMVar t)---- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently--- empty, the transaction will 'retry'.  After a 'takeTMVar',--- the 'TMVar' is left empty.-takeTMVar :: TMVar a -> STM a-takeTMVar (TMVar t) = do-  m <- readTVar t-  case m of-    Nothing -> retry-    Just a  -> do writeTVar t Nothing; return a---- | A version of 'takeTMVar' that does not 'retry'.  The 'tryTakeTMVar'--- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if--- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the--- 'TMVar' is left empty.-tryTakeTMVar :: TMVar a -> STM (Maybe a)-tryTakeTMVar (TMVar t) = do-  m <- readTVar t-  case m of-    Nothing -> return Nothing-    Just a  -> do writeTVar t Nothing; return (Just a)---- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full,--- 'putTMVar' will 'retry'.-putTMVar :: TMVar a -> a -> STM ()-putTMVar (TMVar t) a = do-  m <- readTVar t-  case m of-    Nothing -> do writeTVar t (Just a); return ()-    Just _  -> retry---- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar'--- function attempts to put the value @a@ into the 'TMVar', returning--- 'True' if it was successful, or 'False' otherwise.-tryPutTMVar :: TMVar a -> a -> STM Bool-tryPutTMVar (TMVar t) a = do-  m <- readTVar t-  case m of-    Nothing -> do writeTVar t (Just a); return True-    Just _  -> return False---- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it--- takes the value from the 'TMVar', puts it back, and also returns--- it.-readTMVar :: TMVar a -> STM a-readTMVar (TMVar t) = do-  m <- readTVar t-  case m of-    Nothing -> retry-    Just a  -> return a---- | A version of 'readTMVar' which does not retry. Instead it--- returns @Nothing@ if no value is available.------ @since 2.3-tryReadTMVar :: TMVar a -> STM (Maybe a)-tryReadTMVar (TMVar t) = readTVar t---- |Swap the contents of a 'TMVar' for a new value.-swapTMVar :: TMVar a -> a -> STM a-swapTMVar (TMVar t) new = do-  m <- readTVar t-  case m of-    Nothing -> retry-    Just old -> do writeTVar t (Just new); return old---- |Check whether a given 'TMVar' is empty.-isEmptyTMVar :: TMVar a -> STM Bool-isEmptyTMVar (TMVar t) = do-  m <- readTVar t-  case m of-    Nothing -> return True-    Just _  -> return False---- | Make a 'Weak' pointer to a 'TMVar', using the second argument as--- a finalizer to run when the 'TMVar' is garbage-collected.------ @since 2.4.4-mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a))-mkWeakTMVar tmv@(TMVar (TVar t#)) (IO finalizer) = IO $ \s ->-    case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #)-#endif
hspec-discover/src/Test/Hspec/Discover/Config.hs view
@@ -1,6 +1,6 @@ -- | -- /NOTE:/ This module is not meant for public consumption.  For user--- documentation look at http://hspec.github.io/hspec-discover.html.+-- documentation look at https://hspec.github.io/hspec-discover.html. module Test.Hspec.Discover.Config (   Config (..) , defaultConfig
hspec-discover/src/Test/Hspec/Discover/Run.hs view
@@ -3,7 +3,7 @@ -- | A preprocessor that finds and combines specs. -- -- /NOTE:/ This module is not meant for public consumption.  For user--- documentation look at http://hspec.github.io/hspec-discover.html.+-- documentation look at https://hspec.github.io/hspec-discover.html. module Test.Hspec.Discover.Run (   run @@ -149,7 +149,7 @@     mkModule :: [String] -> String     mkModule = intercalate "." . reverse --- See `Cabal.Distribution.ModuleName` (http://git.io/bj34)+-- See `Cabal.Distribution.ModuleName` (https://git.io/bj34) isValidModuleName :: String -> Bool isValidModuleName [] = False isValidModuleName (c:cs) = isUpper c && all isValidModuleChar cs
hspec-discover/src/Test/Hspec/Discover/Sort.hs view
@@ -1,6 +1,6 @@ -- | -- /NOTE:/ This module is not meant for public consumption.  For user--- documentation look at http://hspec.github.io/hspec-discover.html.+-- documentation look at https://hspec.github.io/hspec-discover.html. module Test.Hspec.Discover.Sort (   sortNaturallyBy , NaturalSortKey
hspec-meta.cabal view
@@ -1,37 +1,38 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack  name:           hspec-meta-version:        2.10.5+version:        2.11.2 synopsis:       A version of Hspec which is used to test Hspec itself description:    A stable version of Hspec which is used to test the                 in-development version of Hspec. category:       Testing stability:      experimental-homepage:       http://hspec.github.io/+homepage:       https://hspec.github.io/ bug-reports:    https://github.com/hspec/hspec/issues maintainer:     Simon Hengel <sol@typeful.net>-copyright:      (c) 2011-2022 Simon Hengel,+copyright:      (c) 2011-2023 Simon Hengel,                 (c) 2011-2012 Trystan Spangler,                 (c) 2011 Greg Weber license:        MIT license-file:   LICENSE build-type:     Simple-extra-source-files:-    version.yaml  source-repository head   type: git   location: https://github.com/hspec/hspec+  subdir: hspec-meta  library   exposed-modules:       Test.Hspec.Meta       Test.Hspec.Discover   other-modules:+      Control.Concurrent.Async+      Data.Algorithm.Diff       Test.Hspec       Test.Hspec.Formatters       Test.Hspec.QuickCheck@@ -56,10 +57,11 @@       Test.Hspec.Core.Formatters.Internal       Test.Hspec.Core.Formatters.Pretty       Test.Hspec.Core.Formatters.Pretty.Parser-      Test.Hspec.Core.Formatters.Pretty.Parser.Types+      Test.Hspec.Core.Formatters.Pretty.Parser.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@@ -67,6 +69,7 @@       Test.Hspec.Core.QuickCheckUtil       Test.Hspec.Core.Runner       Test.Hspec.Core.Runner.Eval+      Test.Hspec.Core.Runner.JobQueue       Test.Hspec.Core.Runner.PrintSlowSpecItems       Test.Hspec.Core.Runner.Result       Test.Hspec.Core.Shuffle@@ -75,44 +78,32 @@       Test.Hspec.Core.Timer       Test.Hspec.Core.Tree       Test.Hspec.Core.Util-      Control.Concurrent.Async-      Data.Algorithm.Diff-      Test.HUnit-      Test.HUnit.Base-      Test.HUnit.Lang-      Test.HUnit.Terminal-      Test.HUnit.Text-      Test.Hspec.Expectations-      Test.Hspec.Expectations.Contrib-      Test.Hspec.Expectations.Matcher       Paths_hspec_meta   hs-source-dirs:       src+      vendor+      hspec/src       hspec-core/src-      hspec-core/vendor-      vendor/HUnit-1.6.2.0/src/-      vendor/hspec-expectations-0.8.2/src/   ghc-options: -Wall -fno-warn-incomplete-uni-patterns   build-depends:-      QuickCheck >=2.12-    , ansi-terminal+      HUnit ==1.6.*+    , QuickCheck >=2.13.1+    , ansi-terminal >=0.6.2     , array-    , base ==4.*-    , call-stack-    , clock+    , base >=4.8.2.0 && <5+    , call-stack >=0.2.0     , deepseq     , directory     , filepath-    , quickcheck-io+    , haskell-lexer+    , hspec-expectations ==0.8.3.*+    , process+    , quickcheck-io >=0.2.0     , random-    , setenv+    , tf-random     , time     , transformers >=0.2.2.0   default-language: Haskell2010-  if impl(ghc >= 8.2.1)-    build-depends:-        ghc-      , ghc-boot-th   if impl(ghc >= 8.4.1)     build-depends:         stm >=2.2@@ -120,7 +111,7 @@     other-modules:         Control.Concurrent.STM.TMVar     hs-source-dirs:-        hspec-core/vendor/stm-2.5.0.1/+        vendor/stm-2.5.0.1/  executable hspec-meta-discover   main-is: hspec-discover.hs@@ -134,22 +125,29 @@       hspec-discover/driver   ghc-options: -Wall -fno-warn-incomplete-uni-patterns   build-depends:-      QuickCheck >=2.12-    , ansi-terminal+      HUnit ==1.6.*+    , QuickCheck >=2.13.1+    , ansi-terminal >=0.6.2     , array-    , base ==4.*-    , call-stack-    , clock+    , base >=4.8.2.0 && <5+    , call-stack >=0.2.0     , deepseq     , directory     , filepath-    , quickcheck-io+    , haskell-lexer+    , hspec-expectations ==0.8.3.*+    , process+    , quickcheck-io >=0.2.0     , random-    , setenv+    , tf-random     , time     , transformers >=0.2.2.0   default-language: Haskell2010-  if impl(ghc >= 8.2.1)+  if impl(ghc >= 8.4.1)     build-depends:-        ghc-      , ghc-boot-th+        stm >=2.2+  else+    other-modules:+        Control.Concurrent.STM.TMVar+    hs-source-dirs:+        vendor/stm-2.5.0.1/
+ hspec/src/Test/Hspec.hs view
@@ -0,0 +1,96 @@+-- |+-- Stability: stable+--+-- Hspec is a testing framework for Haskell.+--+-- This is the library reference for Hspec.+-- The <https://hspec.github.io/ User's Manual> contains more in-depth+-- documentation.+module Test.Hspec (+-- * Types+  Spec+, SpecWith+, Arg+, Example++-- * Setting expectations+, module Test.Hspec.Expectations++-- * Defining a spec+, it+, specify+, describe+, context+, example+, parallel+, sequential+, runIO++-- * Pending spec items+-- |+-- During a test run a /pending/ spec item is:+--+-- 1. not executed+--+-- 1. reported as \"pending\"+, pending+, pendingWith+, xit+, xspecify+, xdescribe+, xcontext++-- * Focused spec items+-- |+-- During a test run, when a spec contains /focused/ spec items, all other spec+-- items are ignored.+, focus+, fit+, fspecify+, fdescribe+, fcontext++-- * Hooks+, ActionWith+, before+, before_+, beforeWith+, beforeAll+, beforeAll_+, beforeAllWith+, after+, after_+, afterAll+, afterAll_+, around+, around_+, aroundWith+, aroundAll+, aroundAll_+, aroundAllWith+, mapSubject+, ignoreSubject++-- * Running a spec+, hspec+) where++import           Test.Hspec.Core.Spec+import           Test.Hspec.Core.Hooks+import           Test.Hspec.Runner+import           Test.Hspec.Expectations++-- | @example@ is a type restricted version of `id`.  It can be used to get better+-- error messages on type mismatches.+--+-- Compare e.g.+--+-- > it "exposes some behavior" $ example $ do+-- >   putStrLn+--+-- with+--+-- > it "exposes some behavior" $ do+-- >   putStrLn+example :: Expectation -> Expectation+example = id
+ hspec/src/Test/Hspec/Discover.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE FlexibleInstances #-}+module Test.Hspec.Discover {-# WARNING+  "This module is used by @hspec-discover@.  It is not part of the public API and may change at any time."+  #-} (+  Spec+, hspec+, IsFormatter (..)+, hspecWithFormatter+, postProcessSpec+, describe+, module Prelude+) where++import           Test.Hspec.Core.Spec+import           Test.Hspec.Core.Runner+import           Test.Hspec.Core.Formatters.V1++class IsFormatter a where+  toFormatter :: a -> IO Formatter++instance IsFormatter (IO Formatter) where+  toFormatter = id++instance IsFormatter Formatter where+  toFormatter = return++hspecWithFormatter :: IsFormatter a => a -> Spec -> IO ()+hspecWithFormatter formatter spec = do+  f <- toFormatter formatter+  hspecWith defaultConfig {configFormatter = Just f} spec++postProcessSpec :: FilePath -> Spec -> Spec+postProcessSpec _ = id
+ hspec/src/Test/Hspec/Formatters.hs view
@@ -0,0 +1,8 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+-- |+-- Stability: deprecated+module Test.Hspec.Formatters+{-# DEPRECATED "Use [Test.Hspec.Api.Formatters.V1](https://hackage.haskell.org/package/hspec-api/docs/Test-Hspec-Api-Formatters-V1.html) instead." #-}+(module Test.Hspec.Core.Formatters.V1)+where+import           Test.Hspec.Core.Formatters.V1
+ hspec/src/Test/Hspec/QuickCheck.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ConstraintKinds #-}+module Test.Hspec.QuickCheck (+-- * Params+  modifyArgs+, modifyMaxSuccess+, modifyMaxDiscardRatio+, modifyMaxSize+, modifyMaxShrinks++-- * Shortcuts+, prop+, xprop+, fprop+) where++import           Test.Hspec+import           Test.QuickCheck+import           Test.Hspec.Core.QuickCheck++-- |+-- > prop ".." $+-- >   ..+--+-- is a shortcut for+--+-- @+-- `it` ".." $ `property` $+--   ..+-- @+prop :: (HasCallStack, Testable prop) => String -> prop -> Spec+prop s = it s . property+++-- |+-- > xprop ".." $+-- >   ..+--+-- is a shortcut for+--+-- @+-- `xit` ".." $ `property` $+--   ..+-- @+xprop :: (HasCallStack, Testable prop) => String -> prop -> Spec+xprop s = xit s . property+++-- |+-- > fprop ".." $+-- >   ..+--+-- is a shortcut for+--+-- @+-- `fit` ".." $ `property` $+--   ..+-- @+fprop :: (HasCallStack, Testable prop) => String -> prop -> Spec+fprop s = fit s . property
+ hspec/src/Test/Hspec/Runner.hs view
@@ -0,0 +1,2 @@+module Test.Hspec.Runner (module Test.Hspec.Core.Runner) where+import           Test.Hspec.Core.Runner
− src/Test/Hspec.hs 
@@ -1,95 +0,0 @@--- |--- Stability: stable------ Hspec is a testing framework for Haskell.------ This is the library reference for Hspec.--- The <http://hspec.github.io/ User's Manual> contains more in-depth--- documentation.-module Test.Hspec (--- * Types-  Spec-, SpecWith-, Arg-, Example---- * Setting expectations-, module Test.Hspec.Expectations---- * Defining a spec-, it-, specify-, describe-, context-, example-, parallel-, runIO---- * Pending spec items--- |--- During a test run a /pending/ spec item is:------ 1. not executed------ 1. reported as \"pending\"-, pending-, pendingWith-, xit-, xspecify-, xdescribe-, xcontext---- * Focused spec items--- |--- During a test run, when a spec contains /focused/ spec items, all other spec--- items are ignored.-, focus-, fit-, fspecify-, fdescribe-, fcontext---- * Hooks-, ActionWith-, before-, before_-, beforeWith-, beforeAll-, beforeAll_-, beforeAllWith-, after-, after_-, afterAll-, afterAll_-, around-, around_-, aroundWith-, aroundAll-, aroundAll_-, aroundAllWith-, mapSubject-, ignoreSubject---- * Running a spec-, hspec-) where--import           Test.Hspec.Core.Spec-import           Test.Hspec.Core.Hooks-import           Test.Hspec.Runner-import           Test.Hspec.Expectations---- | @example@ is a type restricted version of `id`.  It can be used to get better--- error messages on type mismatches.------ Compare e.g.------ > it "exposes some behavior" $ example $ do--- >   putStrLn------ with------ > it "exposes some behavior" $ do--- >   putStrLn-example :: Expectation -> Expectation-example = id
− src/Test/Hspec/Discover.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-module Test.Hspec.Discover {-# WARNING-  "This module is used by @hspec-discover@.  It is not part of the public API and may change at any time."-  #-} (-  Spec-, hspec-, IsFormatter (..)-, hspecWithFormatter-, postProcessSpec-, describe-, module Prelude-) where--import           Test.Hspec.Core.Spec-import           Test.Hspec.Core.Runner-import           Test.Hspec.Core.Formatters.V1--class IsFormatter a where-  toFormatter :: a -> IO Formatter--instance IsFormatter (IO Formatter) where-  toFormatter = id--instance IsFormatter Formatter where-  toFormatter = return--hspecWithFormatter :: IsFormatter a => a -> Spec -> IO ()-hspecWithFormatter formatter spec = do-  f <- toFormatter formatter-  hspecWith defaultConfig {configFormatter = Just f} spec--postProcessSpec :: FilePath -> Spec -> Spec-postProcessSpec _ = id
− src/Test/Hspec/Formatters.hs 
@@ -1,7 +0,0 @@--- |--- Deprecated\: Use "Test.Hspec.Core.Formatters.V1" instead.-module Test.Hspec.Formatters--- {-# DEPRECATED "Use \"Test.Hspec.Core.Formatters.V1\" instead." #-}-(module Test.Hspec.Core.Formatters.V1)-where-import           Test.Hspec.Core.Formatters.V1
− src/Test/Hspec/QuickCheck.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ConstraintKinds #-}-module Test.Hspec.QuickCheck (--- * Params-  modifyArgs-, modifyMaxSuccess-, modifyMaxDiscardRatio-, modifyMaxSize-, modifyMaxShrinks---- * Shortcuts-, prop-) where--import           Test.Hspec-import           Test.QuickCheck-import           Test.Hspec.Core.QuickCheck---- |--- > prop ".." $--- >   ..------ is a shortcut for------ > it ".." $ property $--- >   ..-prop :: (HasCallStack, Testable prop) => String -> prop -> Spec-prop s = it s . property
− src/Test/Hspec/Runner.hs 
@@ -1,2 +0,0 @@-module Test.Hspec.Runner (module Test.Hspec.Core.Runner) where-import           Test.Hspec.Core.Runner
+ vendor/Control/Concurrent/Async.hs view
@@ -0,0 +1,963 @@+{-# 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/Data/Algorithm/Diff.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Algorithm.Diff+-- Copyright   :  (c) Sterling Clover 2008-2011, Kevin Charter 2011+-- License     :  BSD 3 Clause+-- Maintainer  :  s.clover@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- This is an implementation of the O(ND) diff algorithm as described in+-- \"An O(ND) Difference Algorithm and Its Variations (1986)\"+-- <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.4.6927>. It is O(mn) in space.+-- The algorithm is the same one used by standared Unix diff.+-----------------------------------------------------------------------------++module Data.Algorithm.Diff+    ( Diff(..)+    -- * Comparing lists for differences+    , getDiff+    , getDiffBy++    -- * Finding chunks of differences+    , getGroupedDiff+    , getGroupedDiffBy+    ) where++import Prelude hiding (pi)++import Data.Array++data DI = F | S | B deriving (Show, Eq)++-- | A value is either from the 'First' list, the 'Second' or from 'Both'.+-- 'Both' contains both the left and right values, in case you are using a form+-- of equality that doesn't check all data (for example, if you are using a+-- newtype to only perform equality on side of a tuple).+data Diff a = First a | Second a | Both a a deriving (Show, Eq, Functor)++data DL = DL {poi :: !Int, poj :: !Int, path::[DI]} deriving (Show, Eq)++instance Ord DL+        where x <= y = if poi x == poi y+                then  poj x > poj y+                else poi x <= poi y++canDiag :: (a -> a -> Bool) -> [a] -> [a] -> Int -> Int -> Int -> Int -> Bool+canDiag eq as bs lena lenb = \ i j ->+   if i < lena && j < lenb then (arAs ! i) `eq` (arBs ! j) else False+    where arAs = listArray (0,lena - 1) as+          arBs = listArray (0,lenb - 1) bs++dstep :: (Int -> Int -> Bool) -> [DL] -> [DL]+dstep cd dls = hd:pairMaxes rst+  where (hd:rst) = nextDLs dls+        nextDLs [] = []+        nextDLs (dl:rest) = dl':dl'':nextDLs rest+          where dl'  = addsnake cd $ dl {poi=poi dl + 1, path=(F : pdl)}+                dl'' = addsnake cd $ dl {poj=poj dl + 1, path=(S : pdl)}+                pdl = path dl+        pairMaxes [] = []+        pairMaxes [x] = [x]+        pairMaxes (x:y:rest) = max x y:pairMaxes rest++addsnake :: (Int -> Int -> Bool) -> DL -> DL+addsnake cd dl+    | cd pi pj = addsnake cd $+                 dl {poi = pi + 1, poj = pj + 1, path=(B : path dl)}+    | otherwise   = dl+    where pi = poi dl; pj = poj dl++lcs :: (a -> a -> Bool) -> [a] -> [a] -> [DI]+lcs eq as bs = path . head . dropWhile (\dl -> poi dl /= lena || poj dl /= lenb) .+            concat . iterate (dstep cd) . (:[]) . addsnake cd $+            DL {poi=0,poj=0,path=[]}+            where cd = canDiag eq as bs lena lenb+                  lena = length as; lenb = length bs++-- | Takes two lists and returns a list of differences between them. This is+-- 'getDiffBy' with '==' used as predicate.+getDiff :: (Eq t) => [t] -> [t] -> [Diff t]+getDiff = getDiffBy (==)++-- | Takes two lists and returns a list of differences between them, grouped+-- into chunks. This is 'getGroupedDiffBy' with '==' used as predicate.+getGroupedDiff :: (Eq t) => [t] -> [t] -> [Diff [t]]+getGroupedDiff = getGroupedDiffBy (==)++-- | A form of 'getDiff' with no 'Eq' constraint. Instead, an equality predicate+-- is taken as the first argument.+getDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff t]+getDiffBy eq a b = markup a b . reverse $ lcs eq a b+    where markup (x:xs)   ys   (F:ds) = First x  : markup xs ys ds+          markup   xs   (y:ys) (S:ds) = Second y : markup xs ys ds+          markup (x:xs) (y:ys) (B:ds) = Both x y : markup xs ys ds+          markup _ _ _ = []++getGroupedDiffBy :: (t -> t -> Bool) -> [t] -> [t] -> [Diff [t]]+getGroupedDiffBy eq a b = go $ getDiffBy eq a b+    where go (First x  : xs) = let (fs, rest) = goFirsts  xs in First  (x:fs)     : go rest+          go (Second x : xs) = let (fs, rest) = goSeconds xs in Second (x:fs)     : go rest+          go (Both x y : xs) = let (fs, rest) = goBoth    xs+                                   (fxs, fys) = unzip fs+                               in Both (x:fxs) (y:fys) : go rest+          go [] = []++          goFirsts  (First x  : xs) = let (fs, rest) = goFirsts  xs in (x:fs, rest)+          goFirsts  xs = ([],xs)++          goSeconds (Second x : xs) = let (fs, rest) = goSeconds xs in (x:fs, rest)+          goSeconds xs = ([],xs)++          goBoth    (Both x y : xs) = let (fs, rest) = goBoth xs    in ((x,y):fs, rest)+          goBoth    xs = ([],xs)
− vendor/HUnit-1.6.2.0/src/Test/HUnit.hs 
@@ -1,80 +0,0 @@--- | HUnit is a unit testing framework for Haskell, inspired by the JUnit tool--- for Java. This guide describes how to use HUnit, assuming you are familiar--- with Haskell, though not necessarily with JUnit.------ In the Haskell module where your tests will reside, import module--- @Test.HUnit@:------ @---    import Test.HUnit--- @------  Define test cases as appropriate:------ @---    test1 = TestCase (assertEqual "for (foo 3)," (1,2) (foo 3))---    test2 = TestCase (do (x,y) <- partA 3---                         assertEqual "for the first result of partA," 5 x---                         b <- partB y---                         assertBool ("(partB " ++ show y ++ ") failed") b)--- @------ Name the test cases and group them together:------ @---    tests = TestList [TestLabel "test1" test1, TestLabel "test2" test2]--- @------ Run the tests as a group. At a Haskell interpreter prompt, apply the function--- @runTestTT@ to the collected tests. (The /TT/ suggests /T/ext orientation--- with output to the /T/erminal.)------ @---    \> runTestTT tests---    Cases: 2  Tried: 2  Errors: 0  Failures: 0---    \>--- @------ If the tests are proving their worth, you might see:------ @---    \> runTestTT tests---    ### Failure in: 0:test1---    for (foo 3),---    expected: (1,2)---     but got: (1,3)---    Cases: 2  Tried: 2  Errors: 0  Failures: 1---    \>--- @------ You can specify tests even more succinctly using operators and overloaded--- functions that HUnit provides:------ @---    tests = test [ "test1" ~: "(foo 3)" ~: (1,2) ~=? (foo 3),---                   "test2" ~: do (x, y) <- partA 3---                                 assertEqual "for the first result of partA," 5 x---                                 partB y \@? "(partB " ++ show y ++ ") failed" ]--- @------ Assuming the same test failures as before, you would see:------ @---    \> runTestTT tests---    ### Failure in: 0:test1:(foo 3)---    expected: (1,2)---     but got: (1,3)---    Cases: 2  Tried: 2  Errors: 0  Failures: 1---    \>--- @--module Test.HUnit-(-  module Test.HUnit.Base,-  module Test.HUnit.Text-)-where--import Test.HUnit.Base-import Test.HUnit.Text-
− vendor/HUnit-1.6.2.0/src/Test/HUnit/Base.hs 
@@ -1,361 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE ConstraintKinds #-}-#define HasCallStack_ HasCallStack =>-#else-#define HasCallStack_-#endif---- | Basic definitions for the HUnit library.------   This module contains what you need to create assertions and test cases and---   combine them into test suites.------   This module also provides infrastructure for---   implementing test controllers (which are used to execute tests).---   See "Test.HUnit.Text" for a great example of how to implement a test---   controller.--module Test.HUnit.Base-(-  -- ** Declaring tests-  Test(..),-  (~=?), (~?=), (~:), (~?),--  -- ** Making assertions-  assertFailure, {- from Test.HUnit.Lang: -}-  assertBool, assertEqual, assertString,-  Assertion, {- from Test.HUnit.Lang: -}-  (@=?), (@?=), (@?),--  -- ** Extending the assertion functionality-  Assertable(..), ListAssertable(..),-  AssertionPredicate, AssertionPredicable(..),-  Testable(..),--  -- ** Test execution-  -- $testExecutionNote-  State(..), Counts(..),-  Path, Node(..),-  testCasePaths,-  testCaseCount,-  ReportStart, ReportProblem,-  performTest-) where--import Control.Monad (unless, foldM)-import Data.CallStack----- Assertion Definition--- ====================--import Test.HUnit.Lang----- Conditional Assertion Functions--- ----------------------------------- | Asserts that the specified condition holds.-assertBool :: HasCallStack_-              String    -- ^ The message that is displayed if the assertion fails-           -> Bool      -- ^ The condition-           -> Assertion-assertBool msg b = unless b (assertFailure msg)---- | Signals an assertion failure if a non-empty message (i.e., a message--- other than @\"\"@) is passed.-assertString :: HasCallStack_-                String    -- ^ The message that is displayed with the assertion failure-             -> Assertion-assertString s = unless (null s) (assertFailure s)---- Overloaded `assert` Function--- -------------------------------- | Allows the extension of the assertion mechanism.------ Since an 'Assertion' can be a sequence of @Assertion@s and @IO@ actions,--- there is a fair amount of flexibility of what can be achieved.  As a rule,--- the resulting @Assertion@ should be the body of a 'TestCase' or part of--- a @TestCase@; it should not be used to assert multiple, independent--- conditions.------ If more complex arrangements of assertions are needed, 'Test's and--- 'Testable' should be used.-class Assertable t- where assert :: HasCallStack_ t -> Assertion--instance Assertable ()- where assert = return--instance Assertable Bool- where assert = assertBool ""--instance (ListAssertable t) => Assertable [t]- where assert = listAssert--instance (Assertable t) => Assertable (IO t)- where assert = (>>= assert)---- | A specialized form of 'Assertable' to handle lists.-class ListAssertable t- where listAssert :: HasCallStack_ [t] -> Assertion--instance ListAssertable Char- where listAssert = assertString----- Overloaded `assertionPredicate` Function--- -------------------------------------------- | The result of an assertion that hasn't been evaluated yet.------ Most test cases follow the following steps:------ 1. Do some processing or an action.------ 2. Assert certain conditions.------ However, this flow is not always suitable.  @AssertionPredicate@ allows for--- additional steps to be inserted without the initial action to be affected--- by side effects.  Additionally, clean-up can be done before the test case--- has a chance to end.  A potential work flow is:------ 1. Write data to a file.------ 2. Read data from a file, evaluate conditions.------ 3. Clean up the file.------ 4. Assert that the side effects of the read operation meet certain conditions.------ 5. Assert that the conditions evaluated in step 2 are met.-type AssertionPredicate = IO Bool---- | Used to signify that a data type can be converted to an assertion--- predicate.-class AssertionPredicable t- where assertionPredicate :: t -> AssertionPredicate--instance AssertionPredicable Bool- where assertionPredicate = return--instance (AssertionPredicable t) => AssertionPredicable (IO t)- where assertionPredicate = (>>= assertionPredicate)----- Assertion Construction Operators--- ----------------------------------infix  1 @?, @=?, @?=---- | Asserts that the condition obtained from the specified---   'AssertionPredicable' holds.-(@?) :: HasCallStack_ AssertionPredicable t-                                => t          -- ^ A value of which the asserted condition is predicated-                                -> String     -- ^ A message that is displayed if the assertion fails-                                -> Assertion-predi @? msg = assertionPredicate predi >>= assertBool msg---- | Asserts that the specified actual value is equal to the expected value---   (with the expected value on the left-hand side).-(@=?) :: HasCallStack_ (Eq a, Show a)-                        => a -- ^ The expected value-                        -> a -- ^ The actual value-                        -> Assertion-expected @=? actual = assertEqual "" expected actual---- | Asserts that the specified actual value is equal to the expected value---   (with the actual value on the left-hand side).-(@?=) :: HasCallStack_ (Eq a, Show a)-                        => a -- ^ The actual value-                        -> a -- ^ The expected value-                        -> Assertion-actual @?= expected = assertEqual "" expected actual------ Test Definition--- ===============---- | The basic structure used to create an annotated tree of test cases.-data Test-    -- | A single, independent test case composed.-    = TestCase Assertion-    -- | A set of @Test@s sharing the same level in the hierarchy.-    | TestList [Test]-    -- | A name or description for a subtree of the @Test@s.-    | TestLabel String Test--instance Show Test where-  showsPrec _ (TestCase _)    = showString "TestCase _"-  showsPrec _ (TestList ts)   = showString "TestList " . showList ts-  showsPrec p (TestLabel l t) = showString "TestLabel " . showString l-                                . showChar ' ' . showsPrec p t---- Overloaded `test` Function--- ------------------------------ | Provides a way to convert data into a @Test@ or set of @Test@.-class Testable t- where test :: HasCallStack_ t -> Test--instance Testable Test- where test = id--instance (Assertable t) => Testable (IO t)- where test = TestCase . assert--instance (Testable t) => Testable [t]- where test = TestList . map test----- Test Construction Operators--- -----------------------------infix  1 ~?, ~=?, ~?=-infixr 0 ~:---- | Creates a test case resulting from asserting the condition obtained---   from the specified 'AssertionPredicable'.-(~?) :: HasCallStack_ AssertionPredicable t-                                => t       -- ^ A value of which the asserted condition is predicated-                                -> String  -- ^ A message that is displayed on test failure-                                -> Test-predi ~? msg = TestCase (predi @? msg)---- | Shorthand for a test case that asserts equality (with the expected---   value on the left-hand side, and the actual value on the right-hand---   side).-(~=?) :: HasCallStack_ (Eq a, Show a)-                        => a     -- ^ The expected value-                        -> a     -- ^ The actual value-                        -> Test-expected ~=? actual = TestCase (expected @=? actual)---- | Shorthand for a test case that asserts equality (with the actual---   value on the left-hand side, and the expected value on the right-hand---   side).-(~?=) :: HasCallStack_ (Eq a, Show a)-                        => a     -- ^ The actual value-                        -> a     -- ^ The expected value-                        -> Test-actual ~?= expected = TestCase (actual @?= expected)---- | Creates a test from the specified 'Testable', with the specified---   label attached to it.------ Since 'Test' is @Testable@, this can be used as a shorthand way of attaching--- a 'TestLabel' to one or more tests.-(~:) :: HasCallStack_ Testable t => String -> t -> Test-label ~: t = TestLabel label (test t)------ Test Execution--- ==============---- $testExecutionNote--- Note: the rest of the functionality in this module is intended for--- implementors of test controllers. If you just want to run your tests cases,--- simply use a test controller, such as the text-based controller in--- "Test.HUnit.Text".---- | A data structure that hold the results of tests that have been performed--- up until this point.-data Counts = Counts { cases, tried, errors, failures :: Int }-  deriving (Eq, Show, Read)---- | Keeps track of the remaining tests and the results of the performed tests.--- As each test is performed, the path is removed and the counts are--- updated as appropriate.-data State = State { path :: Path, counts :: Counts }-  deriving (Eq, Show, Read)---- | Report generator for reporting the start of a test run.-type ReportStart us = State -> us -> IO us---- | Report generator for reporting problems that have occurred during---   a test run. Problems may be errors or assertion failures.-type ReportProblem us = Maybe SrcLoc -> String -> State -> us -> IO us---- | Uniquely describes the location of a test within a test hierarchy.--- Node order is from test case to root.-type Path = [Node]---- | Composed into 'Path's.-data Node  = ListItem Int | Label String-  deriving (Eq, Show, Read)---- | Determines the paths for all 'TestCase's in a tree of @Test@s.-testCasePaths :: Test -> [Path]-testCasePaths t0 = tcp t0 []- where tcp (TestCase _) p = [p]-       tcp (TestList ts) p =-         concat [ tcp t (ListItem n : p) | (t,n) <- zip ts [0..] ]-       tcp (TestLabel l t) p = tcp t (Label l : p)---- | Counts the number of 'TestCase's in a tree of @Test@s.-testCaseCount :: Test -> Int-testCaseCount (TestCase _)    = 1-testCaseCount (TestList ts)   = sum (map testCaseCount ts)-testCaseCount (TestLabel _ t) = testCaseCount t---- | Performs a test run with the specified report generators.------ This handles the actual running of the tests.  Most developers will want--- to use @HUnit.Text.runTestTT@ instead.  A developer could use this function--- to execute tests via another IO system, such as a GUI, or to output the--- results in a different manner (e.g., upload XML-formatted results to a--- webservice).------ Note that the counts in a start report do not include the test case--- being started, whereas the counts in a problem report do include the--- test case just finished.  The principle is that the counts are sampled--- only between test case executions.  As a result, the number of test--- case successes always equals the difference of test cases tried and--- the sum of test case errors and failures.-performTest :: ReportStart us   -- ^ report generator for the test run start-            -> ReportProblem us -- ^ report generator for errors during the test run-            -> ReportProblem us -- ^ report generator for assertion failures during the test run-            -> us-            -> Test             -- ^ the test to be executed-            -> IO (Counts, us)-performTest reportStart reportError reportFailure initialUs initialT = do-  (ss', us') <- pt initState initialUs initialT-  unless (null (path ss')) $ error "performTest: Final path is nonnull"-  return (counts ss', us')- where-  initState  = State{ path = [], counts = initCounts }-  initCounts = Counts{ cases = testCaseCount initialT, tried = 0,-                       errors = 0, failures = 0}--  pt ss us (TestCase a) = do-    us' <- reportStart ss us-    r <- performTestCase a-    case r of-      Success -> do-        return (ss', us')-      Failure loc m -> do-        usF <- reportFailure loc m ssF us'-        return (ssF, usF)-      Error loc m -> do-        usE <- reportError loc m ssE us'-        return (ssE, usE)-   where c@Counts{ tried = n } = counts ss-         ss' = ss{ counts = c{ tried = n + 1 } }-         ssF = ss{ counts = c{ tried = n + 1, failures = failures c + 1 } }-         ssE = ss{ counts = c{ tried = n + 1, errors   = errors   c + 1 } }--  pt ss us (TestList ts) = foldM f (ss, us) (zip ts [0..])-   where f (ss', us') (t, n) = withNode (ListItem n) ss' us' t--  pt ss us (TestLabel label t) = withNode (Label label) ss us t--  withNode node ss0 us0 t = do (ss2, us1) <- pt ss1 us0 t-                               return (ss2{ path = path0 }, us1)-   where path0 = path ss0-         ss1 = ss0{ path = node : path0 }
− vendor/HUnit-1.6.2.0/src/Test/HUnit/Lang.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}--#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE ConstraintKinds #-}-#define HasCallStack_ HasCallStack =>-#else-#define HasCallStack_-#endif--module Test.HUnit.Lang (-  Assertion,-  assertFailure,-  assertEqual,--  Result (..),-  performTestCase,--- * Internals--- |--- /Note:/ This is not part of the public API!  It is exposed so that you can--- tinker with the internals of HUnit, but do not expect it to be stable!-  HUnitFailure (..),-  FailureReason (..),-  formatFailureReason-) where--import           Control.DeepSeq-import           Control.Exception as E-import           Control.Monad-import           Data.List-import           Data.Typeable-import           Data.CallStack---- | When an assertion is evaluated, it will output a message if and only if the--- assertion fails.------ Test cases are composed of a sequence of one or more assertions.-type Assertion = IO ()--data HUnitFailure = HUnitFailure (Maybe SrcLoc) FailureReason-    deriving (Eq, Show, Typeable)--instance Exception HUnitFailure--data FailureReason = Reason String | ExpectedButGot (Maybe String) String String-    deriving (Eq, Show, Typeable)--location :: HasCallStack_ Maybe SrcLoc-location = case reverse callStack of-  (_, loc) : _ -> Just loc-  [] -> Nothing---- | Unconditionally signals that a failure has occurred.-assertFailure ::-     HasCallStack_-     String -- ^ A message that is displayed with the assertion failure-  -> IO a-assertFailure msg = msg `deepseq` E.throwIO (HUnitFailure location $ Reason msg)---- | Asserts that the specified actual value is equal to the expected value.--- The output message will contain the prefix, the expected value, and the--- actual value.------ If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted--- and only the expected and actual values are output.-assertEqual :: HasCallStack_ (Eq a, Show a)-                              => String -- ^ The message prefix-                              -> a      -- ^ The expected value-                              -> a      -- ^ The actual value-                              -> Assertion-assertEqual preface expected actual =-  unless (actual == expected) $ do-    (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg))-  where-    prefaceMsg-      | null preface = Nothing-      | otherwise = Just preface-    expectedMsg = show expected-    actualMsg = show actual--formatFailureReason :: FailureReason -> String-formatFailureReason (Reason reason) = reason-formatFailureReason (ExpectedButGot preface expected actual) = intercalate "\n" . maybe id (:) preface $ ["expected: " ++ expected, " but got: " ++ actual]--data Result = Success | Failure (Maybe SrcLoc) String | Error (Maybe SrcLoc) String-  deriving (Eq, Show)---- | Performs a single test case.-performTestCase :: Assertion -- ^ an assertion to be made during the test case run-                -> IO Result-performTestCase action =-  (action >> return Success)-     `E.catches`-      [E.Handler (\(HUnitFailure loc reason) -> return $ Failure loc (formatFailureReason reason)),--       -- Re-throw AsyncException, otherwise execution will not terminate on-       -- SIGINT (ctrl-c).  Currently, all AsyncExceptions are being thrown-       -- because it's thought that none of them will be encountered during-       -- normal HUnit operation.  If you encounter an example where this-       -- is not the case, please email the maintainer.-       E.Handler (\e -> throw (e :: E.AsyncException)),--       E.Handler (\e -> return $ Error Nothing $ show (e :: E.SomeException))]
− vendor/HUnit-1.6.2.0/src/Test/HUnit/Terminal.hs 
@@ -1,42 +0,0 @@--- | This module handles the complexities of writing information to the--- terminal, including modifying text in place.--module Test.HUnit.Terminal (-        terminalAppearance-    ) where--import Data.Char (isPrint)----- | Simplifies the input string by interpreting @\\r@ and @\\b@ characters--- specially so that the result string has the same final (or /terminal/,--- pun intended) appearance as would the input string when written to a--- terminal that overwrites character positions following carriage--- returns and backspaces.--terminalAppearance :: String -> String-terminalAppearance str = ta id "" "" str---- | The helper function @ta@ takes an accumulating @ShowS@-style function--- that holds /committed/ lines of text, a (reversed) list of characters--- on the current line /before/ the cursor, a (normal) list of characters--- on the current line /after/ the cursor, and the remaining input.--ta-    :: ([Char] -> t) -- ^ An accumulating @ShowS@-style function-                     -- that holds /committed/ lines of text-    -> [Char] -- ^ A (reversed) list of characters-              -- on the current line /before/ the cursor-    -> [Char] -- ^ A (normal) list of characters-              -- on the current line /after/ the cursor-    -> [Char] -- ^ The remaining input-    -> t-ta f    bs  as ('\n':cs) = ta (\t -> f (reverse bs ++ as ++ '\n' : t)) "" "" cs-ta f    bs  as ('\r':cs) = ta f "" (reverse bs ++ as) cs-ta f (b:bs) as ('\b':cs) = ta f bs (b:as) cs-ta _    ""   _ ('\b': _) = error "'\\b' at beginning of line"-ta f    bs  as (c:cs)-    | not (isPrint c)    = error "invalid nonprinting character"-    | null as            = ta f (c:bs) ""        cs-    | otherwise          = ta f (c:bs) (tail as) cs-ta f    bs  as       ""  = f (reverse bs ++ as)
− vendor/HUnit-1.6.2.0/src/Test/HUnit/Text.hs 
@@ -1,152 +0,0 @@--- | Text-based test controller for running HUnit tests and reporting---   results as text, usually to a terminal.--module Test.HUnit.Text-(-  PutText(..),-  putTextToHandle, putTextToShowS,-  runTestText,-  showPath, showCounts,-  runTestTT,-  runTestTTAndExit-)-where--import Test.HUnit.Base--import Data.CallStack-import Control.Monad (when)-import System.IO (Handle, stderr, hPutStr, hPutStrLn)-import System.Exit (exitSuccess, exitFailure)----- | As the general text-based test controller ('runTestText') executes a---   test, it reports each test case start, error, and failure by---   constructing a string and passing it to the function embodied in a---   'PutText'.  A report string is known as a \"line\", although it includes---   no line terminator; the function in a 'PutText' is responsible for---   terminating lines appropriately.  Besides the line, the function---   receives a flag indicating the intended \"persistence\" of the line:---   'True' indicates that the line should be part of the final overall---   report; 'False' indicates that the line merely indicates progress of---   the test execution.  Each progress line shows the current values of---   the cumulative test execution counts; a final, persistent line shows---   the final count values.------   The 'PutText' function is also passed, and returns, an arbitrary state---   value (called 'st' here).  The initial state value is given in the---   'PutText'; the final value is returned by 'runTestText'.--data PutText st = PutText (String -> Bool -> st -> IO st) st----- | Two reporting schemes are defined here.  @putTextToHandle@ writes--- report lines to a given handle.  'putTextToShowS' accumulates--- persistent lines for return as a whole by 'runTestText'.------ @putTextToHandle@ writes persistent lines to the given handle,--- following each by a newline character.  In addition, if the given flag--- is @True@, it writes progress lines to the handle as well.  A progress--- line is written with no line termination, so that it can be--- overwritten by the next report line.  As overwriting involves writing--- carriage return and blank characters, its proper effect is usually--- only obtained on terminal devices.--putTextToHandle-    :: Handle-    -> Bool -- ^ Write progress lines to handle?-    -> PutText Int-putTextToHandle handle showProgress = PutText put initCnt- where-  initCnt = if showProgress then 0 else -1-  put line pers (-1) = do when pers (hPutStrLn handle line); return (-1)-  put line True  cnt = do hPutStrLn handle (erase cnt ++ line); return 0-  put line False _   = do hPutStr handle ('\r' : line); return (length line)-    -- The "erasing" strategy with a single '\r' relies on the fact that the-    -- lengths of successive summary lines are monotonically nondecreasing.-  erase cnt = if cnt == 0 then "" else "\r" ++ replicate cnt ' ' ++ "\r"----- | Accumulates persistent lines (dropping progess lines) for return by---   'runTestText'.  The accumulated lines are represented by a---   @'ShowS' ('String' -> 'String')@ function whose first argument is the---   string to be appended to the accumulated report lines.--putTextToShowS :: PutText ShowS-putTextToShowS = PutText put id- where put line pers f = return (if pers then acc f line else f)-       acc f line rest = f (line ++ '\n' : rest)----- | Executes a test, processing each report line according to the given---   reporting scheme.  The reporting scheme's state is threaded through calls---   to the reporting scheme's function and finally returned, along with final---   count values.--runTestText :: PutText st -> Test -> IO (Counts, st)-runTestText (PutText put us0) t = do-  (counts', us1) <- performTest reportStart reportError reportFailure us0 t-  us2 <- put (showCounts counts') True us1-  return (counts', us2)- where-  reportStart ss us = put (showCounts (counts ss)) False us-  reportError   = reportProblem "Error:"   "Error in:   "-  reportFailure = reportProblem "Failure:" "Failure in: "-  reportProblem p0 p1 loc msg ss us = put line True us-   where line  = "### " ++ kind ++ path' ++ "\n" ++ formatLocation loc ++ msg-         kind  = if null path' then p0 else p1-         path' = showPath (path ss)--formatLocation :: Maybe SrcLoc -> String-formatLocation Nothing = ""-formatLocation (Just loc) = srcLocFile loc ++ ":" ++ show (srcLocStartLine loc) ++ "\n"---- | Converts test execution counts to a string.--showCounts :: Counts -> String-showCounts Counts{ cases = cases', tried = tried',-                   errors = errors', failures = failures' } =-  "Cases: " ++ show cases' ++ "  Tried: " ++ show tried' ++-  "  Errors: " ++ show errors' ++ "  Failures: " ++ show failures'----- | Converts a test case path to a string, separating adjacent elements by---   the colon (\':\'). An element of the path is quoted (as with 'show') when---   there is potential ambiguity.--showPath :: Path -> String-showPath [] = ""-showPath nodes = foldl1 f (map showNode nodes)- where f b a = a ++ ":" ++ b-       showNode (ListItem n) = show n-       showNode (Label label) = safe label (show label)-       safe s ss = if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s----- | Provides the \"standard\" text-based test controller. Reporting is made to---   standard error, and progress reports are included. For possible---   programmatic use, the final counts are returned.------   The \"TT\" in the name suggests \"Text-based reporting to the Terminal\".--runTestTT :: Test -> IO Counts-runTestTT t = do (counts', 0) <- runTestText (putTextToHandle stderr True) t-                 return counts'---- | Convenience wrapper for 'runTestTT'.---   Simply runs 'runTestTT' and then exits back to the OS,---   using 'exitSuccess' if there were no errors or failures,---   or 'exitFailure' if there were. For example:------   > tests :: Test---   > tests = ...---   >---   > main :: IO ()---   > main = runTestTTAndExit tests--runTestTTAndExit :: Test -> IO ()-runTestTTAndExit tests = do-  c <- runTestTT tests-  if (errors c == 0) && (failures c == 0)-    then exitSuccess-    else exitFailure
− vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations.hs 
@@ -1,189 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ImplicitParams #-}--- |--- Introductory documentation: <https://github.com/sol/hspec-expectations#readme>-module Test.Hspec.Expectations (---- * Setting expectations-  Expectation-, expectationFailure-, shouldBe-, shouldSatisfy-, shouldStartWith-, shouldEndWith-, shouldContain-, shouldMatchList-, shouldReturn--, shouldNotBe-, shouldNotSatisfy-, shouldNotContain-, shouldNotReturn---- * Expecting exceptions-, shouldThrow---- ** Selecting exceptions-, Selector---- ** Predefined type-based selectors--- |--- There are predefined selectors for some standard exceptions.  Each selector--- is just @const True@ with an appropriate type.-, anyException-, anyErrorCall-, anyIOException-, anyArithException---- ** Combinators for defining value-based selectors--- |--- Some exceptions (most prominently `ErrorCall`) have no `Eq` instance.--- Selecting a specific value would require pattern matching.------ For such exceptions, combinators that construct selectors are provided.--- Each combinator corresponds to a constructor; it takes the same arguments,--- and has the same name (but starting with a lower-case letter).-, errorCall---- * Re-exports-, HasCallStack-) where--import qualified Test.HUnit-import           Test.HUnit ((@?=))-import           Control.Exception-import           Data.Typeable-import           Data.List--import           Control.Monad (unless)--import           Test.Hspec.Expectations.Matcher--import           Data.CallStack (HasCallStack)--type Expectation = Test.HUnit.Assertion--expectationFailure :: HasCallStack => String -> Expectation-expectationFailure = Test.HUnit.assertFailure--expectTrue :: HasCallStack => String -> Bool -> Expectation-expectTrue msg b = unless b (expectationFailure msg)--infix 1 `shouldBe`, `shouldSatisfy`, `shouldStartWith`, `shouldEndWith`, `shouldContain`, `shouldMatchList`, `shouldReturn`, `shouldThrow`-infix 1 `shouldNotBe`, `shouldNotSatisfy`, `shouldNotContain`, `shouldNotReturn`---- |--- @actual \`shouldBe\` expected@ sets the expectation that @actual@ is equal--- to @expected@.-shouldBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation-actual `shouldBe` expected = actual @?= expected---- |--- @v \`shouldSatisfy\` p@ sets the expectation that @p v@ is @True@.-shouldSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation-v `shouldSatisfy` p = expectTrue ("predicate failed on: " ++ show v) (p v)--compareWith :: (HasCallStack, Show a) => (a -> a -> Bool) -> String -> a -> a -> Expectation-compareWith comparator errorDesc result expected = expectTrue errorMsg (comparator expected result)-  where-    errorMsg = show result ++ " " ++ errorDesc ++ " " ++ show expected---- |--- @list \`shouldStartWith\` prefix@ sets the expectation that @list@ starts with @prefix@,-shouldStartWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation-shouldStartWith = compareWith isPrefixOf "does not start with"---- |--- @list \`shouldEndWith\` suffix@ sets the expectation that @list@ ends with @suffix@,-shouldEndWith :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation-shouldEndWith = compareWith isSuffixOf "does not end with"---- |--- @list \`shouldContain\` sublist@ sets the expectation that @sublist@ is contained,--- wholly and intact, anywhere in @list@.-shouldContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation-shouldContain = compareWith isInfixOf "does not contain"---- |--- @xs \`shouldMatchList\` ys@ sets the expectation that @xs@ has the same--- elements that @ys@ has, possibly in another order-shouldMatchList :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation-xs `shouldMatchList` ys = maybe (return ()) expectationFailure (matchList xs ys)---- |--- @action \`shouldReturn\` expected@ sets the expectation that @action@--- returns @expected@.-shouldReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation-action `shouldReturn` expected = action >>= (`shouldBe` expected)---- |--- @actual \`shouldNotBe\` notExpected@ sets the expectation that @actual@ is not--- equal to @notExpected@-shouldNotBe :: (HasCallStack, Show a, Eq a) => a -> a -> Expectation-actual `shouldNotBe` notExpected = expectTrue ("not expected: " ++ show actual) (actual /= notExpected)---- |--- @v \`shouldNotSatisfy\` p@ sets the expectation that @p v@ is @False@.-shouldNotSatisfy :: (HasCallStack, Show a) => a -> (a -> Bool) -> Expectation-v `shouldNotSatisfy` p = expectTrue ("predicate succeeded on: " ++ show v) ((not . p) v)---- |--- @list \`shouldNotContain\` sublist@ sets the expectation that @sublist@ is not--- contained anywhere in @list@.-shouldNotContain :: (HasCallStack, Show a, Eq a) => [a] -> [a] -> Expectation-list `shouldNotContain` sublist = expectTrue errorMsg ((not . isInfixOf sublist) list)-  where-    errorMsg = show list ++ " does contain " ++ show sublist---- |--- @action \`shouldNotReturn\` notExpected@ sets the expectation that @action@--- does not return @notExpected@.-shouldNotReturn :: (HasCallStack, Show a, Eq a) => IO a -> a -> Expectation-action `shouldNotReturn` notExpected = action >>= (`shouldNotBe` notExpected)---- |--- A @Selector@ is a predicate; it can simultaneously constrain the type and--- value of an exception.-type Selector a = (a -> Bool)---- |--- @action \`shouldThrow\` selector@ sets the expectation that @action@ throws--- an exception.  The precise nature of the expected exception is described--- with a 'Selector'.-shouldThrow :: (HasCallStack, Exception e) => IO a -> Selector e -> Expectation-action `shouldThrow` p = do-  r <- try action-  case r of-    Right _ ->-      expectationFailure $-        "did not get expected exception: " ++ exceptionType-    Left e ->-      (`expectTrue` p e) $-        "predicate failed on expected exception: " ++ exceptionType ++ " (" ++ show e ++ ")"-  where-    -- a string repsentation of the expected exception's type-    exceptionType = (show . typeOf . instanceOf) p-      where-        instanceOf :: Selector a -> a-        instanceOf _ = error "Test.Hspec.Expectations.shouldThrow: broken Typeable instance"--anyException :: Selector SomeException-anyException = const True--anyErrorCall :: Selector ErrorCall-anyErrorCall = const True--errorCall :: String -> Selector ErrorCall-#if MIN_VERSION_base(4,9,0)-errorCall s (ErrorCallWithLocation msg _) = s == msg-#else-errorCall s (ErrorCall msg) = s == msg-#endif--anyIOException :: Selector IOException-anyIOException = const True--anyArithException :: Selector ArithException-anyArithException = const True
− vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Contrib.hs 
@@ -1,26 +0,0 @@-{-# LANGUAGE CPP #-}--- |--- Experimental combinators, that may become part of the main distribution, if--- they turn out to be useful for a wider audience.-module Test.Hspec.Expectations.Contrib (--- * Predicates--- | (useful in combination with `shouldSatisfy`)-  isLeft-, isRight-) where---#if MIN_VERSION_base(4,7,0)-import Data.Either-#else--isLeft :: Either a b -> Bool-{-# DEPRECATED isLeft "use Data.Either.Compat.isLeft from package base-compat instead" #-}-isLeft (Left  _) = True-isLeft (Right _) = False--isRight :: Either a b -> Bool-{-# DEPRECATED isRight "use Data.Either.Compat.isRight from package base-compat instead" #-}-isRight (Left  _) = False-isRight (Right _) = True-#endif
− vendor/hspec-expectations-0.8.2/src/Test/Hspec/Expectations/Matcher.hs 
@@ -1,26 +0,0 @@-module Test.Hspec.Expectations.Matcher (matchList) where--import           Prelude hiding (showList)-import           Data.List--matchList :: (Show a, Eq a) => [a] -> [a] -> Maybe String-xs `matchList` ys-  | null extra && null missing = Nothing-  | otherwise = Just (err "")-  where-    extra   = xs \\ ys-    missing = ys \\ xs--    msgAndList msg zs = showString msg . showList zs . showString "\n"-    optMsgList msg zs = if null zs then id else msgAndList msg zs--    err :: ShowS-    err =-        showString "Actual list is not a permutation of expected list!\n"-      . msgAndList "  expected list contains:   " ys-      . msgAndList "  actual list contains:     " xs-      . optMsgList "  the missing elements are: " missing-      . optMsgList "  the extra elements are:   " extra--showList :: Show a => [a] -> ShowS-showList xs = showChar '[' . foldr (.) (showChar ']') (intersperse (showString ", ") $ map shows xs)
+ vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP, DeriveDataTypeable, MagicHash, UnboxedTuples #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++{-# OPTIONS -fno-warn-implicit-prelude #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Control.Concurrent.STM.TMVar+-- Copyright   :  (c) The University of Glasgow 2004+-- License     :  BSD-style (see the file libraries/base/LICENSE)+--+-- Maintainer  :  libraries@haskell.org+-- Stability   :  experimental+-- Portability :  non-portable (requires STM)+--+-- TMVar: Transactional MVars, for use in the STM monad+-- (GHC only)+--+-----------------------------------------------------------------------------++module Control.Concurrent.STM.TMVar (+#ifdef __GLASGOW_HASKELL__+        -- * TMVars+        TMVar,+        newTMVar,+        newEmptyTMVar,+        newTMVarIO,+        newEmptyTMVarIO,+        takeTMVar,+        putTMVar,+        readTMVar,+        tryReadTMVar,+        swapTMVar,+        tryTakeTMVar,+        tryPutTMVar,+        isEmptyTMVar,+        mkWeakTMVar+#endif+  ) where++#ifdef __GLASGOW_HASKELL__+import GHC.Base+import GHC.Conc+import GHC.Weak++import Data.Typeable (Typeable)++newtype TMVar a = TMVar (TVar (Maybe a)) deriving (Eq, Typeable)+{- ^+A 'TMVar' is a synchronising variable, used+for communication between concurrent threads.  It can be thought of+as a box, which may be empty or full.+-}++-- |Create a 'TMVar' which contains the supplied value.+newTMVar :: a -> STM (TMVar a)+newTMVar a = do+  t <- newTVar (Just a)+  return (TMVar t)++-- |@IO@ version of 'newTMVar'.  This is useful for creating top-level+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newTMVarIO :: a -> IO (TMVar a)+newTMVarIO a = do+  t <- newTVarIO (Just a)+  return (TMVar t)++-- |Create a 'TMVar' which is initially empty.+newEmptyTMVar :: STM (TMVar a)+newEmptyTMVar = do+  t <- newTVar Nothing+  return (TMVar t)++-- |@IO@ version of 'newEmptyTMVar'.  This is useful for creating top-level+-- 'TMVar's using 'System.IO.Unsafe.unsafePerformIO', because using+-- 'atomically' inside 'System.IO.Unsafe.unsafePerformIO' isn't+-- possible.+newEmptyTMVarIO :: IO (TMVar a)+newEmptyTMVarIO = do+  t <- newTVarIO Nothing+  return (TMVar t)++-- |Return the contents of the 'TMVar'.  If the 'TMVar' is currently+-- empty, the transaction will 'retry'.  After a 'takeTMVar',+-- the 'TMVar' is left empty.+takeTMVar :: TMVar a -> STM a+takeTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> do writeTVar t Nothing; return a++-- | A version of 'takeTMVar' that does not 'retry'.  The 'tryTakeTMVar'+-- function returns 'Nothing' if the 'TMVar' was empty, or @'Just' a@ if+-- the 'TMVar' was full with contents @a@.  After 'tryTakeTMVar', the+-- 'TMVar' is left empty.+tryTakeTMVar :: TMVar a -> STM (Maybe a)+tryTakeTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> return Nothing+    Just a  -> do writeTVar t Nothing; return (Just a)++-- |Put a value into a 'TMVar'.  If the 'TMVar' is currently full,+-- 'putTMVar' will 'retry'.+putTMVar :: TMVar a -> a -> STM ()+putTMVar (TMVar t) a = do+  m <- readTVar t+  case m of+    Nothing -> do writeTVar t (Just a); return ()+    Just _  -> retry++-- | A version of 'putTMVar' that does not 'retry'.  The 'tryPutTMVar'+-- function attempts to put the value @a@ into the 'TMVar', returning+-- 'True' if it was successful, or 'False' otherwise.+tryPutTMVar :: TMVar a -> a -> STM Bool+tryPutTMVar (TMVar t) a = do+  m <- readTVar t+  case m of+    Nothing -> do writeTVar t (Just a); return True+    Just _  -> return False++-- | This is a combination of 'takeTMVar' and 'putTMVar'; ie. it+-- takes the value from the 'TMVar', puts it back, and also returns+-- it.+readTMVar :: TMVar a -> STM a+readTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> return a++-- | A version of 'readTMVar' which does not retry. Instead it+-- returns @Nothing@ if no value is available.+--+-- @since 2.3+tryReadTMVar :: TMVar a -> STM (Maybe a)+tryReadTMVar (TMVar t) = readTVar t++-- |Swap the contents of a 'TMVar' for a new value.+swapTMVar :: TMVar a -> a -> STM a+swapTMVar (TMVar t) new = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just old -> do writeTVar t (Just new); return old++-- |Check whether a given 'TMVar' is empty.+isEmptyTMVar :: TMVar a -> STM Bool+isEmptyTMVar (TMVar t) = do+  m <- readTVar t+  case m of+    Nothing -> return True+    Just _  -> return False++-- | Make a 'Weak' pointer to a 'TMVar', using the second argument as+-- a finalizer to run when the 'TMVar' is garbage-collected.+--+-- @since 2.4.4+mkWeakTMVar :: TMVar a -> IO () -> IO (Weak (TMVar a))+mkWeakTMVar tmv@(TMVar (TVar t#)) (IO finalizer) = IO $ \s ->+    case mkWeak# t# tmv finalizer s of (# s1, w #) -> (# s1, Weak w #)+#endif
− version.yaml 
@@ -1,1 +0,0 @@-&version 2.10.5