registry-hedgehog 0.7.0.5 → 0.7.1.0

raw patch · 7 files changed

+87/−69 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• registry-hedgehog.cabal +7/−39
• src/Data/Registry/Hedgehog.hs +27/−8
• src/Data/Registry/Hedgehog/TH.hs +16/−6
• src/Data/Registry/Internal/TH.hs +27/−13
• test/Test/Data/Registry/Generators.hs +1/−1
• test/Test/Tutorial/Exercise2.hs +1/−1
• test/Test/Tutorial/Exercise3.hs +8/−1

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.35.0. -- -- see: https://github.com/sol/hpack ----- hash: 7d0b0684f2ba9eb6cb838ca63d1f08de7ee191046c523b7d0ede13b888d63a06+-- hash: 6507ac5c7059bc022b2cad2faa557a32b1ed204586dcf512efe171e1e61d5a49  name:           registry-hedgehog-version:        0.7.0.5+version:        0.7.1.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@@ -33,33 +33,17 @@   hs-source-dirs:       src   default-extensions:-      BangPatterns       DefaultSignatures-      EmptyCase-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances       FunctionalDependencies       GADTs-      GeneralizedNewtypeDeriving-      InstanceSigs-      KindSignatures       LambdaCase-      MultiParamTypeClasses       MultiWayIf-      NamedFieldPuns       NoImplicitPrelude       OverloadedStrings       PatternSynonyms-      Rank2Types-      RankNTypes-      ScopedTypeVariables-      StandaloneDeriving-      TupleSections-      TypeApplications+      StrictData       TypeFamilies       TypeFamilyDependencies-      TypeOperators   ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -Wincomplete-uni-patterns   build-depends:       base >=4.14 && <5@@ -78,7 +62,7 @@     , transformers >=0.5 && <2     , universum ==1.*     , unordered-containers >=0.1 && <1-  default-language: Haskell2010+  default-language: GHC2021  test-suite spec   type: exitcode-stdio-1.0@@ -98,33 +82,17 @@   hs-source-dirs:       test   default-extensions:-      BangPatterns       DefaultSignatures-      EmptyCase-      ExistentialQuantification-      FlexibleContexts-      FlexibleInstances       FunctionalDependencies       GADTs-      GeneralizedNewtypeDeriving-      InstanceSigs-      KindSignatures       LambdaCase-      MultiParamTypeClasses       MultiWayIf-      NamedFieldPuns       NoImplicitPrelude       OverloadedStrings       PatternSynonyms-      Rank2Types-      RankNTypes-      ScopedTypeVariables-      StandaloneDeriving-      TupleSections-      TypeApplications+      StrictData       TypeFamilies       TypeFamilyDependencies-      TypeOperators   ghc-options: -Wall -Wcompat -Wincomplete-record-updates -fhide-source-paths -fprint-potential-instances -fno-warn-partial-type-signatures -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N -fno-warn-orphans -fno-warn-missing-signatures -fno-warn-incomplete-uni-patterns -fno-warn-type-defaults -optP-Wno-nonportable-include-path   build-depends:       base >=4.14 && <5@@ -144,4 +112,4 @@     , transformers >=0.5 && <2     , universum ==1.*     , unordered-containers >=0.1 && <1-  default-language: Haskell2010+  default-language: GHC2021

