packages feed

tasty (empty) → 0.1

raw patch · 14 files changed

+1048/−0 lines, 14 filesdep +ansi-terminaldep +basedep +containerssetup-changed

Dependencies added: ansi-terminal, base, containers, mtl, optparse-applicative, regex-posix, stm, tagged

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2013 Roman Cheplyaka++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Test/Tasty.hs view
@@ -0,0 +1,38 @@+-- | This module defines the main data types and functions needed to use+-- Tasty.+module Test.Tasty+  (+  -- * Organizing tests+    TestName+  , TestTree+  , testGroup+  -- * Running tests+  , defaultMain+  , defaultMainWithRunner+  -- * Adjusting options+  -- | 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.+  , adjustOption+  , localOption+  )+  where++import Test.Tasty.Core+import Test.Tasty.Runners+import Test.Tasty.UI+import Test.Tasty.Options++-- | Parse the command line arguments and run the tests using the standard+-- console runner+defaultMain :: TestTree -> IO ()+defaultMain = defaultMainWithRunner runUI++-- | Locally adjust the option value for the given test subtree+adjustOption :: IsOption v => (v -> v) -> TestTree -> TestTree+adjustOption f = PlusTestOptions $ \opts ->+  setOption (f $ lookupOption opts) opts++-- | Locally set the option value for the given test subtree+localOption :: IsOption v => v -> TestTree -> TestTree+localOption v = PlusTestOptions (setOption v)
+ Test/Tasty/CmdLine.hs view
@@ -0,0 +1,43 @@+-- | Parsing options supplied on the command line+{-# LANGUAGE ScopedTypeVariables #-}+module Test.Tasty.CmdLine+  ( treeOptionParser+  , optionParser+  , defaultMainWithRunner+  ) where++import Options.Applicative+import Data.Monoid+import Data.Proxy+import Data.Tagged+import qualified Data.Map as Map+import Data.Typeable+import Control.Arrow++import Test.Tasty.Core+import Test.Tasty.CoreOptions+import Test.Tasty.Run+import Test.Tasty.Options++-- | Generate a command line parser for all the options relevant for this+-- test tree. Also includes 'coreOptions'.+treeOptionParser :: TestTree -> Parser OptionSet+treeOptionParser = optionParser . (coreOptions ++) . getTreeOptions++-- | 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 (px :: Proxy v)) p =+    setOption <$> (optionCLParser :: Parser v) <*> p++-- | Parse the command line arguments and run the tests using the provided+-- runner+defaultMainWithRunner :: Runner -> TestTree -> IO ()+defaultMainWithRunner runner testTree = do+  opts <- execParser $+    info (helper <*> treeOptionParser testTree)+    ( fullDesc <>+      header "Mmm... tasty test suite"+    )+  runner opts testTree =<< launchTestTree opts testTree
+ Test/Tasty/Core.hs view
@@ -0,0 +1,147 @@+-- | Core types and definitions+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,+             ExistentialQuantification, RankNTypes #-}+module Test.Tasty.Core where++import Control.Applicative+import Test.Tasty.Options+import Test.Tasty.Patterns+import Data.Foldable+import Data.Monoid+import Data.Typeable+import qualified Data.Map as Map+import Data.Tagged++-- | A test result+data Result = Result+  { resultSuccessful :: Bool+    -- ^+    -- 'resultSuccessful' should be 'True' for a passed test and 'False' for+    -- a failed one.+  , resultDescription :: String+    -- ^+    -- 'resultDescription' may contain some details about the test. For+    -- a passed test it's ok to leave it empty. Providers like SmallCheck and+    -- QuickCheck use it to provide information about how many tests were+    -- generated.+    --+    -- For a failed test, 'resultDescription' should typically provide more+    -- information about the failure.+  }++-- | Test progress information.+--+-- This may be used by a runner to provide some feedback to the user while+-- a long-running test is executing.+data Progress = Progress+  { progressText :: String+    -- ^ textual information about the test's progress+  , progressPercent :: Float+    -- ^+    -- 'progressPercent' should be a value between 0 and 1. If it's impossible+    -- to compute the estimate, use 0.+  }++-- | The interface to be implemented by a test provider.+--+-- The type @t@ is the concrete representation of the test which is used by+-- the provider.+class Typeable t => IsTest t where+  -- | Run the test+  run+    :: OptionSet -- ^ options+    -> t -- ^ the test to run+    -> (Progress -> IO ()) -- ^ a callback to report progress+    -> IO Result++  -- | The list of options that affect execution of tests of this type+  testOptions :: Tagged t [OptionDescription]++-- | The name of a test or a group of tests+type TestName = String++-- | The main data structure defining a test suite.+--+-- It consists of individual test cases and properties, organized in named+-- groups which form a tree-like hierarchy.+--+-- There is no generic way to create a test case. Instead, every test+-- provider (tasty-hunit, tasty-smallcheck etc.) provides a function to+-- turn a test case into a 'TestTree'.+--+-- Groups can be created using 'testGroup'.+data TestTree+  = forall t . IsTest t => SingleTest TestName t+    -- ^ A single test of some particular type+  | TestGroup TestName [TestTree]+    -- ^ Assemble a number of tests into a cohesive group+  | PlusTestOptions (OptionSet -> OptionSet) TestTree+    -- ^ Add some options to child tests++-- | Create a named group of test cases or other groups+testGroup :: TestName -> [TestTree] -> TestTree+testGroup = TestGroup++-- | Fold a test tree into a single value.+--+-- Apart from pure convenience, this function also does the following+-- useful things:+--+-- 1. Keeping track of the current options (which may change due to+-- `PlusTestOptions` nodes)+--+-- 2. Filtering out the tests which do not match the patterns+--+-- Thus, it is preferred to an explicit recursive traversal of the tree.+--+-- Note: right now, the patterns are looked up only once, and won't be+-- affected by the subsequent option changes. This shouldn't be a problem+-- in practice; OTOH, this behaviour may be changed later.+foldTestTree+  :: Monoid b+  => (forall t . IsTest t => OptionSet -> TestName -> t -> b)+     -- ^ interpret a single test+  -> (TestName -> b -> b)+     -- ^ interpret a test group+  -> OptionSet+     -- ^ initial options+  -> TestTree -> b+foldTestTree fTest fGroup opts tree =+  let pat = lookupOption opts+  in go pat [] opts tree+  where+    go pat path opts tree =+      case tree of+        SingleTest name test+          | testPatternMatches pat (path ++ [name])+            -> fTest opts name test+          | otherwise -> mempty+        TestGroup name trees ->+          fGroup name $ foldMap (go pat (path ++ [name]) opts) trees+        PlusTestOptions f tree -> go pat path (f opts) tree++-- | 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+getTreeOptions :: TestTree -> [OptionDescription]+getTreeOptions =++  Prelude.concat .+  Map.elems .++  foldTestTree+    (\_ _ -> getTestOptions)+    (const id)+    mempty++  where+    getTestOptions+      :: forall t . IsTest t+      => t -> Map.Map TypeRep [OptionDescription]+    getTestOptions t =+      Map.singleton (typeOf t) $+          witness testOptions t
+ Test/Tasty/CoreOptions.hs view
@@ -0,0 +1,30 @@+-- | 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.Options+import Test.Tasty.Patterns++-- | Number of parallel threads to use for running tests+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+coreOptions :: [OptionDescription]+coreOptions =+  [ Option (Proxy :: Proxy NumThreads)+  , Option (Proxy :: Proxy TestPattern)+  ]
+ Test/Tasty/Options.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable,+             ExistentialQuantification, GADTs,+             OverlappingInstances, FlexibleInstances, UndecidableInstances,+             TypeOperators #-}+-- | Extensible options. They are used for provider-specific settings,+-- runner-specific settings and core settings (number of threads, test+-- pattern).+module Test.Tasty.Options+  (+    -- * IsOption class+    IsOption(..)+    -- * Option sets and operations+  , OptionSet+  , setOption+  , changeOption+  , lookupOption+  , OptionDescription(..)+    -- * Utilities+  , safeRead+  ) where++import Data.Typeable+import qualified Data.Map as Map+import Data.Map (Map)+import Data.Tagged+import Data.Proxy+import Data.Monoid++import Options.Applicative++-- | An option is a data type that inhabits the `IsOption` type class.+class Typeable v => IsOption v where+  -- | The value to use if the option was not supplied explicitly+  defaultValue :: v+  -- | Try to parse an option value from a string+  parseValue :: String -> Maybe v+  -- | The option name. It is used to form the command line option name, for+  -- instance. Therefore, it had better not contain spaces or other fancy+  -- characters. It is recommended to use dashes instead of spaces.+  optionName :: Tagged v String+  -- | The option description or help string. This can be an arbitrary+  -- string.+  optionHelp :: Tagged v String+  -- | A command-line option parser.+  --+  -- It has a default implementation in terms of the other methods.+  -- You may want to override it in some cases (e.g. add a short flag).+  --+  -- Even if you override this, you still should implement all the methods+  -- above, to allow alternative interfaces.+  optionCLParser :: Parser v+  optionCLParser =+    nullOption+      (  reader parse+      <> long name+      <> value defaultValue+      <> help helpString+      )+    where+      name = untag (optionName :: Tagged v String)+      helpString = untag (optionHelp :: Tagged v String)+      parse =+        maybe (Left (ErrorMsg $ "Could not parse " ++ name)) Right .+          parseValue+++data OptionValue = forall v . IsOption v => OptionValue v++-- | A set of options. Only one option of each type can be kept.+--+-- If some option has not been explicitly set, the default value is used.+newtype OptionSet = OptionSet (Map TypeRep OptionValue)++-- | Later options override earlier ones+instance Monoid OptionSet where+  mempty = OptionSet mempty+  OptionSet a `mappend` OptionSet b =+    OptionSet $ Map.unionWith (flip const) a b++-- | Set the option value+setOption :: IsOption v => v -> OptionSet -> OptionSet+setOption v (OptionSet s) =+  OptionSet $ Map.insert (typeOf v) (OptionValue v) s++-- | Query the option value+lookupOption :: forall v . IsOption v => OptionSet -> v+lookupOption (OptionSet s) =+  case Map.lookup (typeOf (undefined :: v)) s of+    Just (OptionValue x) | Just v <- cast x -> v+    Just {} -> error "OptionSet: broken invariant (shouldn't happen)"+    Nothing -> defaultValue++-- | Change the option value+changeOption :: forall v . IsOption v => (v -> v) -> OptionSet -> OptionSet+changeOption f s = setOption (f $ lookupOption s) s++-- | 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++-- | Safe read function. Defined here for convenience to use for+-- 'parseValue'.+safeRead :: Read a => String -> Maybe a+safeRead s+  | [(x, "")] <- reads s = Just x+  | otherwise = Nothing
+ Test/Tasty/Parallel.hs view
@@ -0,0 +1,95 @@+-- | A helper module which takes care of parallelism+module Test.Tasty.Parallel (runInParallel) where++import Control.Monad+import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception++-- | Take a list of actions and execute them in parallel, no more than @n@+-- at the same time+runInParallel+  :: Int -- ^ maximum number of parallel threads+  -> [IO ()] -- ^ list of actions to execute+  -> IO ()+-- This implementation tries its best to ensure that exceptions are+-- properly propagated to the caller and threads are not left running.+--+-- Note that exceptions inside tests are already caught by the test+-- actions themselves. Any exceptions that reach this function or its+-- threads are by definition unexpected.+runInParallel nthreads actions = do+  callingThread <- myThreadId+  -- A variable containing all ThreadIds of forked threads.+  --+  -- These are the threads we'll need to kill if something wrong happens.+  pidsVar <- atomically $ newTVar []++  -- If an unexpected exception has been thrown and we started killing all+  -- the spawned threads, this flag will be set to False, so that any+  -- freshly spawned threads will know to terminate, even if their pids+  -- didn't make it to the "kill list" yet.+  aliveVar <- atomically $ newTVar True++  let+    -- Kill all threads.+    killAll :: IO ()+    killAll = do+      pids <- atomically $ do+        writeTVar aliveVar False+        readTVar pidsVar++      -- be sure not to kill myself!+      me <- myThreadId+      mapM_ killThread $ filter (/= me) pids++    cleanup :: Either SomeException () -> IO ()+    cleanup = either (\e -> killAll >> throwTo callingThread e) (const $ return ())++    forkCarefully :: IO () -> IO ()+    forkCarefully action = void . 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.+      --+      -- So we fork and then check/update. If something has happened in+      -- the meantime, it's not a big deal — we just cancel. OTOH, if+      -- we're alive at the time of the transaction, then we add our pid+      -- and will be killed when something happens.+      newPid <- myThreadId++      join . atomically $ do+        alive <- readTVar aliveVar+        if alive+          then do+            modifyTVar pidsVar (newPid :)+            return action+          else+            return (return ())++  capsVar <- atomically $ newTVar nthreads++  let+    go a cont = join . atomically $ do+      caps <- readTVar capsVar+      if caps > 0+        then do+          writeTVar capsVar $! caps - 1+          let+            release = atomically $ modifyTVar' capsVar (+1)++          -- Thanks to our exception handling, we won't deadlock even if+          -- an exception strikes before we 'release'. Everything will be+          -- killed, so why bother.+          return $ do forkCarefully (do a; release); cont++        else retry++  -- fork here as well, so that we can move to the UI without waiting+  -- untill all tests have finished+  forkCarefully $ foldr go (return ()) actions++-- Copied from base to stay compatible with GHC 7.4.+myForkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+myForkFinally action and_then =+  mask $ \restore ->+    forkIO $ try (restore action) >>= and_then
+ Test/Tasty/Patterns.hs view
@@ -0,0 +1,149 @@+-- This code is largely borrowed from test-framework+{-+Copyright (c) 2008, Maximilian Bolingbroke+All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted+provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright notice, this list of+      conditions and the following disclaimer.+    * 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.+    * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to+      endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 COPYRIGHT OWNER 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.+-}++-- | Test patterns+--+-- (Most of the code borrowed from the test-framework)++{-# LANGUAGE DeriveDataTypeable #-}++module Test.Tasty.Patterns+  ( TestPattern+  , parseTestPattern+  , noPattern+  , testPatternMatches+  ) where++import Test.Tasty.Options++import Text.Regex.Posix.Wrap+import Text.Regex.Posix.String()++import Data.List+import Data.Typeable+++data Token = SlashToken+           | WildcardToken+           | DoubleWildcardToken+           | LiteralToken Char+           deriving (Eq)++tokenize :: String -> [Token]+tokenize ('/':rest)     = SlashToken : tokenize rest+tokenize ('*':'*':rest) = DoubleWildcardToken : tokenize rest+tokenize ('*':rest)     = WildcardToken : tokenize rest+tokenize (c:rest)       = LiteralToken c : tokenize rest+tokenize []             = []+++data TestPatternMatchMode = TestMatchMode+                          | PathMatchMode++-- | A pattern to filter tests. For the syntax description, see+-- <http://documentup.com/feuerbach/tasty#using-patterns>+data TestPattern = TestPattern {+        tp_categories_only :: Bool,+        tp_negated :: Bool,+        tp_match_mode :: TestPatternMatchMode,+        tp_tokens :: [Token]+    } | NoPattern+    deriving Typeable++-- | A pattern that matches anything.+noPattern :: TestPattern+noPattern = NoPattern++instance Read TestPattern where+    readsPrec _ string = [(parseTestPattern string, "")]++instance IsOption TestPattern where+    defaultValue = noPattern+    parseValue = Just . parseTestPattern+    optionName = return "pattern"+    optionHelp = return "Select only tests that match pattern"++-- | Parse a pattern+parseTestPattern :: String -> TestPattern+parseTestPattern string = TestPattern {+        tp_categories_only = categories_only,+        tp_negated = negated,+        tp_match_mode = match_mode,+        tp_tokens = tokens''+    }+  where+    tokens = tokenize string+    (negated, tokens')+      | (LiteralToken '!'):rest <- tokens = (True, rest)+      | otherwise                         = (False, tokens)+    (categories_only, tokens'')+      | (prefix, [SlashToken]) <- splitAt (length tokens' - 1) tokens' = (True, prefix)+      | otherwise                                                      = (False, tokens')+    match_mode+      | SlashToken `elem` tokens = PathMatchMode+      | otherwise                = TestMatchMode+++-- | Test a path (which is the sequence of group titles, possibly followed+-- by the test title) against a pattern+testPatternMatches :: TestPattern -> [String] -> Bool+testPatternMatches NoPattern _ = True+testPatternMatches test_pattern path = not_maybe $ any (=~ tokens_regex) things_to_match+  where+    not_maybe | tp_negated test_pattern = not+              | otherwise               = id+    path_to_consider | tp_categories_only test_pattern = dropLast 1 path+                     | otherwise                       = path+    tokens_regex = buildTokenRegex (tp_tokens test_pattern)++    things_to_match = case tp_match_mode test_pattern of+        -- See if the tokens match any single path component+        TestMatchMode -> path_to_consider+        -- See if the tokens match any prefix of the path+        PathMatchMode -> map pathToString $ inits path_to_consider+++buildTokenRegex :: [Token] -> String+buildTokenRegex [] = []+buildTokenRegex (token:tokens) = concat (firstTokenToRegex token : map tokenToRegex tokens)+  where+    firstTokenToRegex SlashToken = "^"+    firstTokenToRegex other = tokenToRegex other++    tokenToRegex SlashToken = "/"+    tokenToRegex WildcardToken = "[^/]*"+    tokenToRegex DoubleWildcardToken = "*"+    tokenToRegex (LiteralToken lit) = regexEscapeChar lit++regexEscapeChar :: Char -> String+regexEscapeChar c | c `elem` "\\*+?|{}[]()^$." = '\\' : [c]+                  | otherwise                  = [c]++pathToString :: [String] -> String+pathToString path = concat (intersperse "/" path)++dropLast :: Int -> [a] -> [a]+dropLast n = reverse . drop n . reverse
+ Test/Tasty/Providers.hs view
@@ -0,0 +1,16 @@+-- | API for test providers+module Test.Tasty.Providers+  ( IsTest(..)+  , Result(..)+  , Progress(..)+  , TestName+  , TestTree+  , singleTest+  )+  where++import Test.Tasty.Core++-- | Convert a test to a leaf of the 'TestTree'+singleTest :: IsTest t => TestName -> t -> TestTree+singleTest = SingleTest
+ Test/Tasty/Run.hs view
@@ -0,0 +1,128 @@+-- | Running tests+module Test.Tasty.Run+  ( Status(..)+  , StatusMap+  , Runner+  , launchTestTree+  ) where++import qualified Data.IntMap as IntMap+import Data.Maybe+import Data.Typeable+import Control.Monad.State+import Control.Concurrent.STM+import Control.Exception++import Test.Tasty.Core+import Test.Tasty.Parallel+import Test.Tasty.Options+import Test.Tasty.CoreOptions++-- | Current status of a test+data Status+  = NotStarted+    -- ^ 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++data TestMap = TestMap+    !Int+    !(IntMap.IntMap (IO (), TVar Status))+      -- ^ Int is the first free index+      --+      -- IntMap maps test indices to:+      --+      --    * the action to launch the test+      --+      --    * the status variable of the launched test++-- | Mapping from test numbers (starting from 0) to their status variables.+--+-- This is what a runner uses to analyse and display progress, and to+-- detect when tests finish.+type StatusMap = IntMap.IntMap (TVar Status)++-- | A 'Runner' is responsible for user interaction during the test run.+--+-- It is provided with the 'StatusMap', so the tests are already launched+-- and all it needs to do is notifying the user about the progress and+-- then displaying the overall results in the end.+--+-- It is also the runner's responsibility to exit with an appropriate+-- exit code.+type Runner = OptionSet -> TestTree -> StatusMap -> IO ()++-- | Start executing a test+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+  -> IO ()+executeTest action statusVar = do+  result <- handleExceptions $+    -- pass our callback (which updates the status variable) to the test+    -- action+    action yieldProgress++  -- when the test is finished, write its result to the status variable+  atomically $ writeTVar statusVar result++  where+    -- the callback+    yieldProgress progress =+      atomically $ writeTVar statusVar $ Executing progress++    handleExceptions a = do+      resultOrException <- try a+      case resultOrException of+        Left e+          | Just async <- fromException e+          -> throwIO (async :: AsyncException) -- user interrupt, etc++          | otherwise+          -> return $ Exception e++        Right result -> return $ Done result++-- | Prepare the test tree to be run+createTestMap :: OptionSet -> TestTree -> IO TestMap+createTestMap opts tree =+  flip execStateT (TestMap 0 IntMap.empty) $ getApp $+  foldTestTree+    runSingleTest+    (const id)+    opts+    tree+  where+    runSingleTest opts _ test = AppMonoid $ do+      statusVar <- liftIO $ atomically $ newTVar NotStarted+      let+        act =+          executeTest (run opts test) statusVar+      TestMap ix tmap <- get+      let+        tmap' = IntMap.insert ix (act, statusVar) tmap+        ix' = ix+1+      put $! TestMap ix' tmap'++-- | Start running all the tests in the TestMap in parallel+launchTests :: Int -> TestMap -> IO ()+launchTests threads (TestMap _ tmap) =+  runInParallel threads $ map fst $ IntMap.elems tmap++-- | 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+  tmap@(TestMap _ smap) <- createTestMap opts tree+  let NumThreads numTheads = lookupOption opts+  launchTests numTheads tmap+  return $ fmap snd smap
+ Test/Tasty/Runners.hs view
@@ -0,0 +1,24 @@+-- | API for test runners+module Test.Tasty.Runners+  (+    -- * Working with the test tree+    TestTree(..)+  , foldTestTree+    -- * Command line handling+  , module Test.Tasty.CmdLine+    -- * Running tests+  , module Test.Tasty.Run+  , module Test.Tasty.UI+    -- * Core options+  , module Test.Tasty.CoreOptions+    -- ** Patterns+  , module Test.Tasty.Patterns+  )+  where++import Test.Tasty.Core+import Test.Tasty.Run+import Test.Tasty.CoreOptions+import Test.Tasty.Patterns+import Test.Tasty.CmdLine+import Test.Tasty.UI
+ Test/Tasty/UI.hs view
@@ -0,0 +1,197 @@+{-# LANGUAGE TupleSections, CPP, ImplicitParams #-}+-- | Console runner+module Test.Tasty.UI (runUI) where++import Prelude hiding (fail)+import Control.Monad.State hiding (fail)+import Control.Concurrent.STM+import Control.Exception+import Test.Tasty.Core+import Test.Tasty.Run+import Test.Tasty.Options+import Text.Printf+import qualified Data.IntMap as IntMap+import Data.Maybe+import Data.Monoid+import System.Exit+import System.IO++#ifdef COLORS+import System.Console.ANSI+#endif++data RunnerState = RunnerState+  { ix :: !Int+  , nestedLevel :: !Int+  , failures :: !Int+  }++initialState :: RunnerState+initialState = RunnerState 0 0 0++type M = StateT RunnerState IO++indentSize :: Int+indentSize = 2++indent :: Int -> String+indent n = replicate (indentSize * n) ' '++-- handle multi-line result descriptions properly+formatDesc+  :: Int -- indent+  -> String+  -> String+formatDesc n desc =+  let+    -- remove all trailing linebreaks+    chomped = reverse . dropWhile (== '\n') . reverse $ desc++    multiline = '\n' `elem` chomped++    -- we add a leading linebreak to the description, to start it on a new+    -- line and add an indentation+    paddedDesc = flip concatMap chomped $ \c ->+      if c == '\n'+        then c : indent n+        else [c]+  in+    if multiline+      then paddedDesc+      else chomped++data Maximum a+  = Maximum a+  | MinusInfinity++instance Ord a => Monoid (Maximum a) where+  mempty = MinusInfinity++  Maximum a `mappend` Maximum b = Maximum (a `max` b)+  MinusInfinity `mappend` a = a+  a `mappend` MinusInfinity = a++-- | Compute the amount of space needed to align "OK"s and "FAIL"s+computeAlignment :: OptionSet -> TestTree -> Int+computeAlignment opts =+  fromMonoid .+  foldTestTree+    (\_ name _ level -> Maximum (length name + level))+    (\_ m -> m . (+ indentSize))+    opts+  where+    fromMonoid m =+      case m 0 of+        MinusInfinity -> 0+        Maximum x -> x++-- | A simple console UI+runUI :: Runner+-- 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.+runUI opts tree smap = do+  isTerm <- hIsTerminalDevice stdout++  let+    ?colors = isTerm++  hSetBuffering stdout NoBuffering++  st <-+    flip execStateT initialState $ getApp $ fst $+      foldTestTree+        (runSingleTest smap)+        runGroup+        opts+        tree++  printf "\n"++  case failures st of+    0 -> do+      ok $ printf "All %d tests passed\n" (ix st)+      exitSuccess++    fs -> do+      fail $ printf "%d out of %d tests failed\n" fs (ix st)+      exitFailure++  where+    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++      (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++      liftIO $ printf "%s%s: %s" (indent level) name+        (replicate (alignment - indentSize * level - length name) ' ')+      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 }++-- (Potentially) colorful output+ok, fail, infoOk, infoFail :: (?colors :: Bool) => String -> IO ()+#ifdef COLORS+fail     = output BoldIntensity   Vivid Red+ok       = output NormalIntensity Dull  Green+infoOk   = output NormalIntensity Dull  White+infoFail = output NormalIntensity Dull  Black++output+  :: (?colors :: Bool)+  => ConsoleIntensity+  -> ColorIntensity+  -> Color+  -> String+  -> IO ()+output bold intensity color str+  | ?colors =+    (do+      setSGR+        [ SetColor Foreground intensity color+        , SetConsoleIntensity bold+        ]+      putStr str+    ) `finally` setSGR []+  | otherwise = putStr str+#else+ok       = putStr+fail     = putStr+infoOk   = putStr+infoFail = putStr+#endif
+ tasty.cabal view
@@ -0,0 +1,53 @@+-- Initial tasty.cabal generated by cabal init.  For further documentation,+--  see http://haskell.org/cabal/users-guide/++name:                tasty+version:             0.1+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+-- copyright:           +category:            Testing+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++Source-repository head+  type:     git+  location: git://github.com/feuerbach/tasty.git++flag colors+  description: Enable colorful output+  default: True++library+  exposed-modules:+    Test.Tasty,+    Test.Tasty.Options,+    Test.Tasty.Providers,+    Test.Tasty.Runners+  other-modules:+    Test.Tasty.Parallel,+    Test.Tasty.Core,+    Test.Tasty.CoreOptions,+    Test.Tasty.Patterns,+    Test.Tasty.Run,+    Test.Tasty.CmdLine,+    Test.Tasty.UI+  build-depends:+    base ==4.*,+    stm,+    containers,+    mtl,+    tagged,+    regex-posix,+    optparse-applicative++  if flag(colors)+    build-depends: ansi-terminal+    cpp-options: -DCOLORS+  -- hs-source-dirs:      +  default-language:    Haskell2010