packages feed

tasty 0.7 → 0.8

raw patch · 20 files changed

+994/−307 lines, 20 filesdep +asyncdep +ghc-primdep +unbounded-delaysdep −eitherdep ~regex-tdfa

Dependencies added: async, ghc-prim, unbounded-delays

Dependencies removed: either

Dependency ranges changed: regex-tdfa

Files

+ CHANGELOG view
@@ -0,0 +1,1 @@+See https://github.com/feuerbach/tasty/blob/master/CHANGES.md
Test/Tasty.hs view
@@ -15,9 +15,16 @@   -- | Normally options are specified on the command line. But you can   -- also have different options for different subtrees in the same tree,   -- using the functions below.+  --+  -- Note that /ingredient options/ (number of threads, hide successes+  -- etc.) set in this way will not have any effect. This is for modifying+  -- per-test options, such as timeout, number of generated tests etc.   , adjustOption   , localOption   , askOption+  -- ** Standard options+  , Timeout(..)+  , mkTimeout   -- * Resources   -- | Sometimes several tests need to access the same resource — say,   -- a file or a socket. We want to create or grab the resource before@@ -29,7 +36,8 @@ import Test.Tasty.Core import Test.Tasty.Runners import Test.Tasty.Options-import Test.Tasty.Ingredients.IncludingOptions+import Test.Tasty.Options.Core+import Test.Tasty.Ingredients.Basic  -- | List of the default ingredients. This is what 'defaultMain' uses. --
Test/Tasty/CmdLine.hs view
@@ -10,31 +10,21 @@ import Options.Applicative import Data.Monoid import Data.Proxy+import Data.Foldable import System.Exit - import Test.Tasty.Core-import Test.Tasty.CoreOptions import Test.Tasty.Ingredients import Test.Tasty.Options+import Test.Tasty.Options.Env+import Test.Tasty.Runners.Reducers  -- | Generate a command line parser from a list of option descriptions optionParser :: [OptionDescription] -> Parser OptionSet-optionParser = foldr addOption (pure mempty) where-  addOption :: OptionDescription -> Parser OptionSet -> Parser OptionSet-  addOption (Option (Proxy :: Proxy v)) p =-    setOption <$> (optionCLParser :: Parser v) <*> p---- suiteOptions doesn't really belong here (since it's not CmdLine--- specific), but I didn't want to create a new module just for it.---- | All the options relevant for this test suite. This includes the--- options for the test tree and ingredients, and the core options.-suiteOptions :: [Ingredient] -> TestTree -> [OptionDescription]-suiteOptions ins tree =-  coreOptions ++-  ingredientsOptions ins ++-  treeOptions tree+optionParser = getApp . foldMap toSet where+  toSet :: OptionDescription -> Ap Parser OptionSet+  toSet (Option (Proxy :: Proxy v)) = Ap $+    (singleOption <$> (optionCLParser :: Parser v)) <|> pure mempty  -- | The command line parser for the test suite suiteOptionParser :: [Ingredient] -> TestTree -> Parser OptionSet@@ -44,11 +34,15 @@ -- ingredient list defaultMainWithIngredients :: [Ingredient] -> TestTree -> IO () defaultMainWithIngredients ins testTree = do-  opts <- execParser $+  cmdlineOpts <- execParser $     info (helper <*> suiteOptionParser ins testTree)     ( fullDesc <>       header "Mmm... tasty test suite"     )++  envOpts <- suiteEnvOptions ins testTree++  let opts = envOpts <> cmdlineOpts    case tryIngredients ins opts testTree of     Nothing ->
Test/Tasty/Core.hs view
@@ -1,9 +1,9 @@ -- | Core types and definitions {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,-             ExistentialQuantification, RankNTypes, DeriveDataTypeable #-}+             ExistentialQuantification, RankNTypes, DeriveDataTypeable,+             DeriveGeneric #-} module Test.Tasty.Core where -import Control.Applicative import Control.Exception import Test.Tasty.Options import Test.Tasty.Patterns@@ -12,14 +12,35 @@ import Data.Typeable import qualified Data.Map as Map import Data.Tagged+import GHC.Generics import Text.Printf +-- | If a test failed, 'FailureReason' describes why+data FailureReason+  = TestFailed+    -- ^ test provider indicated failure+  | TestThrewException SomeException+    -- ^ test resulted in an exception. Note that some test providers may+    -- catch exceptions in order to provide more meaningful errors. In that+    -- case, the 'FailureReason' will be 'TestFailed', not+    -- 'TestThrewException'.+  | TestTimedOut Integer+    -- ^ test didn't complete in allotted time+  deriving Show++-- | Outcome of a test run+--+-- Note: this is isomorphic to @'Maybe' 'FailureReason'@. You can use the+-- @generic-maybe@ package to exploit that.+data Outcome+  = Success -- ^ test succeeded+  | Failure FailureReason -- ^ test failed because of the 'FailureReason'+  deriving (Show, Generic)+ -- | A test result data Result = Result-  { resultSuccessful :: Bool-    -- ^-    -- 'resultSuccessful' should be 'True' for a passed test and 'False' for-    -- a failed one.+  { resultOutcome :: Outcome+    -- ^ Did the test fail? If so, why?   , resultDescription :: String     -- ^     -- 'resultDescription' may contain some details about the test. For@@ -31,6 +52,20 @@     -- information about the failure.   } +-- | 'True' for a passed test, 'False' for a failed one.+resultSuccessful :: Result -> Bool+resultSuccessful r =+  case resultOutcome r of+    Success -> True+    Failure {} -> False++-- | Shortcut for creating a 'Result' that indicates exception+exceptionResult :: SomeException -> Result+exceptionResult e = Result+  { resultOutcome = Failure $ TestThrewException e+  , resultDescription = "Exception: " ++ show e+  }+ -- | Test progress information. -- -- This may be used by a runner to provide some feedback to the user while@@ -66,17 +101,21 @@ -- and how to release it (the second field). data ResourceSpec a = ResourceSpec (IO a) (a -> IO ()) +-- | A resources-related exception data ResourceError   = NotRunningTests-  | UnexpectedState String+  | UnexpectedState String String+  | UseOutsideOfTest   deriving Typeable  instance Show ResourceError where   show NotRunningTests =     "Unhandled resource. Probably a bug in the runner you're using."-  show (UnexpectedState state) =-    printf "Unexpected state of the resource (%s). Report as a tasty bug."-      state+  show (UnexpectedState where_ what) =+    printf "Unexpected state of the resource (%s) in %s. Report as a tasty bug."+      what where_+  show UseOutsideOfTest =+    "It looks like you're attempting to use a resource outside of its test. Don't do that!"  instance Exception ResourceError @@ -180,12 +219,6 @@         PlusTestOptions f tree -> go pat path (f opts) tree         WithResource res tree -> fResource res $ \res -> go pat path opts (tree res)         AskOptions f -> go pat path opts (f opts)---- | Useful wrapper for use with foldTestTree-newtype AppMonoid f = AppMonoid { getApp :: f () }-instance Applicative f => Monoid (AppMonoid f) where-  mempty = AppMonoid $ pure ()-  AppMonoid f1 `mappend` AppMonoid f2 = AppMonoid $ f1 *> f2  -- | Get the list of options that are relevant for a given test tree treeOptions :: TestTree -> [OptionDescription]
− Test/Tasty/CoreOptions.hs 
@@ -1,35 +0,0 @@--- | Core options, i.e. the options used by tasty itself-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}-module Test.Tasty.CoreOptions-  ( NumThreads(..)-  , coreOptions-  )-  where--import Data.Typeable-import Data.Proxy--import Test.Tasty.Options-import Test.Tasty.Patterns---- | Number of parallel threads to use for running tests.------ Note that this is /not/ included in 'coreOptions'.--- Instead, it's automatically included in the options for any--- 'TestReporter' ingredient by 'ingredientOptions', because the way test--- reporters are handled already involves parallelism. Other ingredients--- may also choose to include this option.-newtype NumThreads = NumThreads { getNumThreads :: Int }-  deriving (Eq, Ord, Num, Typeable)-instance IsOption NumThreads where-  defaultValue = 1-  parseValue = fmap NumThreads . safeRead-  optionName = return "num-threads"-  optionHelp = return "Number of threads to use for tests execution"---- | The list of all core options, i.e. the options not specific to any--- provider or ingredient, but to tasty itself. Currently only contains 'TestPattern'.-coreOptions :: [OptionDescription]-coreOptions =-  [ Option (Proxy :: Proxy TestPattern)-  ]
Test/Tasty/Ingredients.hs view
@@ -1,8 +1,13 @@+-- | This module contains the core definitions related to ingredients.+--+-- Ingredients themselves are provided by other modules (usually under+-- the @Test.Tasty.Ingredients.*@ hierarchy). module Test.Tasty.Ingredients   ( Ingredient(..)   , tryIngredients   , ingredientOptions   , ingredientsOptions+  , suiteOptions   ) where  import Control.Monad@@ -12,7 +17,7 @@ import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Options-import Test.Tasty.CoreOptions+import Test.Tasty.Options.Core  -- | 'Ingredient's make your test suite tasty. --@@ -74,7 +79,7 @@ tryIngredient :: Ingredient -> OptionSet -> TestTree -> Maybe (IO Bool) tryIngredient (TestReporter _ report) opts testTree = do -- Maybe monad   reportFn <- report opts testTree-  return $ reportFn =<< launchTestTree opts testTree+  return $ launchTestTree opts testTree $ \smap -> reportFn smap tryIngredient (TestManager _ manage) opts testTree =   manage opts testTree @@ -99,3 +104,11 @@ -- | Like 'ingredientOption', but folds over multiple ingredients. ingredientsOptions :: [Ingredient] -> [OptionDescription] ingredientsOptions = F.foldMap ingredientOptions++-- | All the options relevant for this test suite. This includes the+-- options for the test tree and ingredients, and the core options.+suiteOptions :: [Ingredient] -> TestTree -> [OptionDescription]+suiteOptions ins tree =+  coreOptions +++  ingredientsOptions ins +++  treeOptions tree
+ Test/Tasty/Ingredients/Basic.hs view
@@ -0,0 +1,23 @@+-- | This module exports the basic ingredients defined in the 'tasty'+-- packages.+--+-- Note that if @defaultIngredients@ from "Test.Tasty" suits your needs,+-- use that instead of importing this module.+module Test.Tasty.Ingredients.Basic+  (+    -- ** Console test reporter+    consoleTestReporter+  , Quiet(..)+  , HideSuccesses(..)+    -- ** Listing tests+  , listingTests+  , ListTests(..)+  , testsNames+    -- ** Adding options+  , includingOptions+  )+  where++import Test.Tasty.Ingredients.ConsoleReporter+import Test.Tasty.Ingredients.ListTests+import Test.Tasty.Ingredients.IncludingOptions
Test/Tasty/Ingredients/ConsoleReporter.hs view
@@ -1,9 +1,15 @@-{-# LANGUAGE TupleSections, CPP, ImplicitParams #-}+-- vim:fdm=marker:foldtext=foldtext()+{-# LANGUAGE BangPatterns, CPP, ImplicitParams, MultiParamTypeClasses, DeriveDataTypeable #-} -- | Console reporter ingredient-module Test.Tasty.Ingredients.ConsoleReporter (consoleTestReporter) where+module Test.Tasty.Ingredients.ConsoleReporter+  ( consoleTestReporter+  , Quiet(..)+  , HideSuccesses(..)+  ) where  import Prelude hiding (fail) import Control.Monad.State hiding (fail)+import Control.Monad.Reader hiding (fail) import Control.Concurrent.STM import Control.Exception import Control.DeepSeq@@ -12,27 +18,335 @@ import Test.Tasty.Run import Test.Tasty.Ingredients import Test.Tasty.Options+import Test.Tasty.Runners.Reducers import Text.Printf import qualified Data.IntMap as IntMap import Data.Maybe import Data.Monoid+import Data.Proxy+import Data.Typeable+import Data.Foldable (foldMap) import System.IO  #ifdef COLORS import System.Console.ANSI #endif -data RunnerState = RunnerState-  { ix :: !Int-  , nestedLevel :: !Int-  , failures :: !Int+--------------------------------------------------+-- TestOutput base definitions+--------------------------------------------------+-- {{{+-- | 'TestOutput' is an intermediary between output formatting and output+-- printing. It lets us have several different printing modes (normal; print+-- failures only; quiet).+data TestOutput+  = PrintTest+      {- print test name   -} (IO ())+      {- print test result -} (Result -> IO ())+  | PrintHeading (IO ()) TestOutput+  | Skip+  | Seq TestOutput TestOutput++-- The monoid laws should hold observationally w.r.t. the semantics defined+-- in this module+instance Monoid TestOutput where+  mempty = Skip+  mappend = Seq++type Level = Int++produceOutput :: (?colors :: Bool) => OptionSet -> TestTree -> TestOutput+produceOutput opts tree =+  let+    -- Do not retain the reference to the tree more than necessary+    !alignment = computeAlignment opts tree++    runSingleTest+      :: (IsTest t, ?colors :: Bool)+      => OptionSet -> TestName -> t -> Ap (Reader Level) TestOutput+    runSingleTest _opts name _test = Ap $ do+      level <- ask++      let+        printTestName =+          printf "%s%s: %s" (indent level) name+            (replicate (alignment - indentSize * level - length name) ' ')++        printTestResult result = do+          rDesc <- formatMessage $ resultDescription result++          if resultSuccessful result+            then ok "OK\n"+            else fail "FAIL\n"++          when (not $ null rDesc) $+            (if resultSuccessful result then infoOk else infoFail) $+              printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)++      return $ PrintTest printTestName printTestResult++    runGroup :: TestName -> Ap (Reader Level) TestOutput -> Ap (Reader Level) TestOutput+    runGroup name grp = Ap $ do+      level <- ask+      let+        printHeading = printf "%s%s\n" (indent level) name+        printBody = runReader (getApp grp) (level + 1)+      return $ PrintHeading printHeading printBody++  in+    flip runReader 0 $ getApp $+      foldTestTree+        trivialFold+          { foldSingle = runSingleTest+          , foldGroup = runGroup+          }+          opts tree++foldTestOutput+  :: (?colors :: Bool, Monoid b)+  => (IO () -> IO Result -> (Result -> IO ()) -> b)+  -> (IO () -> b -> b)+  -> TestOutput -> StatusMap -> b+foldTestOutput foldTest foldHeading outputTree smap =+  flip evalState 0 $ getApp $ go outputTree where+  go (PrintTest printName printResult) = Ap $ do+    ix <- get+    put $! ix + 1+    let+      statusVar =+        fromMaybe (error "internal error: index out of bounds") $+        IntMap.lookup ix smap+      readStatusVar = getResultFromTVar statusVar+    return $ foldTest printName readStatusVar printResult+  go (PrintHeading printName printBody) = Ap $+    foldHeading printName <$> getApp (go printBody)+  go (Seq a b) = mappend (go a) (go b)+  go Skip = mempty++-- }}}++--------------------------------------------------+-- TestOutput modes+--------------------------------------------------+-- {{{+consoleOutput :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()+consoleOutput output smap =+  getTraversal . fst $ foldTestOutput foldTest foldHeading output smap+  where+    foldTest printName getResult printResult =+      ( Traversal $ do+          printName+          r <- getResult+          printResult r+      , Any True)+    foldHeading printHeading (printBody, Any nonempty) =+      ( Traversal $ do+          when nonempty $ do printHeading; getTraversal printBody+      , Any nonempty+      )++consoleOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()+consoleOutputHidingSuccesses output smap =+  void . getApp $ foldTestOutput foldTest foldHeading output smap+  where+    foldTest printName getResult printResult =+      Ap $ do+          printName+          r <- getResult+          if resultSuccessful r+            then do clearThisLine; return $ Any False+            else do printResult r; return $ Any True++    foldHeading printHeading printBody =+      Ap $ do+        printHeading+        Any failed <- getApp printBody+        unless failed clearAboveLine+        return $ Any failed++    clearAboveLine = do cursorUpLine 1; clearThisLine+    clearThisLine = do clearLine; setCursorColumn 0++streamOutputHidingSuccesses :: (?colors :: Bool) => TestOutput -> StatusMap -> IO ()+streamOutputHidingSuccesses output smap =+  void . flip evalStateT [] . getApp $+    foldTestOutput foldTest foldHeading output smap+  where+    foldTest printName getResult printResult =+      Ap $ do+          r <- liftIO $ getResult+          if resultSuccessful r+            then return $ Any False+            else do+              stack <- get+              put []++              liftIO $ do+                sequence_ $ reverse stack+                printName+                printResult r++              return $ Any True++    foldHeading printHeading printBody =+      Ap $ do+        modify (printHeading :)+        Any failed <- getApp printBody+        unless failed $+          modify $ \stack ->+            case stack of+              _:rest -> rest+              [] -> [] -- shouldn't happen anyway+        return $ Any failed++-- }}}++--------------------------------------------------+-- Statistics+--------------------------------------------------+-- {{{++data Statistics = Statistics+  { statTotal :: !Int+  , statFailures :: !Int   } -initialState :: RunnerState-initialState = RunnerState 0 0 0+instance Monoid Statistics where+  Statistics t1 f1 `mappend` Statistics t2 f2 = Statistics (t1 + t2) (f1 + f2)+  mempty = Statistics 0 0 -type M = StateT RunnerState IO+computeStatistics :: StatusMap -> IO Statistics+computeStatistics = getApp . foldMap (\var -> Ap $+  (\r -> Statistics 1 (if resultSuccessful r then 0 else 1))+    <$> getResultFromTVar var) +printStatistics :: (?colors :: Bool) => Statistics -> IO ()+printStatistics st = do+  printf "\n"++  case statFailures st of+    0 -> do+      ok $ printf "All %d tests passed\n" (statTotal st)++    fs -> do+      fail $ printf "%d out of %d tests failed\n" fs (statTotal st)++data FailureStatus+  = Unknown+  | Failed+  | OK++instance Monoid FailureStatus where+  mappend Failed _ = Failed+  mappend _ Failed = Failed++  mappend OK OK = OK++  mappend _ _ = Unknown++  mempty = OK++failureStatus :: StatusMap -> IO FailureStatus+failureStatus smap = atomically $ do+  fst <- getApp $ flip foldMap smap $ \svar -> Ap $ do+    status <- readTVar svar+    return $ case status of+        Done r ->+          if resultSuccessful r then OK else Failed+        _ -> Unknown+  case fst of+    Unknown -> retry+    _ -> return fst++-- }}}++--------------------------------------------------+-- Console test reporter+--------------------------------------------------+-- {{{++-- | A simple console UI+consoleTestReporter :: Ingredient+consoleTestReporter =+  TestReporter+    [ Option (Proxy :: Proxy Quiet)+    , Option (Proxy :: Proxy HideSuccesses)+    ] $+  \opts tree -> Just $ \smap ->++  do+  isTerm <- hIsTerminalDevice stdout+  hSetBuffering stdout NoBuffering++  let+    ?colors = isTerm+  let+    Quiet quiet = lookupOption opts+    HideSuccesses hideSuccesses = lookupOption opts++    output = produceOutput opts tree++  case () of { _+    | quiet -> return ()+    | hideSuccesses && isTerm ->+        consoleOutputHidingSuccesses output smap+    | hideSuccesses && not isTerm ->+        streamOutputHidingSuccesses output smap+    | otherwise -> consoleOutput output smap+  }++  if quiet+    then do+      fst <- failureStatus smap+      return $ case fst of+        OK -> True+        _ -> False+    else do+      stats <- computeStatistics smap+      printStatistics stats+      return $ statFailures stats == 0++-- | Do not print test results (see README for details)+newtype Quiet = Quiet Bool+  deriving (Eq, Ord, Typeable)+instance IsOption Quiet where+  defaultValue = Quiet False+  parseValue = fmap Quiet . safeRead+  optionName = return "quiet"+  optionHelp = return "Do not produce any output; indicate success only by the exit code"+  optionCLParser = flagCLParser (Just 'q') (Quiet True)++-- | Report only failed tests+newtype HideSuccesses = HideSuccesses Bool+  deriving (Eq, Ord, Typeable)+instance IsOption HideSuccesses where+  defaultValue = HideSuccesses False+  parseValue = fmap HideSuccesses . safeRead+  optionName = return "hide-successes"+  optionHelp = return "Do not print tests that passed successfully"+  optionCLParser = flagCLParser Nothing (HideSuccesses True)++-- }}}++--------------------------------------------------+-- Various utilities+--------------------------------------------------+-- {{{+getResultFromTVar :: TVar Status -> IO Result+getResultFromTVar var =+  atomically $ do+    status <- readTVar var+    case status of+      Done r -> return r+      _ -> retry++-- }}}++--------------------------------------------------+-- Formatting+--------------------------------------------------+-- {{{+ indentSize :: Int indentSize = 2 @@ -89,96 +403,6 @@         MinusInfinity -> 0         Maximum x -> x --- | A simple console UI-consoleTestReporter :: Ingredient--- We fold the test tree using (AppMonoid m, Any) monoid.------ The 'Any' part is needed to know whether a group is empty, in which case--- we shouldn't display it.-consoleTestReporter = TestReporter [] $ \opts tree -> Just $ \smap -> do-  isTerm <- hIsTerminalDevice stdout--  let-    ?colors = isTerm--  let-    alignment = computeAlignment opts tree--    runSingleTest-      :: (IsTest t, ?colors :: Bool)-      => IntMap.IntMap (TVar Status)-      -> OptionSet -> TestName -> t -> (AppMonoid M, Any)-    runSingleTest smap _opts name _test = (, Any True) $ AppMonoid $ do-      st@RunnerState { ix = ix, nestedLevel = level } <- get-      let-        statusVar =-          fromMaybe (error "internal error: index out of bounds") $-          IntMap.lookup ix smap--      -- Print the test name before waiting for the test. This is useful-      -- for long-running tests.-      liftIO $ printf "%s%s: %s" (indent level) name-        (replicate (alignment - indentSize * level - length name) ' ')--      (rOk, rDesc) <--        liftIO $ atomically $ do-          status <- readTVar statusVar-          case status of-            Done r -> return $ (resultSuccessful r, resultDescription r)-            Exception e -> return (False, "Exception: " ++ show e)-            _ -> retry--      rDesc <- liftIO $ formatMessage rDesc--      liftIO $-        if rOk-          then ok "OK\n"-          else fail "FAIL\n"--      when (not $ null rDesc) $-        liftIO $ (if rOk then infoOk else infoFail) $-          printf "%s%s\n" (indent $ level + 1) (formatDesc (level+1) rDesc)-      let-        ix' = ix+1-        updateFailures = if rOk then id else (+1)-      put $! st { ix = ix', failures = updateFailures (failures st) }--    runGroup :: TestName -> (AppMonoid M, Any) -> (AppMonoid M, Any)-    runGroup _ (_, Any False) = mempty-    runGroup name (AppMonoid act, nonEmpty) = (, nonEmpty) $ AppMonoid $ do-      st@RunnerState { nestedLevel = level } <- get-      liftIO $ printf "%s%s\n" (indent level) name-      put $! st { nestedLevel = level + 1 }-      act-      modify $ \st -> st { nestedLevel = level }--  hSetBuffering stdout NoBuffering--  -- Do not retain the reference to the tree more than necessary-  _ <- evaluate alignment--  st <--    flip execStateT initialState $ getApp $ fst $-      foldTestTree-        trivialFold-          { foldSingle = runSingleTest smap-          , foldGroup = runGroup-          }-        opts-        tree--  printf "\n"--  case failures st of-    0 -> do-      ok $ printf "All %d tests passed\n" (ix st)-      return True--    fs -> do-      fail $ printf "%d out of %d tests failed\n" fs (ix st)-      return False-- -- | Printing exceptions or other messages is tricky — in the process we -- can get new exceptions! --@@ -226,3 +450,5 @@ infoOk   = putStr infoFail = putStr #endif++-- }}}
Test/Tasty/Ingredients/IncludingOptions.hs view
@@ -1,3 +1,4 @@+-- | Ingredient for registering user-defined options module Test.Tasty.Ingredients.IncludingOptions where  import Test.Tasty.Ingredients
Test/Tasty/Ingredients/ListTests.hs view
@@ -1,3 +1,4 @@+-- | Ingredient for listing test names {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Test.Tasty.Ingredients.ListTests   ( ListTests(..)@@ -5,10 +6,8 @@   , listingTests   ) where -import Options.Applicative import Data.Typeable import Data.Proxy-import Data.Tagged  import Test.Tasty.Core import Test.Tasty.Options@@ -23,13 +22,7 @@   parseValue = fmap ListTests . safeRead   optionName = return "list-tests"   optionHelp = return "Do not run the tests; just print their names"-  optionCLParser =-    fmap ListTests $-    switch-      (  short 'l'-      <> long (untag (optionName :: Tagged ListTests String))-      <> help (untag (optionHelp :: Tagged ListTests String))-      )+  optionCLParser = flagCLParser (Just 'l') (ListTests True)  -- | Obtain the list of all tests in the suite testsNames :: OptionSet -> TestTree -> [TestName]
Test/Tasty/Options.hs view
@@ -13,8 +13,10 @@   , setOption   , changeOption   , lookupOption+  , singleOption   , OptionDescription(..)     -- * Utilities+  , flagCLParser   , safeRead   ) where @@ -24,6 +26,7 @@ import Data.Tagged import Data.Proxy import Data.Monoid+import Data.Foldable  import Options.Applicative import Options.Applicative.Types@@ -48,12 +51,22 @@   --   -- Even if you override this, you still should implement all the methods   -- above, to allow alternative interfaces.+  --+  -- Do not supply a default value here for this parser!+  -- This is because if no value was provided on the command line we may+  -- lookup the option e.g. in the environment. But if the parser always+  -- succeeds, we have no way to tell whether the user really provided the+  -- option on the command line.++  -- (If we don't specify a default, the option becomes mandatory.+  -- So, when we build the complete parser for OptionSet, we turn a+  -- failing parser into an always-succeeding one that may return an empty+  -- OptionSet.)   optionCLParser :: Parser v   optionCLParser =     nullOption       (  reader parse       <> long name-      <> value defaultValue       <> help helpString       )     where@@ -95,10 +108,26 @@ changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet changeOption f s = setOption (f $ lookupOption s) s +-- | Create a singleton 'OptionSet'+singleOption :: IsOption v => v -> OptionSet+singleOption v = setOption v mempty+ -- | The purpose of this data type is to capture the dictionary -- corresponding to a particular option. data OptionDescription where   Option :: IsOption v => Proxy v -> OptionDescription++-- | Command-line parser to use with flags+flagCLParser+  :: forall v . IsOption v+  => Maybe Char -- ^ optional short flag+  -> v          -- ^ non-default value (when the flag is supplied)+  -> Parser v+flagCLParser mbShort v = flag' v+  (  foldMap short mbShort+  <> long (untag (optionName :: Tagged v String))+  <> help (untag (optionHelp :: Tagged v String))+  )  -- | Safe read function. Defined here for convenience to use for -- 'parseValue'.
+ Test/Tasty/Options/Core.hs view
@@ -0,0 +1,112 @@+-- | Core options, i.e. the options used by tasty itself+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- for (^)+module Test.Tasty.Options.Core+  ( NumThreads(..)+  , Timeout(..)+  , mkTimeout+  , coreOptions+  )+  where++import Data.Typeable+import Data.Proxy+import Data.Tagged+import Data.Fixed+import Options.Applicative+import Options.Applicative.Types (ReadM(..))++import Test.Tasty.Options+import Test.Tasty.Patterns++-- | Number of parallel threads to use for running tests.+--+-- Note that this is /not/ included in 'coreOptions'.+-- Instead, it's automatically included in the options for any+-- 'TestReporter' ingredient by 'ingredientOptions', because the way test+-- reporters are handled already involves parallelism. Other ingredients+-- may also choose to include this option.+newtype NumThreads = NumThreads { getNumThreads :: Int }+  deriving (Eq, Ord, Num, Typeable)+instance IsOption NumThreads where+  defaultValue = 1+  parseValue = fmap NumThreads . safeRead+  optionName = return "num-threads"+  optionHelp = return "Number of threads to use for tests execution"+  optionCLParser =+    nullOption+      (  reader parse+      <> short 'j'+      <> long name+      <> help (untag (optionHelp :: Tagged NumThreads String))+      )+    where+      name = untag (optionName :: Tagged NumThreads String)+      parse =+        ReadM .+        maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right .+        parseValue++-- | Timeout to be applied to individual tests+data Timeout+  = Timeout Integer String+    -- ^ 'String' is the original representation of the timeout (such as+    -- @\"0.5m\"@), so that we can print it back. 'Integer' is the number of+    -- microseconds.+  | NoTimeout+  deriving (Show, Typeable)++instance IsOption Timeout where+  defaultValue = NoTimeout+  parseValue str =+    Timeout+      <$> parseTimeout str+      <*> pure str+  optionName = return "timeout"+  optionHelp = return "Timeout for individual tests (suffixes: ms,s,m,h; default: s)"+  optionCLParser =+    nullOption+      (  reader parse+      <> short 't'+      <> long name+      <> help (untag (optionHelp :: Tagged Timeout String))+      )+    where+      name = untag (optionName :: Tagged Timeout String)+      parse =+        ReadM .+        maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right .+        parseValue++parseTimeout :: String -> Maybe Integer+parseTimeout str =+  -- it sucks that there's no more direct way to convert to a number of+  -- microseconds+  (round :: Micro -> Integer) . (* 10^6) <$>+  case reads str of+    [(n, suffix)] ->+      case suffix of+        "ms" -> Just (n / 10^3)+        "" -> Just n+        "s" -> Just n+        "m" -> Just (n * 60)+        "h" -> Just (n * 60^2)+        _ -> Nothing+    _ -> Nothing++-- | A shortcut for creating 'Timeout' values+mkTimeout+  :: Integer -- ^ microseconds+  -> Timeout+mkTimeout n =+  Timeout n $+    showFixed True (fromInteger n / (10^6) :: Micro) ++ "s"++-- | The list of all core options, i.e. the options not specific to any+-- provider or ingredient, but to tasty itself. Currently contains+-- 'TestPattern' and 'Timeout'.+coreOptions :: [OptionDescription]+coreOptions =+  [ Option (Proxy :: Proxy TestPattern)+  , Option (Proxy :: Proxy Timeout)+  ]
+ Test/Tasty/Options/Env.hs view
@@ -0,0 +1,62 @@+-- | Get options from the environment+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+module Test.Tasty.Options.Env (getEnvOptions, suiteEnvOptions) where++import Test.Tasty.Options+import Test.Tasty.Core+import Test.Tasty.Ingredients+import Test.Tasty.Runners.Reducers++import System.Environment+import Data.Foldable+import Data.Tagged+import Data.Proxy+import Data.Char+import Data.Typeable+import Control.Exception+import Control.Applicative+import Text.Printf++data EnvOptionException+  = BadOption+      String -- option name+      String -- variable name+      String -- value+  deriving (Typeable)++instance Show EnvOptionException where+  show (BadOption optName varName value) =+    printf+      "Bad environment variable %s='%s' (parsed as option %s)"+        varName value optName++instance Exception EnvOptionException++-- | Search the environment for given options+getEnvOptions :: [OptionDescription] -> IO OptionSet+getEnvOptions = getApp . foldMap lookupOpt+  where+    lookupOpt (Option (px :: Proxy v)) = do+      let+        name = proxy optionName px+        envName = ("TASTY_" ++) . flip map name $ \c ->+          if c == '-'+            then '_'+            else toUpper c+      mbValueStr <- Ap $ myLookupEnv envName+      flip foldMap mbValueStr $ \valueStr ->+        let+          mbValue :: Maybe v+          mbValue = parseValue valueStr++          err = throwIO $ BadOption name envName valueStr++        in Ap $ maybe err (return . singleOption) mbValue++-- | Search the environment for all options relevant for this suite+suiteEnvOptions :: [Ingredient] -> TestTree -> IO OptionSet+suiteEnvOptions ins tree = getEnvOptions $ suiteOptions ins tree++-- note: switch to lookupEnv once we no longer support 7.4+myLookupEnv :: String -> IO (Maybe String)+myLookupEnv name = either (const Nothing) Just <$> (try (getEnv name) :: IO (Either IOException String))
Test/Tasty/Parallel.hs view
@@ -1,4 +1,5 @@ -- | A helper module which takes care of parallelism+{-# LANGUAGE DeriveDataTypeable #-} module Test.Tasty.Parallel (runInParallel) where  import Control.Monad@@ -6,13 +7,35 @@ import Control.Concurrent.STM import Control.Exception import Foreign.StablePtr+import Data.Typeable +data Interrupt = Interrupt+  deriving Typeable+instance Show Interrupt where+  show Interrupt = "interrupted"+instance Exception Interrupt++data ParThreadKilled = ParThreadKilled SomeException+  deriving Typeable+instance Show ParThreadKilled where+  show (ParThreadKilled exn) =+    "tasty: one of the test running threads was killed by: " +++    show exn+instance Exception ParThreadKilled++shutdown :: ThreadId -> IO ()+shutdown = flip throwTo Interrupt+ -- | Take a list of actions and execute them in parallel, no more than @n@--- at the same time+-- at the same time.+--+-- The action itself is asynchronous, ie. it returns immediately and does+-- the work in new threads. It returns an action which aborts tests and+-- cleans up. runInParallel   :: Int -- ^ maximum number of parallel threads   -> [IO ()] -- ^ list of actions to execute-  -> IO ()+  -> IO (IO ()) -- This implementation tries its best to ensure that exceptions are -- properly propagated to the caller and threads are not left running. --@@ -41,21 +64,33 @@    let     -- Kill all threads.-    killAll :: IO ()-    killAll = do+    shutdownAll :: IO ()+    shutdownAll = do       pids <- atomically $ do         writeTVar aliveVar False         readTVar pidsVar        -- be sure not to kill myself!       me <- myThreadId-      mapM_ killThread $ filter (/= me) pids+      mapM_ shutdown $ filter (/= me) pids      cleanup :: Either SomeException () -> IO ()-    cleanup = either (\e -> killAll >> throwTo callingThread e) (const $ return ())+    cleanup Right {} = return ()+    cleanup (Left exn)+      | Just Interrupt <- fromException exn+        -- I'm being shut down either by a fellow thread (which caught an+        -- exception), or by the main thread which decided to stop running+        -- tests. In any case, just end silently.+        = return ()+      | otherwise = do+        -- Wow, I caught an exception (most probably an async one,+        -- although it doesn't really matter). Shut down all other+        -- threads, and re-throw my exception to the calling thread.+        shutdownAll+        throwTo callingThread $ ParThreadKilled exn -    forkCarefully :: IO () -> IO ()-    forkCarefully action = void . flip myForkFinally cleanup $ do+    forkCarefully :: IO () -> IO ThreadId+    forkCarefully action = flip myForkFinally cleanup $ do       -- We cannot check liveness and update the pidsVar in one       -- transaction before forking, because we don't know the new pid yet.       --@@ -95,6 +130,7 @@   -- fork here as well, so that we can move to the UI without waiting   -- untill all tests have finished   forkCarefully $ foldr go (return ()) actions+  return shutdownAll  -- Copied from base to stay compatible with GHC 7.4. myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
Test/Tasty/Patterns.hs view
@@ -44,7 +44,10 @@  import Data.List import Data.Typeable+import Data.Tagged +import Options.Applicative+import Options.Applicative.Types (ReadM(..))  data Token = SlashToken            | WildcardToken@@ -81,10 +84,17 @@     readsPrec _ string = [(parseTestPattern string, "")]  instance IsOption TestPattern where-    defaultValue = noPattern-    parseValue = Just . parseTestPattern-    optionName = return "pattern"-    optionHelp = return "Select only tests that match pattern"+  defaultValue = noPattern+  parseValue = Just . parseTestPattern+  optionName = return "pattern"+  optionHelp = return "Select only tests that match pattern"+  optionCLParser =+    nullOption+      (  reader (ReadM . Right . parseTestPattern)+      <> short 'p'+      <> long (untag (optionName :: Tagged TestPattern String))+      <> help (untag (optionHelp :: Tagged TestPattern String))+      )  -- | Parse a pattern parseTestPattern :: String -> TestPattern
Test/Tasty/Providers.hs view
@@ -1,7 +1,9 @@ -- | API for test providers module Test.Tasty.Providers   ( IsTest(..)-  , Result(..)+  , testPassed+  , testFailed+  , Result   , Progress(..)   , TestName   , TestTree@@ -14,3 +16,21 @@ -- | Convert a test to a leaf of the 'TestTree' singleTest :: IsTest t => TestName -> t -> TestTree singleTest = SingleTest++-- | 'Result' of a passed test+testPassed+  :: String -- ^ description (may be empty)+  -> Result+testPassed desc = Result+  { resultOutcome = Success+  , resultDescription = desc+  }++-- | 'Result' of a failed test+testFailed+  :: String -- ^ description+  -> Result+testFailed desc = Result+  { resultOutcome = Failure TestFailed+  , resultDescription = desc+  }
Test/Tasty/Run.hs view
@@ -1,5 +1,5 @@ -- | Running tests-{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification #-}+{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, RankNTypes #-} module Test.Tasty.Run   ( Status(..)   , StatusMap@@ -9,20 +9,22 @@ import qualified Data.IntMap as IntMap import qualified Data.Sequence as Seq import qualified Data.Foldable as F+import Data.Maybe import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader-import Control.Monad.Trans.Either-import Control.Concurrent import Control.Concurrent.STM-import Control.Exception+import Control.Concurrent.Timeout+import Control.Concurrent.Async+import Control.Exception as E import Control.Applicative import Control.Arrow  import Test.Tasty.Core import Test.Tasty.Parallel import Test.Tasty.Options-import Test.Tasty.CoreOptions+import Test.Tasty.Options.Core+import Test.Tasty.Runners.Reducers  -- | Current status of a test data Status@@ -30,8 +32,6 @@     -- ^ test has not started running yet   | Executing Progress     -- ^ test is being run-  | Exception SomeException-    -- ^ test threw an exception and was aborted   | Done Result     -- ^ test finished with a given result @@ -43,143 +43,229 @@  data Resource r   = NotCreated+  | BeingCreated   | FailedToCreate SomeException   | Created r+  | Destroyed +instance Show (Resource r) where+  show r = case r of+    NotCreated -> "NotCreated"+    BeingCreated -> "BeingCreated"+    FailedToCreate exn -> "FailedToCreate " ++ show exn+    Created {} -> "Created"+    Destroyed -> "Destroyed"++data ResourceVar = forall r . ResourceVar (TVar (Resource r))+ data Initializer   = forall res . Initializer       (IO res)-      (MVar (Resource res))+      (TVar (Resource res)) data Finalizer   = forall res . Finalizer       (res -> IO ())-      (MVar (Resource res))-      (MVar Int)+      (TVar (Resource res))+      (TVar Int) --- | Start executing a test------ Note: we take the finalizer as an argument because it's important that--- it's run *before* we write the status var and signal to other threads--- that we're finished+-- | Execute a test taking care of resources executeTest   :: ((Progress -> IO ()) -> IO Result)     -- ^ the action to execute the test, which takes a progress callback as     -- a parameter   -> TVar Status -- ^ variable to write status to+  -> Timeout -- ^ optional timeout to apply   -> Seq.Seq Initializer -- ^ initializers (to be executed in this order)   -> Seq.Seq Finalizer -- ^ finalizers (to be executed in this order)   -> IO ()-executeTest action statusVar inits fins =-  handle (atomically . writeTVar statusVar . Exception) $ do-  -- We don't try to protect against async exceptions here.-  -- This is because we use interruptible modifyMVar and wouldn't be able-  -- to give any guarantees anyway.-  -- So all we do is guard actual acquire/test/release actions using 'try'.-  -- The only thing we guarantee upon catching an async exception is that-  -- we'll write it to the status var, so that the UI won't be waiting-  -- infinitely.-  resultOrExcn <- runEitherT $ do-    F.forM_ inits $ \(Initializer doInit initVar) -> EitherT $-      modifyMVar initVar $ \resStatus  ->-        case resStatus of-          NotCreated -> do-            mbRes <- try doInit-            case mbRes of-              Right res -> return (Created res, Right ())-              Left ex -> return (FailedToCreate ex, Left ex)-          Created {} -> return (resStatus, Right ())-          FailedToCreate ex -> return (resStatus, Left ex)+executeTest action statusVar timeoutOpt inits fins = mask $ \restore -> do+  resultOrExn <- try $ restore $ do+    -- N.B. this can (re-)throw an exception. It's okay. By design, the+    -- actual test will not be run, then. We still run all the+    -- finalizers.+    --+    -- There's no point to transform these exceptions to something like+    -- EitherT, because an async exception (cancellation) can strike+    -- anyway.+    initResources -    -- if all initializers ran successfully, actually run the test-    EitherT . try $-      -- pass our callback (which updates the status variable) to the test-      -- action-      action yieldProgress+    -- If all initializers ran successfully, actually run the test.+    -- We run it in a separate thread, so that the test's exception+    -- handler doesn't interfere with our timeout.+    withAsync (action yieldProgress) $ \asy ->+      applyTimeout timeoutOpt $ wait asy    -- no matter what, try to run each finalizer-  -- remember the first exception that occurred-  mbExcn <- liftM getFirst . execWriterT . getApp $-    flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) ->-      AppMonoid $ do-        mbExcn <--          liftIO $ modifyMVar finishVar $ \nUsers -> do-            let nUsers' = nUsers - 1-            mbExcn <--              if nUsers' == 0-              then do-                resStatus <- readMVar initVar+  mbExn <- destroyResources restore++  atomically . writeTVar statusVar $ Done $+    case resultOrExn <* maybe (Right ()) Left mbExn of+      Left ex -> exceptionResult ex+      Right r -> r++  where+    initResources :: IO ()+    initResources =+      F.forM_ inits $ \(Initializer doInit initVar) -> do+        join $ atomically $ do+          resStatus <- readTVar initVar+          case resStatus of+            NotCreated -> do+              -- signal to others that we're taking care of the resource+              -- initialization+              writeTVar initVar BeingCreated+              return $+                (do+                  res <- doInit+                  atomically $ writeTVar initVar $ Created res+                 ) `E.catch` \exn -> do+                  atomically $ writeTVar initVar $ FailedToCreate exn+                  throwIO exn+            BeingCreated -> retry+            Created {} -> return $ return ()+            FailedToCreate exn -> return $ throwIO exn+            _ -> return $ throwIO $+              unexpectedState "initResources" resStatus++    applyTimeout :: Timeout -> IO Result -> IO Result+    applyTimeout NoTimeout a = a+    applyTimeout (Timeout t tstr) a = do+      let+        timeoutResult =+          Result+            { resultOutcome = Failure $ TestTimedOut t+            , resultDescription =+                "Timed out after " ++ tstr+            }+      fromMaybe timeoutResult <$> timeout t a++    -- destroyResources should not be interrupted by an exception+    -- Here's how we ensure this:+    --+    -- * the finalizer is wrapped in 'try'+    -- * async exceptions are masked by the caller+    -- * we don't use any interruptible operations here (outside of 'try')+    destroyResources :: (forall a . IO a -> IO a) -> IO (Maybe SomeException)+    destroyResources restore = do+      -- remember the first exception that occurred+      liftM getFirst . execWriterT . getTraversal $+        flip F.foldMap fins $ \(Finalizer doRelease initVar finishVar) ->+          Traversal $ do+            iAmLast <- liftIO $ atomically $ do+              nUsers <- readTVar finishVar+              let nUsers' = nUsers - 1+              writeTVar finishVar nUsers'+              return $ nUsers' == 0++            mbExcn <- liftIO $+              if iAmLast+              then join $ atomically $ do+                resStatus <- readTVar initVar                 case resStatus of-                  Created res ->-                    either-                      (\ex -> Just ex)-                      (\_ -> Nothing)-                    <$> try (doRelease res)-                  _ -> return Nothing+                  Created res -> do+                    -- Don't worry about double destroy — only one thread+                    -- receives iAmLast+                    return $+                      (either Just (const Nothing)+                        <$> try (restore $ doRelease res))+                        <* atomically (writeTVar initVar Destroyed)+                  FailedToCreate {} -> return $ return Nothing+                  _ -> return $ return $ Just $+                    unexpectedState "destroyResources" resStatus               else return Nothing-            return (nUsers', mbExcn) -- end of modifyMVar -        tell $ First mbExcn--  atomically . writeTVar statusVar $-    case resultOrExcn <* maybe (return ()) Left mbExcn of-      Left ex -> Exception ex-      Right r -> Done r+            tell $ First mbExcn -  where-    -- the callback-    yieldProgress progress =-      atomically $ writeTVar statusVar $ Executing progress+    -- The callback+    -- Since this is not used yet anyway, disable for now.+    -- I'm not sure whether we should get rid of this altogether. For most+    -- providers this is either difficult to implement or doesn't make+    -- sense at all.+    -- See also https://github.com/feuerbach/tasty/issues/33+    yieldProgress _ = return ()  type InitFinPair = (Seq.Seq Initializer, Seq.Seq Finalizer) --- | Prepare the test tree to be run-createTestActions :: OptionSet -> TestTree -> IO [(IO (), TVar Status)]-createTestActions opts tree =-  liftM (map (first ($ (Seq.empty, Seq.empty)))) $-  execWriterT $ getApp $-  (foldTestTree-    trivialFold-      { foldSingle = runSingleTest-      , foldResource = addInitAndRelease-      }-    opts-    tree-    :: AppMonoid (WriterT [(InitFinPair -> IO (), TVar Status)] IO))+-- | Turn a test tree into a list of actions to run tests coupled with+-- variables to watch them+createTestActions :: OptionSet -> TestTree -> IO ([(IO (), TVar Status)], [ResourceVar])+createTestActions opts tree = do+  let+    traversal ::+      Traversal (WriterT ([(InitFinPair -> IO (), TVar Status)], [ResourceVar]) IO)+    traversal =+      foldTestTree+        trivialFold+          { foldSingle = runSingleTest+          , foldResource = addInitAndRelease+          }+        opts tree+  (tests, rvars) <- unwrap traversal+  let tests' = map (first ($ (Seq.empty, Seq.empty))) tests+  return (tests', rvars)+   where-    runSingleTest opts _ test = AppMonoid $ do+    runSingleTest opts _ test = Traversal $ do       statusVar <- liftIO $ atomically $ newTVar NotStarted       let         act (inits, fins) =-          executeTest (run opts test) statusVar inits fins-      tell [(act, statusVar)]-    addInitAndRelease (ResourceSpec doInit doRelease) a =-      AppMonoid . WriterT . fmap ((,) ()) $ do-        initVar <- newMVar NotCreated-        tests <- execWriterT $ getApp $ a (getResource initVar)-        let ntests = length tests-        finishVar <- newMVar ntests-        let-          ini = Initializer doInit initVar-          fin = Finalizer doRelease initVar finishVar-        return $ map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests+          executeTest (run opts test) statusVar (lookupOption opts) inits fins+      tell ([(act, statusVar)], mempty)+    addInitAndRelease (ResourceSpec doInit doRelease) a = wrap $ do+      initVar <- atomically $ newTVar NotCreated+      (tests, rvars) <- unwrap $ a (getResource initVar)+      let ntests = length tests+      finishVar <- atomically $ newTVar ntests+      let+        ini = Initializer doInit initVar+        fin = Finalizer doRelease initVar finishVar+        tests' = map (first $ local $ (Seq.|> ini) *** (fin Seq.<|)) tests+      return (tests', ResourceVar initVar : rvars)+    wrap = Traversal . WriterT . fmap ((,) ())+    unwrap = execWriterT . getTraversal  -- | Used to create the IO action which is passed in a WithResource node-getResource :: MVar (Resource r) -> IO r+getResource :: TVar (Resource r) -> IO r getResource var =-  readMVar var >>= \rState ->+  atomically $ do+    rState <- readTVar var     case rState of       Created r -> return r-      NotCreated -> throwIO $ UnexpectedState "not created"-      FailedToCreate {} -> throwIO $ UnexpectedState "failed to create"+      Destroyed -> throwSTM UseOutsideOfTest+      _ -> throwSTM $ unexpectedState "getResource" rState  -- | Start running all the tests in a test tree in parallel. The number of -- threads is determined by the 'NumThreads' option. -- -- Return a map from the test number (starting from 0) to its status -- variable.-launchTestTree :: OptionSet -> TestTree -> IO StatusMap-launchTestTree opts tree = do-  testActions <- createTestActions opts tree+launchTestTree+  :: OptionSet+  -> TestTree+  -> (StatusMap -> IO a)+  -> IO a+launchTestTree opts tree k = do+  (testActions, rvars) <- createTestActions opts tree   let NumThreads numTheads = lookupOption opts-  runInParallel numTheads (fst <$> testActions)-  return $ IntMap.fromList $ zip [0..] (snd <$> testActions)+  abortTests <- runInParallel numTheads (fst <$> testActions)+  (do let smap = IntMap.fromList $ zip [0..] (snd <$> testActions)+      k smap)+   `finally` do+      abortTests+      waitForResources rvars+  where+    alive :: Resource r -> Bool+    alive r = case r of+      NotCreated -> False+      BeingCreated -> True+      FailedToCreate {} -> False+      Created {} -> True+      Destroyed -> False++    waitForResources rvars = atomically $+      forM_ rvars $ \(ResourceVar rvar) -> do+        res <- readTVar rvar+        check $ not $ alive res++unexpectedState :: String -> Resource r -> SomeException+unexpectedState where_ r = toException $ UnexpectedState where_ (show r)
Test/Tasty/Runners.hs view
@@ -6,14 +6,18 @@   , foldTestTree   , TreeFold(..)   , trivialFold-  , AppMonoid(..)   , ResourceSpec(..)+  , module Test.Tasty.Runners.Reducers     -- * Ingredients   , Ingredient(..)   , tryIngredients   , ingredientOptions   , ingredientsOptions     -- * Standard console ingredients+    -- | NOTE: the exports in this section are deprecated and will be+    -- removed in the future. Please import "Test.Tasty.Ingredients.Basic"+    -- if you need them.+     -- ** Console test reporter   , consoleTestReporter     -- ** Tests list@@ -27,6 +31,9 @@     -- * Running tests   , Status(..)   , Result(..)+  , Outcome(..)+  , FailureReason(..)+  , resultSuccessful   , Progress(..)   , StatusMap   , launchTestTree@@ -42,8 +49,8 @@ import Test.Tasty.Core import Test.Tasty.Run import Test.Tasty.Ingredients-import Test.Tasty.CoreOptions+import Test.Tasty.Options.Core import Test.Tasty.Patterns import Test.Tasty.CmdLine-import Test.Tasty.Ingredients.ConsoleReporter-import Test.Tasty.Ingredients.ListTests+import Test.Tasty.Ingredients.Basic+import Test.Tasty.Runners.Reducers
+ Test/Tasty/Runners/Reducers.hs view
@@ -0,0 +1,58 @@+-- | Monoidal wrappers for applicative functors. Useful to define tree+-- folds.++-- These are the same as in the 'reducers' package. We do not use+-- 'reducers' to avoid its dependencies.++{- License for the 'reducers' package+Copyright 2008-2011 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Test.Tasty.Runners.Reducers where++import Data.Monoid+import Control.Applicative++-- | Monoid generated by '*>'+newtype Traversal f = Traversal { getTraversal :: f () }+instance Applicative f => Monoid (Traversal f) where+  mempty = Traversal $ pure ()+  Traversal f1 `mappend` Traversal f2 = Traversal $ f1 *> f2++-- | Monoid generated by @'liftA2' ('<>')@+newtype Ap f a = Ap { getApp :: f a }+  deriving (Functor, Applicative, Monad)+instance (Applicative f, Monoid a) => Monoid (Ap f a) where+  mempty = pure mempty+  mappend = liftA2 mappend
tasty.cabal view
@@ -2,22 +2,24 @@ --  see http://haskell.org/cabal/users-guide/  name:                tasty-version:             0.7+version:             0.8 synopsis:            Modern and extensible testing framework description:         See <http://documentup.com/feuerbach/tasty> license:             MIT license-file:        LICENSE author:              Roman Cheplyaka maintainer:          roma@ro-che.info+homepage:            http://documentup.com/feuerbach/tasty -- copyright:            category:            Testing build-type:          Simple--- extra-source-files:  +extra-source-files:  CHANGELOG cabal-version:       >=1.10  Source-repository head   type:     git   location: git://github.com/feuerbach/tasty.git+  subdir:   core  flag colors   description: Enable colorful output@@ -29,13 +31,16 @@     Test.Tasty.Options,     Test.Tasty.Providers,     Test.Tasty.Runners+    Test.Tasty.Ingredients,+    Test.Tasty.Ingredients.Basic   other-modules:     Test.Tasty.Parallel,     Test.Tasty.Core,-    Test.Tasty.CoreOptions,+    Test.Tasty.Options.Core,+    Test.Tasty.Options.Env,     Test.Tasty.Patterns,     Test.Tasty.Run,-    Test.Tasty.Ingredients,+    Test.Tasty.Runners.Reducers,     Test.Tasty.CmdLine,     Test.Tasty.Ingredients.ConsoleReporter     Test.Tasty.Ingredients.ListTests@@ -46,10 +51,15 @@     containers,     mtl,     tagged >= 0.5,-    regex-tdfa >= 1.1.8,+    regex-tdfa >= 1.2,     optparse-applicative >= 0.6,     deepseq >= 1.3,-    either >= 4.0+    unbounded-delays >= 0.1,+    async >= 2.0++  if impl(ghc < 7.6)+    -- for GHC.Generics+    build-depends: ghc-prim    if flag(colors)     build-depends: ansi-terminal >= 0.6.1