@@ -27,10 +27,14 @@     genNonEmptyMapOf,     genHashMapOf,     setDistinctPairOf,+    setDistinctPairOfOn,     setDistinctTripleOf,+    setDistinctTripleOfOn,     -- combinators to compose different types of generators     distinctPairOf,+    distinctPairOfOn,     distinctTripleOf,+    distinctTripleOfOn,     eitherOf,     hashMapOf,     listOf,@@ -61,7 +65,6 @@ import Data.Maybe as Maybe import Data.Registry import Data.Registry.Internal.Hedgehog-import Data.Registry.Internal.Types import Data.Set as Set (fromList) import Hedgehog import Hedgehog.Gen as Gen@@ -92,7 +95,7 @@ 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 :: forall (a :: Type) b ins out. (Typeable a, Typeable b) => Gen b -> Registry ins out -> Registry ins out specializeGen = specialize @(Gen a) @(Gen b)  -- | Add a generator for a list of elements@@ -147,17 +150,25 @@ setDistinctPairOf :: forall a. (Typeable a, Eq a) => Registry _ _ -> Registry _ _ setDistinctPairOf r = fun (distinctPairOf @a) +: r +-- | Add the generation of a pair of distinct elements, according to one of their part+setDistinctPairOfOn :: forall a b. (Typeable a, Eq b) => (a -> b) -> Registry _ _ -> Registry _ _+setDistinctPairOfOn f r = fun (distinctPairOfOn @a f) +: 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 +-- | Add the generation of a triple of distinct elements, according to one of their part+setDistinctTripleOfOn :: forall a b. (Typeable a, Eq b) => (a -> b) -> Registry _ _ -> Registry _ _+setDistinctTripleOfOn f r = fun (distinctTripleOfOn @a f) +: 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 =+makeNonEmpty :: forall (a :: Type) ins out. (Typeable a) => Registry ins out -> Registry ins out+makeNonEmpty r = do   -- 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 @(Gen [a]) (\genAs -> (:) <$> genA <*> genAs) r+  -- add that element in front of a list of generated elements+  tweak @(Gen [a]) (\genAs -> (:) <$> genA <*> genAs) r  -- * CONTAINERS COMBINATORS @@ -227,8 +238,16 @@  -- | 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+distinctPairOf = distinctPairOfOn identity +-- | Make a generator for a pair of distinct values according to one of their part+distinctPairOfOn :: forall a b. (Eq b) => (a -> b) -> Gen a -> Gen (a, a)+distinctPairOfOn f genA = Gen.filterT (\(a1, a2) -> f a1 /= f a2) $ (,) <$> genA <*> genA+ -- | 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+distinctTripleOf = distinctTripleOfOn identity++-- | Make a generator for a triple of distinct values according to one of their part+distinctTripleOfOn :: forall a b. (Eq b) => (a -> b) -> Gen a -> Gen (a, a, a)+distinctTripleOfOn f genA = Gen.filterT (\(a1, a2, a3) -> f a1 /= f a2 && f a2 /= f a3 && f a1 /= f a3) $ (,,) <$> genA <*> genA <*> genA

