hedgehog 0.1 → 0.2

raw patch · 17 files changed

+1043/−340 lines, 17 filesdep +stmdep +unixPVP ok

version bump matches the API change (PVP)

Dependencies added: stm, unix

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +67/−1
• hedgehog.cabal +10/−1
• src/Hedgehog.hs +33/−13
• src/Hedgehog/Gen.hs +24/−9
• src/Hedgehog/Internal/Config.hs +171/−0
• src/Hedgehog/Internal/Discovery.hs +1/−1
• src/Hedgehog/Internal/Property.hs +71/−23
• src/Hedgehog/Internal/Queue.hs +116/−0
• src/Hedgehog/Internal/Region.hs +110/−0
• src/Hedgehog/Internal/Report.hs +222/−107
• src/Hedgehog/Internal/Runner.hs +191/−142
• src/Hedgehog/Internal/Seed.hs +1/−2
• src/Hedgehog/Internal/Shrink.hs +5/−5
• src/Hedgehog/Internal/TH.hs +6/−35
• src/Hedgehog/Internal/Tree.hs +1/−1
• src/Hedgehog/Range.hs +4/−0

@@ -0,0 +1,10 @@+## Version 0.2 (2017-05-06)++- Added a quiet test runner which can be activated by setting `HEDGEHOG_VERBOSITY=0`+- Concurrent test runner does not display tests until they are executing.+- Test runner now outputs a summary of how many successful / failed tests were run.+- `checkSequential` and `checkParallel` now allow for tests to be run without Template Haskell.+- Auto-discovery of properties is now available via `discover` instead of being baked in.+- `annotate` allows source code to be annotated inline with extra information.+- `forAllWith` can be used to generate values without a `Show` instance.+- Removed uses of `Typeable` to allow for generating types which cannot implement it.

