hedgehog-gen-json 0.0.0 → 0.1.0

raw patch · 11 files changed

+904/−109 lines, 11 filesdep +containersdep +exceptionsdep +regex-genexdep −hjsonschemaPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, exceptions, regex-genex, regex-posix, text, unordered-containers

Dependencies removed: hjsonschema

API changes (from Hackage documentation)

Files

• README.md +5/−2
• hedgehog-gen-json.cabal +27/−4
• src/Hedgehog/Gen/JSON.hs +51/−76
• src/Hedgehog/Gen/JSON/Constrained.hs +121/−0
• src/Hedgehog/Gen/JSON/Constrained/Internal.hs +137/−0
• src/Hedgehog/Gen/JSON/JSONSchema.hs +182/−0
• src/Hedgehog/Gen/JSON/Ranges.hs +36/−0
• src/Hedgehog/Gen/JSON/Unconstrained.hs +47/−0
• test/Hedgehog/Gen/JSON/Constrained/Internal/InternalSpec.hs +103/−0
• test/Hedgehog/Gen/JSON/JSONSpec.hs +187/−0
• test/Spec.hs +8/−27

@@ -1,2 +1,5 @@-# haskell-hedgehog-gen-json-JSON Gen for Hedgehog+[![Build Status](https://travis-ci.org/amrhassan/haskell-hedgehog-gen-json.svg?branch=master)](https://travis-ci.org/amrhassan/haskell-hedgehog-gen-json)+[![Hackage version](https://img.shields.io/hackage/v/hedgehog-gen-json.svg?label=Hackage)](https://hackage.haskell.org/package/hedgehog-gen-json)+[![Stackage version](https://www.stackage.org/package/hedgehog-gen-json/badge/lts?label=Stackage)](https://www.stackage.org/package/hedgehog-gen-json)++JSON generators for [Hedgehog](https://github.com/hedgehogqa).

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: aaf5869b8143146c3771604d497a1884654598a47bc908828bf2563742f29117+-- hash: 19509d71ae99a04870b3c2924858c720249638f0ff47c4c07a0545c172c51681  name:           hedgehog-gen-json-version:        0.0.0+version:        0.1.0 synopsis:       JSON generators for Hedgehog description:    Generate JSON values for Hedgehog tests category:       Test@@ -24,19 +24,29 @@ library   hs-source-dirs:       src+  ghc-options: -Wall   build-depends:       aeson     , base >=4.7 && <5     , bytestring+    , containers+    , exceptions     , hedgehog-    , hjsonschema     , lens     , protolude+    , regex-genex     , scientific+    , text+    , unordered-containers     , vector   exposed-modules:       Hedgehog.Gen.JSON   other-modules:+      Hedgehog.Gen.JSON.Constrained+      Hedgehog.Gen.JSON.Constrained.Internal+      Hedgehog.Gen.JSON.JSONSchema+      Hedgehog.Gen.JSON.Ranges+      Hedgehog.Gen.JSON.Unconstrained       Paths_hedgehog_gen_json   default-language: Haskell2010 @@ -46,19 +56,32 @@   hs-source-dirs:       src       test+  ghc-options: -Wall   build-depends:       aeson     , base >=4.7 && <5     , bytestring+    , containers+    , exceptions     , hedgehog-    , hjsonschema     , lens     , protolude+    , regex-genex+    , regex-posix     , scientific     , tasty     , tasty-hedgehog+    , text+    , unordered-containers     , vector   other-modules:       Hedgehog.Gen.JSON+      Hedgehog.Gen.JSON.Constrained+      Hedgehog.Gen.JSON.Constrained.Internal+      Hedgehog.Gen.JSON.JSONSchema+      Hedgehog.Gen.JSON.Ranges+      Hedgehog.Gen.JSON.Unconstrained+      Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec+      Hedgehog.Gen.JSON.JSONSpec       Paths_hedgehog_gen_json   default-language: Haskell2010

