diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## 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,8 +232,14 @@ https://github.com/mpilgrem [utdemir]: https://github.com/utdemir +[patrickt]: + https://github.com/patrickt +[436]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/436 +[421]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/421 [415]: https://github.com/hedgehogqa/haskell-hedgehog/pull/415 [414]: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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]
@@ -91,14 +91,17 @@
+## Contributors + + + + + [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 --git a/hedgehog.cabal b/hedgehog.cabal --- a/hedgehog.cabal +++ b/hedgehog.cabal @@ -1,4 +1,4 @@ -version: 1.0.5 +version: 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 @@ -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 diff --git a/src/Hedgehog.hs b/src/Hedgehog.hs --- a/src/Hedgehog.hs +++ b/src/Hedgehog.hs @@ -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) +-- @ +-- diff --git a/src/Hedgehog/Internal/Barbie.hs b/src/Hedgehog/Internal/Barbie.hs new file mode 100644 --- /dev/null +++ b/src/Hedgehog/Internal/Barbie.hs @@ -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 --git a/src/Hedgehog/Internal/Gen.hs b/src/Hedgehog/Internal/Gen.hs --- a/src/Hedgehog/Internal/Gen.hs +++ b/src/Hedgehog/Internal/Gen.hs @@ -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 --git a/src/Hedgehog/Internal/HTraversable.hs b/src/Hedgehog/Internal/HTraversable.hs --- a/src/Hedgehog/Internal/HTraversable.hs +++ b/src/Hedgehog/Internal/HTraversable.hs @@ -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 --git a/src/Hedgehog/Internal/Report.hs b/src/Hedgehog/Internal/Report.hs --- a/src/Hedgehog/Internal/Report.hs +++ b/src/Hedgehog/Internal/Report.hs @@ -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 @@ -140,18 +143,20 @@ } 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) (x3 + y3) (x4 + y4) (x5 + y5) - -instance Semigroup Summary where - (<>) = mappend -- | Construct a summary from a single result. -- diff --git a/src/Hedgehog/Internal/State.hs b/src/Hedgehog/Internal/State.hs --- a/src/Hedgehog/Internal/State.hs +++ b/src/Hedgehog/Internal/State.hs @@ -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 =