@@ -1,4 +1,4 @@-hedgehog [![Hackage version](https://img.shields.io/hackage/v/hedgehog.svg?style=flat)](http://hackage.haskell.org/package/hedgehog) [![Build Status](https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master)](https://travis-ci.org/hedgehogqa/haskell-hedgehog)+hedgehog [![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] ========  > Hedgehog will eat all your bugs.@@ -16,3 +16,69 @@ - Range combinators for full control over the scope of generated numbers and collections. - Equality and roundtrip assertions show a diff instead of the two inequal values. - Template Haskell test runner which executes properties concurrently.++## Example++The main module, [Hedgehog][haddock-hedgehog], includes almost+everything you need to get started writing property tests with Hedgehog.++It is designed to be used alongside [Hedgehog.Gen][haddock-hedgehog-gen]+and [Hedgehog.Range][haddock-hedgehog-range] which should be imported+qualified. You also need to enable Template Haskell so the Hedgehog test+runner can find your properties.++```hs+{-# LANGUAGE TemplateHaskell #-}++import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+```++Once you have your imports set up, you can write a simple property:++```hs+prop_reverse :: Property+prop_reverse =+  property $ do+    xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha+    reverse (reverse xs) === xs+```++And add the Template Haskell splice which will discover your properties:++```hs+tests :: IO Bool+tests =+  checkParallel $$(discover)+```++If you prefer to avoid macros, you can specify the group of properties+to run manually instead:++```hs+tests :: IO Bool+tests =+  checkParallel $ Group "Test.Example" [+      ("prop_reverse", prop_reverse)+    ]+```++You can then load the module in GHCi, and run it:++```+λ tests+━━━ Test.Example ━━━+  ✓ prop_reverse passed 100 tests.++```++ [hackage]: http://hackage.haskell.org/package/hedgehog+ [hackage-shield]: http://img.shields.io/hackage/v/hedgehog.svg?style=flat++ [travis]: https://travis-ci.org/hedgehogqa/haskell-hedgehog+ [travis-shield]: https://travis-ci.org/hedgehogqa/haskell-hedgehog.svg?branch=master++ [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html+ [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html+ [haddock-hedgehog-range]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Range.html

@@ -1,7 +1,7 @@ name:   hedgehog version:-  0.1+  0.2 license:   BSD3 author:@@ -38,6 +38,7 @@   , GHC == 8.0.2 extra-source-files:   README.md+  CHANGELOG.md  source-repository head   type: git@@ -59,6 +60,7 @@     , primitive                       >= 0.6        && < 0.7     , random                          >= 1.1        && < 1.2     , resourcet                       >= 1.1        && < 1.2+    , stm                             >= 2.4        && < 2.5     , template-haskell                >= 2.10       && < 2.12     , text                            >= 1.1        && < 1.3     , th-lift                         >= 0.7        && < 0.8@@ -71,6 +73,10 @@     build-depends:       semigroups                      >= 0.16       && < 0.19 +  if !os(windows)+    build-depends:+      unix                            >= 2.6        && < 2.8+   ghc-options:     -Wall @@ -82,8 +88,11 @@     Hedgehog.Gen     Hedgehog.Range +    Hedgehog.Internal.Config     Hedgehog.Internal.Discovery     Hedgehog.Internal.Property+    Hedgehog.Internal.Queue+    Hedgehog.Internal.Region     Hedgehog.Internal.Report     Hedgehog.Internal.Runner     Hedgehog.Internal.Seed

@@ -20,20 +20,32 @@ -- >     xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha -- >     reverse (reverse xs) === xs ----- And add the Template Haskell splice which will run your properies:+-- And add the Template Haskell splice which will discover your properties: -- -- > tests :: IO Bool -- > tests =--- >   $$(checkConcurrent)+-- >   checkParallel $$(discover) --+-- If you prefer to avoid macros, you can specify the group of properties to+-- run manually instead:+--+-- > tests :: IO Bool+-- > tests =+-- >   checkParallel $ Group "Test.Example" [+-- >       ("prop_reverse", prop_reverse)+-- >     ]+-- -- You can then load the module in GHCi, and run it: ----- >>> tests--- ━━━ Test.Example ━━━---   ✓ prop_reverse passed 100 tests.+-- > λ tests+-- > ━━━ Test.Example ━━━+-- >   ✓ prop_reverse passed 100 tests. -- module Hedgehog (-    Property+    Group(..)+  , GroupName+  , Property+  , PropertyName   , Test   , TestLimit   , DiscardLimit@@ -51,13 +63,19 @@   , withShrinks    , check-  , checkSequential-  , checkConcurrent   , recheck +  , discover+  , checkParallel+  , checkSequential+   -- * Test   , forAll-  , info+  , forAllWith+  , annotate+  , annotateShow+  , footnote+  , footnoteShow   , success   , discard   , failure@@ -75,14 +93,16 @@ import           Hedgehog.Internal.Property (assert, (===)) import           Hedgehog.Internal.Property (discard, failure, success) import           Hedgehog.Internal.Property (DiscardLimit, withDiscards)-import           Hedgehog.Internal.Property (forAll, info)+import           Hedgehog.Internal.Property (forAll, forAllWith)+import           Hedgehog.Internal.Property (annotate, annotateShow)+import           Hedgehog.Internal.Property (footnote, footnoteShow) import           Hedgehog.Internal.Property (liftEither, liftExceptT, withResourceT)-import           Hedgehog.Internal.Property (Property)+import           Hedgehog.Internal.Property (Property, PropertyName, Group(..), GroupName) import           Hedgehog.Internal.Property (ShrinkLimit, withShrinks) import           Hedgehog.Internal.Property (Test, property) import           Hedgehog.Internal.Property (TestLimit, withTests)-import           Hedgehog.Internal.Runner (check, recheck)+import           Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel) import           Hedgehog.Internal.Seed (Seed(..))-import           Hedgehog.Internal.TH (checkSequential, checkConcurrent)+import           Hedgehog.Internal.TH (discover) import           Hedgehog.Internal.Tripping (tripping) import           Hedgehog.Range (Range, Size(..))

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}@@ -74,6 +73,7 @@   , bytes    -- ** Choice+  , constant   , element   , choice   , frequency@@ -87,6 +87,7 @@   -- ** Collections   , maybe   , list+  , seq   , nonEmpty   , set   , map@@ -162,6 +163,8 @@ import           Data.Map (Map) import qualified Data.Map as Map import qualified Data.Maybe as Maybe+import           Data.Sequence (Seq)+import qualified Data.Sequence as Seq import           Data.Set (Set) import           Data.Text (Text) import qualified Data.Text as Text@@ -176,7 +179,7 @@ import           Hedgehog.Range (Size, Range) import qualified Hedgehog.Range as Range -import           Prelude hiding (filter, print, maybe, map)+import           Prelude hiding (filter, print, maybe, map, seq)   ------------------------------------------------------------------------@@ -236,7 +239,7 @@ --   at the nodes. 'Nothing' means discarded, 'Just' means we have a value. -- runDiscardEffect :: Monad m => Tree (MaybeT m) a -> Tree m (Maybe a)-runDiscardEffect s = do+runDiscardEffect s =   Tree $ do     mx <- runMaybeT $ runTree s     case mx of@@ -768,6 +771,13 @@ ------------------------------------------------------------------------ -- Combinators - Choice +-- | Trivial generator that always produces the same element.+--+--   /This is another name for 'pure' \/ 'return'./+constant :: Monad m => a -> Gen m a+constant =+  pure+ -- | Randomly selects one of the elements in the list. -- --   This generator shrinks towards the first element in the list.@@ -889,8 +899,7 @@ -- @ -- --   It differs from the above in that we keep some state to avoid looping---   forever. If we trigger these limits then the whole whole generator is---   discarded.+--   forever. If we trigger these limits then the whole generator is discarded. -- filter :: Monad m => (a -> Bool) -> Gen m a -> Gen m a filter p gen =@@ -922,7 +931,7 @@ -- | Generates a 'Nothing' some of the time. -- maybe :: Monad m => Gen m a -> Gen m (Maybe a)-maybe gen = do+maybe gen =   sized $ \n ->     frequency [         (2, pure Nothing)@@ -940,6 +949,12 @@       k <- integral_ range       replicateM k (freeze gen) +-- | Generates a seq using a 'Range' to determine the length.+--+seq :: Monad m => Range Int -> Gen m a -> Gen m (Seq a)+seq range gen =+  Seq.fromList <$> list range gen+ -- | Generates a non-empty list using a 'Range' to determine the length. -- nonEmpty :: Monad m => Range Int -> Gen m a -> Gen m (NonEmpty a)@@ -1155,7 +1170,7 @@ sample gen =   fmap (fmap nodeValue . Maybe.catMaybes) .   replicateM 10 $ do-    seed <- liftIO $ Seed.random+    seed <- liftIO Seed.random     runMaybeT . runTree $ runGen 30 seed gen  -- | Print the value produced by a generator, and the first level of shrinks,@@ -1199,7 +1214,7 @@ -- print :: (MonadIO m, Show a) => Gen m a -> m () print gen = do-  seed <- liftIO $ Seed.random+  seed <- liftIO Seed.random   printWith 30 seed gen  -- | Run a generator with a random seed and print the resulting shrink tree.@@ -1221,7 +1236,7 @@ -- printTree :: (MonadIO m, Show a) => Gen m a -> m () printTree gen = do-  seed <- liftIO $ Seed.random+  seed <- liftIO Seed.random   printTreeWith 30 seed gen  -- | Render a generator as a tree of strings.

@@ -0,0 +1,171 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Hedgehog.Internal.Config (+    UseColor(..)+  , resolveColor++  , Verbosity(..)+  , resolveVerbosity++  , WorkerCount(..)+  , resolveWorkers++  , detectMark+  , detectColor+  , detectVerbosity+  , detectWorkers+  ) where++import           Control.Monad.IO.Class (MonadIO(..))++import qualified GHC.Conc as Conc++import           Language.Haskell.TH.Lift (deriveLift)++import           System.Console.ANSI (hSupportsANSI)+import           System.Environment (lookupEnv)+import           System.IO (stdout)++#if !mingw32_HOST_OS+import           System.Posix.User (getEffectiveUserName)+#endif++import           Text.Read (readMaybe)+++-- | Whether to render output using ANSI colors or not.+--+data UseColor =+    DisableColor+    -- ^ Disable ANSI colors in report output.+  | EnableColor+    -- ^ Enable ANSI colors in report output.+    deriving (Eq, Ord, Show)++-- | How verbose should the report output be.+--+data Verbosity =+    Quiet+    -- ^ Only display the summary of the test run.+  | Normal+    -- ^ Display each property as it is running, as well as the summary.+    deriving (Eq, Ord, Show)++-- | The number of workers to use when running properties in parallel.+--+newtype WorkerCount =+  WorkerCount Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++detectMark :: MonadIO m => m Bool+detectMark = do+#if mingw32_HOST_OS+   pure False+#else+   user <- liftIO getEffectiveUserName+   pure $ user == "mth"+#endif++lookupBool :: MonadIO m => String -> m (Maybe Bool)+lookupBool key =+  liftIO $ do+    menv <- lookupEnv key+    case menv of+      Just "0" ->+        pure $ Just False+      Just "no" ->+        pure $ Just False+      Just "false" ->+        pure $ Just False++      Just "1" ->+        pure $ Just True+      Just "yes" ->+        pure $ Just True+      Just "true" ->+        pure $ Just True++      _ ->+        pure Nothing++detectColor :: MonadIO m => m UseColor+detectColor =+  liftIO $ do+    ok <- lookupBool "HEDGEHOG_COLOR"+    case ok of+      Just False ->+        pure DisableColor++      Just True ->+        pure EnableColor++      Nothing -> do+        mth <- detectMark+        if mth then+          pure DisableColor -- avoid getting fired :)+        else do+          enable <- hSupportsANSI stdout+          if enable then+            pure EnableColor+          else+            pure DisableColor++detectVerbosity :: MonadIO m => m Verbosity+detectVerbosity =+  liftIO $ do+    menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_VERBOSITY"+    case menv of+      Just (0 :: Int) ->+        pure Quiet++      Just (1 :: Int) ->+        pure Normal++      _ -> do+        mth <- detectMark+        if mth then+          pure Quiet+        else+          pure Normal++detectWorkers :: MonadIO m => m WorkerCount+detectWorkers = do+  liftIO $ do+    menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_WORKERS"+    case menv of+      Nothing ->+        WorkerCount <$> Conc.getNumProcessors+      Just env ->+        pure $ WorkerCount env++resolveColor :: MonadIO m => Maybe UseColor -> m UseColor+resolveColor = \case+  Nothing ->+    detectColor+  Just x ->+    pure x++resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity+resolveVerbosity = \case+  Nothing ->+    detectVerbosity+  Just x ->+    pure x++resolveWorkers :: MonadIO m => Maybe WorkerCount -> m WorkerCount+resolveWorkers = \case+  Nothing ->+    detectWorkers+  Just x ->+    pure x++------------------------------------------------------------------------+-- FIXME Replace with DeriveLift when we drop 7.10 support.++$(deriveLift ''UseColor)+$(deriveLift ''Verbosity)+$(deriveLift ''WorkerCount)

@@ -31,7 +31,7 @@     } deriving (Eq, Ord, Show)  readProperties :: MonadIO m => FilePath -> m (Map PropertyName PropertySource)-readProperties path = do+readProperties path =   findProperties path <$> liftIO (readFile path)  readDeclaration :: MonadIO m => FilePath -> LineNo -> m (Maybe (String, Pos String))

@@ -15,7 +15,6 @@ module Hedgehog.Internal.Property (   -- * Property     Property(..)-  , GroupName(..)   , PropertyName(..)   , PropertyConfig(..)   , TestLimit(..)@@ -26,13 +25,21 @@   , withDiscards   , withShrinks +  -- * Group+  , Group(..)+  , GroupName(..)+   -- * Test   , Test(..)   , Log(..)   , Failure(..)   , Diff(..)   , forAll-  , info+  , forAllWith+  , annotate+  , annotateShow+  , footnote+  , footnoteShow   , discard   , failure   , success@@ -69,7 +76,8 @@ import           Control.Monad.Trans.Writer.Lazy (WriterT(..)) import           Control.Monad.Writer.Class (MonadWriter(..)) -import           Data.Typeable (Typeable, TypeRep, typeOf)+import           Data.Semigroup (Semigroup)+import           Data.String (IsString)  import           Hedgehog.Gen (Gen) import qualified Hedgehog.Gen as Gen@@ -96,19 +104,12 @@       unTest :: ExceptT Failure (WriterT [Log] (Gen m)) a     } deriving (Functor, Applicative) --- | The name of a group of properties.----newtype GroupName =-  GroupName {-      unGroupName :: String-    } deriving (Eq, Ord, Show)- -- | The name of a property. -- newtype PropertyName =   PropertyName {       unPropertyName :: String-    } deriving (Eq, Ord, Show)+    } deriving (Eq, Ord, Show, IsString, Semigroup)  -- | Configuration for a property test. --@@ -138,7 +139,22 @@   DiscardLimit Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral) +-- | A named collection of property tests. --+data Group =+  Group {+      groupName :: !GroupName+    , groupProperties :: ![(PropertyName, Property)]+    }++-- | The name of a group of properties.+--+newtype GroupName =+  GroupName {+      unGroupName :: String+    } deriving (Eq, Ord, Show, IsString, Semigroup)++-- -- FIXME This whole Log/Failure thing could be a lot more structured to allow -- FIXME for richer user controlled error messages, think Doc. Ideally we'd -- FIXME allow user's to create their own diffs anywhere.@@ -147,8 +163,8 @@ -- | Log messages which are recorded during a test run. -- data Log =-    Info String-  | Input (Maybe Span) TypeRep String+    Annotation (Maybe Span) String+  | Footnote String     deriving (Eq, Show)  -- | Details on where and why a test failed.@@ -318,18 +334,50 @@  -- | Generates a random input for the test by running the provided generator. ---forAll :: (Monad m, Show a, Typeable a, HasCallStack) => Gen m a -> Test m a-forAll gen = do+forAll :: (Monad m, Show a, HasCallStack) => Gen m a -> Test m a+forAll gen =+  withFrozenCallStack $ forAllWith showPretty gen++-- | Generates a random input for the test by running the provided generator.+--+--   /This is a the same as 'forAll' but allows the user to provide a custom/+--   /rendering function. This is useful for values which don't have a/+--   /'Show' instance./+--+forAllWith :: (Monad m, HasCallStack) => (a -> String) -> Gen m a -> Test m a+forAllWith render gen = do   x <- Test . lift $ lift gen-  writeLog $ Input (getCaller callStack) (typeOf x) (showPretty x)+  withFrozenCallStack $ annotate (render x)   return x --- | Logs an information message to be displayed if the test fails.+-- | Annotates the source code with a message that might be useful for+--   debugging a test failure. ---info :: Monad m => String -> Test m ()-info =-  writeLog . Info+annotate :: (Monad m, HasCallStack) => String -> Test m ()+annotate x = do+  writeLog $ Annotation (getCaller callStack) x +-- | Annotates the source code with a value that might be useful for+--   debugging a test failure.+--+annotateShow :: (Monad m, Show a, HasCallStack) => a -> Test m ()+annotateShow x = do+  withFrozenCallStack $ annotate (showPretty x)++-- | Logs a message to be displayed as additional information in the footer of+--   the failure report.+--+footnote :: Monad m => String -> Test m ()+footnote =+  writeLog . Footnote++-- | Logs a value to be displayed as additional information in the footer of+--   the failure report.+--+footnoteShow :: (Monad m, Show a) => a -> Test m ()+footnoteShow =+  writeLog . Footnote . showPretty+ -- | Discards a test entirely. -- discard :: Monad m => Test m a@@ -360,7 +408,7 @@ assert b =   if b then     success-  else do+  else     withFrozenCallStack failure  infix 4 ===@@ -389,7 +437,7 @@ -- liftEither :: (Monad m, Show x, HasCallStack) => Either x a -> Test m a liftEither = \case-  Left x -> do+  Left x ->     withFrozenCallStack $ failWith Nothing $ showPretty x   Right x ->     pure x@@ -398,7 +446,7 @@ --   the 'Right'. -- liftExceptT :: (Monad m, Show x, HasCallStack) => ExceptT x m a -> Test m a-liftExceptT m = do+liftExceptT m =   withFrozenCallStack liftEither =<< lift (runExceptT m)  -- | Run a computation which requires resource acquisition / release.