@@ -1,97 +1,72 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE NoImplicitPrelude    #-}+{-# LANGUAGE TypeSynonymInstances #-}  module Hedgehog.Gen.JSON   ( genJSON+  , genJSONValue+  , genConstrainedJSON+  , genConstrainedJSONValue+  , Schema+  , readSchema   , Ranges(..)   , NumberRange(..)   , StringRange(..)   , ArrayRange(..)   , ObjectRange(..)+  , sensibleRanges   ) where -import           Control.Lens-import qualified Data.Aeson           as A-import qualified Data.ByteString      as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Scientific      as Scientific-import qualified Data.Vector          as Vector+import           Control.Monad.Catch             (MonadThrow, throwM)+import qualified Data.Aeson                      as Aeson+import qualified Data.ByteString                 as BS+import qualified Data.ByteString.Lazy            as LBS+import qualified Data.Text                       as Text import           Hedgehog-import qualified Hedgehog.Gen         as Gen-import qualified JSONSchema.Draft4    as D4+import qualified Hedgehog.Gen.JSON.Constrained   as Constrained+import           Hedgehog.Gen.JSON.JSONSchema    (Schema)+import           Hedgehog.Gen.JSON.Ranges+import qualified Hedgehog.Gen.JSON.Unconstrained as Unconstrained+import qualified Hedgehog.Range                  as Range import           Protolude -newtype NumberRange = NumberRange-  { unNumberRange :: Range Double-  }--newtype StringRange = StringRange-  { unStringRange :: Range Int-  }--newtype ArrayRange = ArrayRange-  { unArrayRange :: Range Int-  }--newtype ObjectRange = ObjectRange-  { unObjectRange :: Range Int-  }--data Ranges = Ranges-  { _numberRange :: NumberRange-  , _stringRange :: StringRange-  , _arrayRange  :: ArrayRange-  , _objectRange :: ObjectRange-  }--makeLenses ''Ranges--readSchema :: FilePath -> IO (Either Text D4.Schema)+-- | Reads a JSON Schema from a filepath+readSchema :: (MonadIO m, MonadThrow m) => FilePath -> m Schema readSchema fp = do-  bytes <- BS.readFile fp-  pure $ maybeToEither "failed to decode JSON Schema" (A.decodeStrict bytes)--genNull :: Gen A.Value-genNull = pure A.Null+  bytes <- liftIO $ BS.readFile fp+  case Aeson.eitherDecodeStrict bytes of+    Left err     -> throwM $ DecodingSchemaException $ Text.pack err+    Right schema -> pure schema -genString :: StringRange -> Gen A.Value-genString sr = A.String <$> Gen.text (unStringRange sr) Gen.unicode+-- | Generator for arbitrary unconstrained JSON values encoded as UTF-8+genJSON :: Ranges -> Gen ByteString+genJSON ranges = (LBS.toStrict . Aeson.encode) <$> genJSONValue ranges -genBool :: Gen A.Value-genBool = A.Bool <$> Gen.bool+-- | Generator for arbitrary unconstrained JSON values+genJSONValue :: Ranges -> Gen Aeson.Value+genJSONValue = Unconstrained.genValue -genNumber :: NumberRange -> Gen A.Value-genNumber nr = (A.Number . Scientific.fromFloatDigits) <$> Gen.double (unNumberRange nr)+-- | Generator for arbitrary JSON values constrained by the given JSON Schema and encoded as UTF-8+genConstrainedJSON :: Ranges -> Schema -> Gen ByteString+genConstrainedJSON ranges schema = (LBS.toStrict . Aeson.encode) <$> genConstrainedJSONValue ranges schema -genArray :: Ranges -> Gen A.Value-genArray ranges = do-  let gen =-        Gen.recursive-          Gen.choice-          [genBool, genNumber (ranges ^. numberRange), genString (ranges ^. stringRange)]-          [genArray ranges, genObj ranges]-  (A.Array . Vector.fromList) <$> Gen.list (unArrayRange (ranges ^. arrayRange)) gen+-- | Generator for arbitrary JSON values constrained by the given JSON Schema+genConstrainedJSONValue :: Ranges -> Schema -> Gen Aeson.Value+genConstrainedJSONValue = Constrained.genValue -genObj :: Ranges -> Gen A.Value-genObj ranges =-  A.object <$>-  Gen.list-    (unArrayRange (ranges ^. arrayRange))-    ((,) <$> Gen.text (unStringRange (ranges ^. stringRange)) Gen.unicode <*> genValue ranges)+-- | Sensible ranges for arbitrary JSON values if you're too lazy to define some+sensibleRanges :: Ranges+sensibleRanges =+  Ranges+  { _arrayRange = ArrayRange $ Range.linear 0 5+  , _stringRange = StringRange $ Range.linear 0 1000+  , _numberRange = NumberRange $ Range.linearFrac (-1000) 1000+  , _integerRange = IntegerRange $ Range.linear (-1000) 1000+  , _objectRange = ObjectRange $ Range.linear 0 5+  } -genValue :: Ranges -> Gen A.Value-genValue ranges =-  Gen.choice-    [ genNull-    , genString (ranges ^. stringRange)-    , genBool-    , genNumber (ranges ^. numberRange)-    , genArray ranges-    , genObj ranges-    ]+newtype JSONException =+  DecodingSchemaException Text+  deriving (Show, Eq) -genJSON :: Ranges -> Gen ByteString-genJSON ranges = (LBS.toStrict . A.encode) <$> genValue ranges---genFakeJson :: D4.Schema -> Gen Value---genFakeJson = undefined+instance Exception JSONException

