packages feed

registry-hedgehog-aeson (empty) → 0.1.0.0

raw patch · 7 files changed

+335/−0 lines, 7 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, hedgehog, mmorph, multimap, protolude, registry, registry-hedgehog, registry-hedgehog-aeson, scientific, tasty, tasty-discover, tasty-hedgehog, tasty-th, template-haskell, text, transformers, universum, unordered-containers, vector

Files

+ LICENSE.txt view
@@ -0,0 +1,16 @@+Copyright (c) 2022 Eric Torreborre <etorreborre@yahoo.com>++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated+documentation files (the "Software"), to deal in the Software without restriction, including without limitation+the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software,+and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of+the Software. Neither the name of specs nor the names of its contributors may be used to endorse or promote+products derived from this software without specific prior written permission.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED+TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL+THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF+CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER+DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain
+ registry-hedgehog-aeson.cabal view
@@ -0,0 +1,139 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           registry-hedgehog-aeson+version:        0.1.0.0+synopsis:       Hedgehog generators for Aeson+description:    This library provides generators for Aeson values which can be easily customized.+category:       Test+maintainer:     etorreborre@yahoo.com+license:        MIT+license-file:   LICENSE.txt+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/etorreborre/registry-hedgehog-aeson++library+  exposed-modules:+      Data.Registry.Hedgehog.AesonGenerators+  other-modules:+      Paths_registry_hedgehog_aeson+  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+      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:+      aeson >=1.0 && <3+    , base >=4.7 && <5+    , containers >=0.2 && <1+    , hedgehog >=1.0 && <2+    , mmorph ==1.*+    , multimap ==1.*+    , protolude ==0.3.*+    , registry ==0.2.*+    , scientific ==0.3.*+    , tasty ==1.*+    , tasty-discover >=2 && <5+    , tasty-hedgehog >=1.0 && <2.0+    , tasty-th >=0.1 && <1+    , template-haskell >=2.13 && <3.0+    , text ==1.*+    , transformers >=0.5 && <2+    , universum ==1.*+    , unordered-containers >=0.1 && <1+    , vector >=0.1 && <1+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: test.hs+  other-modules:+      AutoDiscoveredSpecs+      Test.Data.Registry.Hedgehog.AesonGeneratorsSpec+      Paths_registry_hedgehog_aeson+  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+      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:+      aeson >=1.0 && <3+    , base >=4.7 && <5+    , containers >=0.2 && <1+    , hedgehog >=1.0 && <2+    , mmorph ==1.*+    , multimap ==1.*+    , protolude ==0.3.*+    , registry ==0.2.*+    , registry-hedgehog+    , registry-hedgehog-aeson+    , scientific ==0.3.*+    , tasty ==1.*+    , tasty-discover >=2 && <5+    , tasty-hedgehog >=1.0 && <2.0+    , tasty-th >=0.1 && <1+    , template-haskell >=2.13 && <3.0+    , text ==1.*+    , transformers >=0.5 && <2+    , universum ==1.*+    , unordered-containers >=0.1 && <1+    , vector >=0.1 && <1+  default-language: Haskell2010
+ src/Data/Registry/Hedgehog/AesonGenerators.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Data.Registry.Hedgehog.AesonGenerators where++import Data.Aeson+import Data.Registry+import Data.Registry.Internal.Types (Typed)+import Data.Scientific as Scientific hiding (normalize)+import Data.Vector as Vector (fromList)+import Hedgehog as H+import Hedgehog.Gen as Gen hiding (either)+import Hedgehog.Range as Range+import Protolude++-- | Generator for a default JSON value+genValue :: Gen Value+genValue = genValueFor simpleGens++-- | Generator for a JSON value with an adjusted set of generators+--   For example:+--    - change the recursive depth of the generation: genValueWith (setDepth 5)+--    - change the number of elements in an array or an object: genValueWith (setFieldsNb 5)+--    - use a custom text generator: genValueWith (setGen myTextGenerator)+--    - change the range used for generating numbers: genValueWith (setRange (linear @Int 0 20))+genValueWith :: (Registry _ _ -> Registry _ _) -> Gen Value+genValueWith f = genValueFor (f simpleGens)++-- | Specialized generator for a number value+genNumberValue :: Gen Value+genNumberValue = unTag <$> make @(Gen (Tag "Number" Value)) simpleGens++-- | Generate a JSON value with a given set of generators to be used when recursing+genValueFor :: Registry _ _ -> Gen Value+genValueFor gens =+  case make @Depth gens of+    -- if the depth is 0 generate a Value from the `Simple` Value generation+    0 -> make @(Gen Value) gens+    -- if the depth is > 0 generate possibly recursive values like arrays and objects+    _ -> make @(Gen Value) $ recursiveGens (decrementDepth gens)++-- | Set of generators for JSON values including recursive values like arrays and objects+--   In order to control the recursivity of the Value data type we produce several types+--   for JSON values using tags:+--     `Recurse Value` is a generated value to be used when generating an array or an object+--     `Simple Value` is a generated value that is either: a String, a Number, a Bool, a Null value+recursiveGens :: Registry _ _ -> Registry _ _+recursiveGens overrides =+  normalize $+    -- generator choosing between generated arrays, objects or simple values+    gen genRecursiveValue+      -- generator for objects+      <: gen genObject+      -- generator for arras+      <: gen genArray+      -- generator for field names (up to 3 by default)+      <: fun (listOf @Text 1 3)+      -- generator for the elements of arrays or objects (up to 3 by default)+      <: fun (listOf @(Tag "Recurse" Value) 1 3)+      -- generator for a JSON value to be used in an object or an array+      <: fun (tag <$> genValueFor overrides :: Gen (Tag "Recurse" Value))+      -- simple, non-recursive, generators+      <: overrides++-- | Set of generators for non-recursive JSON values+--   Those value are tagged as `Simple` but we can also extract a `Gen Value` from this list+simpleGens :: Registry _ _+simpleGens =+  gen untagSimpleValue+    <: gen genSimpleValue+    <: gen genNumber+    <: gen genString+    <: gen genText+    <: gen genBool+    <: gen genNull+    <: gen (linear 0 5 :: Range Int)+    <: gen (linear (-1000) 1000 :: Range Integer)+    <: val (Depth 3)++-- * Individual generators++genRecursiveValue :: Tag "Array" Value -> Tag "Object" Value -> Tag "Simple" Value -> Gen Value+genRecursiveValue arrayValue objectValue simpleValue = Gen.element [unTag arrayValue, unTag objectValue, unTag simpleValue]++untagSimpleValue :: Tag "Simple" Value -> Value+untagSimpleValue = unTag++genSimpleValue :: Tag "Null" Value -> Tag "Bool" Value -> Tag "Number" Value -> Tag "String" Value -> Gen (Tag "Simple" Value)+genSimpleValue nullValue boolValue numberValue stringValue =+  tag <$> Gen.element [unTag nullValue, unTag boolValue, unTag numberValue, unTag stringValue]++genNull :: Gen (Tag "Null" Value)+genNull = pure (tag Null)++genBool :: Gen (Tag "Bool" Value)+genBool = tag . Bool <$> Gen.bool++genText :: Range Int -> Gen Text+genText range = Gen.text range Gen.alphaNum++genString :: Text -> Tag "String" Value+genString = tag . String++genNumber :: Range Integer -> Gen (Tag "Number" Value)+genNumber range = fmap tag $ Number <$> (scientific <$> Gen.integral range <*> pure 0)++genArray :: [Tag "Recurse" Value] -> Tag "Array" Value+genArray = tag . Array . Vector.fromList . fmap unTag++genObject :: [Text] -> [Tag "Recurse" Value] -> Tag "Object" Value+genObject fields values = tag . object $ zip fields (unTag <$> values)++-- * SUPPORT FUNCTION++-- | Simplification for funTo @Gen when adding a new function to the registry+gen :: forall a b. (ApplyVariadic Gen a b, Typeable a, Typeable b) => a -> Typed b+gen = funTo @Gen++-- | set a specific generator on top of the list of generators+setGen :: (Typeable a) => Gen a -> Registry _ _ -> Registry _ _+setGen = addFun++-- | set a specific range on top of the list of generators+setRange :: (Typeable a) => Range a -> Registry _ _ -> Registry _ _+setRange = addFun++-- | Generate a list of min' to max' elements+listOf :: forall a. Int -> Int -> Gen a -> Gen [a]+listOf min' max' = Gen.list (linear min' max')++-- | Simplification for setting a new recursion depth on the registry+setDepth :: Depth -> Registry _ _ -> Registry _ _+setDepth d r = normalize $ val d +: r++-- | Decrement the depth of generation during recursion+decrementDepth :: Registry _ _ -> Registry _ _+decrementDepth = tweak (\(d :: Depth) -> d - 1)++-- | Simplification for setting the number of fields+setFieldsNb :: Int -> Registry _ _ -> Registry _ _+setFieldsNb n r = fun (listOf @Text 1 n) +: r++newtype Depth = Depth {unDepth :: Int}+  deriving newtype (Eq, Show, Num)
+ test/AutoDiscoveredSpecs.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover -optF --generated-module=AutoDiscoveredSpecs #-}
+ test/Test/Data/Registry/Hedgehog/AesonGeneratorsSpec.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}++module Test.Data.Registry.Hedgehog.AesonGeneratorsSpec where++import Protolude+import Test.Tasty.Hedgehogx++-- | Sanity check+test_json_simple_values = prop "generate simple json values" $ do+  -- uncomment to display the generated values+  -- values <- forAll (genValueWith (setDepth 0))+  -- collect values+  success++test_json_complex_values = prop "generate complex json values" $ do+  -- uncomment to display the generated values+  -- values <- forAll (genValueWith (setDepth 2))+  -- collect values+  success
+ test/test.hs view
@@ -0,0 +1,5 @@+import AutoDiscoveredSpecs (tests)+import Protolude+import Test.Tasty.Hedgehogx++main = tests >>= defaultMain . groupByModuleName