@@ -0,0 +1,116 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+module Hedgehog.Internal.Queue (+    TaskIndex(..)+  , TasksRemaining(..)++  , runTasks+  , finalizeTask+ +  , runActiveFinalizers+  , dequeueMVar++  , updateNumCapabilities+  ) where++import           Control.Concurrent.Async (forConcurrently)+import           Control.Concurrent.MVar (MVar)+import qualified Control.Concurrent.MVar as MVar+import           Control.Monad (when)+import           Control.Monad.IO.Class (MonadIO(..))++import           Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map++import qualified GHC.Conc as Conc++import           Hedgehog.Internal.Config+++newtype TaskIndex =+  TaskIndex Int+  deriving (Eq, Ord, Enum, Num)++newtype TasksRemaining =+  TasksRemaining Int++dequeueMVar ::+     MVar [(TaskIndex, a)]+  -> (TasksRemaining -> TaskIndex -> a -> IO b)+  -> IO (Maybe (TaskIndex, b))+dequeueMVar mvar start =+  MVar.modifyMVar mvar $ \case+    [] ->+      pure ([], Nothing)+    (ix, x) : xs -> do+      y <- start (TasksRemaining $ length xs) ix x+      pure (xs, Just (ix, y))++runTasks ::+     WorkerCount+  -> [a]+  -> (TasksRemaining -> TaskIndex -> a -> IO b)+  -> (b -> IO ())+  -> (b -> IO ())+  -> (b -> IO c)+  -> IO [c]+runTasks n tasks start finish finalize runTask = do+  qvar <- MVar.newMVar (zip [0..] tasks)+  fvar <- MVar.newMVar (-1, Map.empty)++  let+    worker rs = do+      mx <- dequeueMVar qvar start+      case mx of+        Nothing ->+          pure rs+        Just (ix, x) -> do+          r <- runTask x+          finish x+          finalizeTask fvar ix (finalize x)+          worker (r : rs)++  -- FIXME ensure all workers have finished running+  fmap concat . forConcurrently [1..max 1 n] $ \_ix ->+    worker []++runActiveFinalizers ::+     MonadIO m+  => MVar (TaskIndex, Map TaskIndex (IO ()))+  -> m ()+runActiveFinalizers mvar =+  liftIO $ do+    again <-+      MVar.modifyMVar mvar $ \original@(minIx, finalizers0) ->+        case Map.minViewWithKey finalizers0 of+          Nothing ->+            pure (original, False)++          Just ((ix, finalize), finalizers) ->+            if ix == minIx + 1 then do+              finalize+              pure ((ix, finalizers), True)+            else+              pure (original, False)++    when again $+      runActiveFinalizers mvar++finalizeTask ::+     MonadIO m+  => MVar (TaskIndex, Map TaskIndex (IO ()))+  -> TaskIndex+  -> IO ()+  -> m ()+finalizeTask mvar ix finalize = do+  liftIO . MVar.modifyMVar_ mvar $ \(minIx, finalizers) ->+    pure (minIx, Map.insert ix finalize finalizers)+  runActiveFinalizers mvar++-- | Update the number of capabilities but never set it lower than it already+--   is.+--+updateNumCapabilities :: WorkerCount -> IO ()+updateNumCapabilities (WorkerCount n) = do+  ncaps <- Conc.getNumCapabilities+  Conc.setNumCapabilities (max n ncaps)

