diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ===== diff --git a/hedgehog-classes.cabal b/hedgehog-classes.cabal --- a/hedgehog-classes.cabal +++ b/hedgehog-classes.cabal @@ -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 diff --git a/src/Hedgehog/Classes.hs b/src/Hedgehog/Classes.hs --- a/src/Hedgehog/Classes.hs +++ b/src/Hedgehog/Classes.hs @@ -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) - + diff --git a/src/Hedgehog/Classes/Bifoldable.hs b/src/Hedgehog/Classes/Bifoldable.hs --- a/src/Hedgehog/Classes/Bifoldable.hs +++ b/src/Hedgehog/Classes/Bifoldable.hs @@ -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 diff --git a/src/Hedgehog/Classes/Binary.hs b/src/Hedgehog/Classes/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Classes/Binary.hs @@ -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 diff --git a/src/Hedgehog/Classes/Common/Laws.hs b/src/Hedgehog/Classes/Common/Laws.hs --- a/src/Hedgehog/Classes/Common/Laws.hs +++ b/src/Hedgehog/Classes/Common/Laws.hs @@ -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) --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. +-- Monoid: Left Identity ✓ passed 100 tests. +-- Monoid: Right Identity ✓ passed 100 tests. +-- Monoid: Associativity ✓ passed 100 tests. +-- Monoid: Concatenation ✓ 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] --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. +-- ToJSON/FromJSON: Partial Isomorphism ✓ passed 100 tests. +-- ToJSON/FromJSON: Encoding equals value ✓ passed 100 tests. +-- Show/Read: Partial Isomorphism: show/read ✓ passed 100 tests. +-- Show/Read: Partial Isomorphism: show/read with initial space ✓ passed 100 tests. +-- Show/Read: Partial Isomorphism: showsPrec/readsPrec ✓ passed 100 tests. +-- Show/Read: Partial Isomorphism: showList/readList ✓ passed 100 tests. +-- Show/Read: Partial Isomorphism: showListWith shows/readListDefault ✓ 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 -- -- ------------- --- --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- +-- +-- Eq: Transitive ✓ passed 100 tests. +-- Eq: Symmetric ✓ passed 100 tests. +-- Eq: Reflexive ✓ passed 100 tests. +-- Eq: Negation ✓ passed 100 tests. +-- Monoid: Left Identity ✓ passed 100 tests. +-- Monoid: Right Identity ✓ passed 100 tests. +-- Monoid: Associativity ✓ passed 100 tests. +-- Monoid: Concatenation ✓ passed 100 tests. +-- -- -------------------- -- -- Map String Int -- -- -------------------- --- --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- ✓ passed 100 tests. --- --- +-- +-- Eq: Transitive ✓ passed 100 tests. +-- Eq: Symmetric ✓ passed 100 tests. +-- Eq: Reflexive ✓ passed 100 tests. +-- Eq: Negation ✓ passed 100 tests. +-- Monoid: Left Identity ✓ passed 100 tests. +-- Monoid: Right Identity ✓ passed 100 tests. +-- Monoid: Associativity ✓ passed 100 tests. +-- Monoid: Concatenation ✓ 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 " ✓ 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 " ✓ 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 diff --git a/src/Hedgehog/Classes/Common/PP.hs b/src/Hedgehog/Classes/Common/PP.hs --- a/src/Hedgehog/Classes/Common/PP.hs +++ b/src/Hedgehog/Classes/Common/PP.hs @@ -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 = "" - -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 "") <+> - "" - ] +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 diff --git a/src/Hedgehog/Classes/Common/Property.hs b/src/Hedgehog/Classes/Common/Property.hs --- a/src/Hedgehog/Classes/Common/Property.hs +++ b/src/Hedgehog/Classes/Common/Property.hs @@ -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'. diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 diff --git a/test/Spec/Binary.hs b/test/Spec/Binary.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Binary.hs @@ -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)) diff --git a/test/Spec/Foldable.hs b/test/Spec/Foldable.hs --- a/test/Spec/Foldable.hs +++ b/test/Spec/Foldable.hs @@ -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 --}