registry-hedgehog 0.5.0.0 → 0.6.0.0

raw patch · 13 files changed

+162/−339 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• registry-hedgehog.cabal +2/−3
• src/Data/Registry/Hedgehog.hs +91/−134
• src/Data/Registry/Hedgehog/TH.hs +1/−1
• src/Data/Registry/Internal/Hedgehog.hs +8/−52
• src/Data/Registry/Internal/TH.hs +5/−4
• test/Test/Data/Registry/Generators.hs +2/−3
• test/Test/Data/Registry/HedgehogSpec.hs +20/−86
• test/Test/Tutorial/Exercise1.hs +10/−9
• test/Test/Tutorial/Exercise2.hs +4/−4
• test/Test/Tutorial/Exercise3.hs +1/−1
• test/Test/Tutorial/Exercise4.hs +2/−2
• test/Test/Tutorial/Exercise5.hs +16/−12
• test/Test/Tutorial/Exercise6.hs +0/−28

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 8df9d1fe1e960d1a38f39a81e36d27257cfaf4c32fc4907122da8842b84271a5+-- hash: 6a7d709328017b52e337399c103ca4bb6188933c06bdd3cb5e3e608bae7f2c38  name:           registry-hedgehog-version:        0.5.0.0+version:        0.6.0.0 synopsis:       utilities to work with Hedgehog generators and `registry` description:    This library provides some functions to extract generators from a "Registry" and make stateful modifications of that Registry to precisely control the generation of data category:       Control@@ -94,7 +94,6 @@       Test.Tutorial.Exercise3       Test.Tutorial.Exercise4       Test.Tutorial.Exercise5-      Test.Tutorial.Exercise6       Paths_registry_hedgehog   hs-source-dirs:       test