@@ -0,0 +1,110 @@+module Hedgehog.Internal.Region (+    Region(..)+  , newEmptyRegion+  , newRegion+  , forceRegion+  , setRegion+  , displayRegions+  , displayRegion+  , moveToBottom+  , finishRegion+  ) where++import           Control.Concurrent.STM (STM, TVar, atomically)+import qualified Control.Concurrent.STM.TMVar as TMVar+import qualified Control.Concurrent.STM.TVar as TVar+import           Control.Monad.Catch (MonadMask(..), bracket)+import           Control.Monad.IO.Class (MonadIO(..))++import           System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion(..))+import qualified System.Console.Regions as Console+++newtype Region =+  Region {+      unRegion :: TVar (Maybe ConsoleRegion)+    }++newEmptyRegion :: LiftRegion m => m Region+newEmptyRegion =+  liftRegion $ do+    ref <- TVar.newTVar Nothing+    pure $ Region ref++newRegion :: LiftRegion m => m Region+newRegion =+  liftRegion $ do+    region <- Console.openConsoleRegion Linear+    ref <- TVar.newTVar $ Just region+    pure $ Region ref++forceRegion :: LiftRegion m => Region -> String -> m ()+forceRegion (Region var) content =+  liftRegion $ do+    mregion <- TVar.readTVar var+    case mregion of+      Nothing -> do+        region <- Console.openConsoleRegion Linear+        TVar.writeTVar var $ Just region+        Console.setConsoleRegion region content++      Just region ->+        Console.setConsoleRegion region content++setRegion :: LiftRegion m => Region -> String -> m ()+setRegion (Region var) content =+  liftRegion $ do+    mregion <- TVar.readTVar var+    case mregion of+      Nothing -> do+        pure ()++      Just region ->+        Console.setConsoleRegion region content++displayRegions :: (MonadIO m, MonadMask m) => m a -> m a+displayRegions io = do+  liftIO . atomically $ do+    -- clear old regions+    mxs <- TMVar.tryTakeTMVar Console.regionList+    case mxs of+      Nothing ->+        pure ()+      Just _xs ->+        TMVar.putTMVar Console.regionList []++  Console.displayConsoleRegions io++displayRegion ::+     MonadIO m+  => MonadMask m+  => LiftRegion m+  => (Region -> m a)+  -> m a+displayRegion =+  displayRegions . bracket newRegion finishRegion++moveToBottom :: ConsoleRegion -> STM ()+moveToBottom region = do+  mxs <- TMVar.tryTakeTMVar Console.regionList+  case mxs of+    Nothing ->+      pure ()+    Just xs0 ->+      let+        xs1 =+          filter (/= region) xs0+      in+        TMVar.putTMVar Console.regionList (region : xs1)++finishRegion :: LiftRegion m => Region -> m ()+finishRegion (Region var) =+  liftRegion $ do+    mregion <- TVar.readTVar var+    case mregion of+      Nothing ->+        pure ()++      Just region -> do+        content <- Console.getConsoleRegion region+        Console.finishConsoleRegion region content

