diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for tasty-hedgehog + +## 0.1.0.0 -- 2017-08-24 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Test/Tasty/Hedgehog.hs b/src/Test/Tasty/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Test/Tasty/Hedgehog.hs @@ -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 diff --git a/tasty-hedgehog.cabal b/tasty-hedgehog.cabal new file mode 100644 --- /dev/null +++ b/tasty-hedgehog.cabal @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 + ]