sydtest-hedgehog (empty) → 0.0.0.0
raw patch · 6 files changed
+237/−0 lines, 6 filesdep +basedep +containersdep +hedgehog
Dependencies added: base, containers, hedgehog, sydtest, sydtest-hedgehog
Files
- LICENSE.md +5/−0
- src/Test/Syd/Hedgehog.hs +101/−0
- sydtest-hedgehog.cabal +57/−0
- test/Main.hs +10/−0
- test/Spec.hs +1/−0
- test/Test/Syd/HedgehogSpec.hs +63/−0
+ LICENSE.md view
@@ -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.
+ src/Test/Syd/Hedgehog.hs view
@@ -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 {..}
+ sydtest-hedgehog.cabal view
@@ -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
+ test/Main.hs view
@@ -0,0 +1,10 @@+module Main where++import Spec+import Test.Syd+import Test.Syd.OptParse++main :: IO ()+main = do+ _ <- sydTestResult defaultSettings spec+ pure ()
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF sydtest-discover -optF --no-main #-}
+ test/Test/Syd/HedgehogSpec.hs view
@@ -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+ )+ ]