@@ -1,4 +1,6 @@+{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}@@ -6,21 +8,31 @@ {-# LANGUAGE TupleSections #-} module Hedgehog.Internal.Report (   -- * Report-    Report(..)-  , Status(..)+    Summary(..)+  , Report(..)+  , Progress(..)+  , Result(..)   , FailureReport(..)-  , FailedInput(..)+  , FailedAnnotation(..) -  , ShrinkCount-  , TestCount-  , DiscardCount+  , ShrinkCount(..)+  , TestCount(..)+  , DiscardCount(..)+  , PropertyCount(..)    , Style(..)   , Markup(..) -  , renderReport-  , ppReport+  , renderProgress+  , renderResult+  , renderSummary+  , renderDoc +  , ppProgress+  , ppResult+  , ppSummary++  , fromResult   , mkFailure   ) where @@ -36,8 +48,8 @@ import qualified Data.Map as Map import           Data.Maybe (mapMaybe, catMaybes) import           Data.Semigroup (Semigroup(..))-import           Data.Typeable (TypeRep) +import           Hedgehog.Internal.Config import           Hedgehog.Internal.Discovery (Pos(..), Position(..)) import qualified Hedgehog.Internal.Discovery as Discovery import           Hedgehog.Internal.Property (PropertyName(..), Log(..), Diff(..))@@ -48,10 +60,8 @@  import           System.Console.ANSI (ColorIntensity(..), Color(..)) import           System.Console.ANSI (ConsoleLayer(..), ConsoleIntensity(..))-import           System.Console.ANSI (SGR(..), setSGRCode, hSupportsANSI)+import           System.Console.ANSI (SGR(..), setSGRCode) import           System.Directory (makeRelativeToCurrentDirectory)-import           System.Environment (lookupEnv)-import           System.IO (stdout)  import           Text.PrettyPrint.Annotated.WL (Doc, (<+>)) import qualified Text.PrettyPrint.Annotated.WL as WL@@ -78,10 +88,15 @@   DiscardCount Int   deriving (Eq, Ord, Show, Num, Enum, Real, Integral) -data FailedInput =-  FailedInput {+-- | The number of properties in a group.+--+newtype PropertyCount =+  PropertyCount Int+  deriving (Eq, Ord, Show, Num, Enum, Real, Integral)++data FailedAnnotation =+  FailedAnnotation {       failedSpan :: !(Maybe Span)-    , failedType :: !TypeRep     , failedValue :: !String     } deriving (Eq, Show) @@ -90,36 +105,83 @@       failureSize :: !Size     , failureSeed :: !Seed     , failureShrinks :: !ShrinkCount-    , failureInputs :: ![FailedInput]+    , failureAnnotations :: ![FailedAnnotation]     , failureLocation :: !(Maybe Span)     , failureMessage :: !String     , failureDiff :: !(Maybe Diff)-    , failureMessages :: ![String]+    , failureFootnotes :: ![String]     } deriving (Eq, Show) --- | The status of a property test run.+-- | The status of a running property test. --+data Progress =+    Running+  | Shrinking !FailureReport+    deriving (Eq, Show)++-- | The status of a completed property test.+-- --   In the case of a failure it provides the seed used for the test, the --   number of shrinks, and the execution log. ---data Status =-    Waiting-  | Running-  | Shrinking !FailureReport-  | Failed !FailureReport+data Result =+    Failed !FailureReport   | GaveUp   | OK     deriving (Eq, Show) --- | The report from a property test run.+-- | A report on a running or completed property test. ---data Report =+data Report a =   Report {       reportTests :: !TestCount     , reportDiscards :: !DiscardCount-    , reportStatus :: !Status+    , reportStatus :: !a+    } deriving (Show, Functor, Foldable, Traversable)++-- | A summary of all the properties executed.+--+data Summary =+  Summary {+      summaryWaiting :: !PropertyCount+    , summaryRunning :: !PropertyCount+    , summaryFailed :: !PropertyCount+    , summaryGaveUp :: !PropertyCount+    , summaryOK :: !PropertyCount     } deriving (Show) +instance Monoid Summary where+  mempty =+    Summary 0 0 0 0 0+  mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) =+    Summary+      (x1 + y1)+      (x2 + y2)+      (x3 + y3)+      (x4 + y4)+      (x5 + y5)++instance Semigroup Summary++-- | Construct a summary from a single result.+--+fromResult :: Result -> Summary+fromResult = \case+  Failed _ ->+    mempty { summaryFailed = 1 }+  GaveUp ->+    mempty { summaryGaveUp = 1 }+  OK ->+    mempty { summaryOK = 1 }++summaryCompleted :: Summary -> PropertyCount+summaryCompleted (Summary _ _ x3 x4 x5) =+  x3 + x4 + x5++summaryTotal :: Summary -> PropertyCount+summaryTotal (Summary x1 x2 x3 x4 x5) =+  x1 + x2 + x3 + x4 + x5+ ------------------------------------------------------------------------ -- Pretty Printing Helpers @@ -139,8 +201,8 @@     } deriving (Eq, Ord, Show, Functor)  data Style =-    StyleInfo-  | StyleInput+    StyleDefault+  | StyleAnnotation   | StyleFailure     deriving (Eq, Ord, Show) @@ -161,8 +223,8 @@   | StyledLineNo !Style   | StyledBorder !Style   | StyledSource !Style-  | InputGutter-  | InputValue+  | AnnotationGutter+  | AnnotationValue   | FailureArrows   | FailureGutter   | FailureMessage@@ -184,25 +246,25 @@         StyleFailure       (_, StyleFailure) ->         StyleFailure-      (StyleInput, _) ->-        StyleInput-      (_, StyleInput) ->-        StyleInput-      (StyleInfo, _) ->-        StyleInfo+      (StyleAnnotation, _) ->+        StyleAnnotation+      (_, StyleAnnotation) ->+        StyleAnnotation+      (StyleDefault, _) ->+        StyleDefault  ------------------------------------------------------------------------ -takeInput :: Log -> Maybe FailedInput-takeInput = \case-  Input loc typ val ->-    Just $ FailedInput loc typ val+takeAnnotation :: Log -> Maybe FailedAnnotation+takeAnnotation = \case+  Annotation loc val ->+    Just $ FailedAnnotation loc val   _ ->     Nothing -takeInfo :: Log -> Maybe String-takeInfo = \case-  Info x ->+takeFootnote :: Log -> Maybe String+takeFootnote = \case+  Footnote x ->     Just x   _ ->     Nothing@@ -219,12 +281,12 @@ mkFailure size seed shrinks location message diff logs =   let     inputs =-      mapMaybe takeInput logs+      mapMaybe takeAnnotation logs -    info =-      mapMaybe takeInfo logs+    footnotes =+      mapMaybe takeFootnote logs   in-    FailureReport size seed shrinks inputs location message diff info+    FailureReport size seed shrinks inputs location message diff footnotes  ------------------------------------------------------------------------ -- Pretty Printing@@ -266,6 +328,10 @@   ShrinkCount n ->     ppShow n <+> "shrinks" +ppRawPropertyCount :: PropertyCount -> Doc a+ppRawPropertyCount (PropertyCount n) =+  ppShow n+ ppWithDiscardCount :: DiscardCount -> Doc Markup ppWithDiscardCount = \case   DiscardCount 0 ->@@ -340,7 +406,7 @@  defaultStyle :: Declaration a -> Declaration (Style, [(Style, Doc Markup)]) defaultStyle =-  fmap $ const (StyleInfo, [])+  fmap $ const (StyleDefault, [])  lastLineSpan :: Monad m => Span -> Declaration a -> MaybeT m (ColumnNo, ColumnNo) lastLineSpan sloc decl =@@ -351,19 +417,18 @@       pure $         lineSpan x -ppFailedInputTypedArgument :: Int -> FailedInput -> Doc Markup-ppFailedInputTypedArgument ix (FailedInput _ typ val) =+ppFailedInputTypedArgument :: Int -> FailedAnnotation -> Doc Markup+ppFailedInputTypedArgument ix (FailedAnnotation _ val) =   WL.vsep [-      WL.text "forAll" <> ppShow ix <+> "::" <+> ppShow typ-    , WL.text "forAll" <> ppShow ix <+> "="-    , WL.indent 2 . WL.vsep . fmap (markup InputValue . WL.text) $ lines val+      WL.text "forAll" <> ppShow ix <+> "="+    , WL.indent 2 . WL.vsep . fmap (markup AnnotationValue . WL.text) $ lines val     ]  ppFailedInputDeclaration ::      MonadIO m-  => FailedInput+  => FailedAnnotation   -> m (Maybe (Declaration (Style, [(Style, Doc Markup)])))-ppFailedInputDeclaration (FailedInput msloc _ val) =+ppFailedInputDeclaration (FailedAnnotation msloc val) =   runMaybeT $ do     sloc <- MaybeT $ pure msloc     decl <- fmap defaultStyle . MaybeT $ readDeclaration sloc@@ -372,12 +437,12 @@     let       ppValLine =         WL.indent startCol .-          (markup InputGutter (WL.text "│ ") <>) .-          markup InputValue .+          (markup AnnotationGutter (WL.text "│ ") <>) .+          markup AnnotationValue .           WL.text        valDocs =-        fmap ((StyleInput, ) . ppValLine) $+        fmap ((StyleAnnotation, ) . ppValLine) $         List.lines val        startLine =@@ -387,7 +452,7 @@         fromIntegral $ spanEndLine sloc        styleInput kvs =-        foldr (Map.adjust . fmap . first $ const StyleInput) kvs [startLine..endLine]+        foldr (Map.adjust . fmap . first $ const StyleAnnotation) kvs [startLine..endLine]        insertDoc =         Map.adjust (fmap . second $ const valDocs) endLine@@ -398,7 +463,7 @@ ppFailedInput ::      MonadIO m   => Int-  -> FailedInput+  -> FailedAnnotation   -> m (Either (Doc Markup) (Declaration (Style, [(Style, Doc Markup)]))) ppFailedInput ix input = do   mdecl <- ppFailedInputDeclaration input@@ -488,9 +553,9 @@       let         ppLocation =           WL.indent (digits + 1) $-            markup (StyledBorder StyleInfo) "┏━━" <+>+            markup (StyledBorder StyleDefault) "┏━━" <+>             markup DeclarationLocation (WL.text (declarationFile decl)) <+>-            markup (StyledBorder StyleInfo) "━━━"+            markup (StyledBorder StyleDefault) "━━━"          digits =           length . show . unLineNo $ lineNumber lastLine@@ -601,14 +666,10 @@   Just (PropertyName name) ->     WL.text name -ppReport :: MonadIO m => Maybe PropertyName -> Report -> m (Doc Markup)-ppReport name (Report tests discards status) =+ppProgress :: MonadIO m => Maybe PropertyName -> Report Progress -> m (Doc Markup)+ppProgress name (Report tests discards status) =   case status of-    Waiting -> do-      pure . icon WaitingIcon '○' . WL.annotate WaitingHeader $-        ppName name--    Running -> do+    Running ->       pure . icon RunningIcon '●' . WL.annotate RunningHeader $         ppName name <+>         "passed" <+>@@ -616,7 +677,7 @@         ppWithDiscardCount discards <+>         "(running)" -    Shrinking failure -> do+    Shrinking failure ->       pure . icon ShrinkingIcon '↯' . WL.annotate ShrinkingHeader $         ppName name <+>         "failed after" <+>@@ -624,6 +685,9 @@         ppShrinkDiscard (failureShrinks failure) discards <+>         "(shrinking)" +ppResult :: MonadIO m => Maybe PropertyName -> Report Result -> m (Doc Markup)+ppResult name (Report tests discards result) =+  case result of     Failed failure -> do       pfailure <- ppFailureReport name failure       pure . WL.vsep $ [@@ -637,6 +701,7 @@         , pfailure         , mempty         ]+     GaveUp ->       pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $         ppName name <+>@@ -645,6 +710,7 @@         ", passed" <+>         ppTestCount tests <>         "."+     OK ->       pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $         ppName name <+>@@ -652,35 +718,68 @@         ppTestCount tests <>         "." -useColor :: MonadIO m => m Bool-useColor =-  liftIO $ do-    menv <- lookupEnv "HEDGEHOG_COLOR"-    case menv of-      Just "0" ->-        pure False-      Just "no" ->-        pure False-      Just "false" ->-        pure False+ppWhenNonZero :: Doc a -> PropertyCount -> Maybe (Doc a)+ppWhenNonZero suffix n =+  if n <= 0 then+    Nothing+  else+    Just $ ppRawPropertyCount n <+> suffix -      Just "1" ->-        pure True-      Just "yes" ->-        pure True-      Just "true" ->-        pure True+annotateSummary :: Summary -> Doc Markup -> Doc Markup+annotateSummary summary =+  if summaryFailed summary > 0 then+    icon FailedIcon '✗' . WL.annotate FailedHeader+  else if summaryGaveUp summary > 0 then+    icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader+  else if summaryWaiting summary > 0 || summaryRunning summary > 0 then+    icon WaitingIcon '○' . WL.annotate WaitingHeader+  else+    icon SuccessIcon '✓' . WL.annotate SuccessHeader -      Just _ ->-        hSupportsANSI stdout-      Nothing ->-        hSupportsANSI stdout+ppSummary :: MonadIO m => Summary -> m (Doc Markup)+ppSummary summary =+  let+    complete =+      summaryCompleted summary == summaryTotal summary -renderReport :: MonadIO m => Maybe PropertyName -> Report -> m String-renderReport name x = do-  doc <- ppReport name x-  color <- useColor+    prefix end =+      if complete then+        mempty+      else+        ppRawPropertyCount (summaryCompleted summary) <>+        "/" <>+        ppRawPropertyCount (summaryTotal summary) <+>+        "complete" <> end +    addPrefix xs =+      if null xs then+        prefix mempty : []+      else+        prefix ": " : xs++    suffix =+      if complete then+        "."+      else+        " (running)"+  in+    pure .+      annotateSummary summary .+      (<> suffix) .+      WL.hcat .+      addPrefix .+      WL.punctuate ", " $+      catMaybes [+          ppWhenNonZero "failed" (summaryFailed summary)+        , ppWhenNonZero "gave up" (summaryGaveUp summary)+        , if complete then+            ppWhenNonZero "succeeded" (summaryOK summary)+          else+            Nothing+        ]++renderDoc :: MonadIO m => Maybe UseColor -> Doc Markup -> m String+renderDoc mcolor doc = do   let     dull =       SetColor Foreground Dull@@ -720,22 +819,22 @@       DeclarationLocation ->         setSGRCode [] -      StyledLineNo StyleInfo ->+      StyledLineNo StyleDefault ->         setSGRCode []-      StyledSource StyleInfo ->+      StyledSource StyleDefault ->         setSGRCode []-      StyledBorder StyleInfo ->+      StyledBorder StyleDefault ->         setSGRCode [] -      StyledLineNo StyleInput ->+      StyledLineNo StyleAnnotation ->         setSGRCode [dull Magenta]-      StyledSource StyleInput ->+      StyledSource StyleAnnotation ->         setSGRCode []-      StyledBorder StyleInput ->+      StyledBorder StyleAnnotation ->         setSGRCode []-      InputGutter ->+      AnnotationGutter ->         setSGRCode [dull Magenta]-      InputValue ->+      AnnotationValue ->         setSGRCode [dull Magenta]        StyledLineNo StyleFailure ->@@ -774,13 +873,29 @@     end _ =       setSGRCode [Reset] +  color <- resolveColor mcolor++  let     display =-      if color then-        WL.displayDecorated start end id-      else-        WL.display+      case color of+        EnableColor ->+          WL.displayDecorated start end id+        DisableColor ->+          WL.display    pure .     display .     WL.renderSmart 100 $     WL.indent 2 doc++renderProgress :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Progress -> m String+renderProgress mcolor name x =+  renderDoc mcolor =<< ppProgress name x++renderResult :: MonadIO m => Maybe UseColor -> Maybe PropertyName -> Report Result -> m String+renderResult mcolor name x =+  renderDoc mcolor =<< ppResult name x++renderSummary :: MonadIO m => Maybe UseColor -> Summary -> m String+renderSummary mcolor x =+  renderDoc mcolor =<< ppSummary x

@@ -1,63 +1,69 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DoAndIfThenElse #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.Runner (-  -- * Runner-    RunnerConfig(..)-  , check-  , checkGroupWith+  -- * Running Individual Properties+    check   , recheck +  -- * Running Groups of Properties+  , RunnerConfig(..)+  , checkParallel+  , checkSequential+  , checkGroup+   -- * Internal   , checkReport-  , checkConsoleRegion+  , checkRegion   , checkNamed   ) where -import           Control.Concurrent.Async (forConcurrently)-import           Control.Concurrent.MVar (MVar)-import qualified Control.Concurrent.MVar as MVar-import qualified Control.Concurrent.QSem as QSem-import           Control.Monad (when)-import           Control.Monad.Catch (MonadMask(..), MonadCatch(..), catchAll, bracket)+import           Control.Concurrent.STM (TVar, atomically)+import qualified Control.Concurrent.STM.TVar as TVar+import           Control.Monad.Catch (MonadCatch(..), catchAll) import           Control.Monad.IO.Class (MonadIO(..)) -import           Data.Map.Strict (Map)-import qualified Data.Map.Strict as Map-import           Data.Traversable (for)--import qualified GHC.Conc as Conc+import           Data.Semigroup ((<>))  import           Hedgehog.Gen (runGen) import qualified Hedgehog.Gen as Gen+import           Hedgehog.Internal.Config+import           Hedgehog.Internal.Property (Group(..), GroupName(..))+import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..))+import           Hedgehog.Internal.Property (ShrinkLimit, withTests)+import           Hedgehog.Internal.Property (Test, Log(..), Failure(..), runTest)+import           Hedgehog.Internal.Queue+import           Hedgehog.Internal.Region import           Hedgehog.Internal.Report import           Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import           Hedgehog.Internal.Tree (Tree(..), Node(..))-import           Hedgehog.Internal.Property (PropertyName(..), GroupName(..))-import           Hedgehog.Internal.Property (Test, Log(..), Failure(..), runTest)-import           Hedgehog.Internal.Property (Property(..), PropertyConfig(..))-import           Hedgehog.Internal.Property (ShrinkLimit, withTests) import           Hedgehog.Range (Size)  import           Language.Haskell.TH.Lift (deriveLift) -import           System.Console.Regions (ConsoleRegion, RegionLayout(..), LiftRegion)+import           System.Console.Regions (ConsoleRegion, RegionLayout(..)) import qualified System.Console.Regions as Console-import           System.Environment (lookupEnv) -import           Text.Read (readMaybe) - -- | Configuration for a property test run. -- data RunnerConfig =   RunnerConfig {       -- | The number of property tests to run concurrently. 'Nothing' means       --   use one worker per processor.-      runnerWorkers :: !(Maybe Int)+      runnerWorkers :: !(Maybe WorkerCount)++      -- | Whether to use colored output or not. 'Nothing' means detect from+      --   the environment.+    , runnerColor :: !(Maybe UseColor)++      -- | How verbose to be in the runner output. 'Nothing' means detect from+      --   the environment.+    , runnerVerbosity :: !(Maybe Verbosity)     } deriving (Eq, Ord, Show)  findM :: Monad m => [a] -> b -> (a -> m (Maybe b)) -> m b@@ -86,9 +92,9 @@   -> Seed   -> ShrinkCount   -> ShrinkLimit-  -> (Status -> m ())+  -> (Progress -> m ())   -> Node m (Maybe (Either Failure (), [Log]))-  -> m Status+  -> m Result takeSmallest size seed shrinks slimit updateUI = \case   Node Nothing _ ->     pure GaveUp@@ -124,14 +130,14 @@   -> Size   -> Seed   -> Test m ()-  -> (Report -> m ())-  -> m Report+  -> (Report Progress -> m ())+  -> m (Report Result) checkReport cfg size0 seed0 test0 updateUI =   let     test =       catchAll test0 (fail . show) -    loop :: TestCount -> DiscardCount -> Size -> Seed -> m Report+    loop :: TestCount -> DiscardCount -> Size -> Seed -> m (Report Result)     loop !tests !discards !size !seed = do       updateUI $ Report tests discards Running @@ -175,37 +181,54 @@   in     loop 0 0 size0 seed0 -checkConsoleRegion ::+checkRegion ::      MonadIO m-  => ConsoleRegion+  => Region+  -> Maybe UseColor   -> Maybe PropertyName   -> Size   -> Seed   -> Property-  -> m Report-checkConsoleRegion region name size seed prop =+  -> m (Report Result)+checkRegion region mcolor name size seed prop =   liftIO $ do-    report <--      checkReport (propertyConfig prop) size seed (propertyTest prop) $ \report -> do-        setRegionReport region name report+    result <-+      checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do+        ppprogress <- renderProgress mcolor name progress+        case reportStatus progress of+          Running ->+            setRegion region ppprogress+          Shrinking _ ->+            forceRegion region ppprogress -    setRegionReport region name report+    ppresult <- renderResult mcolor name result+    case reportStatus result of+      Failed _ ->+        forceRegion region ppresult+      GaveUp ->+        forceRegion region ppresult+      OK ->+        setRegion region ppresult -    pure report+    pure result -checkNamed :: MonadIO m => ConsoleRegion -> Maybe PropertyName -> Property -> m Bool-checkNamed region name prop = do+checkNamed ::+     MonadIO m+  => Region+  -> Maybe UseColor+  -> Maybe PropertyName+  -> Property+  -> m (Report Result)+checkNamed region mcolor name prop = do   seed <- liftIO Seed.random-  report <- checkConsoleRegion region name 0 seed prop-  pure $-    reportStatus report == OK+  checkRegion region mcolor name 0 seed prop  -- | Check a property. -- check :: MonadIO m => Property -> m Bool-check prop = do+check prop =   liftIO . displayRegion $ \region ->-    checkNamed region Nothing prop+    (== OK) . reportStatus <$> checkNamed region Nothing Nothing prop  -- | Check a property using a specific size and seed. --@@ -213,125 +236,151 @@ recheck size seed prop0 = do   let prop = withTests 1 prop0   _ <- liftIO . displayRegion $ \region ->-    checkConsoleRegion region Nothing size seed prop+    checkRegion region Nothing Nothing size seed prop   pure ()  -- | Check a group of properties using the specified runner config. ---checkGroupWith ::-     MonadIO m-  => RunnerConfig-  -> GroupName-  -> [(PropertyName, Property)]-  -> m Bool-checkGroupWith config group props0 =+checkGroup :: MonadIO m => RunnerConfig -> Group -> m Bool+checkGroup config (Group group props) =   liftIO $ do-    n <- maybe getNumWorkers pure (runnerWorkers config)+    n <- resolveWorkers (runnerWorkers config) -    -- ensure one spare capability for concurrent-output, it's likely that our-    -- tests will saturate all the capabilities they're given.-    updateNumCapabilities (n + 1)+    -- ensure few spare capabilities for concurrent-output, it's likely that+    -- our tests will saturate all the capabilities they're given.+    updateNumCapabilities (n + 2)      putStrLn $ "━━━ " ++ unGroupName group ++ " ━━━"-    Console.displayConsoleRegions $ do-      mvar <- MVar.newMVar (-1, Map.empty) -      props <--        fmap (zip [0..]) . for props0 $ \(name, p) -> do-          region <- Console.openConsoleRegion Linear-          setRegionReport region (Just name) $ Report 0 0 Waiting-          pure (name, p, region)+    verbosity <- resolveVerbosity (runnerVerbosity config)+    summary <- checkGroupWith n verbosity (runnerColor config) props -      qsem <- QSem.newQSem n+    pure $+      summaryFailed summary == 0 &&+      summaryGaveUp summary == 0 -      results <--        forConcurrently props $ \(ix, (name, p, region)) ->-          bracket (QSem.waitQSem qsem) (const $ QSem.signalQSem qsem) $ \_ -> do-            ok <- checkNamed region (Just name) p-            finishIndexedRegion mvar ix region-            pure ok+updateSummary :: ConsoleRegion -> TVar Summary -> Maybe UseColor -> (Summary -> Summary) -> IO ()+updateSummary sregion svar mcolor f = do+  summary <- atomically (TVar.modifyTVar' svar f >> TVar.readTVar svar)+  Console.setConsoleRegion sregion =<< renderSummary mcolor summary -      pure $-        and results+checkGroupWith ::+     WorkerCount+  -> Verbosity+  -> Maybe UseColor+  -> [(PropertyName, Property)]+  -> IO Summary+checkGroupWith n verbosity mcolor props =+  displayRegions $ do+    sregion <- Console.openConsoleRegion Linear+    svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) } ---------------------------------------------------------------------------- concurrent-output utils+    let+      start (TasksRemaining tasks) _ix (name, prop) =+        liftIO $ do+          updateSummary sregion svar mcolor $ \x -> x {+              summaryWaiting =+                PropertyCount tasks+            , summaryRunning =+                summaryRunning x + 1+            } -displayRegion ::-     MonadIO m-  => MonadMask m-  => LiftRegion m-  => (ConsoleRegion -> m a)-  -> m a-displayRegion =-  Console.displayConsoleRegions .-  bracket (Console.openConsoleRegion Linear) finishRegion+          atomically $ do+            region <-+              case verbosity of+                Quiet ->+                  newEmptyRegion+                Normal ->+                  newRegion -setRegionReport ::-     MonadIO m-  => LiftRegion m-  => ConsoleRegion-  -> Maybe PropertyName-  -> Report-  -> m ()-setRegionReport region name report = do-  content <- renderReport name report-  Console.setConsoleRegion region content+            moveToBottom sregion -finishRegion :: (Monad m, LiftRegion m) => ConsoleRegion -> m ()-finishRegion region = do-  content <- Console.getConsoleRegion region-  Console.finishConsoleRegion region content+            pure (name, prop, region) -flushRegions ::-     MonadIO m-  => MVar (Int, Map Int ConsoleRegion)-  -> m ()-flushRegions mvar =-  liftIO $ do-    again <--      MVar.modifyMVar mvar $ \original@(minIx, regions0) ->-        case Map.minViewWithKey regions0 of-          Nothing ->-            pure (original, False)+      finish (_name, _prop, _region) =+        updateSummary sregion svar mcolor $ \x -> x {+            summaryRunning =+              summaryRunning x - 1+          } -          Just ((ix, region), regions) ->-            if ix == minIx + 1 then do-              finishRegion region-              pure ((ix, regions), True)-            else-              pure (original, False)+      finalize (_name, _prop, region) =+        finishRegion region -    when again $-      flushRegions mvar+    summary <-+      fmap (mconcat . fmap (fromResult . reportStatus)) $+        runTasks n props start finish finalize $ \(name, prop, region) -> do+          result <- checkNamed region mcolor (Just name) prop+          updateSummary sregion svar mcolor+            (<> fromResult (reportStatus result))+          pure result -finishIndexedRegion ::-     MonadIO m-  => MVar (Int, Map Int ConsoleRegion)-  -> Int-  -> ConsoleRegion-  -> m ()-finishIndexedRegion mvar ix region = do-  liftIO . MVar.modifyMVar_ mvar $ \(minIx, regions) ->-    pure (minIx, Map.insert ix region regions)-  flushRegions mvar+    updateSummary sregion svar mcolor (const summary)+    Console.finishConsoleRegion sregion =<< Console.getConsoleRegion sregion --- | Update the number of capabilities but never set it lower than it already---   is.+    pure summary++-- | Check a group of properties sequentially. ---updateNumCapabilities :: Int -> IO ()-updateNumCapabilities n = do-  ncaps <- Conc.getNumCapabilities-  Conc.setNumCapabilities (max n ncaps)+--   Using Template Haskell for property discovery:+--+-- > tests :: IO Bool+-- > tests =+-- >   checkSequential $$(discover)+--+--   With manually specified properties:+--+-- > tests :: IO Bool+-- > tests =+-- >   checkSequential $ Group "Test.Example" [+-- >       ("prop_reverse", prop_reverse)+-- >     ]+--+--+checkSequential :: MonadIO m => Group -> m Bool+checkSequential =+  checkGroup+    RunnerConfig {+        runnerWorkers =+          Just 1+      , runnerColor =+          Nothing+      , runnerVerbosity =+          Nothing+      } -getNumWorkers :: IO Int-getNumWorkers = do-  menv <- (readMaybe =<<) <$> lookupEnv "HEDGEHOG_WORKERS"-  case menv of-    Nothing ->-      Conc.getNumProcessors-    Just env ->-      pure env+-- | Check a group of properties in parallel.+--+--   /Warning: although this check function runs tests faster than/+--   /'checkSequential', it should be noted that it may cause problems with/+--   /properties that are not self-contained. For example, if you have a group/+--   /of tests which all use the same database table, you may find that they/+--   /interfere with each other when being run in parallel./+--+--   Using Template Haskell for property discovery:+--+-- > tests :: IO Bool+-- > tests =+-- >   checkParallel $$(discover)+--+--   With manually specified properties:+--+-- > tests :: IO Bool+-- > tests =+-- >   checkParallel $ Group "Test.Example" [+-- >       ("prop_reverse", prop_reverse)+-- >     ]+--+checkParallel :: MonadIO m => Group -> m Bool+checkParallel =+  checkGroup+    RunnerConfig {+        runnerWorkers =+          Nothing+      , runnerColor =+          Nothing+      , runnerVerbosity =+          Nothing+      }  ------------------------------------------------------------------------ -- FIXME Replace with DeriveLift when we drop 7.10 support.

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-} -- | -- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele -- et. al. [1].@@ -93,7 +92,7 @@ -- | Create a random 'Seed' using an effectful source of randomness. -- random :: MonadIO m => m Seed-random = do+random =   liftIO $ IORef.atomicModifyIORef' global split  -- | Create a 'Seed' using an 'Int64'.