@@ -1,6 +1,10 @@ {-# LANGUAGE DataKinds #-} -module Data.Registry.Hedgehog.TH where+module Data.Registry.Hedgehog.TH+  ( GeneratorOptions (..),+    module Data.Registry.Hedgehog.TH,+  )+where  import Control.Monad.Fail (fail) import Data.Registry@@ -9,6 +13,12 @@ import Language.Haskell.TH.Syntax import Protolude +makeGenerators :: Name -> ExpQ+makeGenerators = makeGeneratorsWith defaultGeneratorOptions++makeGeneratorsUnchecked :: Name -> ExpQ+makeGeneratorsUnchecked = makeGeneratorsWith defaultGeneratorOptions {checked = False}+ -- | Make a registry containing generators for an ADT --   We  want to generate the following --@@ -18,20 +28,20 @@ -- -- 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+makeGeneratorsWith :: GeneratorOptions -> Name -> ExpQ+makeGeneratorsWith options genType = do   info <- reify genType   case info of     TyConI (NewtypeD _context _name _typeVars _kind constructor _deriving) -> do       constructorType <- nameOf constructor-      app (genFunOf (conE constructorType)) (varE (mkName "emptyRegistry"))+      genFunOf (conE constructorType)     TyConI (DataD _context _name _typeVars _kind [constructor] _deriving) -> do       constructorType <- nameOf constructor-      app (genFunOf (conE constructorType)) (varE (mkName "emptyRegistry"))+      genFunOf (conE constructorType)     TyConI (DataD _context name _typeVars _kind constructors _deriving) -> do       selector <- makeSelectGenerator name constructors       generators <- traverse makeConstructorGenerator constructors-      assembleGeneratorsToRegistry selector generators+      assembleGeneratorsToRegistry options selector generators     other -> do       qReport True ("can not create generators for this kind of data type at the moment. Got: " <> show other)       fail "generators creation failed"

@@ -13,6 +13,18 @@ import Protolude hiding (Type) import Prelude (last) +-- | Options for changing the generated TH code+--    if checked = True then we use the <: operator which checks input+--    otherwise we use the <+ operator which doesn't check inputs+newtype GeneratorOptions = GeneratorOptions+  { checked :: Bool+  }+  deriving (Eq, Show)++-- | By default we want to typecheck the generators+defaultGeneratorOptions :: GeneratorOptions+defaultGeneratorOptions = GeneratorOptions True+ -- | Create a generator for selecting between constructors of an ADT --   One parameter is a Gen Chooser in order to be able to later on --   switch the selection strategy@@ -82,20 +94,22 @@ -- | runQ [| fun g +: genFun e +: genFun f|] --   InfixE (Just (AppE (VarE Data.Registry.Registry.fun) (UnboundVarE g))) (VarE +:) (Just (InfixE (Just (AppE (VarE Data.Registry.Hedgehog.genFun) (UnboundVarE e))) --  (VarE Data.Registry.Registry.+:) (Just (AppE (VarE Data.Registry.Hedgehog.genFun) (UnboundVarE f)))))-assembleGeneratorsToRegistry :: Exp -> [Exp] -> ExpQ-assembleGeneratorsToRegistry _ [] =-  fail "generators creation failed"-assembleGeneratorsToRegistry selectorGenerator [g] =-  app (genFunOf (pure g)) $-    app (funOf (pure selectorGenerator)) $-      app (genFunOf (varE (mkName "choiceChooser"))) (varE (mkName "emptyRegistry"))----assembleGeneratorsToRegistry selectorGenerator (g : gs) =-  app (genFunOf (pure g)) (assembleGeneratorsToRegistry selectorGenerator gs)+assembleGeneratorsToRegistry :: GeneratorOptions -> Exp -> [Exp] -> ExpQ+assembleGeneratorsToRegistry options selectorGenerator generators =+  app options (funOf (pure selectorGenerator)) $+    app options (genFunOf (varE (mkName "choiceChooser"))) $+      go generators+  where+    go [] = fail "generators creation failed"+    go [g] = genFunOf (pure g)+    go (g:gs) =+      app options (genFunOf (pure g)) $+        go gs -app :: ExpQ -> ExpQ -> ExpQ-app e1 e2 =-  infixE (Just e1) (varE (mkName "+:")) (Just e2)+app :: GeneratorOptions -> ExpQ -> ExpQ -> ExpQ+app options e1 e2 = do+  let op = if checked options then "<:" else "<+"+  infixE (Just e1) (varE (mkName op)) (Just e2)  genFunOf :: ExpQ -> ExpQ genFunOf = appE (varE (mkName "genFun"))

@@ -26,7 +26,7 @@     <: $(makeGenerators ''EmployeeStatus)     <: $(makeGenerators ''DepartmentName)     <: $(makeGenerators ''EmployeeName)-    <: fun (maybeOf @Int)+    <: genMaybeOf @Int     -- we can generate Lists or Maybe of elements     <: genVal genInt     <: genVal genText

@@ -22,7 +22,7 @@     <: fun (listOf @Employee)     <: genFun Employee     <: genFun genEmployeeStatus-    <: fun (maybeOf @Int)+    <: genMaybeOf @Int     <: genVal genInt     <: genVal genText 

@@ -16,7 +16,14 @@ import Test.Tutorial.Exercise2 (registry)  registry3 :: Registry _ _-registry3 = $(makeGenerators ''EmployeeStatus) <: registry+registry3 =+  $(makeGenerators ''EmployeeStatus)+    <: registry++registry3Unchecked :: Registry _ _+registry3Unchecked =+  $(makeGeneratorsUnchecked ''EmployeeStatus)+    <: registry  forall :: forall a. (Typeable a, Show a) => PropertyT IO a forall = withFrozenCallStack $ forAll $ genWith @a registry3