tasty-hedgehog (empty) → 0.1.0.0
raw patch · 6 files changed
+294/−0 lines, 6 filesdep +basedep +hedgehogdep +taggedsetup-changed
Dependencies added: base, hedgehog, tagged, tasty, tasty-expected-failure, tasty-hedgehog
Files
- ChangeLog.md +5/−0
- LICENSE +31/−0
- Setup.hs +2/−0
- src/Test/Tasty/Hedgehog.hs +170/−0
- tasty-hedgehog.cabal +41/−0
- test/Main.hs +45/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for tasty-hedgehog++## 0.1.0.0 -- 2017-08-24++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation+(CSIRO) ABN 41 687 119 230.++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 QFPL 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Test/Tasty/Hedgehog.hs view
@@ -0,0 +1,170 @@+-- |+-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Test.Tasty.Hedgehog (+ testProperty+ ) where++import Data.Typeable++import qualified Test.Tasty.Providers as T+import Test.Tasty.Options++import Hedgehog+import Hedgehog.Internal.Property+import Hedgehog.Internal.Runner as H+import Hedgehog.Internal.Report+import Hedgehog.Internal.Seed as Seed++data HP = HP T.TestName Property+ deriving (Typeable)++-- | Create a 'Test' for a Hedgehog property+testProperty :: T.TestName -> Property -> T.TestTree+testProperty name prop = T.singleTest name (HP name prop)++newtype HedgehogReplay = HedgehogReplay (Maybe (Size, Seed))+ deriving (Typeable)++instance IsOption HedgehogReplay where+ defaultValue = HedgehogReplay Nothing+ parseValue v = HedgehogReplay . Just <$> replay+ -- Reads a replay token in the form "{size} {seed}"+ where replay = (,) <$> safeRead (unwords size) <*> safeRead (unwords seed)+ (size, seed) = splitAt 2 $ words v+ optionName = return "hedgehog-replay"+ optionHelp = return "Replay token to use for replaying a previous test run"++newtype HedgehogShowReplay = HedgehogShowReplay Bool+ deriving (Typeable)++instance IsOption HedgehogShowReplay where+ defaultValue = HedgehogShowReplay True+ parseValue = fmap HedgehogShowReplay . safeRead+ optionName = return "hedgehog-show-replay"+ optionHelp = return "Show a replay token for replaying tests"++newtype HedgehogVerbose = HedgehogVerbose Bool+ deriving (Typeable)++instance IsOption HedgehogVerbose where+ defaultValue = HedgehogVerbose False+ parseValue = fmap HedgehogVerbose . safeRead+ optionName = return "hedgehog-verbose"+ optionHelp = return "Show the generated Hedgehog test cases"+ optionCLParser = flagCLParser Nothing (HedgehogVerbose True)++newtype HedgehogTestLimit = HedgehogTestLimit Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)++instance IsOption HedgehogTestLimit where+ defaultValue = 100+ parseValue = fmap HedgehogTestLimit . safeRead+ optionName = return "hedgehog-tests"+ optionHelp = return "Number of successful test cases required before Hedgehog will pass a test"++newtype HedgehogDiscardLimit = HedgehogDiscardLimit Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)++instance IsOption HedgehogDiscardLimit where+ defaultValue = 100+ parseValue = fmap HedgehogDiscardLimit . safeRead+ optionName = return "hedgehog-discards"+ optionHelp = return "Number of discarded cases allowed before Hedgehog will fail a test"++newtype HedgehogShrinkLimit = HedgehogShrinkLimit Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)++instance IsOption HedgehogShrinkLimit where+ defaultValue = 100+ parseValue = fmap HedgehogShrinkLimit . safeRead+ optionName = return "hedgehog-shrinks"+ optionHelp = return "Number of shrinks allowed before Hedgehog will fail a test"+ +newtype HedgehogShrinkRetries = HedgehogShrinkRetries Int+ deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Typeable)++instance IsOption HedgehogShrinkRetries where+ defaultValue = 10+ parseValue = fmap HedgehogShrinkRetries . safeRead+ optionName = return "hedgehog-retries"+ optionHelp = return "Number of times to re-run a test during shrinking"+ +reportToProgress :: Int+ -> Int+ -> Int+ -> Report Progress+ -> T.Progress+reportToProgress testLimit _ shrinkLimit (Report testsDone _ status) =+ let+ ratio x y = 1.0 * fromIntegral x / fromIntegral y+ in+ -- TODO add details for tests run / discarded / shrunk+ case status of+ Running ->+ T.Progress "Running" (ratio testsDone testLimit)+ Shrinking fr ->+ T.Progress "Shrinking" (ratio (failureShrinks fr) shrinkLimit)++reportOutput :: Bool+ -> Bool+ -> String+ -> Report Result+ -> IO String+reportOutput _ showReplay name report@(Report _ _ status) = do+ -- TODO add details for tests run / discarded / shrunk+ s <- renderResult Nothing (Just (PropertyName name)) report+ pure $ case status of+ Failed fr -> do+ let+ size = failureSize fr+ seed = failureSeed fr+ replayStr =+ if showReplay+ then "\nUse '--hedgehog-replay \"" ++ show size ++ " " ++ show seed ++ "\"' to reproduce."+ else ""+ s ++ replayStr+ GaveUp -> "Gave up"+ OK -> "OK"++instance T.IsTest HP where+ testOptions =+ return [ Option (Proxy :: Proxy HedgehogReplay)+ , Option (Proxy :: Proxy HedgehogShowReplay)+ , Option (Proxy :: Proxy HedgehogVerbose)+ , Option (Proxy :: Proxy HedgehogTestLimit)+ , Option (Proxy :: Proxy HedgehogDiscardLimit)+ , Option (Proxy :: Proxy HedgehogShrinkLimit)+ , Option (Proxy :: Proxy HedgehogShrinkRetries)+ ]++ run opts (HP name (Property _ pTest)) yieldProgress = do+ let+ HedgehogReplay replay = lookupOption opts+ HedgehogShowReplay showReplay = lookupOption opts+ HedgehogVerbose verbose = lookupOption opts+ HedgehogTestLimit tests = lookupOption opts+ HedgehogDiscardLimit discards = lookupOption opts+ HedgehogShrinkLimit shrinks = lookupOption opts+ HedgehogShrinkRetries retries = lookupOption opts+ config =+ PropertyConfig+ (TestLimit tests)+ (DiscardLimit discards)+ (ShrinkLimit shrinks)+ (ShrinkRetries retries)++ randSeed <- Seed.random+ let+ size = maybe 0 fst replay+ seed = maybe randSeed snd replay++ report <- checkReport config size seed pTest (yieldProgress . reportToProgress tests discards shrinks)++ let+ resultFn = if reportStatus report == OK+ then T.testPassed+ else T.testFailed++ out <- reportOutput verbose showReplay name report+ return $ resultFn out
+ tasty-hedgehog.cabal view
@@ -0,0 +1,41 @@+name: tasty-hedgehog+version: 0.1.0.0+license: BSD3+license-file: LICENSE+author: Dave Laing+maintainer: dave.laing.80@gmail.com+copyright: Copyright (c) 2017, Commonwealth Scientific and Industrial Research Organisation (CSIRO) ABN 41 687 119 230.+description: Integrates the hedgehog testing library with the tasty testing framework.+category: Testing+synopsis: Integrates the hedgehog testing library with the tasty testing framework.+homepage: https://github.com/qfpl/tasty-hedghog+bug-reports: https://github.com/qfpl/tasty-hedgehog/issues+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: git@github.com:qfpl/tasty-hedgehog.git++library+ exposed-modules: Test.Tasty.Hedgehog+ build-depends: base >= 4.8 && <4.11+ , tagged >= 0.8 && < 0.9+ , tasty >= 0.11 && < 0.12+ , hedgehog >= 0.5 && < 0.6+ hs-source-dirs: src+ ghc-options: -Wall+ default-language: Haskell2010++test-suite tasty-hedgehog-tests+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test+ build-depends: base >= 4.8 && <4.11+ , tasty >= 0.11 && < 0.12+ , tasty-expected-failure >= 0.11 && < 0.12+ , hedgehog >= 0.5 && < 0.6+ , tasty-hedgehog+ ghc-options: -Wall+ default-language: Haskell2010
+ test/Main.hs view
@@ -0,0 +1,45 @@+module Main where++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import Test.Tasty+import Test.Tasty.ExpectedFailure+import Test.Tasty.Hedgehog++genAlphaList :: Gen String+genAlphaList =+ Gen.list (Range.linear 0 100) Gen.alpha++test_involutive :: (MonadTest m, Eq a, Show a) => (a -> a) -> a -> m ()+test_involutive f x =+ f (f x) === x++prop_reverse_involutive :: Property+prop_reverse_involutive =+ property $ do+ xs <- forAll genAlphaList+ test_involutive reverse xs++badReverse :: [a] -> [a]+badReverse [] = []+badReverse [_] = []+badReverse as = reverse as++prop_badReverse_involutive :: Property+prop_badReverse_involutive =+ property $ do+ xs <- forAll genAlphaList+ test_involutive badReverse xs++main :: IO ()+main =+ defaultMain $+ testGroup "tasty-hedgehog tests"+ [ testProperty+ "reverse involutive"+ prop_reverse_involutive+ , expectFail $ testProperty+ "badReverse involutive fails"+ prop_badReverse_involutive+ ]