@@ -37,11 +37,11 @@  -- | Shrink a floating-point number by edging towards a destination. -----   >>> towards 0.0 100---   [0.0,50.0,75.0,87.5,93.75,96.875,98.4375,..+--   >>> take 7 (towardsFloat 0.0 100)+--   [0.0,50.0,75.0,87.5,93.75,96.875,98.4375] -----   >>> towards 1.0 0.5---   [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125,..+--   >>> take 7 (towardsFloat 1.0 0.5)+--   [1.0,0.75,0.625,0.5625,0.53125,0.515625,0.5078125] -- --   /Note we always try the destination first, as that is the optimal shrink./ --@@ -72,7 +72,7 @@ --   /Note we always try the empty list first, as that is the optimal shrink./ -- list :: [a] -> [[a]]-list xs = do+list xs =  concatMap    (\k -> removes k xs)    (halves $ length xs)

@@ -2,9 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} module Hedgehog.Internal.TH (     TExpQ-  , checkSequential-  , checkConcurrent-  , checkWith+  , discover   ) where  import qualified Data.List as List@@ -13,7 +11,6 @@  import           Hedgehog.Internal.Discovery import           Hedgehog.Internal.Property-import           Hedgehog.Internal.Runner  import           Language.Haskell.TH import           Language.Haskell.TH.Syntax@@ -21,38 +18,12 @@ type TExpQ a =   Q (TExp a) --- | Check all the properties in a file sequentially.------ > tests :: IO Bool--- > tests =--- >   $$(checkSequential)----checkSequential :: TExpQ (IO Bool)-checkSequential =-  checkWith $-    RunnerConfig {-        runnerWorkers =-          Just 1-      }---- | Check all the properties in a file concurrently.------ > tests :: IO Bool--- > tests =--- >   $$(checkConcurrent)+-- | Discover all the properties in a module. ---checkConcurrent :: TExpQ (IO Bool)-checkConcurrent =-  checkWith $-    RunnerConfig {-        runnerWorkers =-          Nothing-      }---- | Check all the properties in a file.+--   Functions starting with `prop_` are assumed to be properties. ---checkWith :: RunnerConfig -> TExpQ (IO Bool)-checkWith config = do+discover :: TExpQ Group+discover = do   file <- getCurrentFile   properties <- Map.toList <$> runIO (readProperties file) @@ -68,7 +39,7 @@       fmap (mkNamedProperty . fst) $       List.sortBy startLine properties -  [|| checkGroupWith config $$(moduleName) $$(listTE names) ||]+  [|| Group $$(moduleName) $$(listTE names) ||]  mkNamedProperty :: PropertyName -> TExpQ (PropertyName, Property) mkNamedProperty name = do

@@ -242,7 +242,7 @@  passTree :: MonadWriter w m => Tree m (a, w -> w) -> Tree m a passTree (Tree m) =-  Tree $ do+  Tree $     pure . passNode =<< m  instance MonadWriter w m => MonadWriter w (Tree m) where

@@ -34,6 +34,10 @@  import           Prelude hiding (minimum, maximum) +-- $setup+-- >>> import Data.Int (Int8)+-- >>> let x = 3+ -- | Tests are parameterized by the size of the randomly-generated data, the --   meaning of which depends on the particular generator used. --