@@ -0,0 +1,121 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Gen.JSON.Constrained+  ( genValue+  , Schema+  ) where++import           Control.Lens+import qualified Data.Aeson                             as Aeson+import qualified Data.HashMap.Strict                    as HashMap+import qualified Data.Scientific                        as Scientific+import qualified Data.Vector                            as Vector+import           Hedgehog+import qualified Hedgehog.Gen                           as Gen+import           Hedgehog.Gen.JSON.Constrained.Internal+import           Hedgehog.Gen.JSON.JSONSchema+import           Hedgehog.Gen.JSON.Ranges+import qualified Hedgehog.Gen.JSON.Unconstrained        as Unconstrained+import qualified Hedgehog.Range                         as Range+import           Protolude++genValue :: Ranges -> Schema -> Gen Aeson.Value+genValue ranges schema+  | isJust (schema ^. schemaEnum) =+    case schema ^. schemaEnum of+      Just (AnyConstraintEnum vs) -> (Gen.element . toList) vs+      Nothing                     -> empty+  | isJust (schema ^. schemaConst) =+    case schema ^. schemaConst of+      Just (AnyConstraintConst c) -> pure c+      Nothing                     -> empty+  | otherwise =+    case schema ^. schemaType of+      Nothing -> Unconstrained.genValue ranges+      Just (MultipleTypes (t :| [])) -> genValue ranges (set schemaType (Just $ SingleType t) schema)+      Just (MultipleTypes (t :| [t'])) ->+        Gen.choice+          [ genValue ranges (set schemaType (Just $ SingleType t) schema)+          , genValue ranges (set schemaType (Just $ SingleType t') schema)+          ]+      Just (MultipleTypes (t :| (t':ts))) ->+        Gen.choice+          [ genValue ranges (set schemaType (Just $ SingleType t) schema)+          , genValue ranges (set schemaType (Just $ MultipleTypes (t' :| ts)) schema)+          ]+      Just (SingleType NullType) -> genNullValue+      Just (SingleType BooleanType) -> genBooleanValue+      Just (SingleType NumberType) -> genNumberValue (ranges ^. numberRange) schema+      Just (SingleType IntegerType) -> genIntegerValue (ranges ^. integerRange) schema+      Just (SingleType StringType) -> genStringValue (ranges ^. stringRange) schema+      Just (SingleType ObjectType) -> genObjectValue ranges schema+      Just (SingleType ArrayType) -> genArrayValue ranges schema++genNullValue :: Gen Aeson.Value+genNullValue = Gen.constant Aeson.Null++genBooleanValue :: Gen Aeson.Value+genBooleanValue = Aeson.Bool <$> Gen.bool++genNumberValue :: NumberRange -> Schema -> Gen Aeson.Value+genNumberValue (NumberRange nr) schema =+  (Aeson.Number . Scientific.fromFloatDigits) <$>+  genBoundedReal+    (schema ^. schemaExclusiveMinimum)+    (schema ^. schemaMinimum)+    (schema ^. schemaExclusiveMaximum)+    (schema ^. schemaMaximum)+    nr++genIntegerValue :: IntegerRange -> Schema -> Gen Aeson.Value+genIntegerValue (IntegerRange nr) schema =+  (Aeson.Number . fromInteger) <$>+  genBoundedInteger+    (schema ^. schemaExclusiveMinimum)+    (schema ^. schemaMinimum)+    (schema ^. schemaExclusiveMaximum)+    (schema ^. schemaMaximum)+    (schema ^. schemaMultipleOf)+    nr++genStringValue :: StringRange -> Schema -> Gen Aeson.Value+genStringValue (StringRange sr) schema =+  case schema ^. schemaPattern of+    Just (StringConstraintPattern regexp) -> Aeson.String <$> genStringFromRegexp regexp+    Nothing -> Aeson.String <$> genBoundedString (schema ^. schemaMinLength) (schema ^. schemaMaxLength) sr++genObjectValue :: Ranges -> Schema -> Gen Aeson.Value+genObjectValue ranges schema = (Aeson.Object . HashMap.fromList . join) <$> generatedFields+  where+    generatedFields = traverse (\(n, gen) -> (\m -> (\v -> (n, v)) <$> (maybeToList m)) <$> gen) generatedFieldsMaybes+    generatedFieldsMaybes =+      (\(n, s) ->+         ( n+         , (if n `elem` required+              then fmap Just+              else Gen.maybe)+             (Gen.small $ genValue ranges s))) <$>+      HashMap.toList properties+    required = maybe [] unObjectConstraintRequired (schema ^. schemaRequired)+    properties = maybe HashMap.empty unObjectConstraintProperties (schema ^. schemaProperties)++genArrayValue :: Ranges -> Schema -> Gen Aeson.Value+genArrayValue ranges schema =+  case unArrayConstraintItems <$> (schema ^. schemaItems) of+    Just itemSchema ->+      Gen.sized $ \sz ->+        (Aeson.Array . Vector.fromList) <$>+        let listMaker =+              if uniqueItems+                then genUniqueItems+                else Gen.list+        in listMaker (finalRange sz) (Gen.small $ genValue ranges itemSchema)+    Nothing -> Unconstrained.genArray ranges+  where+    ar = unArrayRange (ranges ^. arrayRange)+    finalRange sz =+      Range.linear (fromMaybe (Range.lowerBound sz ar) minItems) (fromMaybe (Range.upperBound sz ar) maxItems)+    uniqueItems = maybe False unArrayConstraintUniqueItems (schema ^. schemaUniqueItems)+    maxItems = unArrayConstraintMaxItems <$> (schema ^. schemaMaxItems)+    minItems = unArrayConstraintMinItems <$> (schema ^. schemaMinItems)

