hedgehog-extras 0.3.0.3 → 0.4.0.0

raw patch · 2 files changed

+37/−21 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hedgehog-extras.cabal +1/−1
• src/Hedgehog/Extras/Test/Base.hs +36/−20

@@ -1,7 +1,7 @@ cabal-version: 2.4  name:                   hedgehog-extras-version:                0.3.0.3+version:                0.4.0.0 synopsis:               Supplemental library for hedgehog description:            Supplemental library for hedgehog. category:               Test

@@ -38,6 +38,10 @@   , nothingFailM   , leftFail   , leftFailM++  , onLeft+  , onNothing+   , jsonErrorFail   , jsonErrorFailM @@ -64,41 +68,43 @@   , runFinallies    , retry+  , retry'   ) where -import           Control.Monad+import           Control.Applicative (Applicative (..))+import           Control.Monad (Functor (fmap), Monad (return, (>>=)), mapM_, unless, void, when) import           Control.Monad.Catch (MonadCatch) import           Control.Monad.Morph (hoist)-import           Control.Monad.Reader+import           Control.Monad.Reader (MonadIO (..), MonadReader (..)) import           Control.Monad.Trans.Resource (ReleaseKey, runResourceT) import           Data.Aeson (Result (..))-import           Data.Bool-import           Data.Either (Either (..))-import           Data.Eq-import           Data.Foldable-import           Data.Function (($), (.))-import           Data.Functor-import           Data.Int+import           Data.Bool (Bool, (&&))+import           Data.Either (Either (..), either)+import           Data.Eq (Eq ((/=)))+import           Data.Foldable (for_)+import           Data.Function (const, ($), (.))+import           Data.Functor ((<$>))+import           Data.Int (Int) import           Data.Maybe (Maybe (..), listToMaybe, maybe) import           Data.Monoid (Monoid (..))-import           Data.Ord+import           Data.Ord (Ord (..)) import           Data.Semigroup (Semigroup (..)) import           Data.String (String) import           Data.Time.Clock (NominalDiffTime, UTCTime)-import           Data.Traversable-import           Data.Tuple-import           GHC.Num+import           Data.Traversable (Traversable)+import           Data.Tuple (snd)+import           GHC.Num (Num ((*), (+))) import           GHC.Stack (CallStack, HasCallStack) import           Hedgehog (MonadTest)-import           Hedgehog.Extras.Internal.Test.Integration-import           Hedgehog.Extras.Stock.CallStack-import           Hedgehog.Extras.Stock.Monad+import           Hedgehog.Extras.Internal.Test.Integration (Integration, IntegrationState (..))+import           Hedgehog.Extras.Stock.CallStack (callerModuleName)+import           Hedgehog.Extras.Stock.Monad (forceM) import           Hedgehog.Extras.Test.MonadAssertion (MonadAssertion) import           Hedgehog.Internal.Property (Diff, liftTest, mkTest) import           Hedgehog.Internal.Source (getCaller) import           Prelude (floor) import           System.IO (FilePath, IO)-import           Text.Show+import           Text.Show (Show (show))  import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM@@ -106,6 +112,7 @@ import qualified Data.Time.Clock as DTC import qualified GHC.Stack as GHC import qualified Hedgehog as H+import qualified Hedgehog.Extras.Internal.Test.Integration as H import qualified Hedgehog.Extras.Test.MonadAssertion as H import qualified Hedgehog.Internal.Property as H import qualified System.Directory as IO@@ -119,7 +126,7 @@ -- | Run a property with only one test.  This is intended for allowing hedgehog -- to run unit tests. propertyOnce :: HasCallStack => Integration () -> H.Property-propertyOnce = H.withTests 1 . H.property . hoist runResourceT . hoist runIntegrationReaderT+propertyOnce = H.withTests 1 . H.property . hoist runResourceT . hoist H.runIntegrationReaderT  -- | Takes a 'CallStack' so the error can be rendered at the appropriate call site. failWithCustom :: MonadTest m => CallStack -> Maybe Diff -> String -> m a@@ -312,6 +319,12 @@ headM (a:_) = return a headM [] = GHC.withFrozenCallStack $ failMessage GHC.callStack "Cannot take head of empty list" +onLeft :: Monad m => (e -> m a) -> m (Either e a) -> m a+onLeft h f = f >>= either h pure++onNothing :: Monad m => m a -> m (Maybe a) -> m a+onNothing h f = f >>= maybe h pure+ fromJustM :: (MonadTest m, HasCallStack) => Maybe a -> m a fromJustM (Just a) = return a fromJustM Nothing = GHC.withFrozenCallStack $ failMessage GHC.callStack "Cannot take head of empty list"@@ -477,12 +490,12 @@       mapM_ reportFinally finals       H.throwAssertion assertion -retry :: forall a. Int -> Integration a -> Integration a+retry :: forall a. Int -> (Int -> Integration a) -> Integration a retry n f = go 0   where go :: Int -> Integration a         go i = do           note_ $ "Retry attempt " <> show i <> " of " <> show n-          result <- H.catchAssertion (fmap Right f) (return . Left)+          result <- H.catchAssertion (fmap Right (f i)) (return . Left)            case result of             Right a -> return a@@ -492,3 +505,6 @@                 else do                   note_ $ "All " <> show (n + 1) <> " attempts failed"                   H.throwAssertion assertion++retry' :: forall a. Int -> Integration a -> Integration a+retry' n f = retry n (const f)