hedgehog-classes 0.1.2 → 0.2
raw patch · 11 files changed
+240/−209 lines, 11 filesdep +binarydep +silentlydep ~basedep ~hedgehogdep ~pretty-showPVP ok
version bump matches the API change (PVP)
Dependencies added: binary, silently
Dependency ranges changed: base, hedgehog, pretty-show
API changes (from Hackage documentation)
+ Hedgehog.Classes: binaryLaws :: (Binary a, Eq a, Show a) => Gen a -> Laws
Files
- CHANGELOG.md +11/−0
- hedgehog-classes.cabal +21/−16
- src/Hedgehog/Classes.hs +7/−5
- src/Hedgehog/Classes/Bifoldable.hs +19/−14
- src/Hedgehog/Classes/Binary.hs +38/−0
- src/Hedgehog/Classes/Common/Laws.hs +85/−40
- src/Hedgehog/Classes/Common/PP.hs +15/−114
- src/Hedgehog/Classes/Common/Property.hs +14/−15
- test/Spec.hs +2/−2
- test/Spec/Binary.hs +27/−0
- test/Spec/Foldable.hs +1/−3
CHANGELOG.md view
@@ -3,6 +3,17 @@ `hedgehog-classes` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +0.2+===++* switch to hedgehog-1.0+* add `binaryLaws`+* relax cabal-version to 2.2+* use randomly generated, not hard-coded functions, in bifoldable tests+* significantly simplify pretty printing using `silently` package, and+ bad hack.+* make several haddock improvements.+ 0.1.2 =====
hedgehog-classes.cabal view
@@ -1,8 +1,8 @@-cabal-version: 2.4-name: +cabal-version: 2.2+name: hedgehog-classes version:- 0.1.2+ 0.2 synopsis: Hedgehog will eat your typeclass bugs description:@@ -36,7 +36,7 @@ extra-doc-files: README.md , CHANGELOG.md-tested-with: GHC == 8.6.1, GHC == 8.6.2, GHC == 8.6.3+tested-with: GHC == 8.6.5, GHC == 8.8.1 source-repository head type: git@@ -77,6 +77,7 @@ Hedgehog.Classes.Arrow Hedgehog.Classes.Bifoldable Hedgehog.Classes.Bifunctor+ Hedgehog.Classes.Binary Hedgehog.Classes.Bitraversable Hedgehog.Classes.Bits Hedgehog.Classes.Category@@ -114,11 +115,13 @@ Hedgehog.Classes.Storable Hedgehog.Classes.Traversable build-depends:- , base >= 4.12 && < 4.14- , hedgehog >= 0.5 && < 0.7- , containers >= 0.5 && < 0.7- , pretty-show >= 1.6 && < 2.0- , transformers >= 0.5 && < 0.6+ , base >= 4.12 && < 4.14+ , binary >= 0.8 && < 0.9+ , containers >= 0.5 && < 0.7+ , hedgehog >= 1 && < 1.1+ , pretty-show >= 1.9 && < 1.10+ , silently >= 1.2 && < 1.3+ , transformers >= 0.5 && < 0.6 , wl-pprint-annotated >= 0.0 && < 0.2 ghc-options: -Wall@@ -134,9 +137,9 @@ build-depends: semirings >= 0.2 && < 0.4 cpp-options: -DHAVE_SEMIRINGS -- if flag(vector)--- build-depends: vector >= 0.12.0.0 && < 0.13.0.0 +-- build-depends: vector >= 0.12.0.0 && < 0.13.0.0 -- cpp-options: -DHAVE_VECTOR- + test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: test@@ -147,6 +150,7 @@ Spec.Arrow Spec.Bifoldable Spec.Bifunctor+ Spec.Binary Spec.Bitraversable Spec.Bits Spec.Category@@ -171,12 +175,13 @@ Spec.Storable Spec.Traversable - build-depends: base >= 4.12.0.0 && < 4.13- , aeson - , containers - , hedgehog + build-depends: base+ , aeson+ , binary+ , containers+ , hedgehog , hedgehog-classes ghc-options: -Wall- + default-language: Haskell2010
src/Hedgehog/Classes.hs view
@@ -15,6 +15,7 @@ -- * Properties -- ** Ground types+ , binaryLaws , bitsLaws , eqLaws , integralLaws@@ -29,7 +30,7 @@ , exponentialSemigroupLaws , idempotentSemigroupLaws , rectangularBandSemigroupLaws-#if HAVE_AESON +#if HAVE_AESON , jsonLaws #endif , genericLaws@@ -37,15 +38,15 @@ , semiringLaws , ringLaws , starLaws-#endif +#endif , showLaws , showReadLaws , storableLaws- + -- ** Unary type constructors , alternativeLaws , applicativeLaws- , contravariantLaws + , contravariantLaws , foldableLaws , functorLaws , monadLaws@@ -83,6 +84,7 @@ import Hedgehog.Classes.Arrow (arrowLaws) import Hedgehog.Classes.Bifoldable (bifoldableLaws, bifoldableFunctorLaws) import Hedgehog.Classes.Bifunctor (bifunctorLaws)+import Hedgehog.Classes.Binary (binaryLaws) import Hedgehog.Classes.Bitraversable (bitraversableLaws) import Hedgehog.Classes.Bits (bitsLaws) import Hedgehog.Classes.Category (categoryLaws, commutativeCategoryLaws)@@ -112,4 +114,4 @@ import Hedgehog.Classes.ShowRead (showReadLaws) import Hedgehog.Classes.Storable (storableLaws) import Hedgehog.Classes.Traversable (traversableLaws)- +
src/Hedgehog/Classes/Bifoldable.hs view
@@ -13,7 +13,7 @@ -- | Tests the following 'Bifoldable' laws: ----- [__Identity__]: @'bifold'@ ≡ @'bifoldMap' 'id' 'id'@ +-- [__Identity__]: @'bifold'@ ≡ @'bifoldMap' 'id' 'id'@ -- [__FoldMap__]: @'bifoldMap' f g@ ≡ @'bifoldr' ('mappend' '.' f) ('mappend' '.' g) 'mempty'@ -- [__Foldr__]: @'bifoldr' f g z t@ ≡ @'appEndo' ('bifoldMap' ('Endo' '.' f) ('Endo' '.' g) t) z@ bifoldableLaws :: forall f.@@ -60,28 +60,33 @@ [ "bimap id id x" `congruency` "x, where" , "x = " ++ showX ]- , lawContextReduced = reduced lhs rhs - } + , lawContextReduced = reduced lhs rhs+ } heqCtx lhs rhs ctx- + bifoldableFoldMap :: forall f. BifoldableProp f bifoldableFoldMap fgen = property $ do x <- forAll $ fgen genSmallInteger genSmallInteger- let f = Sum; g = Sum . (+1)+ f' <- forAll genQuadraticEquation+ g' <- forAll genQuadraticEquation+ let f = Sum . runQuadraticEquation f'+ let g = Sum . runQuadraticEquation g' let lhs = (bifoldMap f g x) let rhs = (bifoldr (mappend . f) (mappend . g) mempty x) let ctx = contextualise $ LawContext { lawContextLawName = "FoldMap", lawContextLawBody = "bifoldMap f g" `congruency` "bifoldr (mappend . f) (mappend . g) mempty" , lawContextTcName = "Bifoldable", lawContextTcProp = let showX = show x;+ showF = show f';+ showG = show g'; in lawWhere [ "bifoldMap f g x" `congruency` "bifoldr (mappend . f) (mappend . g) mempty x, where"- , "f = \\x -> Sum x"- , "g = \\x -> Sum (x + 1)"+ , "f = " ++ showF+ , "g = " ++ showG , "x = " ++ showX ]- , lawContextReduced = reduced lhs rhs - } + , lawContextReduced = reduced lhs rhs+ } heqCtx lhs rhs ctx bifoldableFoldr :: forall f. BifoldableProp f@@ -105,9 +110,9 @@ , "t = " ++ showX , "z = " ++ showZ ]- , lawContextReduced = reduced lhs rhs + , lawContextReduced = reduced lhs rhs }- heqCtx lhs rhs ctx + heqCtx lhs rhs ctx type BifoldableFunctorProp f = ( Bifoldable f, Bifunctor f@@ -131,9 +136,9 @@ , "g = \\x -> Product (x + 1)" , "x = " ++ showX ]- , lawContextReduced = reduced lhs rhs + , lawContextReduced = reduced lhs rhs }- heqCtx lhs rhs ctx + heqCtx lhs rhs ctx bifoldableFunctorFoldMap :: forall f. BifoldableFunctorProp f bifoldableFunctorFoldMap fgen = property $ do@@ -155,7 +160,7 @@ , "i = " ++ showI , "x = " ++ showX ]- , lawContextReduced = reduced lhs rhs + , lawContextReduced = reduced lhs rhs } heqCtx lhs rhs ctx
+ src/Hedgehog/Classes/Binary.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Hedgehog.Classes.Binary (binaryLaws) where++import Hedgehog+import Hedgehog.Classes.Common+import Data.Binary (Binary)+import qualified Data.Binary as Binary++-- | Tests the following 'Binary' laws:+--+-- [__Encoding Partial Isomorphism__]: @'Binary.decode' '.' 'Binary.encode'@ ≡ @'id'@+binaryLaws :: (Binary a, Eq a, Show a) => Gen a -> Laws+binaryLaws gen = Laws "Binary"+ [ ("Partial Isomorphism", binaryPartialIsomorphism gen)+ ]++binaryPartialIsomorphism :: forall a. (Binary a, Show a, Eq a) => Gen a -> Property+binaryPartialIsomorphism gen = property $ do+ x <- forAll gen+ let encoded = Binary.encode x+ let lhs = Binary.decode @a encoded+ let rhs = x+ let ctx = contextualise $ LawContext+ { lawContextLawName = "Partial Isomorphism", lawContextTcName = "Binary"+ , lawContextLawBody = "decode . encode" `congruency` "id"+ , lawContextTcProp =+ let showX = show x+ showEncoded = show encoded+ in lawWhere+ [ "decode . encode $ x" `congruency` "x, where"+ , "x = " ++ showX+ , "encode x = " ++ showEncoded+ ]+ , lawContextReduced = reduced lhs rhs+ }+ heqCtx lhs rhs ctx
src/Hedgehog/Classes/Common/Laws.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} module Hedgehog.Classes.Common.Laws ( Laws(..)@@ -22,7 +23,8 @@ ) where import Control.Monad.IO.Class (MonadIO(liftIO))-import Data.Monoid (All(..), Ap(..))+import Data.Char (isSpace, isDigit)+import Data.Monoid (All(..), Any(..), Ap(..)) import Hedgehog (Gen) import Hedgehog.Classes.Common.Property (Context(..)) import Hedgehog.Internal.Property (Property(..))@@ -33,6 +35,7 @@ import qualified Hedgehog.Classes.Common.PP as PP import qualified Hedgehog.Internal.Region as Region import qualified Hedgehog.Internal.Seed as Seed+import qualified System.IO.Silently as S congruent :: String congruent = " ≡ "@@ -73,7 +76,7 @@ -- | Turn a 'LawContext' into a 'Context'. contextualise :: LawContext -> Context-contextualise LawContext{..} = Context $ unlines +contextualise LawContext{..} = Context $ unlines [ "When testing the " ++ lawContextLawName ++ " law(" ++ dagger ++"), for the " ++ lawContextTcName ++ " typeclass, the following test failed: " , newline ++ lawContextTcProp , newline ++ "The reduced test is: "@@ -87,10 +90,10 @@ -- -- >>> genOrdering :: Gen Ordering; genOrdering = frequency [(1,pure EQ),(1,pure LT),(1,pure GT)] -- >>> lawsCheck (monoidLaws genOrdering)--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.+-- Monoid: Left Identity ✓ <interactive> passed 100 tests.+-- Monoid: Right Identity ✓ <interactive> passed 100 tests.+-- Monoid: Associativity ✓ <interactive> passed 100 tests.+-- Monoid: Concatenation ✓ <interactive> passed 100 tests. -- True lawsCheck :: Laws -- ^ The 'Laws' you would like to check.@@ -101,13 +104,13 @@ -- a single type. -- -- >>> lawsCheckOne (word8 constantBounded) [jsonLaws, showReadLaws]--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.+-- ToJSON/FromJSON: Partial Isomorphism ✓ <interactive> passed 100 tests.+-- ToJSON/FromJSON: Encoding equals value ✓ <interactive> passed 100 tests.+-- Show/Read: Partial Isomorphism: show/read ✓ <interactive> passed 100 tests.+-- Show/Read: Partial Isomorphism: show/read with initial space ✓ <interactive> passed 100 tests.+-- Show/Read: Partial Isomorphism: showsPrec/readsPrec ✓ <interactive> passed 100 tests.+-- Show/Read: Partial Isomorphism: showList/readList ✓ <interactive> passed 100 tests.+-- Show/Read: Partial Isomorphism: showListWith shows/readListDefault ✓ <interactive> passed 100 tests. -- True lawsCheckOne :: Gen a -- ^ The generator for your type.@@ -136,11 +139,11 @@ -- -- -- Generate a small @Set Int@ -- genSet :: Gen (Set Int)--- genSet = Set.fromList <$> (Gen.list (Range.linear 2 10) (Gen.int Range.constantBounded))+-- genSet = Set.fromList \<$\> (Gen.list (Range.linear 2 10) (Gen.int Range.constantBounded)) -- -- -- Generate a small @Map String Int@ -- genMap :: Gen (Map String Int)--- genMap = Map.fromList <$> (liftA2 List.zip genStrings genInts)+-- genMap = Map.fromList \<$\> (liftA2 List.zip genStrings genInts) -- where -- rng = Range.linear 2 6 -- genStrings = Gen.list rng (Gen.string rng Gen.lower)@@ -166,28 +169,29 @@ -- ------------- -- -- Set Int -- -- ---------------- --- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- +--+-- Eq: Transitive ✓ <interactive> passed 100 tests.+-- Eq: Symmetric ✓ <interactive> passed 100 tests.+-- Eq: Reflexive ✓ <interactive> passed 100 tests.+-- Eq: Negation ✓ <interactive> passed 100 tests.+-- Monoid: Left Identity ✓ <interactive> passed 100 tests.+-- Monoid: Right Identity ✓ <interactive> passed 100 tests.+-- Monoid: Associativity ✓ <interactive> passed 100 tests.+-- Monoid: Concatenation ✓ <interactive> passed 100 tests.+-- -- -------------------- -- -- Map String Int -- -- ----------------------- --- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- ✓ <interactive> passed 100 tests.--- --- +--+-- Eq: Transitive ✓ <interactive> passed 100 tests.+-- Eq: Symmetric ✓ <interactive> passed 100 tests.+-- Eq: Reflexive ✓ <interactive> passed 100 tests.+-- Eq: Negation ✓ <interactive> passed 100 tests.+-- Monoid: Left Identity ✓ <interactive> passed 100 tests.+-- Monoid: Right Identity ✓ <interactive> passed 100 tests.+-- Monoid: Associativity ✓ <interactive> passed 100 tests.+-- Monoid: Concatenation ✓ <interactive> passed 100 tests.+-- -- All tests succeeded -- True -- @@@ -200,7 +204,11 @@ lawsCheckInternal (Laws className properties) = flip foldMapA properties $ \(name,p) -> do putStr (className ++ ": " ++ name ++ " ")- All <$> check p+ (out,b) <- S.capture $ check p+ if b+ then putStr " ✓ <interactive> passed 100 tests.\n"+ else putStr $ (removeBadOutput out) <> "\n"+ pure (All b) lawsCheckOneInternal :: Gen a -> [Gen a -> Laws] -> IO All lawsCheckOneInternal p ls = foldMap (lawsCheckInternal . ($ p)) ls@@ -214,8 +222,12 @@ putStrLn $ prettyHeader typeName r <- flip foldMapA laws $ \(Laws typeclassName properties) -> do flip foldMapA properties $ \(name,p) -> do- putStr (typeclassName ++ ": " ++ name ++ " ")- check p >>= \case { True -> pure Good; _ -> pure Bad }+ putStr (typeclassName ++ ": " ++ name)+ (out,b) <- S.capture $ check p+ if b+ then putStr " ✓ <interactive> passed 100 tests.\n"+ else putStr $ (removeBadOutput out) <> "\n"+ pure (boolToStatus b) putStrLn "" pure r putStrLn ""@@ -245,12 +257,15 @@ instance Monoid Status where mempty = Good +boolToStatus :: Bool -> Status+boolToStatus = \case { False -> Bad; True -> Good; }+ checkRegion :: MonadIO m => Region -> Property -> m (Report Result) checkRegion region prop = liftIO $ do- seed <- liftIO Seed.random + seed <- liftIO Seed.random result <- checkReport (propertyConfig prop) 0 seed (propertyTest prop) $ \progress -> do ppprogress <- renderProgress Nothing Nothing progress case reportStatus progress of@@ -261,8 +276,7 @@ Failed _ -> Region.openRegion region ppresult GaveUp -> Region.openRegion region ppresult OK -> Region.setRegion region ppresult-- pure result + pure result check :: MonadIO m => Property@@ -270,3 +284,34 @@ check prop = liftIO . Region.displayRegion $ \region -> (== OK) . reportStatus <$> checkRegion region prop +-- HACK!+-- BAD!+-- ALERT!++stripLeading :: String -> String+stripLeading [] = []+stripLeading s@(x:xs) = if isSpace x+ then stripLeading xs+ else s++startsWithNumber :: String -> Bool+startsWithNumber [] = False+startsWithNumber (x:_) = isDigit x++startsWithCorner :: String -> Bool+startsWithCorner [] = False+startsWithCorner (x:_) = x == '┏'++containsSkinnyBar :: String -> Bool+containsSkinnyBar = any (== '│')++isBad :: String -> Bool+isBad x = getAny $ foldMap (\f -> Any (f x))+ [ startsWithNumber, startsWithCorner, containsSkinnyBar ]++removeBadOutput :: String -> String+removeBadOutput = unlines . go . lines where+ go [] = []+ go (x:xs) = if isBad (stripLeading x)+ then go xs+ else x : go xs
src/Hedgehog/Classes/Common/PP.hs view
@@ -11,124 +11,25 @@ -- | Reverse-engineered hedgehog internals that don't print out source locations. module Hedgehog.Classes.Common.PP- ( ppDiscardCount- , ppDoc- , ppName- , ppResult- , ppShrinkCount- , ppShrinkDiscard- , ppTestCount+ ( ppResult , renderResult ) where -import Hedgehog.Range (Size) import Control.Monad.IO.Class (MonadIO(..))-import qualified Data.List as List-import Hedgehog.Internal.Report- ( DiscardCount(..), TestCount(..), ShrinkCount(..), Markup(..), Report(..)- , Result(..), FailureReport(..), renderDoc- )-import qualified Text.PrettyPrint.Annotated.WL as WL-import Text.PrettyPrint.Annotated.WL ( (<+>) )-import qualified Hedgehog.Internal.Seed as Seed+import Hedgehog.Internal.Report hiding (ppResult, renderResult) import Text.PrettyPrint.Annotated.WL (Doc)--ppDoc :: Show x => x -> Doc a-ppDoc = WL.text . show--ppName :: Doc a-ppName = "<interactive>"--ppDiscardCount :: DiscardCount -> Doc a-ppDiscardCount = \case- DiscardCount 1 -> "1 discard"- DiscardCount n -> ppDoc n <+> "discards"--ppTestCount :: TestCount -> Doc a-ppTestCount = \case- TestCount 1 -> "1 test"- TestCount n -> ppDoc n <+> "tests"--ppShrinkCount :: ShrinkCount -> Doc a-ppShrinkCount = \case- ShrinkCount 1 -> "1 shrink"- ShrinkCount n -> ppDoc n <+> "shrinks"--ppShrinkDiscard :: ShrinkCount -> DiscardCount -> Doc Markup-ppShrinkDiscard s d = case (s, d) of- (0, 0) -> ""- (0, _) -> " and" <+> ppDiscardCount d- (_, 0) -> " and" <+> ppShrinkCount s- (_, _) -> "," <+> ppShrinkCount s <+> "and" <+> ppDiscardCount d--ppResult :: MonadIO m => Report Result -> m (Doc Markup)-ppResult (Report tests discards result) = case result of- Failed failure -> do- pfailure <- ppFailure failure- pure . WL.vsep $- [ icon FailedIcon '✗' . markup FailedHeader $- ppName <+>- "failed after" <+>- ppTestCount tests <>- ppShrinkDiscard (failureShrinks failure) discards <>- "."- , mempty- , pfailure- , mempty- ] - - GaveUp -> pure . icon GaveUpIcon '⚐' . WL.annotate GaveUpHeader $- ppName <+>- "gave up after" <+>- ppDiscardCount discards <>- ", passed" <+>- ppTestCount tests <>- "." - OK -> pure . icon SuccessIcon '✓' . WL.annotate SuccessHeader $- ppName <+>- "passed" <+>- ppTestCount tests <>- "."--icon :: Markup -> Char -> Doc Markup -> Doc Markup-icon m i x = WL.annotate m (WL.char i) <+> x--ppTextLines :: String -> [Doc Markup]-ppTextLines = fmap WL.text . List.lines--markup :: Markup -> Doc Markup -> Doc Markup-markup = WL.annotate--gutter :: Markup -> Doc Markup -> Doc Markup-gutter m x = markup m ">" <+> x--ppFailure :: MonadIO m => FailureReport -> m (Doc Markup)-ppFailure (FailureReport size seed _ _inputs0 mlocation0 msg _mdiff msgs0) = do- msgs <- case mlocation0 of- Nothing ->- let msgs1 = msgs0 ++ (if null msg then [] else [msg])- docs = concatMap ppTextLines msgs1- in pure docs- Just _location0 -> - let l = concatMap ppTextLines msgs0- in pure l-- let with xs f = if null xs then [] else [f xs]-- pure . WL.indent 2 . WL.vsep . WL.punctuate WL.line $ concat- [ with msgs WL.vsep- , [ppReproduce size seed]- ]--ppReproduce :: Size -> Seed.Seed -> Doc Markup-ppReproduce size seed = WL.vsep- [ markup ReproduceHeader "This failure can be reproduced by running:"- , gutter ReproduceGutter . markup ReproduceSource $- "recheck" <+>- WL.text (showsPrec 11 size "") <+>- WL.text (showsPrec 11 seed "") <+>- "<property>"- ]+import qualified Hedgehog.Internal.Report as R -renderResult :: MonadIO m => Report Result -> m String+renderResult :: MonadIO m+ => Report Result+ -> m String renderResult x = renderDoc Nothing =<< ppResult x++ppResult :: MonadIO m+ => Report Result+ -> m (Doc Markup)+ppResult r@(Report tests discards coverage status) = case status of+ Failed (FailureReport size seed shrinks _mcoverage annots _mspan msg _mdiff footnotes) ->+ let failure = Failed $ FailureReport size seed shrinks Nothing annots Nothing msg Nothing footnotes+ in R.ppResult Nothing (Report tests discards coverage failure)+ _ -> R.ppResult Nothing r
src/Hedgehog/Classes/Common/Property.hs view
@@ -14,7 +14,7 @@ , heq, heq1, heq2 , heqCtx, heqCtx1, heqCtx2 , hneq, hneq1, hneq2- , hneqCtx, hneqCtx1, hneqCtx2 + , hneqCtx, hneqCtx1, hneqCtx2 , bar , Context(..) ) where@@ -24,7 +24,7 @@ import GHC.Stack import Hedgehog.Classes.Common.Compat import Hedgehog.Internal.Exception (tryEvaluate)-import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, Failure(..), Log(..))+import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, Failure(..)) import Text.Show.Pretty (ppShow) import qualified Data.Char as Char import qualified Data.List as List@@ -40,8 +40,8 @@ failWithNoSrc :: (MonadTest m, HasCallStack) => String -> m a failWithNoSrc msg = do- liftTest $ mkTest (Left $ Failure Nothing "" Nothing, [Footnote msg])- + liftTest $ mkTest (Left $ Failure Nothing msg Nothing, mempty)+ failExceptionNoSrc :: (MonadTest m, HasCallStack) => SomeException -> m a failExceptionNoSrc (SomeException x) = withFrozenCallStack $ failWithNoSrc $ unlines@@ -55,17 +55,16 @@ contextToString :: Context -> String contextToString = \case NoContext -> "No Context provided."- Context ctx -> bar ++ " Context " ++ bar ++ "\n" ++ ctx ++ bar5+ Context ctx -> bar ++ " Context " ++ bar ++ "\n" ++ ctx ++ "\n" ++ bar5 failContext:: ( MonadTest m, HasCallStack- , Show a, Show b- ) => a -> b -> Context -> m ()-failContext _x _y ctx = withFrozenCallStack $+ ) => Context -> m ()+failContext ctx = withFrozenCallStack $ failWithNoSrc $ contextToString ctx -- | Fails the test if the right argument is less than or equal to the left.--- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 +-- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 hLessThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m () hLessThan x y = do ok <- withFrozenCallStack $ evalNoSrc (x < y)@@ -102,7 +101,7 @@ ok <- withFrozenCallStack $ evalNoSrc (x `neq` y) if ok then success- else withFrozenCallStack $ failContext x y ctx+ else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are not equal. Otherwise fails -- with 'NoContext'.@@ -128,7 +127,7 @@ ok <- withFrozenCallStack $ evalNoSrc (x `eq` y) if ok then success- else withFrozenCallStack $ failContext x y ctx+ else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are equal. Otherwise fails -- with 'NoContext'.@@ -156,7 +155,7 @@ ok <- withFrozenCallStack $ evalNoSrc (x `neq1` y) if ok then success- else withFrozenCallStack $ failContext x y ctx+ else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are not equal. Otherwise fails -- with 'NoContext'.@@ -184,7 +183,7 @@ ok <- withFrozenCallStack $ evalNoSrc (x `eq1` y) if ok then success- else withFrozenCallStack $ failContext x y ctx+ else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are equal. Otherwise fails -- with 'NoContext'.@@ -216,7 +215,7 @@ ok <- withFrozenCallStack $ evalNoSrc (x `eq2` y) if ok then success- else withFrozenCallStack $ failContext x y ctx+ else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are equal. Otherwise fails -- with 'NoContext'.@@ -250,7 +249,7 @@ ok <- withFrozenCallStack $ evalNoSrc (x `neq2` y) if ok then success- else withFrozenCallStack $ failContext x y ctx+ else withFrozenCallStack $ failContext ctx -- | Passes the test if the given arguments are not equal. Otherwise fails -- with 'NoContext'.
test/Spec.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE LambdaCase #-}- module Main (main) where import Hedgehog.Classes@@ -9,6 +7,7 @@ import Spec.Arrow import Spec.Bifoldable import Spec.Bifunctor+import Spec.Binary import Spec.Bitraversable import Spec.Bits import Spec.Category@@ -40,6 +39,7 @@ allNullaryLaws = testBits ++ testEnum ++ testBoundedEnum+ ++ testBinary ++ testEq ++ testGeneric ++ testIntegral
+ test/Spec/Binary.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric #-}++module Spec.Binary (testBinary) where++import Hedgehog+import Hedgehog.Classes+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Data.Binary+import GHC.Generics (Generic(..))++testBinary :: [(String, [Laws])]+testBinary =+ [ ("Person", listPerson)+ ]++data Person = Person { name :: String, age :: Int }+ deriving (Eq, Show, Generic)++instance Binary Person where++listPerson :: [Laws]+listPerson = [binaryLaws genPerson]++genPerson :: Gen Person+genPerson = Person <$> (Gen.string (Range.linear 3 7) Gen.alpha) <*> (Gen.int (Range.linear 0 65))
test/Spec/Foldable.hs view
@@ -13,7 +13,7 @@ testFoldable :: [(String, [Laws])] testFoldable = [ ("Set", listSet)--- , ("BadList", listBadList) +-- , ("BadList", listBadList) ] listSet :: [Laws]@@ -24,7 +24,6 @@ x <- gen pure (Set.singleton x) -{- listBadList :: [Laws] listBadList = [foldableLaws genBadList] @@ -37,4 +36,3 @@ instance Foldable BadList where foldMap f (BadList x) = foldMap f x foldl' = List.foldl--}