@@ -0,0 +1,137 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Gen.JSON.Constrained.Internal+  ( genBoundedInteger+  , genBoundedReal+  , genBoundedString+  , genStringFromRegexp+  , genUniqueItems+  , filterAll+  , filterAllMaybe+  ) where++import qualified Data.HashSet                 as HashSet+import           Data.Scientific              (Scientific)+import qualified Data.Scientific              as Scientific+import qualified Data.Text                    as Text+import           Hedgehog+import qualified Hedgehog.Gen                 as Gen+import           Hedgehog.Gen.JSON.JSONSchema+import qualified Hedgehog.Range               as Range+import           Protolude+import qualified Regex.Genex                  as Genex++-- | Generates an Integer bounded by the given constraints or by the given range, as well as a multiple-of constraint.+genBoundedInteger ::+     Maybe NumberConstraintExclusiveMinimum+  -> Maybe NumberConstraintMinimum+  -> Maybe NumberConstraintExclusiveMaximum+  -> Maybe NumberConstraintMaximum+  -> Maybe NumberConstraintMultipleOf+  -> Range Integer+  -> Gen Integer+genBoundedInteger cminEx cmin cmaxEx cmax cmult range =+  Gen.sized $ \sz -> filterAllMaybe filters $ Gen.integral (finalRange sz)+  where+    filters = [minExFilter, maxExFilter, minFilter, maxFilter, multipleOfFilter]+    minExFilter = ((\b -> (> b)) . truncateScientific . unNumberConstraintExclusiveMinimum) <$> cminEx+    minFilter = ((\b -> (>= b)) . truncateScientific . unNumberConstraintMinimum) <$> cmin+    maxExFilter = ((\b -> (< b)) . truncateScientific . unNumberConstraintExclusiveMaximum) <$> cmaxEx+    maxFilter = ((\b -> (<= b)) . truncateScientific . unNumberConstraintMaximum) <$> cmax+    multipleOfFilter = ((\m x -> (x `rem` m == 0)) . truncateScientific . unNumberConstraintMultipleOf) <$> cmult+    finalRange sz = Range.linear (minB sz) (maxB sz)+    minB sz =+      fromMaybe+        (Range.lowerBound sz range)+        ((maximumMay . catMaybes)+           [ (truncateScientific . unNumberConstraintMinimum) <$> cmin+           , (truncateScientific . unNumberConstraintExclusiveMinimum) <$> cminEx+           ])+    maxB sz =+      fromMaybe+        (Range.lowerBound sz range)+        ((minimumMay . catMaybes)+           [ (truncateScientific . unNumberConstraintMaximum) <$> cmax+           , (truncateScientific . unNumberConstraintExclusiveMaximum) <$> cmaxEx+           ])++-- | Generates a Double bounded by the given constraints or by the given range.+genBoundedReal ::+     Maybe NumberConstraintExclusiveMinimum+  -> Maybe NumberConstraintMinimum+  -> Maybe NumberConstraintExclusiveMaximum+  -> Maybe NumberConstraintMaximum+  -> Range Double+  -> Gen Double+genBoundedReal cminEx cmin cmaxEx cmax range = Gen.sized $ \sz -> filterAllMaybe filters $ Gen.realFloat (finalRange sz)+  where+    filters = [minExFilter, maxExFilter, minFilter, maxFilter]+    minExFilter = ((\b -> (> b)) . Scientific.toRealFloat . unNumberConstraintExclusiveMinimum) <$> cminEx+    minFilter = ((\b -> (>= b)) . Scientific.toRealFloat . unNumberConstraintMinimum) <$> cmin+    maxExFilter = ((\b -> (< b)) . Scientific.toRealFloat . unNumberConstraintExclusiveMaximum) <$> cmaxEx+    maxFilter = ((\b -> (<= b)) . Scientific.toRealFloat . unNumberConstraintMaximum) <$> cmax+    finalRange sz = Range.linearFrac (minB sz) (maxB sz)+    minB sz =+      fromMaybe+        (Range.lowerBound sz range)+        ((maximumMay . catMaybes)+           [ (Scientific.toRealFloat . unNumberConstraintMinimum) <$> cmin+           , (Scientific.toRealFloat . unNumberConstraintExclusiveMinimum) <$> cminEx+           ])+    maxB sz =+      fromMaybe+        (Range.lowerBound sz range)+        ((minimumMay . catMaybes)+           [ (Scientific.toRealFloat . unNumberConstraintMaximum) <$> cmax+           , (Scientific.toRealFloat . unNumberConstraintExclusiveMaximum) <$> cmaxEx+           ])++-- | Generates a Text bounded in size by the given constraints or by the given range.+genBoundedString :: Maybe StringConstraintMinLength -> Maybe StringConstraintMaxLength -> Range Int -> Gen Text+genBoundedString minLengthC maxLengthC range =+  Gen.sized $ \size -> filterAllMaybe filters $ Gen.text (Range.linear (minB size) (maxB size)) Gen.unicode+  where+    minB sz = maybe (Range.lowerBound sz range) unStringConstraintMinLength minLengthC+    maxB sz = maybe (Range.upperBound sz range) unStringConstraintMaxLength maxLengthC+    filters =+      [ ((\b t -> Text.length t >= b) . unStringConstraintMinLength) <$> minLengthC+      , ((\b t -> Text.length t <= b) . unStringConstraintMaxLength) <$> maxLengthC+      ]++-- | Generates a Text from a given Regular Expression+genStringFromRegexp :: Text -> Gen Text+genStringFromRegexp regexp = Gen.element $ Text.pack <$> take 10 (Genex.genexPure [Text.unpack regexp])++-- | Generates unique lists of the given generator and a size range+genUniqueItems :: (Hashable a, Eq a) => Range Int -> Gen a -> Gen [a]+genUniqueItems = genUniqueItems' 100 []++-- Gives up after 100 trials+genUniqueItems' :: (Hashable a, Eq a) => Int -> [a] -> Range Int -> Gen a -> Gen [a]+genUniqueItems' s acc range gen+  | s == 0 = Gen.discard+  | otherwise =+    Gen.sized $ \size -> do+      initialList <- (makeListUnique . (++ acc)) <$> Gen.list range gen+      let l = length initialList+      if Range.lowerBound size range <= l+        then pure initialList+        else take (Range.upperBound size range) <$> genUniqueItems' (s - 1) initialList range gen++-- | Filters out values that do not satisfy all the given predicates each+filterAll :: [a -> Bool] -> Gen a -> Gen a+filterAll filters = Gen.filter (\e -> and (($ e) <$> filters))++-- | Filters out values that do not satisfy all the given not-Nothing predicates+filterAllMaybe :: [Maybe (a -> Bool)] -> Gen a -> Gen a+filterAllMaybe filters = filterAll (catMaybes filters)++--- Helpers ----+truncateScientific :: Integral a => Scientific -> a+truncateScientific x = truncate real+  where+    real :: Double = Scientific.toRealFloat x++makeListUnique :: (Eq a, Hashable a) => [a] -> [a]+makeListUnique = toList . HashSet.fromList