@@ -5,30 +5,34 @@  module Data.Registry.Hedgehog   ( -- creation / tweaking functions-    GenIO,+    Gen,     Chooser (..),-    forallS,-    forAllT, -- re-export of forAllT for convenience purpose since we are working in GenIO-    filterGenS,     genFun,     genVal,     genWith,-    modifyGenS,     setGen,-    setGenIO,-    setGenS,     specializeGen,-    specializeGenIO,-    specializeGenS,     tweakGen,-    tweakGenS,     makeNonEmpty,-    makeNonEmptyS,+    genListOf,+    genListOfMinMax,+    genNonEmptyOfMinMax,+    genNonEmptyOf,+    genMaybeOf,+    genOneOf,+    genPairOf,+    genTripleOf,+    genTuple4Of,+    setDistinctPairOf,+    setDistinctTripleOf,     -- combinators to compose different types of generators+    distinctPairOf,+    distinctTripleOf,     eitherOf,     hashMapOf,     listOf,     listOfMinMax,+    nonEmptyOfMinMax,     mapOf,     maybeOf,     nonEmptyMapOf,@@ -38,26 +42,16 @@     tripleOf,     tuple4Of,     tuple5Of,-    -- cycling values+    -- choosing constructors in an ADT     choiceChooser,     chooseOne,-    setCycleChooser,-    setCycleChooserS,-    -- making distinct values-    distinct,-    setDistinct,-    setDistinctFor,-    setDistinctForS,-    setDistinctS,-    -- sampling for GenIO generators+    -- sampling for Gen generators     sampleIO,   ) where -import Control.Monad.Morph import Data.HashMap.Strict as HashMap (HashMap, fromList)-import Data.IORef-import Data.List.NonEmpty hiding (cycle, nonEmpty, (!!))+import Data.List.NonEmpty as NonEmpty hiding (cycle, nonEmpty, (!!)) import Data.Map as Map (fromList) import Data.Maybe as Maybe import Data.Registry@@ -66,190 +60,153 @@ import Data.Set as Set (fromList) import Hedgehog import Hedgehog.Gen as Gen-import Hedgehog.Internal.Property (forAllT) import Hedgehog.Range import Protolude as P-import System.IO.Unsafe  -- * CREATION / TWEAKING OF REGISTRY GENERATORS --- | Create a GenIO a for a given constructor of type a-genFun :: forall a b. (ApplyVariadic GenIO a b, Typeable a, Typeable b) => a -> Typed b-genFun = funTo @GenIO+-- | Create a Gen a for a given constructor of type a+genFun :: forall a b. (ApplyVariadic Gen a b, Typeable a, Typeable b) => a -> Typed b+genFun = funTo @Gen --- | Lift a Gen a into GenIO a to be added to a registry-genVal :: forall a. (Typeable a) => Gen a -> Typed (GenIO a)-genVal g = fun (liftGen g)+-- | Create a Gen a for a given constructor of type a+genVal :: forall a. (Typeable a) => Gen a -> Typed (Gen a)+genVal = fun  -- | Extract a generator from a registry --   We use makeUnsafe assuming that the registry has been checked before-genWith :: forall a ins out. (Typeable a) => Registry ins out -> GenIO a-genWith = make @(GenIO a)+genWith :: forall a ins out. (Typeable a) => Registry ins out -> Gen a+genWith = make @(Gen a)  -- | Modify the value of a generator in a given registry tweakGen :: forall a ins out. (Typeable a) => (a -> a) -> Registry ins out -> Registry ins out-tweakGen f = tweak @(GenIO a) (f <$>)---- | Modify the registry for a given generator in a State monad-tweakGenS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m) => (a -> a) -> m ()-tweakGenS f = modify (tweakGen f)+tweakGen f = tweak @(Gen a) (f <$>)  -- | Set a specific generator on the registry the value of a generator in a given registry setGen :: forall a ins out. (Typeable a) => Gen a -> Registry ins out -> Registry ins out-setGen = setGenIO . liftGen--setGenIO :: forall a ins out. (Typeable a) => GenIO a -> Registry ins out -> Registry ins out-setGenIO genA = tweak @(GenIO a) (const genA)---- | Set a specific generator on the registry the value of a generator in a given registry in a State monad-setGenS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m) => Gen a -> m ()-setGenS genA = modify (setGen genA)+setGen = tweak @(Gen a) . const  -- | Specialize a generator in a given context specializeGen :: forall a b ins out. (Typeable a, Typeable b) => Gen b -> Registry ins out -> Registry ins out-specializeGen g = specializeGenIO @a (liftGen g)+specializeGen = specialize @(Gen a) @(Gen b) --- | Specialize a generator in a given context-specializeGenIO :: forall a b ins out. (Typeable a, Typeable b) => GenIO b -> Registry ins out -> Registry ins out-specializeGenIO = specialize @(GenIO a)+-- | Add a generator for a list of elements+genListOf :: forall a. (Typeable a) => Typed (Gen a -> Gen [a])+genListOf = fun (listOf @a) --- | Specialize a generator in a given context-specializeGenS :: forall a b m ins out. (Typeable a, Typeable b, MonadState (Registry ins out) m) => Gen b -> m ()-specializeGenS g = modify (specializeGen @a @b g)+-- | Add a generator for a bounded list of elements+genListOfMinMax :: forall a. (Typeable a) => Int -> Int -> Typed (Gen a -> Gen [a])+genListOfMinMax mn mx = fun (listOfMinMax @a mn mx) --- | Modify a generator-modifyGenS :: forall a ins out. (Typeable a) => (GenIO a -> GenIO a) -> PropertyT (StateT (Registry ins out) IO) ()-modifyGenS f = modify (tweak @(GenIO a) f)+-- | Add a generator for a non-empty list of elements+genNonEmptyOf :: forall a. (Typeable a) => Typed (Gen a -> Gen (NonEmpty a))+genNonEmptyOf = fun (nonEmptyOf @a) --- | Filter a generator-filterGenS :: forall a ins out. (Typeable a) => (a -> Bool) -> PropertyT (StateT (Registry ins out) IO) ()-filterGenS = modifyGenS . Gen.filterT+-- | Add a generator for a bounded non-empty list of elements+genNonEmptyOfMinMax :: forall a. (Typeable a) => Int -> Int -> Typed (Gen a -> Gen (NonEmpty a))+genNonEmptyOfMinMax mn mx = fun (nonEmptyOfMinMax @a mn mx) --- | Get a value generated from one of the generators in the registry and modify the registry---   using a state monad-forallS :: forall a m out. (Typeable a, Show a, MonadIO m) => PropertyT (StateT (Registry _ out) m) a-forallS = do-  r <- P.lift $ get-  withFrozenCallStack $ hoist liftIO $ forAllT (genWith @a r)+-- | Add a generator for an optional element+genMaybeOf :: forall a. (Typeable a) => Typed (Gen a -> Gen (Maybe a))+genMaybeOf = fun (maybeOf @a) +-- | Add a generator for a element picked from a list+genOneOf :: (Typeable a, Show a) => [a] -> Typed (Gen a)+genOneOf as = genVal (Gen.element as)++-- | Add a generator for a pair of elements+genPairOf :: forall a b. (Typeable a, Typeable b) => Typed (Gen a -> Gen b -> Gen (a, b))+genPairOf = fun (pairOf @a @b)++-- | Add a generator for a triple of elements+genTripleOf :: forall a b c. (Typeable a, Typeable b, Typeable c) => Typed (Gen a -> Gen b -> Gen c -> Gen (a, b, c))+genTripleOf = fun (tripleOf @a @b @c)++-- | Add a generator for 4 elements+genTuple4Of :: forall a b c d. (Typeable a, Typeable b, Typeable c, Typeable d) => Typed (Gen a -> Gen b -> Gen c -> Gen d -> Gen (a, b, c, d))+genTuple4Of = fun (tuple4Of @a @b @c @d)++-- | Add the generation of a pair of distinct elements+setDistinctPairOf :: forall a. (Typeable a, Eq a) => Registry _ _ -> Registry _ _+setDistinctPairOf r = fun (distinctPairOf @a) +: r++-- | Add the generation of a triple of distinct elements+setDistinctTripleOf :: forall a. (Typeable a, Eq a) => Registry _ _ -> Registry _ _+setDistinctTripleOf r = fun (distinctTripleOf @a) +: r+ -- | Make sure there is always one element of a given type in a list of elements makeNonEmpty :: forall a ins out. (Typeable a) => Registry ins out -> Registry ins out makeNonEmpty r =   -- extract a generator for one element only   let genA = genWith @a r    in -- add that element in front of a list of generated elements-      tweak @(GenIO [a]) (\genAs -> (:) <$> genA <*> genAs) r---- | Make sure there is always one element of a given type in a list of elements in a State monad-makeNonEmptyS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m) => m ()-makeNonEmptyS = modify (makeNonEmpty @a)+      tweak @(Gen [a]) (\genAs -> (:) <$> genA <*> genAs) r  -- * CONTAINERS COMBINATORS  -- | Create a generator for a pair-pairOf :: forall a b. GenIO a -> GenIO b -> GenIO (a, b)+pairOf :: forall a b. Gen a -> Gen b -> Gen (a, b) pairOf ga gb = (,) <$> ga <*> gb  -- | Create a generator for a triple-tripleOf :: forall a b c. GenIO a -> GenIO b -> GenIO c -> GenIO (a, b, c)+tripleOf :: forall a b c. Gen a -> Gen b -> Gen c -> Gen (a, b, c) tripleOf ga gb gc = (,,) <$> ga <*> gb <*> gc  -- | Create a generator for a quadruple-tuple4Of :: forall a b c d. GenIO a -> GenIO b -> GenIO c -> GenIO d -> GenIO (a, b, c, d)+tuple4Of :: forall a b c d. Gen a -> Gen b -> Gen c -> Gen d -> Gen (a, b, c, d) tuple4Of ga gb gc gd = (,,,) <$> ga <*> gb <*> gc <*> gd  -- | Create a generator for a quintuple-tuple5Of :: forall a b c d e. GenIO a -> GenIO b -> GenIO c -> GenIO d -> GenIO e -> GenIO (a, b, c, d, e)+tuple5Of :: forall a b c d e. Gen a -> Gen b -> Gen c -> Gen d -> Gen e -> Gen (a, b, c, d, e) tuple5Of ga gb gc gd ge = (,,,,) <$> ga <*> gb <*> gc <*> gd <*> ge  -- | Create a default generator for a small list of elements-listOf :: forall a. GenIO a -> GenIO [a]+listOf :: forall a. Gen a -> Gen [a] listOf = Gen.list (linear 0 10)  -- | Create a default generator for a list of elements of min elements and max elements-listOfMinMax :: forall a. Int -> Int -> GenIO a -> GenIO [a]+listOfMinMax :: forall a. Int -> Int -> Gen a -> Gen [a] listOfMinMax min' max' = Gen.list (linear min' max')  -- | Create a default generator for a small non-empty list of elements-nonEmptyOf :: GenIO a -> GenIO (NonEmpty a)+nonEmptyOf :: Gen a -> Gen (NonEmpty a) nonEmptyOf = Gen.nonEmpty (linear 1 10)  -- | Create a default generator for a Maybe, choosing evenly between Nothing and Just-maybeOf :: forall a. GenIO a -> GenIO (Maybe a)+maybeOf :: forall a. Gen a -> Gen (Maybe a) maybeOf genA = choice [pure Nothing, Just <$> genA]  -- | Create a default generator for a Either, choosing evenly between Left and Right-eitherOf :: forall a b. GenIO a -> GenIO b -> GenIO (Either a b)+eitherOf :: forall a b. Gen a -> Gen b -> Gen (Either a b) eitherOf genA genB = choice [Left <$> genA, Right <$> genB]  -- | Create a default generator for a small set of elements-setOf :: forall a. (Ord a) => GenIO a -> GenIO (Set a)+setOf :: forall a. (Ord a) => Gen a -> Gen (Set a) setOf = fmap Set.fromList . listOf  -- | Create a default generator for map of key/values-mapOf :: forall k v. (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v)+mapOf :: forall k v. (Ord k) => Gen k -> Gen v -> Gen (Map k v) mapOf gk gv = Map.fromList <$> listOf (pairOf gk gv)  -- | Create a default generator for HashMap of key/values-hashMapOf :: forall k v. (Ord k, Hashable k) => GenIO k -> GenIO v -> GenIO (HashMap k v)+hashMapOf :: forall k v. (Ord k, Hashable k) => Gen k -> Gen v -> Gen (HashMap k v) hashMapOf gk gv = HashMap.fromList <$> listOf (pairOf gk gv)  -- | Create a default generator for a small non-empty map of elements-nonEmptyMapOf :: forall k v. (Ord k) => GenIO k -> GenIO v -> GenIO (Map k v)+nonEmptyMapOf :: forall k v. (Ord k) => Gen k -> Gen v -> Gen (Map k v) nonEmptyMapOf gk gv = do   h <- pairOf gk gv   t <- listOf (pairOf gk gv)   pure (Map.fromList (h : t)) --- * STATEFUL GENERATORS---- * CHOOSING VALUES DETERMINISTICALLY---- | Set a cycling chooser for a specific data type-{-# NOINLINE setCycleChooser #-}-setCycleChooser :: forall a ins out. (Typeable a) => Registry ins out -> Registry ins out-setCycleChooser r = unsafePerformIO $ do-  c <- cycleChooser-  pure $ specializeValTo @GenIO @(GenIO a) c r---- | Set a cycling chooser for a specific data type-{-# NOINLINE setCycleChooserS #-}-setCycleChooserS :: forall a m ins out. (Typeable a, MonadState (Registry ins out) m, MonadIO m) => m ()-setCycleChooserS =-  let c = unsafePerformIO cycleChooser-   in do-        r <- get-        let r' = specializeValTo @GenIO @(GenIO a) c r-        put r'---- * MAKING DISTINCT VALUES---- | Generate distinct values for a specific data type-{-# NOINLINE setDistinct #-}-setDistinct :: forall a ins out. (Eq a, Typeable a) => Registry ins out -> Registry ins out-setDistinct = setDistinctWithRef @a (unsafePerformIO $ newIORef [])--setDistinctWithRef :: forall a ins out. (Eq a, Typeable a) => IORef [a] -> Registry ins out -> Registry ins out-setDistinctWithRef ref r = setGenIO (distinctWith ref (make @(GenIO a) r)) r---- | Generate distinct values for a specific data type-{-# NOINLINE setDistinctS #-}-setDistinctS :: forall a m ins out. (Eq a, Typeable a, MonadState (Registry ins out) m, MonadIO m) => m ()-setDistinctS =-  let ref = unsafePerformIO $ newIORef []-   in modify (setDistinctWithRef @a ref)---- | Generate distinct values for a specific data type, when used inside another data type-{-# NOINLINE setDistinctFor #-}-setDistinctFor :: forall a b ins out. (Typeable a, Eq b, Typeable b) => Registry ins out -> Registry ins out-setDistinctFor = setDistinctForWithRef @a @b (unsafePerformIO $ newIORef [])+-- | Make a generator for a non empty list of elements of a given type+nonEmptyOfMinMax :: Int -> Int -> Gen a -> Gen (NonEmpty a)+nonEmptyOfMinMax mi ma g = NonEmpty.fromList <$> listOfMinMax mi ma g -setDistinctForWithRef :: forall a b ins out. (Typeable a, Eq b, Typeable b) => IORef [b] -> Registry ins out -> Registry ins out-setDistinctForWithRef ref r = specializeGenIO @a (distinctWith ref (make @(GenIO b) r)) r+-- | Make a generator for a pair of distinct values+distinctPairOf :: forall a. (Eq a) => Gen a -> Gen (a, a)+distinctPairOf genA = Gen.filterT (uncurry (/=)) $ (,) <$> genA <*> genA --- | Generate distinct values for a specific data type, when used inside another data type-{-# NOINLINE setDistinctForS #-}-setDistinctForS :: forall a b m ins out. (Typeable a, Eq b, Typeable b, MonadState (Registry ins out) m, MonadIO m) => m ()-setDistinctForS =-  let ref = unsafePerformIO $ newIORef []-   in modify (setDistinctForWithRef @a @b ref)+-- | Make a generator for a triple of distinct values+distinctTripleOf :: forall a. (Eq a) => Gen a -> Gen (a, a, a)+distinctTripleOf genA = Gen.filterT (\(a1, a2, a3) -> a1 /= a2 && a2 /= a3 && a1 /= a3) $ (,,) <$> genA <*> genA <*> genA

@@ -16,7 +16,7 @@ --    <: genFun (tag @"permanent" Permanent) --    <: genFun (tag @"temporary" Temporary) ----- genEmployeeStatus :: GenIO Chooser -> GenIO (Tag "permanent" EmployeeStatus) -> GenIO (Tag "temporary" EmployeeStatus) -> GenIO EmployeeStatus+-- genEmployeeStatus :: Gen Chooser -> Gen (Tag "permanent" EmployeeStatus) -> Gen (Tag "temporary" EmployeeStatus) -> Gen EmployeeStatus -- genEmployeeStatus chooser g1 g2 = chooseOne chooser [fmap unTag1, fmap unTag g2] makeGenerators :: Name -> ExpQ makeGenerators genType = do

@@ -3,16 +3,9 @@ {-# LANGUAGE PartialTypeSignatures #-}  module Data.Registry.Internal.Hedgehog-  ( GenIO,-    Chooser (..),-    -- cycling values-    cycleWith,+  ( Chooser (..),     chooseOne,     choiceChooser,-    cycleChooser,-    -- making distinct values-    distinct,-    distinctWith,     -- utilities     liftGen,     sampleIO,@@ -20,7 +13,6 @@ where  import Control.Monad.Morph-import Data.IORef import Data.Maybe as Maybe import Hedgehog import Hedgehog.Gen as Gen@@ -28,10 +20,7 @@ import Hedgehog.Internal.Seed as Seed (random) import Hedgehog.Internal.Tree as Tree (NodeT (..), runTreeT) import Protolude as P-import Prelude (show, (!!))---- | All the generators we use are lifted into GenIO to allow some generators to be stateful-type GenIO = GenT IO+import Prelude (show)  -- | Lift a pure generator into another monad like IO liftGen :: (Monad m) => Gen a -> GenT m a@@ -41,62 +30,29 @@  -- | Given a choosing strategy pick a generator --   This is possibly a stateful operation-chooseOne :: GenIO Chooser -> [GenIO a] -> GenIO a+chooseOne :: Gen Chooser -> [Gen a] -> Gen a chooseOne chooser gs = do   c <- chooser-  join $ P.lift $ pickOne c gs+  pickOne c gs  -- | Chooser for randomly selecting a generator choiceChooser :: Chooser-choiceChooser = Chooser {chooserType = "choice", pickOne = pure . Gen.choice}---- | Chooser for deterministically choosing elements in a list---   by cycling over them, which requires to maintain some state about the last position-cycleChooser :: IO Chooser-cycleChooser = do-  ref <- newIORef 0-  pure $ Chooser {chooserType = "cycle", pickOne = cycleWith ref}+choiceChooser = Chooser {chooserType = "choice", pickOne = Gen.choice}  -- | A "chooser" strategy --   The type can be used to debug specializations data Chooser = Chooser   { chooserType :: Text,-    pickOne :: forall a. [GenIO a] -> IO (GenIO a)+    pickOne :: forall a. [Gen a] -> Gen a   }  instance Show Chooser where   show c = toS (chooserType c) --- | Pick a generator in a list based on the previous position selected-cycleWith :: (MonadIO m) => IORef Int -> [GenT m a] -> IO (GenT m a)-cycleWith ref gs = do-  n <- readIORef ref-  modifyIORef ref increment-  pure (gs !! n)-  where-    increment i = if i == P.length gs - 1 then 0 else i + 1---- * MAKING DISTINCT VALUES---- | Create a generator for distinct values---   This is a stateful operation-distinct :: (MonadIO m, Eq a) => GenT m a -> IO (GenT m a)-distinct g = do-  ref <- newIORef []-  pure $ distinctWith ref g---- | Generate distinct values based on the values already generated-distinctWith :: (MonadIO m, Eq a) => IORef [a] -> GenT m a -> GenT m a-distinctWith ref g = GenT $ \size seed -> do-  as <- liftIO $ readIORef ref-  a <- runGenT size seed $ (Gen.filterT (not . flip elem as)) g-  liftIO $ writeIORef ref (a : as)-  pure a- -- * UTILITIES --- | Sample GenIO values-sampleIO :: GenIO a -> IO a+-- | Sample Gen values+sampleIO :: GenT IO a -> IO a sampleIO gen =   let loop n =         if n <= 0

@@ -7,17 +7,18 @@ import Control.Monad.Fail (fail) import Data.Registry.Internal.Hedgehog import Data.Text (splitOn)+import Hedgehog import Language.Haskell.TH import Language.Haskell.TH.Syntax import Protolude hiding (Type) import Prelude (last)  -- | Create a generator for selecting between constructors of an ADT---   One parameter is a GenIO Chooser in order to be able to later on+--   One parameter is a Gen Chooser in order to be able to later on --   switch the selection strategy makeSelectGenerator :: Name -> [Con] -> ExpQ makeSelectGenerator name constructors = do-  chooserParam <- [p|(chooser :: GenIO Chooser)|]+  chooserParam <- [p|(chooser :: Gen Chooser)|]   otherParams <- traverse (parameterFor name) constructors   untaggedGenerators <- traverse untagGenerator constructors   expression <- appE (appE (varE (mkName "chooseOne")) (varE (mkName "chooser"))) (pure $ ListE untaggedGenerators)@@ -27,7 +28,7 @@     parameterFor typeName constructor = do       constructorParam <- constructorParameterName constructor       constructorTag <- tagName constructor-      sigP (varP constructorParam) (appT (conT (mkName "GenIO")) (appT (appT (conT (mkName "Tag")) (litT (strTyLit (show constructorTag)))) (conT typeName)))+      sigP (varP constructorParam) (appT (conT (mkName "Gen")) (appT (appT (conT (mkName "Tag")) (litT (strTyLit (show constructorTag)))) (conT typeName)))  -- Create a generator expression for a specific constructor of a data type -- runQ [|tag @"permanent" Permanent|]@@ -38,7 +39,7 @@   constructorType <- nameOf constructor   appE (appTypeE (varE (mkName "tag")) (litT (strTyLit (show constructorTag)))) (conE constructorType) --- | Remove the tag of a given constructor: fmap unTag g :: GenIO (Tag "t" SomeType) -> GenIO SomeType+-- | Remove the tag of a given constructor: fmap unTag g :: Gen (Tag "t" SomeType) -> Gen SomeType untagGenerator :: Con -> ExpQ untagGenerator constructor = do   constructorParam <- constructorParameterName constructor

@@ -11,7 +11,6 @@ import Data.Registry.Hedgehog import Data.Registry.Hedgehog.TH import Hedgehog.Gen as Gen hiding (print)-import Hedgehog.Internal.Gen hiding (print) import Hedgehog.Range import Protolude hiding (list) import Test.Data.Registry.Company@@ -19,7 +18,7 @@  registry =   genFun Company-    <: fun (listOf @Department)+    <: fun (listOfMinMax @Department 1 5)     <: genFun Department     <: fun (listOf @Employee)     <: genFun Employee@@ -42,4 +41,4 @@  -- | We create a forall function using all the generators forall :: forall a. _ => PropertyT IO a-forall = withFrozenCallStack $ forAllT (genWith @a registry)+forall = withFrozenCallStack $ forAll (genWith @a registry)

@@ -7,7 +7,6 @@ module Test.Data.Registry.HedgehogSpec where  import Control.Monad.Morph (hoist)-import Data.IORef import Data.Registry import Data.Registry.Hedgehog import qualified Data.Text as T@@ -18,31 +17,6 @@ import Hedgehog.Internal.Tree as Tree (NodeT (..), runTreeT) import Hedgehog.Range import Protolude-  ( Applicative (pure),-    Bool (True),-    Eq,-    Foldable (length),-    IO,-    Int,-    Maybe (Just, Nothing),-    Monad ((>>)),-    MonadIO (..),-    MonadState (get, put),-    Num ((+), (-)),-    Ord ((<=), (>=)),-    Show,-    State,-    Text,-    evalState,-    flip,-    head,-    lift,-    panic,-    ($),-    (.),-    (<$>),-  )-import System.IO.Unsafe import Test.Data.Registry.Company import Test.Data.Registry.Generators import Test.Tasty.Hedgehogx@@ -89,23 +63,20 @@   prop "a company can be used for testing" $ do     -- note that we are using forall and not forAll     company <- forall @Company-    (length (departments company) >= 0) === True+    (not . null) (departments company) === True  -- Let's create some registry modifiers to constrain the generation-setOneDepartment = addFunS $ listOfMinMax @Department 1 1+setOneDepartment = addFun $ listOfMinMax @Department 1 1 -setOneEmployee = addFunS $ listOfMinMax @Employee 1 1+setOneEmployee = addFun $ listOfMinMax @Employee 1 1 -setSmallCompany = setOneEmployee >> setOneDepartment+setSmallCompany = setOneEmployee . setOneDepartment -test_small_company =-  prop "a small company has just one department and one employee" $-    runS registry $ do-      setSmallCompany-      company <- forallS @Company-      length (departments company) === 1-      let Just d = head $ departments company-      length (employees d) === 1+test_small_company = prop "a small company has just one department and one employee" $ do+  company <- forallWith @Company setSmallCompany+  length (departments company) === 1+  let Just d = head $ departments company+  length (employees d) === 1  -- * We can also specialize some registry in a given context @@ -115,45 +86,20 @@  genDepartmentName = T.take 5 . T.toUpper <$> genText -setDepartmentName = specializeGenS @Department genDepartmentName--test_with_better_department_name = noShrink $-  prop "a department must have a short capitalized name" $-    runS registry $ do-      setSmallCompany-      setDepartmentName-      company <- forallS @Company--      -- uncomment to print the department names and inspect them-      -- print company-      let Just d = head $ departments company-      (T.length (departmentName d) <= 5) === True---- * It would be also very nice to have stateful generation where we can cycle----   across different constructors for a given data type+setDepartmentName = specializeGen @Department genDepartmentName -test_cycle_constructors =-  prop "we can cycle deterministically across all the constructors of a data type" $-    runS registry $ do-      setCycleChooserS @EmployeeStatus-      -- uncomment to check-      -- collect =<< forallS @EmployeeStatus-      success+test_with_better_department_name = prop "a department must have a short capitalized name" $ do+  company <- forallWith @Company (setSmallCompany . setDepartmentName)+  -- uncomment to print the department names and inspect them+  -- print company+  let Just d = head $ departments company+  (T.length (departmentName d) <= 5) === True --- We can also make sure we generate distinct values for a given type-test_distinct_values =-  prop "we can generate distinct values for a given data type when used in a specific context" $-    runS registry $ do-      setDistinctForS @Department @Text-      -- uncomment to check-      -- collect =<< departmentName <$> forallS @Department-      success+-- | Generate a value with a modified list of generators+forallWith :: forall a b c. (HasCallStack, Show a, Typeable a) => (Registry _ _ -> Registry b c) -> PropertyT IO a+forallWith f = withFrozenCallStack $ forAll $ genWith @a (f registry) -test_ints_generator =-  prop "we can generate ints" $ do-    n <- forAllT distinctInt-    n === n -- collect n+-- * Fresh identifiers using a state monad  test_fresh = minTestsOk 10000 $   prop "we can generate terms with fresh ids" $ do@@ -218,15 +164,3 @@               Just a ->                 pure a    in loop (100 :: Int)--{-# NOINLINE distinctInt #-}-distinctInt :: GenIO Int-distinctInt = unsafePerformIO $ do-  ref <- newIORef (0 :: Int)-  pure $ distinctIntGenerator ref--distinctIntGenerator :: IORef Int -> GenIO Int-distinctIntGenerator ref = do-  i <- lift $ readIORef ref-  lift $ writeIORef ref (i + 1)-  pure i

@@ -7,7 +7,6 @@  import Data.Registry import Data.Registry.Hedgehog-import Hedgehog hiding (test) import Hedgehog.Gen import Hedgehog.Range import Protolude@@ -16,12 +15,14 @@ registry :: Registry _ _ registry =   genFun Company-    +: genFun Department-    +: genFun Employee-    +: genVal genEmployeeStatus-    +: genVal genInt-    +: genVal genText-    +: mempty+    <: fun (listOfMinMax @Department 1 5)+    <: genFun Department+    <: fun (listOfMinMax @Employee 1 5)+    <: genFun Employee+    <: genVal genEmployeeStatus+    <: fun (maybeOf @Int)+    <: genVal genInt+    <: genVal genText  genInt :: Gen Int genInt = integral (linear 1 3)@@ -33,5 +34,5 @@ genEmployeeStatus = pure Permanent  -- this does not compile the registry is not complete--- makeCompanyGen :: GenIO Company--- makeCompanyGen = make @(GenIO Company) registry+-- makeCompanyGen :: Gen Company+-- makeCompanyGen = make @(Gen Company) registry

@@ -21,7 +21,7 @@     <: genFun Department     <: fun (listOf @Employee)     <: genFun Employee-    <: genVal genEmployeeStatus+    <: genFun genEmployeeStatus     <: fun (maybeOf @Int)     <: genVal genInt     <: genVal genText@@ -36,11 +36,11 @@ genEmployeeStatus = pure Permanent  -- this compiles ok now-makeCompanyGen :: GenIO Company-makeCompanyGen = make @(GenIO Company) registry+makeCompanyGen :: Gen Company+makeCompanyGen = make @(Gen Company) registry  forall :: forall a. (Typeable a, Show a) => PropertyT IO a-forall = withFrozenCallStack $ forAllT $ genWith @a registry+forall = withFrozenCallStack $ forAll $ genWith @a registry  test_company = test "make a company" $ do   _ <- forall @Company

@@ -19,7 +19,7 @@ registry3 = $(makeGenerators ''EmployeeStatus) <: registry  forall :: forall a. (Typeable a, Show a) => PropertyT IO a-forall = withFrozenCallStack $ forAllT $ genWith @a registry3+forall = withFrozenCallStack $ forAll $ genWith @a registry3  test_employee_status = prop "make an employee status" $ do   status <- forall @EmployeeStatus

@@ -16,13 +16,13 @@ import Test.Tutorial.Exercise3 (registry3)  registry12 :: Registry _ _-registry12 = specializeGen @Department genDepartmentName $ registry3+registry12 = specializeGen @Department genDepartmentName registry3  genDepartmentName :: Gen Text genDepartmentName = T.take 5 . T.toUpper <$> genText  forall :: forall a. (Typeable a, Show a) => PropertyT IO a-forall = withFrozenCallStack $ forAllT $ genWith @a registry12+forall = withFrozenCallStack $ forAll $ genWith @a registry12  test_deparment_name = prop "make a department" $ do   department <- forall @Department

@@ -16,24 +16,28 @@ import Test.Tutorial.Exercise3 (registry3) import Test.Tutorial.Exercise4 (genDepartmentName) -runGens = runS registry3+test_small_company = prop "make a small company" $ do+  company <- forallWith @Company (setSmallCompany . setEmployeeName . setDepartmentName)+  collect company  genEmployeeName :: Gen Text genEmployeeName = T.take 10 . T.toLower <$> genText -setDepartmentName = specializeGenS @Department genDepartmentName+setDepartmentName :: Registry _ _ -> Registry _ _+setDepartmentName = specializeGen @Department genDepartmentName -setEmployeeName = specializeGenS @Employee genEmployeeName+setEmployeeName :: Registry _ _ -> Registry _ _+setEmployeeName = specializeGen @Employee genEmployeeName -setOneDepartment = addFunS $ listOfMinMax @Department 1 1+setOneDepartment :: Registry _ _ -> Registry _ _+setOneDepartment = addFun (listOfMinMax @Department 1 1) -setOneEmployee = addFunS $ listOfMinMax @Employee 1 1+setOneEmployee :: Registry _ _ -> Registry _ _+setOneEmployee = addFun (listOfMinMax @Employee 1 1) -setSmallCompany = setOneEmployee >> setOneDepartment+setSmallCompany :: Registry _ _ -> Registry _ _+setSmallCompany = setOneEmployee . setOneDepartment -test_small_company = prop "make a small company" $-  runGens $ do-    setSmallCompany-    setEmployeeName-    setDepartmentName-    collect =<< forallS @Company+-- | Generate a value with a modified list of generators+forallWith :: forall a b c. (HasCallStack, Show a, Typeable a) => (Registry _ _ -> Registry b c) -> PropertyT IO a+forallWith f = withFrozenCallStack $ forAll $ genWith @a (f registry3)

@@ -1,28 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE PartialTypeSignatures #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}--module Test.Tutorial.Exercise6 where--import Data.Registry.Hedgehog-import Data.Text as T-import Hedgehog hiding (test)-import Protolude-import Test.Tasty.Hedgehogx-import Test.Tutorial.DataModel-import Test.Tutorial.Exercise5--test_another_small_company = prop "make a small company" $-  runGens $ do-    setSmallCompany-    setEmployeeName-    setDepartmentName-    setGenS @Int (pure 1)-    setDistinctForS @Department @Text--    collect =<< forallS @Company--    setCycleChooserS @EmployeeStatus-    collect =<< forallS @EmployeeStatus