Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-hedgehog for openSUSE:Factory checked in at 2022-02-11 23:09:01 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-hedgehog (Old) and /work/SRC/openSUSE:Factory/.ghc-hedgehog.new.1956 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-hedgehog" Fri Feb 11 23:09:01 2022 rev:6 rq:953468 version:1.1.1 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-hedgehog/ghc-hedgehog.changes 2021-09-10 23:41:45.954588410 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-hedgehog.new.1956/ghc-hedgehog.changes 2022-02-11 23:10:53.259202482 +0100 @@ -1,0 +2,9 @@ +Sat Jan 29 06:40:09 UTC 2022 - Peter Simons <psim...@suse.com> + +- Update hedgehog to version 1.1.1. + Upstream has edited the change log file since the last release in + a non-trivial way, i.e. they did more than just add a new entry + at the top. You can review the file at: + http://hackage.haskell.org/package/hedgehog-1.1.1/src/CHANGELOG.md + +------------------------------------------------------------------- Old: ---- hedgehog-1.0.5.tar.gz hedgehog.cabal New: ---- hedgehog-1.1.1.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-hedgehog.spec ++++++ --- /var/tmp/diff_new_pack.FEAOq8/_old 2022-02-11 23:10:53.695203744 +0100 +++ /var/tmp/diff_new_pack.FEAOq8/_new 2022-02-11 23:10:53.711203790 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-hedgehog # -# Copyright (c) 2021 SUSE LLC +# Copyright (c) 2022 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,16 +19,16 @@ %global pkg_name hedgehog %bcond_with tests Name: ghc-%{pkg_name} -Version: 1.0.5 +Version: 1.1.1 Release: 0 Summary: Release with confidence License: BSD-3-Clause URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz -Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel BuildRequires: ghc-ansi-terminal-devel BuildRequires: ghc-async-devel +BuildRequires: ghc-barbies-devel BuildRequires: ghc-bytestring-devel BuildRequires: ghc-concurrent-output-devel BuildRequires: ghc-containers-devel @@ -78,8 +78,6 @@ %prep %autosetup -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal -cabal-tweak-dep-ver 'mmorph' '< 1.2' '< 1.3' %build %ghc_lib_build ++++++ hedgehog-1.0.5.tar.gz -> hedgehog-1.1.1.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/CHANGELOG.md new/hedgehog-1.1.1/CHANGELOG.md --- old/hedgehog-1.0.5/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/CHANGELOG.md 2001-09-09 03:46:40.000000000 +0200 @@ -1,3 +1,13 @@ +## Version 1.1.1 (2022-01-29) + +* Support using fixed seed via `HEDGEHOG_SEED` ([#446][446], [@simfleischman][simfleischman] / [@moodmosaic][moodmosaic]) +* Better 'cover' example code in haddocks ([#423][423], [@jhrcek][jhrcek]) + +## Version 1.1 (2022-01-27) + +- Replace HTraversable with TraversableB (from barbies) ([#412][412], [@ocharles][ocharles]) +- Support GHC 9.2 ([#436][436], [@patrickt][patrickt]) + ## Version 1.0.5 (2021-03-12) - GHC 9 Support ([#392][392], [@utdemir][utdemir]) @@ -227,14 +237,28 @@ https://github.com/mpilgrem [utdemir]: https://github.com/utdemir +[patrickt]: + https://github.com/patrickt +[simfleischman]: + https://github.com/simfleischman +[jhrcek]: + https://github.com/jhrcek +[446]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/446 +[436]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/436 +[423]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/423 [415]: https://github.com/hedgehogqa/haskell-hedgehog/pull/415 [414]: https://github.com/hedgehogqa/haskell-hedgehog/pull/414 [413]: https://github.com/hedgehogqa/haskell-hedgehog/pull/413 +[412]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/412 [409]: https://github.com/hedgehogqa/haskell-hedgehog/pull/409 [408]: diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/README.md new/hedgehog-1.1.1/README.md --- old/hedgehog-1.0.5/README.md 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/README.md 2001-09-09 03:46:40.000000000 +0200 @@ -11,7 +11,7 @@ # Release with confidence. -[![Hackage][hackage-shield]][hackage] [![Travis][travis-shield]][travis] [![AppVeyor][appveyor-shield]][appveyor] +[![Hackage][hackage-shield]][hackage] [![GitHub CI][github-shield]][github-ci] <div align="left"> @@ -91,14 +91,17 @@ <br /> <img width="307" src="https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png"; /> +## Contributors + +<a href="https://github.com/hedgehogqa/haskell-hedgehog/graphs/contributors";> + <img src="https://contrib.rocks/image?repo=hedgehogqa/haskell-hedgehog"; /> +</a> + [hackage]: http://hackage.haskell.org/package/hedgehog [hackage-shield]: https://img.shields.io/hackage/v/hedgehog.svg?style=flat - [travis]: https://travis-ci.com/hedgehogqa/haskell-hedgehog - [travis-shield]: https://travis-ci.com/hedgehogqa/haskell-hedgehog.svg?branch=master - - [appveyor]: https://ci.appveyor.com/project/hedgehogqa/haskell-hedgehog - [appveyor-shield]: https://ci.appveyor.com/api/projects/status/o4rlstbc80sum3on/branch/master?svg=true + [github-shield]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/ci.yaml/badge.svg + [github-ci]: https://github.com/hedgehogqa/haskell-hedgehog/actions/workflows/ci.yaml [haddock-hedgehog]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog.html [haddock-hedgehog-gen]: http://hackage.haskell.org/package/hedgehog/docs/Hedgehog-Gen.html diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/hedgehog.cabal new/hedgehog-1.1.1/hedgehog.cabal --- old/hedgehog-1.0.5/hedgehog.cabal 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/hedgehog.cabal 2001-09-09 03:46:40.000000000 +0200 @@ -1,4 +1,4 @@ -version: 1.0.5 +version: 1.1.1 name: hedgehog @@ -39,6 +39,7 @@ , GHC == 8.6.5 , GHC == 8.8.3 , GHC == 8.10.1 + , GHC == 9.2.1 extra-source-files: README.md CHANGELOG.md @@ -53,6 +54,7 @@ base >= 4.9 && < 5 , ansi-terminal >= 0.6 && < 0.12 , async >= 2.0 && < 2.3 + , barbies >= 1.0 && < 2.1 , bytestring >= 0.10 && < 0.12 , concurrent-output >= 1.7 && < 1.11 , containers >= 0.4 && < 0.7 @@ -61,7 +63,7 @@ , erf >= 2.0 && < 2.1 , exceptions >= 0.7 && < 0.11 , lifted-async >= 0.7 && < 0.11 - , mmorph >= 1.0 && < 1.2 + , mmorph >= 1.0 && < 1.3 , monad-control >= 1.0 && < 1.1 , mtl >= 2.1 && < 2.3 , pretty-show >= 1.6 && < 1.11 @@ -69,9 +71,9 @@ , random >= 1.1 && < 1.3 , resourcet >= 1.1 && < 1.3 , stm >= 2.4 && < 2.6 - , template-haskell >= 2.10 && < 2.18 + , template-haskell >= 2.10 && < 2.19 , text >= 1.1 && < 1.3 - , time >= 1.4 && < 1.10 + , time >= 1.4 && < 1.13 , transformers >= 0.5 && < 0.6 , transformers-base >= 0.4.5.1 && < 0.5 , wl-pprint-annotated >= 0.0 && < 0.2 @@ -88,6 +90,7 @@ Hedgehog.Main Hedgehog.Range + Hedgehog.Internal.Barbie Hedgehog.Internal.Config Hedgehog.Internal.Discovery Hedgehog.Internal.Distributive @@ -140,7 +143,7 @@ hedgehog , base >= 3 && < 5 , containers >= 0.4 && < 0.7 - , mmorph >= 1.0 && < 1.2 + , mmorph >= 1.0 && < 1.3 , mtl >= 2.1 && < 2.3 , pretty-show >= 1.6 && < 1.11 , text >= 1.1 && < 1.3 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Barbie.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Barbie.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Barbie.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Barbie.hs 2001-09-09 03:46:40.000000000 +0200 @@ -0,0 +1,18 @@ +{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE CPP #-} + +-- | For compatibility across different versions of the @barbie@ package. +-- +module Hedgehog.Internal.Barbie ( + FunctorB(..) + , TraversableB(..) + , Rec(..) + ) where + +-- Hide CPP in here instead of the State.hs file. + +#if MIN_VERSION_barbies(2,0,0) +import Data.Functor.Barbie (FunctorB(..), TraversableB(..), Rec(..)) +#else +import Data.Barbie (FunctorB(..), TraversableB(..), Rec(..)) +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Config.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Config.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Config.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Config.hs 2001-09-09 03:46:40.000000000 +0200 @@ -9,6 +9,9 @@ UseColor(..) , resolveColor + , Seed(..) + , resolveSeed + , Verbosity(..) , resolveVerbosity @@ -17,14 +20,20 @@ , detectMark , detectColor + , detectSeed , detectVerbosity , detectWorkers ) where import Control.Monad.IO.Class (MonadIO(..)) +import qualified Data.Text as Text + import qualified GHC.Conc as Conc +import Hedgehog.Internal.Seed (Seed(..)) +import qualified Hedgehog.Internal.Seed as Seed + import Language.Haskell.TH.Syntax (Lift) import System.Console.ANSI (hSupportsANSI) @@ -107,6 +116,28 @@ else pure DisableColor +splitOn :: String -> String -> [String] +splitOn needle haystack = + fmap Text.unpack $ Text.splitOn (Text.pack needle) (Text.pack haystack) + +parseSeed :: String -> Maybe Seed +parseSeed env = + case splitOn " " env of + [value, gamma] -> + Seed <$> readMaybe value <*> readMaybe gamma + _ -> + Nothing + +detectSeed :: MonadIO m => m Seed +detectSeed = + liftIO $ do + menv <- lookupEnv "HEDGEHOG_SEED" + case parseSeed =<< menv of + Nothing -> + Seed.random + Just seed -> + pure seed + detectVerbosity :: MonadIO m => m Verbosity detectVerbosity = liftIO $ do @@ -142,6 +173,13 @@ Just x -> pure x +resolveSeed :: MonadIO m => Maybe Seed -> m Seed +resolveSeed = \case + Nothing -> + detectSeed + Just x -> + pure x + resolveVerbosity :: MonadIO m => Maybe Verbosity -> m Verbosity resolveVerbosity = \case Nothing -> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Gen.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Gen.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Gen.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Gen.hs 2001-09-09 03:46:40.000000000 +0200 @@ -471,9 +471,15 @@ (<>) = liftA2 (Semigroup.<>) -instance (Monad m, Monoid a) => Monoid (GenT m a) where - mappend = - liftA2 mappend +instance ( + Monad m, Monoid a +#if !MIN_VERSION_base(4,11,0) + , Semigroup a +#endif + ) => Monoid (GenT m a) where +#if !MIN_VERSION_base(4,11,0) + mappend = (Semigroup.<>) +#endif mempty = return mempty diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/HTraversable.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/HTraversable.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/HTraversable.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/HTraversable.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,13 +1,20 @@ {-# OPTIONS_HADDOCK not-home #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE RankNTypes #-} module Hedgehog.Internal.HTraversable ( HTraversable(..) ) where +import Hedgehog.Internal.Barbie (TraversableB) -- | Higher-order traversable functors. -- --- This is used internally to make symbolic variables concrete given an 'Environment'. +-- /Deprecated in favor of 'TraversableB' which can be derived using "GHC.Generics"/ -- class HTraversable t where htraverse :: Applicative f => (forall a. g a -> f (h a)) -> t g -> f (t h) + +{-# + DEPRECATED HTraversable + "Replace with Hedgehog.TraversableB (defined in Data.Functor.Barbie) which can be derived automatically using GHC.Generics" +#-} diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Property.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Property.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Property.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Property.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1248,8 +1248,8 @@ -- prop_with_coverage = -- property $ do -- match <- forAll Gen.bool --- cover 30 "True" $ match --- cover 30 "False" $ not match +-- cover 30 \"True\" $ match +-- cover 30 \"False\" $ not match -- @ -- -- The example above requires a minimum of 30% coverage for both diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Report.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Report.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Report.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Report.hs 2001-09-09 03:46:40.000000000 +0200 @@ -46,6 +46,9 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe, catMaybes) +#if !MIN_VERSION_base(4,11,0) +import qualified Data.Semigroup as Semigroup +#endif import Data.Traversable (for) import Hedgehog.Internal.Config @@ -60,7 +63,6 @@ import Hedgehog.Internal.Property (coverPercentage, coverageFailures) import Hedgehog.Internal.Property (labelCovered) -import Hedgehog.Internal.Seed (Seed) import Hedgehog.Internal.Show import Hedgehog.Internal.Source import Hedgehog.Range (Size) @@ -140,9 +142,14 @@ } deriving (Show) instance Monoid Summary where +#if !MIN_VERSION_base(4,11,0) + mappend = (Semigroup.<>) +#endif mempty = Summary 0 0 0 0 0 - mappend (Summary x1 x2 x3 x4 x5) (Summary y1 y2 y3 y4 y5) = + +instance Semigroup Summary where + Summary x1 x2 x3 x4 x5 <> Summary y1 y2 y3 y4 y5 = Summary (x1 + y1) (x2 + y2) @@ -150,9 +157,6 @@ (x4 + y4) (x5 + y5) -instance Semigroup Summary where - (<>) = mappend - -- | Construct a summary from a single result. -- fromResult :: Result -> Summary diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Runner.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Runner.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Runner.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Runner.hs 2001-09-09 03:46:40.000000000 +0200 @@ -48,7 +48,6 @@ import Hedgehog.Internal.Queue import Hedgehog.Internal.Region import Hedgehog.Internal.Report -import Hedgehog.Internal.Seed (Seed) import qualified Hedgehog.Internal.Seed as Seed import Hedgehog.Internal.Tree (TreeT(..), NodeT(..)) import Hedgehog.Range (Size) @@ -71,6 +70,9 @@ -- the environment. , runnerColor :: !(Maybe UseColor) + -- | The seed to use. 'Nothing' means detect from the environment. + , runnerSeed :: !(Maybe Seed) + -- | How verbose to be in the runner output. 'Nothing' means detect from -- the environment. , runnerVerbosity :: !(Maybe Verbosity) @@ -331,10 +333,11 @@ => Region -> UseColor -> Maybe PropertyName + -> Maybe Seed -> Property -> m (Report Result) -checkNamed region color name prop = do - seed <- liftIO Seed.random +checkNamed region color name mseed prop = do + seed <- resolveSeed mseed checkRegion region color name 0 seed prop -- | Check a property. @@ -343,7 +346,7 @@ check prop = do color <- detectColor liftIO . displayRegion $ \region -> - (== OK) . reportStatus <$> checkNamed region color Nothing prop + (== OK) . reportStatus <$> checkNamed region color Nothing Nothing prop -- | Check a property using a specific size and seed. -- @@ -373,9 +376,10 @@ putStrLn $ "????????? " ++ unGroupName group ++ " ?????????" + seed <- resolveSeed (runnerSeed config) verbosity <- resolveVerbosity (runnerVerbosity config) color <- resolveColor (runnerColor config) - summary <- checkGroupWith n verbosity color props + summary <- checkGroupWith n verbosity color seed props pure $ summaryFailed summary == 0 && @@ -390,9 +394,10 @@ WorkerCount -> Verbosity -> UseColor + -> Seed -> [(PropertyName, Property)] -> IO Summary -checkGroupWith n verbosity color props = +checkGroupWith n verbosity color seed props = displayRegion $ \sregion -> do svar <- atomically . TVar.newTVar $ mempty { summaryWaiting = PropertyCount (length props) } @@ -430,7 +435,7 @@ summary <- fmap (mconcat . fmap (fromResult . reportStatus)) $ runTasks n props start finish finalize $ \(name, prop, region) -> do - result <- checkNamed region color (Just name) prop + result <- checkNamed region color (Just name) (Just seed) prop updateSummary sregion svar color (<> fromResult (reportStatus result)) pure result @@ -463,6 +468,8 @@ Just 1 , runnerColor = Nothing + , runnerSeed = + Nothing , runnerVerbosity = Nothing } @@ -497,6 +504,8 @@ Nothing , runnerColor = Nothing + , runnerSeed = + Nothing , runnerVerbosity = Nothing } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/Seed.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/Seed.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/Seed.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/Seed.hs 2001-09-09 03:46:40.000000000 +0200 @@ -1,5 +1,6 @@ {-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveLift #-} -- | -- This is a port of "Fast Splittable Pseudorandom Number Generators" by Steele -- et. al. [1]. @@ -61,6 +62,8 @@ import qualified Data.IORef as IORef import Data.Word (Word32, Word64) +import Language.Haskell.TH.Syntax (Lift) + import System.IO.Unsafe (unsafePerformIO) import System.Random (RandomGen) import qualified System.Random as Random @@ -71,7 +74,7 @@ Seed { seedValue :: !Word64 , seedGamma :: !Word64 -- ^ must be an odd number - } deriving (Eq, Ord) + } deriving (Eq, Ord, Lift) instance Show Seed where showsPrec p (Seed v g) = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog/Internal/State.hs new/hedgehog-1.1.1/src/Hedgehog/Internal/State.hs --- old/hedgehog-1.0.5/src/Hedgehog/Internal/State.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog/Internal/State.hs 2001-09-09 03:46:40.000000000 +0200 @@ -71,10 +71,10 @@ import qualified Data.Maybe as Maybe import Data.Typeable (Typeable, TypeRep, Proxy(..), typeRep) +import Hedgehog.Internal.Barbie (FunctorB(..), TraversableB(..)) import Hedgehog.Internal.Distributive (distributeT) import Hedgehog.Internal.Gen (MonadGen, GenT, GenBase) import qualified Hedgehog.Internal.Gen as Gen -import Hedgehog.Internal.HTraversable (HTraversable(..)) import Hedgehog.Internal.Opaque (Opaque(..)) import Hedgehog.Internal.Property (MonadTest(..), Test, evalEither, evalM, success, runTest, failWith, annotate) import Hedgehog.Internal.Range (Range) @@ -202,8 +202,12 @@ showString "Var " . showsPrec1 11 x -instance HTraversable (Var a) where - htraverse f (Var v) = +instance FunctorB (Var a) where + bmap f (Var v) = + Var (f v) + +instance TraversableB (Var a) where + btraverse f (Var v) = fmap Var (f v) ------------------------------------------------------------------------ @@ -262,9 +266,9 @@ -- | Convert a symbolic structure to a concrete one, using the provided environment. -- -reify :: HTraversable t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete) +reify :: TraversableB t => Environment -> t Symbolic -> Either EnvironmentError (t Concrete) reify vars = - htraverse (reifyEnvironment vars) + btraverse (reifyEnvironment vars) ------------------------------------------------------------------------ -- Callbacks @@ -377,7 +381,7 @@ -- data Command gen m (state :: (Type -> Type) -> Type) = forall input output. - (HTraversable input, Show (input Symbolic), Show output, Typeable output) => + (TraversableB input, Show (input Symbolic), Show output, Typeable output) => Command { -- | A generator which provides random arguments for a command. If the -- command cannot be executed in the current state, it should return @@ -409,7 +413,7 @@ -- data Action m (state :: (Type -> Type) -> Type) = forall input output. - (HTraversable input, Show (input Symbolic), Show output) => + (TraversableB input, Show (input Symbolic), Show output) => Action { actionInput :: input Symbolic @@ -457,19 +461,19 @@ -- | Collects all the symbolic values in a data structure and produces a set of -- all the variables they refer to. -- -takeVariables :: forall t. HTraversable t => t Symbolic -> Map Name TypeRep +takeVariables :: forall t. TraversableB t => t Symbolic -> Map Name TypeRep takeVariables xs = let go x = do modify (insertSymbolic x) pure x in - flip execState Map.empty $ htraverse go xs + flip execState Map.empty $ btraverse go xs -- | Checks that the symbolic values in the data structure refer only to the -- variables in the provided set, and that they are of the correct type. -- -variablesOK :: HTraversable t => t Symbolic -> Map Name TypeRep -> Bool +variablesOK :: TraversableB t => t Symbolic -> Map Name TypeRep -> Bool variablesOK xs allowed = let vars = diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/hedgehog-1.0.5/src/Hedgehog.hs new/hedgehog-1.1.1/src/Hedgehog.hs --- old/hedgehog-1.0.5/src/Hedgehog.hs 2001-09-09 03:46:40.000000000 +0200 +++ new/hedgehog-1.1.1/src/Hedgehog.hs 2001-09-09 03:46:40.000000000 +0200 @@ -145,7 +145,10 @@ , distributeT -- * Functors - , HTraversable(..) + -- $functors + , FunctorB(..) + , TraversableB(..) + , Rec(..) , Eq1 , eq1 @@ -155,10 +158,14 @@ , Show1 , showsPrec1 + + -- * Deprecated + , HTraversable(..) ) where import Data.Functor.Classes (Eq1, eq1, Ord1, compare1, Show1, showsPrec1) +import Hedgehog.Internal.Barbie (FunctorB(..), TraversableB(..), Rec(..)) import Hedgehog.Internal.Distributive (distributeT) import Hedgehog.Internal.Gen (Gen, GenT, MonadGen(..)) import Hedgehog.Internal.HTraversable (HTraversable(..)) @@ -183,7 +190,6 @@ import Hedgehog.Internal.Property (collect, label) import Hedgehog.Internal.Range (Range, Size(..)) import Hedgehog.Internal.Runner (check, recheck, checkSequential, checkParallel) - import Hedgehog.Internal.Seed (Seed(..)) import Hedgehog.Internal.State (Command(..), Callback(..)) import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) @@ -191,3 +197,40 @@ import Hedgehog.Internal.State (Var(..), Symbolic, Concrete(..), concrete, opaque) import Hedgehog.Internal.TH (discover, discoverPrefix) import Hedgehog.Internal.Tripping (tripping) + + +-- $functors +-- +-- 'FunctorB' and 'TraversableB' must be implemented for all 'Command' @input@ types. +-- +-- This is most easily achieved using `DeriveGeneric`: +-- +-- @ +-- data Register v = +-- Register Name (Var Pid v) +-- deriving (Eq, Show, Generic) +-- +-- instance FunctorB Register +-- instance TraversableB Register +-- +-- newtype Unregister (v :: * -> *) = +-- Unregister Name +-- deriving (Eq, Show, Generic) +-- +-- instance FunctorB Unregister +-- instance TraversableB Unregister +-- @ +-- +-- `DeriveAnyClass` and `DerivingStrategies` allow a more compact syntax: +-- +-- @ +-- data Register v = +-- Register Name (Var Pid v) +-- deriving (Eq, Show, Generic, FunctorB, TraversableB) +-- +-- newtype Unregister (v :: * -> *) = +-- Unregister Name +-- deriving (Eq, Show, Generic) +-- deriving anyclass (FunctorB, TraversableB) +-- @ +--
![https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png"](https://github.com/hedgehogqa/haskell-hedgehog/raw/master/img/hedgehog-logo-grey.png"){kind=link}