@@ -0,0 +1,182 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE StrictData                 #-}+{-# LANGUAGE TemplateHaskell            #-}++module Hedgehog.Gen.JSON.JSONSchema where++import           Control.Lens        (makeLenses)+import           Control.Monad.Fail+import           Data.Aeson          (withObject, (.:?))+import qualified Data.Aeson          as Aeson+import qualified Data.ByteString     as BS+import qualified Data.HashMap.Strict as HM+import qualified Data.List.NonEmpty  as NonEmpty+import           Data.Scientific     (Scientific)+import qualified Data.Text           as Text+import           Protolude++data PrimitiveType+  = NullType+  | BooleanType+  | ObjectType+  | ArrayType+  | NumberType+  | StringType+  | IntegerType+  deriving (Show, Eq, Ord, Enum, Bounded)++instance Aeson.FromJSON PrimitiveType where+  parseJSON (Aeson.String t) =+    case Text.toLower t of+      "null" -> pure NullType+      "bool" -> pure BooleanType+      "array" -> pure ArrayType+      "integer" -> pure IntegerType+      "number" -> pure NumberType+      "string" -> pure StringType+      "object" -> pure ObjectType+      _ -> fail "Primitive type is not one of (null, bool, array, number, string)"+  parseJSON _ = fail "type is not a JSON String"++data AnyConstraintType+  = SingleType PrimitiveType+  | MultipleTypes (NonEmpty PrimitiveType)+  deriving (Eq, Show)++instance Aeson.FromJSON AnyConstraintType where+  parseJSON str@(Aeson.String _) = SingleType <$> Aeson.parseJSON str+  parseJSON (Aeson.Array ts) = (MultipleTypes . NonEmpty.fromList . toList) <$> traverse Aeson.parseJSON ts+  parseJSON _ = fail "type must be either a string or an array of strings"++newtype AnyConstraintEnum = AnyConstraintEnum+  { unArrayConstraintEnum :: NonEmpty Aeson.Value+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype AnyConstraintConst = AnyConstraintConst+  { unArrayConstraintConst :: Aeson.Value+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype NumberConstraintMultipleOf = NumberConstraintMultipleOf+  { unNumberConstraintMultipleOf :: Scientific+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype NumberConstraintMaximum = NumberConstraintMaximum+  { unNumberConstraintMaximum :: Scientific+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype NumberConstraintExclusiveMaximum = NumberConstraintExclusiveMaximum+  { unNumberConstraintExclusiveMaximum :: Scientific+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype NumberConstraintMinimum = NumberConstraintMinimum+  { unNumberConstraintMinimum :: Scientific+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype NumberConstraintExclusiveMinimum = NumberConstraintExclusiveMinimum+  { unNumberConstraintExclusiveMinimum :: Scientific+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype StringConstraintPattern = StringConstraintPattern+  { unStringConstraintPattern :: Text+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype StringConstraintMaxLength = StringConstraintMaxLength+  { unStringConstraintMaxLength :: Int+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype StringConstraintMinLength = StringConstraintMinLength+  { unStringConstraintMinLength :: Int+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++instance Aeson.FromJSON Schema where+  parseJSON =+    withObject "Schema" $ \obj ->+      Schema <$> obj .:? "type" <*> obj .:? "enum" <*> obj .:? "const" <*> obj .:? "properties" <*> obj .:? "required" <*>+      obj .:? "multipleOf" <*>+      obj .:? "maximum" <*>+      obj .:? "exclusiveMaximum" <*>+      obj .:? "minimum" <*>+      obj .:? "exclusiveMinimum" <*>+      obj .:? "pattern" <*>+      obj .:? "maxLength" <*>+      obj .:? "minLength" <*>+      obj .:? "items" <*>+      obj .:? "maxItems" <*>+      obj .:? "minItems" <*>+      obj .:? "uniqueItems"++newtype ObjectConstraintProperties = ObjectConstraintProperties+  { unObjectConstraintProperties :: HM.HashMap Text Schema+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype ObjectConstraintRequired = ObjectConstraintRequired+  { unObjectConstraintRequired :: [Text]+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype ArrayConstraintItems = ArrayConstraintItems+  { unArrayConstraintItems :: Schema+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype ArrayConstraintMaxItems = ArrayConstraintMaxItems+  { unArrayConstraintMaxItems :: Int+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype ArrayConstraintMinItems = ArrayConstraintMinItems+  { unArrayConstraintMinItems :: Int+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++newtype ArrayConstraintUniqueItems = ArrayConstraintUniqueItems+  { unArrayConstraintUniqueItems :: Bool+  } deriving (Generic, Eq, Show, Aeson.FromJSON)++data Schema = Schema+  { _schemaType             :: Maybe AnyConstraintType+  , _schemaEnum             :: Maybe AnyConstraintEnum+  , _schemaConst            :: Maybe AnyConstraintConst+  , _schemaProperties       :: Maybe ObjectConstraintProperties+  , _schemaRequired         :: Maybe ObjectConstraintRequired+  , _schemaMultipleOf       :: Maybe NumberConstraintMultipleOf+  , _schemaMaximum          :: Maybe NumberConstraintMaximum+  , _schemaExclusiveMaximum :: Maybe NumberConstraintExclusiveMaximum+  , _schemaMinimum          :: Maybe NumberConstraintMinimum+  , _schemaExclusiveMinimum :: Maybe NumberConstraintExclusiveMinimum+  , _schemaPattern          :: Maybe StringConstraintPattern+  , _schemaMaxLength        :: Maybe StringConstraintMaxLength+  , _schemaMinLength        :: Maybe StringConstraintMinLength+  , _schemaItems            :: Maybe ArrayConstraintItems+  , _schemaMaxItems         :: Maybe ArrayConstraintMaxItems+  , _schemaMinItems         :: Maybe ArrayConstraintMinItems+  , _schemaUniqueItems      :: Maybe ArrayConstraintUniqueItems+  } deriving (Generic, Eq, Show)++emptySchema :: Schema+emptySchema =+  Schema+  { _schemaType = Nothing+  , _schemaEnum = Nothing+  , _schemaConst = Nothing+  , _schemaRequired = Nothing+  , _schemaProperties = Nothing+  , _schemaMultipleOf = Nothing+  , _schemaMaximum = Nothing+  , _schemaMinimum = Nothing+  , _schemaExclusiveMaximum = Nothing+  , _schemaExclusiveMinimum = Nothing+  , _schemaPattern = Nothing+  , _schemaMinLength = Nothing+  , _schemaMaxLength = Nothing+  , _schemaItems = Nothing+  , _schemaMinItems = Nothing+  , _schemaMaxItems = Nothing+  , _schemaUniqueItems = Nothing+  }++makeLenses ''Schema++read :: FilePath -> IO (Either Text Schema)+read fp = do+  bytes <- BS.readFile fp+  pure $ maybeToEither "failed to decode JSON Schema" (Aeson.decodeStrict bytes)

