diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,5 @@ +# Sydtest License + +Copyright (c) 2022 Tom Sydney Kerckhove + +See the Sydtest License at https://github.com/NorfairKing/sydtest/blob/master/sydtest/LICENSE.md for the full license text. diff --git a/src/Test/Syd/Hedgehog.hs b/src/Test/Syd/Hedgehog.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Hedgehog.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Test.Syd.Hedgehog (fromHedgehogGroup) where + +import Control.Monad +import qualified Data.Map as M +import qualified Hedgehog +import qualified Hedgehog.Internal.Config as Hedgehog +import qualified Hedgehog.Internal.Property as Hedgehog +import qualified Hedgehog.Internal.Report as Hedgehog +import qualified Hedgehog.Internal.Runner as Hedgehog +import qualified Hedgehog.Internal.Seed as Seed +import Test.Syd as Syd + +-- | Import an Hedgehog 'Hedgehog.Group' as a Sydtest 'Test.Syd.Spec'. +-- +-- The reasoning behind this function is that, eventhough migration from hedgehog +-- to sydtest is usually very simple, you might depend on certain libraries +-- beyond your control that still use hedgehog. In that case you want to be able +-- to still use those libraries but also use sydtest already. +fromHedgehogGroup :: Hedgehog.Group -> Syd.Spec +fromHedgehogGroup hedgehogGroup = Syd.describe (Hedgehog.unGroupName $ Hedgehog.groupName hedgehogGroup) $ + forM_ (Hedgehog.groupProperties hedgehogGroup) $ \(propertyName, property) -> do + it (Hedgehog.unPropertyName propertyName) property + +instance IsTest Hedgehog.Property where + type Arg1 Hedgehog.Property = () + type Arg2 Hedgehog.Property = () + runTest = runHedgehogProperty + +runHedgehogProperty :: Hedgehog.Property -> Syd.TestRunSettings -> ((() -> () -> IO ()) -> IO ()) -> IO TestRunResult +runHedgehogProperty hedgehogProp TestRunSettings {..} wrapper = do + let config = + (Hedgehog.propertyConfig hedgehogProp) + { Hedgehog.propertyDiscardLimit = Hedgehog.DiscardLimit testRunSettingMaxDiscardRatio, + Hedgehog.propertyShrinkLimit = Hedgehog.ShrinkLimit testRunSettingMaxShrinks + } + let size = Hedgehog.Size testRunSettingMaxSize + seed <- case testRunSettingSeed of + RandomSeed -> Seed.random + FixedSeed i -> pure $ Seed.from (fromIntegral i) + errOrReport <- applyWrapper2 wrapper $ \() () -> + Hedgehog.checkReport + config + size + seed + (Hedgehog.propertyTest hedgehogProp) + (\_ -> pure ()) -- Don't report progress + ( testRunResultStatus, + testRunResultException, + testRunResultNumTests, + testRunResultLabels, + testRunResultNumShrinks, + testRunResultFailingInputs + ) <- case errOrReport of + Left e -> pure (TestFailed, Just e, Nothing, Nothing, Nothing, []) + Right report -> do + let Hedgehog.TestCount testCountInt = Hedgehog.reportTests report + numTests = Just $ fromIntegral testCountInt + labelList = + M.toList + . Hedgehog.coverageLabels + $ Hedgehog.reportCoverage report + + labels = + if null labelList + then Nothing + else + Just + . M.fromList + . map + ( \(labelName, label) -> + ([Hedgehog.unLabelName labelName], Hedgehog.unCoverCount $ Hedgehog.labelAnnotation label) + ) + $ labelList + case Hedgehog.reportStatus report of + Hedgehog.OK -> pure (TestPassed, Nothing, numTests, labels, Nothing, []) + Hedgehog.GaveUp -> pure (TestFailed, Nothing, numTests, labels, Nothing, []) + Hedgehog.Failed failureReport -> do + s <- + Hedgehog.renderResult + Hedgehog.EnableColor + Nothing + report + let Hedgehog.ShrinkCount shrinkCountInt = Hedgehog.failureShrinks failureReport + numShrinks = Just $ fromIntegral shrinkCountInt + exception = Just $ Left s + inputs = map Hedgehog.failedValue $ Hedgehog.failureAnnotations failureReport + pure (TestFailed, exception, numTests, labels, numShrinks, inputs) -- TODO + let testRunResultRetries = Nothing + let testRunResultGoldenCase = Nothing + let testRunResultExtraInfo = Nothing + let testRunResultClasses = Nothing + let testRunResultTables = Nothing + let testRunResultFlakinessMessage = Nothing + + pure TestRunResult {..} diff --git a/sydtest-hedgehog.cabal b/sydtest-hedgehog.cabal new file mode 100644 --- /dev/null +++ b/sydtest-hedgehog.cabal @@ -0,0 +1,57 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.6. +-- +-- see: https://github.com/sol/hpack + +name: sydtest-hedgehog +version: 0.0.0.0 +synopsis: A Hedgehog companion library for sydtest +category: Testing +homepage: https://github.com/NorfairKing/sydtest#readme +bug-reports: https://github.com/NorfairKing/sydtest/issues +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright (c) 2022 Tom Sydney Kerckhove +license: OtherLicense +license-file: LICENSE.md +build-type: Simple +extra-source-files: + LICENSE.md + +source-repository head + type: git + location: https://github.com/NorfairKing/sydtest + +library + exposed-modules: + Test.Syd.Hedgehog + other-modules: + Paths_sydtest_hedgehog + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , containers + , hedgehog + , sydtest + default-language: Haskell2010 + +test-suite sydtest-hedgehog-test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Spec + Test.Syd.HedgehogSpec + Paths_sydtest_hedgehog + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + base >=4.7 && <5 + , hedgehog + , sydtest + , sydtest-hedgehog + 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,10 @@ +module Main where + +import Spec +import Test.Syd +import Test.Syd.OptParse + +main :: IO () +main = do + _ <- sydTestResult defaultSettings spec + pure () diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover -optF --no-main #-} diff --git a/test/Test/Syd/HedgehogSpec.hs b/test/Test/Syd/HedgehogSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/HedgehogSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Test.Syd.HedgehogSpec (spec) where + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Syd as Syd +import qualified Test.Syd.Hedgehog as Syd + +spec :: Syd.Spec +spec = do + describe "Adapter" $ Syd.fromHedgehogGroup exampleHedgehogGroup + describe "reverse" $ + specify "reversing twice is the same as not reversing" $ + property $ do + xs <- forAll $ Gen.list (Range.linear 0 100) Gen.alpha + reverse (reverse xs) === xs + +exampleHedgehogGroup :: Hedgehog.Group +exampleHedgehogGroup = + Hedgehog.Group + "test group name" + [ ( "prop_add_distributive_int", + property $ do + let genInt :: Gen Int + genInt = Gen.int Range.linearBounded + a <- forAll genInt + b <- forAll genInt + c <- forAll genInt + classify "all zero" $ a == 0 && b == 0 && c == 0 + classify "False" False + classify "a == 0" $ a == 0 + classify "b == 0" $ b == 0 + classify "c == 0" $ c == 0 + let left = a * (b + c) + let right = (a * b) + (a * c) + classify "left == 0" $ left == 0 + classify "right == 0" $ right == 0 + left === right + ), + ( "prop_add_distributive_double", + property $ do + let genDouble :: Gen Double + genDouble = Gen.double $ Range.exponentialFloat (-1E1024) 1E1024 + a <- forAll genDouble + b <- forAll genDouble + c <- forAll genDouble + a * (b + c) === (a * b) + (a * c) + ), + ( "prop_undefined", + property $ do + _ <- forAll $ Gen.int Range.linearBounded + undefined + ), + ( "prop_equal", + property $ do + a <- forAll $ Gen.int Range.linearBounded + b <- forAll $ Gen.int Range.linearBounded + footnote "foobar" + a === b + ) + ]