@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell #-}++module Hedgehog.Gen.JSON.Ranges where++import           Control.Lens+import           Hedgehog++newtype NumberRange = NumberRange+  { unNumberRange :: Range Double+  }++newtype IntegerRange = IntegerRange+  { unIntegerRange :: Range Integer+  }++newtype StringRange = StringRange+  { unStringRange :: Range Int+  }++newtype ArrayRange = ArrayRange+  { unArrayRange :: Range Int+  }++newtype ObjectRange = ObjectRange+  { unObjectRange :: Range Int+  }++data Ranges = Ranges+  { _numberRange  :: NumberRange+  , _integerRange :: IntegerRange+  , _stringRange  :: StringRange+  , _arrayRange   :: ArrayRange+  , _objectRange  :: ObjectRange+  }++makeLenses ''Ranges

@@ -0,0 +1,47 @@+module Hedgehog.Gen.JSON.Unconstrained where++import           Control.Lens+import qualified Data.Aeson               as A+import qualified Data.Scientific          as Scientific+import qualified Data.Vector              as Vector+import           Hedgehog+import qualified Hedgehog.Gen             as Gen+import           Hedgehog.Gen.JSON.Ranges++genNull :: Gen A.Value+genNull = pure A.Null++genStringValue :: StringRange -> Gen A.Value+genStringValue (StringRange sr) = A.String <$> Gen.text sr Gen.unicode++genBool :: Gen A.Value+genBool = A.Bool <$> Gen.bool++genNumber :: NumberRange -> Gen A.Value+genNumber (NumberRange nr) = (A.Number . Scientific.fromFloatDigits) <$> Gen.double nr++genArray :: Ranges -> Gen A.Value+genArray ranges = do+  let gen = Gen.recursive Gen.choice [genBool, genNumber nr, genStringValue sr] [genArray ranges, genObj ranges]+  (A.Array . Vector.fromList) <$> Gen.list ar gen+  where+    nr = ranges ^. numberRange+    sr = ranges ^. stringRange+    ArrayRange ar = ranges ^. arrayRange++genObj :: Ranges -> Gen A.Value+genObj ranges = A.object <$> Gen.list ar ((,) <$> Gen.text sr Gen.unicode <*> genValue ranges)+  where+    (StringRange sr) = ranges ^. stringRange+    (ArrayRange ar) = ranges ^. arrayRange++genValue :: Ranges -> Gen A.Value+genValue ranges =+  Gen.choice+    [ genNull+    , genStringValue (ranges ^. stringRange)+    , genBool+    , genNumber (ranges ^. numberRange)+    , genArray ranges+    , genObj ranges+    ]

@@ -0,0 +1,103 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec+  ( tests+  ) where++import qualified Data.HashSet                           as HashSet+import qualified Data.Scientific                        as Scientific+import qualified Data.Text                              as Text+import           Hedgehog+import qualified Hedgehog.Gen                           as Gen+import           Hedgehog.Gen.JSON.Constrained.Internal+import           Hedgehog.Gen.JSON.JSONSchema+import qualified Hedgehog.Range                         as Range+import           Protolude+import           Test.Tasty+import           Test.Tasty.Hedgehog+import           Text.Regex.Posix++prop_genBoundedInteger :: Property+prop_genBoundedInteger =+  property $ do+    minC <- forAll $ Gen.maybe $ Gen.integral (Range.linear (-500) 500)+    maxC <- forAll $ Gen.maybe $ Gen.integral (Range.linear 500 1500)+    minExC <- forAll $ Gen.maybe $ Gen.integral (Range.linear (-500) 500)+    maxExC <- forAll $ Gen.maybe $ Gen.integral (Range.linear 500 1500)+    multC <- forAll $ Gen.maybe $ Gen.integral (Range.linear 1 10)+    v <-+      forAll $+      genBoundedInteger+        ((NumberConstraintExclusiveMinimum . fromInteger) <$> minExC)+        ((NumberConstraintMinimum . fromInteger) <$> minC)+        ((NumberConstraintExclusiveMaximum . fromInteger) <$> maxExC)+        ((NumberConstraintMaximum . fromInteger) <$> maxC)+        ((NumberConstraintMultipleOf . fromInteger) <$> multC)+        (Range.linear (-5000) 5000)+    assert $ maybe True (v >=) minC+    assert $ maybe True (v <=) maxC+    assert $ maybe True (v >) minExC+    assert $ maybe True (v <) maxExC+    assert $ maybe True (\m -> v `rem` m == 0) multC++prop_genBoundedReal :: Property+prop_genBoundedReal =+  property $ do+    minC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac (-500) 500)+    maxC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac 500 1500)+    minExC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac (-500) 500)+    maxExC <- forAll $ Gen.maybe $ Gen.double (Range.linearFrac 500 1500)+    v <-+      forAll $+      genBoundedReal+        ((NumberConstraintExclusiveMinimum . Scientific.fromFloatDigits) <$> minExC)+        ((NumberConstraintMinimum . Scientific.fromFloatDigits) <$> minC)+        ((NumberConstraintExclusiveMaximum . Scientific.fromFloatDigits) <$> maxExC)+        ((NumberConstraintMaximum . Scientific.fromFloatDigits) <$> maxC)+        (Range.linearFrac (-5000) 5000)+    assert $ maybe True (v >=) minC+    assert $ maybe True (v <=) maxC+    assert $ maybe True (v >) minExC+    assert $ maybe True (v <) maxExC++prop_genBoundedString :: Property+prop_genBoundedString =+  property $ do+    minLengthC <- forAll $ Gen.maybe $ Gen.int (Range.linear 0 100)+    maxLengthC <- forAll $ Gen.maybe $ Gen.int (Range.linear 100 200)+    v <-+      forAll $+      genBoundedString+        ((StringConstraintMinLength . fromIntegral) <$> minLengthC)+        ((StringConstraintMaxLength . fromIntegral) <$> maxLengthC)+        (Range.linear 0 500)+    assert $ maybe True (\n -> Text.length v >= n) minLengthC+    assert $ maybe True (\n -> Text.length v <= n) maxLengthC++prop_genStringFromRegexp :: Property+prop_genStringFromRegexp =+  property $ do+    let regexp = "[a-zA-Z0-9]{3,9}"+    v <- forAll $ genStringFromRegexp regexp+    assert $ Text.unpack v =~ Text.unpack regexp++prop_genUniqueItems :: Property+prop_genUniqueItems = property $ do+  let gen = Gen.int (Range.linear 0 1000)+  generated <- forAll $ genUniqueItems (Range.linear 10 50) gen+  assert $ length generated <= 50+  assert $ length generated >= 10+  (length . HashSet.fromList) generated === length generated++tests :: TestTree+tests =+  testGroup+    "Constrained.Internal"+    [ testProperty "Generates a bounded integer" prop_genBoundedInteger+    , testProperty "Generates a bounded real" prop_genBoundedReal+    , testProperty "Generates a bounded string" prop_genBoundedString+    , testProperty "Generates a string from a regexp" prop_genStringFromRegexp+    , testProperty "Generates a list of unique items" prop_genUniqueItems+    ]

@@ -0,0 +1,187 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Gen.JSON.JSONSpec+  ( tests+  ) where++import           Control.Lens                 (over, set)+import qualified Data.Aeson                   as Aeson+import           Data.Fixed                   (mod')+import qualified Data.HashMap.Strict          as H+import qualified Data.HashSet                 as HS+import qualified Data.Scientific              as Scientific+import qualified Data.Text                    as Text+import           Hedgehog+import qualified Hedgehog.Gen                 as Gen+import           Hedgehog.Gen.JSON+import           Hedgehog.Gen.JSON.JSONSchema+import qualified Hedgehog.Range               as Range+import qualified Prelude                      as P+import           Protolude+import           Test.Tasty+import           Test.Tasty.Hedgehog+import           Text.Regex.Posix++prop_generatedUnconstrainedJSON :: Property+prop_generatedUnconstrainedJSON =+  property $ do+    v <- forAll $ genJSON sensibleRanges+    assert $ isJust (Aeson.decodeStrict v :: Maybe Aeson.Value)++prop_constrainedValueFromEnum :: Property+prop_constrainedValueFromEnum =+  property $ do+    values <- forAll $ Gen.nonEmpty (Range.linear 1 10) (Gen.text (Range.linear 1 100) Gen.unicode)+    schema <- forAll $ over schemaEnum (const $ Just $ AnyConstraintEnum (Aeson.String <$> values)) <$> genSchema+    v <- forAll $ genConstrainedJSON sensibleRanges schema+    assert $ isJust $ find (== Aeson.decodeStrict v) (Just <$> values)++prop_constrainedValueFromConst :: Property+prop_constrainedValueFromConst =+  property $ do+    c <- forAll $ genJSONValue sensibleRanges+    schema <- forAll $ over schemaConst (const $ Just $ AnyConstraintConst c) <$> genSchema+    v <- forAll $ genConstrainedJSON sensibleRanges schema+    Aeson.decodeStrict v === Just c++prop_constrainedNumber :: Property+prop_constrainedNumber =+  property $ do+    vmin <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 0 5000)+    vminEx <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 0 5000)+    vmax <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 6000 10000)+    vmaxEx <- forAll $ Gen.maybe $ Scientific.fromFloatDigits <$> Gen.double (Range.linearFrac 6000 10000)+    let schema =+          (set schemaMinimum (NumberConstraintMinimum <$> vmin) .+           set schemaMaximum (NumberConstraintMaximum <$> vmax) .+           set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) .+           set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx))+            (singleTypeSchema NumberType)+    (Aeson.Number v) <- forAll $ genConstrainedJSONValue sensibleRanges schema+    assert $ maybe True (v >=) vmin+    assert $ maybe True (v <=) vmax+    assert $ maybe True (v <) vmaxEx+    assert $ maybe True (v >) vminEx++prop_constrainedInteger :: Property+prop_constrainedInteger =+  property $ do+    vmin <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear (-50) 50)+    vminEx <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear (-50) 50)+    vmax <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear 50 100)+    vmaxEx <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear 50 100)+    multipleOf <- forAll $ Gen.maybe $ fromInteger <$> Gen.integral (Range.linear 1 10)+    let schema =+          (set schemaMinimum (NumberConstraintMinimum <$> vmin) .+           set schemaMaximum (NumberConstraintMaximum <$> vmax) .+           set schemaExclusiveMinimum (NumberConstraintExclusiveMinimum <$> vminEx) .+           set schemaExclusiveMaximum (NumberConstraintExclusiveMaximum <$> vmaxEx) .+           set schemaMultipleOf (NumberConstraintMultipleOf <$> multipleOf))+            (singleTypeSchema IntegerType)+    (Aeson.Number v) <- forAll $ genConstrainedJSONValue sensibleRanges schema+    assert $ maybe True (v >=) vmin+    assert $ maybe True (v <=) vmax+    assert $ maybe True (v <) vmaxEx+    assert $ maybe True (v >) vminEx+    assert $ maybe True (\x -> v `mod'` x == 0) multipleOf+    assert $ Scientific.isInteger v++prop_constrainedString :: Property+prop_constrainedString =+  property $ do+    minLength <- forAll $ Gen.maybe $ Gen.integral (Range.linear 0 50)+    maxLength <- forAll $ Gen.maybe $ Gen.integral (Range.linear 50 100)+    regexp <- forAll $ Gen.maybe $ Gen.constant "[a-zA-Z0-9]{3,9}" -- Not very arbitrary, I know.+    let schema =+          (set schemaPattern (StringConstraintPattern <$> regexp) .+           set schemaMinLength (StringConstraintMinLength <$> minLength) .+           set schemaMaxLength (StringConstraintMaxLength <$> maxLength))+            (singleTypeSchema StringType)+    (Aeson.String v) <- forAll $ genConstrainedJSONValue sensibleRanges schema+    assert $+      case regexp of+        Just p -> Text.unpack v =~ Text.unpack p+        Nothing -> Text.length v >= fromMaybe 0 minLength && Text.length v <= fromMaybe 1000 maxLength++prop_constrainedObject :: Property+prop_constrainedObject =+  property $ do+    nonRequiredFields <-+      forAll $+      H.fromList <$> (Gen.list (Range.linear 1 10) $ ((,) <$> (Gen.text (Range.linear 1 10) Gen.unicode) <*> genSchema))+    requiredFields <-+      forAll $+      H.fromList <$> (Gen.list (Range.linear 1 10) $ ((,) <$> (Gen.text (Range.linear 1 10) Gen.unicode) <*> genSchema))+    let schema =+          (set schemaProperties (Just $ ObjectConstraintProperties (nonRequiredFields `H.union` requiredFields)) .+           set schemaRequired (Just $ ObjectConstraintRequired $ H.keys requiredFields))+            (singleTypeSchema ObjectType)+    (Aeson.Object v) <- forAll $ genConstrainedJSONValue sensibleRanges schema+    assert $ all (`elem` (H.keys v)) (H.keys requiredFields)++prop_constrainedArray :: Property+prop_constrainedArray =+  property $ do+    uniqueItems <- forAll $ Gen.maybe Gen.bool+    minItems <- forAll $ Gen.maybe $ Gen.integral (Range.linear 0 2)+    maxItems <- forAll $ Gen.maybe $ Gen.integral (Range.linear 3 5)+    itemSchema <- forAll genSchema+    let schema =+          (set schemaMinItems (ArrayConstraintMinItems <$> minItems) .+           set schemaMaxItems (ArrayConstraintMaxItems <$> maxItems) .+           set schemaUniqueItems (ArrayConstraintUniqueItems <$> uniqueItems) .+           set schemaItems (Just $ ArrayConstraintItems itemSchema))+            (singleTypeSchema ArrayType)+    (Aeson.Array v) <- forAll $ genConstrainedJSONValue sensibleRanges schema+    assert $ maybe True (length v >=) minItems+    assert $ maybe True (length v <=) maxItems+    assert $+      maybe+        True+        (\b ->+           if b+             then isUnique v+             else True)+        uniqueItems++prop_decodesSchema :: Property+prop_decodesSchema = property $ decoded === Right expected+  where+    schemaJson =+      "{\"type\":\"object\",\"properties\":{\"user_id\":{\"type\":\"integer\"},\"user_domain\":{\"type\":\"string\"}},\"required\":[\"user_id\"]}"+    decoded :: Either P.String Schema = Aeson.eitherDecode schemaJson+    expected =+      (set schemaRequired (Just (ObjectConstraintRequired ["user_id"])) .+       set+         schemaProperties+         ((Just . ObjectConstraintProperties)+            (H.fromList [("user_id", singleTypeSchema IntegerType), ("user_domain", singleTypeSchema StringType)])))+        (singleTypeSchema ObjectType)++genSchema :: Gen Schema+genSchema = do+  t <- Gen.enumBounded+  pure $ singleTypeSchema t++singleTypeSchema :: PrimitiveType -> Schema+singleTypeSchema t = set schemaType (Just $ SingleType t) emptySchema++isUnique :: (Hashable a, Eq a, Foldable t) => t a -> Bool+isUnique xs = (toList . HS.fromList . toList) xs == toList xs++tests :: TestTree+tests =+  testGroup+    "Generated JSON"+    [ testProperty "Generated unconstrained values are valid JSON" prop_generatedUnconstrainedJSON+    , testProperty "Decodes JSON Schema" prop_decodesSchema+    , testProperty "Generates constrained values from JSON Schema enum when present" prop_constrainedValueFromEnum+    , testProperty "Generates constrained values from JSON Schema const when present" prop_constrainedValueFromConst+    , testProperty "Generates a constrained number" prop_constrainedNumber+    , testProperty "Generates a constrained integer" prop_constrainedInteger+    , testProperty "Generates a constrained string" prop_constrainedString+    , testProperty "Generates a constrained object" prop_constrainedObject+    , testProperty "Generates a constrained array" prop_constrainedArray+    ]

@@ -1,35 +1,16 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-} -import qualified Data.Aeson          as Aeson-import           Hedgehog-import           Hedgehog.Gen.JSON-import qualified Hedgehog.Range      as Range+module Main where++import qualified Hedgehog.Gen.JSON.Constrained.Internal.InternalSpec as InternalSpec+import qualified Hedgehog.Gen.JSON.JSONSpec                          as JSONSpec import           Protolude import           Test.Tasty-import           Test.Tasty.Hedgehog -ranges :: Ranges-ranges =-  Ranges-  { _arrayRange = ArrayRange {unArrayRange = (Range.linear 0 5)}-  , _stringRange = StringRange {unStringRange = (Range.linear 0 100)}-  , _numberRange = NumberRange {unNumberRange = (Range.linearFrac 0 1000)}-  , _objectRange = ObjectRange {unObjectRange = (Range.linear 0 5)}-  }--prop_generatedUnconstrainedJSON :: Property-prop_generatedUnconstrainedJSON =-  property $ do-    v <- forAll $ genJSON ranges-    assert $ isJust ((Aeson.decodeStrict v) :: Maybe Aeson.Value)- tests :: TestTree-tests =-  testGroup-    "Hedgehog.Gen.JSON tests"-    [testProperty "Generated unconstrained values are valid JSON" prop_generatedUnconstrainedJSON]+tests = testGroup "Hedgehog.Gen.JSON tests" [InternalSpec.tests, JSONSpec.tests]  main :: IO () main = defaultMain tests