diff --git a/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal b/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal index 0b9c0f2a..ff708b4e 100644 --- a/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal +++ b/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal @@ -37,7 +37,7 @@ library , beeline-http-client >=0.2 && <0.9 , bytestring ==0.11.* , http-client ==0.7.* - , json-fleece-aeson >=0.1 && <0.4 + , json-fleece-aeson >=0.1 && <0.5 default-language: Haskell2010 if flag(strict) ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors diff --git a/json-fleece-aeson-beeline/package.yaml b/json-fleece-aeson-beeline/package.yaml index abce5e12..cda43d93 100644 --- a/json-fleece-aeson-beeline/package.yaml +++ b/json-fleece-aeson-beeline/package.yaml @@ -49,10 +49,10 @@ when: library: source-dirs: src dependencies: - - json-fleece-aeson >= 0.1 && < 0.4 - beeline-http-client >= 0.2 && < 0.9 - bytestring >= 0.11 && < 0.12 - http-client >= 0.7 && < 0.8 + - json-fleece-aeson >= 0.1 && < 0.5 exposed-modules: - Fleece.Aeson.Beeline diff --git a/json-fleece-aeson/json-fleece-aeson.cabal b/json-fleece-aeson/json-fleece-aeson.cabal index 49093d1b..84faa75f 100644 --- a/json-fleece-aeson/json-fleece-aeson.cabal +++ b/json-fleece-aeson/json-fleece-aeson.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-aeson -version: 0.3.5.0 +version: 0.4.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -41,7 +41,7 @@ library , base >=4.7 && <5 , bytestring ==0.11.* , containers ==0.6.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , shrubbery ==0.2.* , text >=1.2 && <2.1 , vector >=0.12 && <0.14 @@ -66,7 +66,7 @@ test-suite json-fleece-aeson-test , containers ==0.6.* , hedgehog , json-fleece-aeson - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-examples , scientific >=0.3.7 && <0.4 , shrubbery ==0.2.* diff --git a/json-fleece-aeson/package.yaml b/json-fleece-aeson/package.yaml index 5fba15dd..548b52c3 100644 --- a/json-fleece-aeson/package.yaml +++ b/json-fleece-aeson/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-aeson -version: 0.3.5.0 +version: 0.4.0.0 github: "flipstone/json-fleece/json-fleece-aeson" license: BSD3 author: "Author name here" @@ -16,14 +16,14 @@ copyright: "2023 Author name here" description: Please see the README on GitHub at dependencies: -- base >= 4.7 && < 5 - aeson >= 2.0 && < 2.2 +- base >= 4.7 && < 5 - bytestring >= 0.11 && < 0.12 - containers >= 0.6 && < 0.7 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 +- shrubbery >= 0.2 && < 0.3 - text >= 1.2 && < 2.1 - vector >= 0.12 && < 0.14 -- shrubbery >= 0.2 && < 0.3 flags: strict: diff --git a/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs b/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs index 5f726153..49d119ef 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs @@ -14,7 +14,7 @@ import qualified Fleece.Core as FC aesonValue :: FC.Fleece schema => schema Aeson.Value aesonValue = - FC.transform valueToAnyJSON anyJSONToValue FC.anyJSON + FC.validate (FC.transform valueToAnyJSON anyJSONToValue) FC.anyJSON anyJSONToValue :: FC.AnyJSON -> Aeson.Value anyJSONToValue = diff --git a/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs b/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs index 433bf1f0..e00a4e37 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs @@ -71,6 +71,8 @@ instance FC.Fleece Decoder where newtype TaggedUnionMembers Decoder allTags _handledTags = TaggedUnionMembers (Map.Map T.Text (Aeson.Object -> AesonTypes.Parser (Shrubbery.TaggedUnion allTags))) + type Validator Decoder = FC.StandardValidator + schemaName (Decoder name _parseValue) = name @@ -172,10 +174,10 @@ instance FC.Fleece Decoder where <> " enum: " <> show textValue - validateNamed name _uncheck check (Decoder _unvalidatedName parseValue) = + validateNamed name validator (Decoder _unvalidatedName parseValue) = Decoder name $ \jsonValue -> do uncheckedValue <- parseValue jsonValue - case check uncheckedValue of + case FC.check validator uncheckedValue of Right checkedValue -> pure checkedValue Left err -> fail $ "Error validating " <> FC.nameToString name <> ": " <> err diff --git a/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs b/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs index 1932bf30..4ea3ae90 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs @@ -56,6 +56,8 @@ instance FC.Fleece Encoder where newtype TaggedUnionMembers Encoder _allTags handledTags = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTags (T.Text, Aeson.Series)) + type Validator Encoder = FC.StandardValidator + schemaName (Encoder name _toEncoding) = name @@ -128,8 +130,8 @@ instance FC.Fleece Encoder where boundedEnumNamed name toText = Encoder name (Aeson.toEncoding . toText) - validateNamed name uncheck _check (Encoder _unvalidatedName toEncoding) = - Encoder name (toEncoding . uncheck) + validateNamed name validator (Encoder _unvalidatedName toEncoding) = + Encoder name (toEncoding . FC.uncheck validator) unionNamed name (UnionMembers builder) = let diff --git a/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs b/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs index ebc42c97..3f5eecac 100644 --- a/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs +++ b/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs @@ -39,6 +39,8 @@ instance FC.Fleece EncoderDecoder where , taggedUnionMembersDecoder :: FC.TaggedUnionMembers Decoder allTags handledTags } + type Validator EncoderDecoder = FC.StandardValidator + schemaName = FC.schemaName . encoder number = @@ -127,10 +129,10 @@ instance FC.Fleece EncoderDecoder where FC.additional (objectDecoder object) (additionalFieldsDecoder addFields) } - validateNamed name uncheck check itemEncoderDecoder = + validateNamed name validator itemEncoderDecoder = EncoderDecoder - { encoder = FC.validateNamed name uncheck check $ encoder itemEncoderDecoder - , decoder = FC.validateNamed name uncheck check $ decoder itemEncoderDecoder + { encoder = FC.validateNamed name validator $ encoder itemEncoderDecoder + , decoder = FC.validateNamed name validator $ decoder itemEncoderDecoder } boundedEnumNamed name toText = diff --git a/json-fleece-aeson/test/Spec.hs b/json-fleece-aeson/test/Spec.hs index 412ae5ee..1ae118a7 100644 --- a/json-fleece-aeson/test/Spec.hs +++ b/json-fleece-aeson/test/Spec.hs @@ -72,6 +72,7 @@ tests = , ("prop_decode_taggedUnion", prop_decode_taggedUnion) , ("prop_encode_taggedUnion", prop_encode_taggedUnion) , ("prop_utcTimeAndZonedTime", prop_utcTimeAndZonedTime) + , ("prop_decode_CustomValidatorObject", prop_decode_CustomValidatorObject) ] prop_decode_number :: HH.Property @@ -779,6 +780,32 @@ prop_utcTimeAndZonedTime = Right (Time.zonedTimeToUTC originalZonedTime) === decodedUTCTime +prop_decode_CustomValidatorObject :: HH.Property +prop_decode_CustomValidatorObject = HH.property $ do + positiveInt <- HH.forAll . Gen.int $ Range.linear 0 10 + negativeInt <- HH.forAll . Gen.int $ Range.linear (-10) (-1) + let + validTestObject = + encodeTestObject $ + [ "positive_int" .= positiveInt + , "negative_int" .= negativeInt + ] + + invalidTestObject = + encodeTestObject $ + [ "positive_int" .= positiveInt + , "negative_int" .= positiveInt + ] + + expected = + Examples.CustomValidatorObject + { Examples.customValidatorObjectPositiveInt = Examples.PositiveInt positiveInt + , Examples.customValidatorObjectNegativeInt = Examples.NegativeInt negativeInt + } + + FA.decode (FA.decoder Examples.customValidatorObjectExampleSchema) validTestObject === Right expected + FA.decode (FA.decoder Examples.customValidatorObjectExampleSchema) invalidTestObject === Left "Error in $['negative_int']: Error validating Fleece.Examples.NegativeInt: Too big" + genAnyJSON :: HH.Gen FC.AnyJSON genAnyJSON = Gen.choice diff --git a/json-fleece-core/json-fleece-core.cabal b/json-fleece-core/json-fleece-core.cabal index 674422ba..f78551d4 100644 --- a/json-fleece-core/json-fleece-core.cabal +++ b/json-fleece-core/json-fleece-core.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-core -version: 0.7.0.0 +version: 0.8.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -32,6 +32,7 @@ library Fleece.Core.Class Fleece.Core.Name Fleece.Core.Schemas + Fleece.Core.Validator other-modules: Paths_json_fleece_core hs-source-dirs: diff --git a/json-fleece-core/package.yaml b/json-fleece-core/package.yaml index 6f850936..44c9ecba 100644 --- a/json-fleece-core/package.yaml +++ b/json-fleece-core/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-core -version: 0.7.0.0 +version: 0.8.0.0 github: "flipstone/json-fleece/json-fleece-core" license: BSD3 author: "Author name here" @@ -63,4 +63,4 @@ library: - Fleece.Core.Class - Fleece.Core.Name - Fleece.Core.Schemas - + - Fleece.Core.Validator diff --git a/json-fleece-core/src/Fleece/Core.hs b/json-fleece-core/src/Fleece/Core.hs index 698b993d..2fe8492a 100644 --- a/json-fleece-core/src/Fleece/Core.hs +++ b/json-fleece-core/src/Fleece/Core.hs @@ -37,8 +37,6 @@ module Fleece.Core , nullable , validate , validateNamed - , transform - , transformNamed , coerceSchema , coerceSchemaNamed @@ -129,9 +127,24 @@ module Fleece.Core , autoQualifiedName , nameToString , annotateName + , defaultSchemaName + + -- * Validators + , Validator + , FleeceValidator + , mkValidator + , mapUncheck + , mapCheck + , compose + , coercion + , transform + , identity + , StandardValidator (..) + , NoOpValidator (..) ) where import Fleece.Core.AnyJSON import Fleece.Core.Class import Fleece.Core.Name import Fleece.Core.Schemas +import Fleece.Core.Validator diff --git a/json-fleece-core/src/Fleece/Core/AnyJSON.hs b/json-fleece-core/src/Fleece/Core/AnyJSON.hs index 9201be42..3e6d2981 100644 --- a/json-fleece-core/src/Fleece/Core/AnyJSON.hs +++ b/json-fleece-core/src/Fleece/Core/AnyJSON.hs @@ -38,7 +38,8 @@ import Fleece.Core.Class , (#|) ) import Fleece.Core.Name (unqualifiedName) -import Fleece.Core.Schemas (list, transform, unionMember) +import Fleece.Core.Schemas (list, unionMember, validate) +import Fleece.Core.Validator (transform) newtype AnyJSON = AnyJSON @@ -150,7 +151,7 @@ handleAnyJSON handleText handleBool handleNumber handleArray handleObject handle anyJSON :: Fleece schema => schema AnyJSON anyJSON = - transform (\(AnyJSON u) -> u) AnyJSON $ + validate (transform (\(AnyJSON u) -> u) AnyJSON) $ unionNamed (unqualifiedName "AnyJSON") $ unionMember text #| unionMember boolean diff --git a/json-fleece-core/src/Fleece/Core/Class.hs b/json-fleece-core/src/Fleece/Core/Class.hs index 3483ae44..2296ee71 100644 --- a/json-fleece-core/src/Fleece/Core/Class.hs +++ b/json-fleece-core/src/Fleece/Core/Class.hs @@ -11,6 +11,7 @@ module Fleece.Core.Class , Object , UnionMembers , TaggedUnionMembers + , Validator , schemaName , text , number @@ -53,13 +54,15 @@ import Shrubbery (BranchIndex, Tag, TagIndex, TagType, TaggedTypes, TaggedUnion, import Shrubbery.TypeList (Append, Length) import Fleece.Core.Name (Name) +import Fleece.Core.Validator (FleeceValidator) -class Fleece schema where +class FleeceValidator (Validator schema) => Fleece schema where data Object schema :: Type -> Type -> Type data Field schema :: Type -> Type -> Type data AdditionalFields schema :: Type -> Type -> Type data UnionMembers schema :: [Type] -> [Type] -> Type data TaggedUnionMembers schema :: [Tag] -> [Tag] -> Type + type Validator schema :: Type -> Type -> Type schemaName :: schema a -> Name @@ -118,10 +121,9 @@ class Fleece schema where validateNamed :: Name -> - (a -> b) -> - (b -> Either String a) -> - (schema b) -> - (schema a) + Validator schema a b -> + schema a -> + schema b boundedEnumNamed :: (Bounded a, Enum a) => diff --git a/json-fleece-core/src/Fleece/Core/Schemas.hs b/json-fleece-core/src/Fleece/Core/Schemas.hs index 29d6a06e..62a9fb15 100644 --- a/json-fleece-core/src/Fleece/Core/Schemas.hs +++ b/json-fleece-core/src/Fleece/Core/Schemas.hs @@ -42,8 +42,6 @@ module Fleece.Core.Schemas , boundedIntegralNumberNamed , unboundedIntegralNumber , unboundedIntegralNumberNamed - , transform - , transformNamed , coerceSchema , coerceSchemaNamed , eitherOf @@ -60,7 +58,7 @@ module Fleece.Core.Schemas import qualified Data.Attoparsec.Text as AttoText import qualified Data.Attoparsec.Time as AttoTime -import Data.Coerce (Coercible, coerce) +import Data.Coerce (Coercible) import qualified Data.Int as I import qualified Data.List.NonEmpty as NEL import qualified Data.Map as Map @@ -85,6 +83,7 @@ import Fleece.Core.Class , Object , TaggedUnionMembers , UnionMembers + , Validator , additionalFields , array , boundedEnumNamed @@ -113,6 +112,7 @@ import Fleece.Core.Name , nameUnqualified , unqualifiedName ) +import Fleece.Core.Validator (FleeceValidator (mkValidator), coercion, transform) eitherOf :: forall schema a b. @@ -165,10 +165,9 @@ eitherOfNamed name leftSchema rightSchema = unionMember leftSchema #| unionMember rightSchema in - transformNamed + validateNamed name - toUnion - fromUnion + (transform toUnion fromUnion) unionSchema union :: @@ -258,47 +257,20 @@ boundedEnum toText = schema validate :: - (Fleece schema, Typeable a) => - (a -> b) -> - (b -> Either String a) -> - schema b -> - schema a -validate uncheck check schemaB = - let - name = - defaultSchemaName schemaA - - schemaA = - validateNamed name uncheck check schemaB - in - schemaA - -transform :: - (Fleece schema, Typeable a) => - (a -> b) -> - (b -> a) -> - schema b -> - schema a -transform aToB bToA schemaB = + (Fleece schema, Typeable b) => + Validator schema a b -> + schema a -> + schema b +validate validator schemaB = let name = defaultSchemaName schemaA schemaA = - transformNamed name aToB bToA schemaB + validateNamed name validator schemaB in schemaA -transformNamed :: - Fleece schema => - Name -> - (a -> b) -> - (b -> a) -> - schema b -> - schema a -transformNamed name aToB bToA = - validateNamed name aToB (Right . bToA) - coerceSchema :: (Fleece schema, Typeable a, Coercible a b) => schema b -> @@ -318,8 +290,8 @@ coerceSchemaNamed :: Name -> schema b -> schema a -coerceSchemaNamed name schemaB = - transformNamed name coerce coerce schemaB +coerceSchemaNamed name = + validateNamed name coercion data NothingEncoding = EmitNull @@ -350,10 +322,9 @@ optionalNullable encoding name accessor schema = list :: Fleece schema => schema a -> schema [a] list itemSchema = - transformNamed + validateNamed (unqualifiedName $ "[" <> nameUnqualified (schemaName itemSchema) <> "]") - V.fromList - V.toList + (transform V.fromList V.toList) (array itemSchema) map :: (Fleece schema, Typeable a) => schema a -> schema (Map.Map T.Text a) @@ -372,8 +343,7 @@ nonEmpty itemSchema = in validateNamed (unqualifiedName $ "NonEmpty " <> nameUnqualified (schemaName itemSchema)) - NEL.toList - validateNonEmpty + (mkValidator NEL.toList validateNonEmpty) (list itemSchema) data SetDuplicateHandling @@ -384,10 +354,9 @@ set :: (Ord a, Fleece schema) => SetDuplicateHandling -> schema a -> schema (Set set handling itemSchema = case handling of AllowInputDuplicates -> - transformNamed + validateNamed (unqualifiedName $ "Set [" <> nameUnqualified (schemaName itemSchema) <> "]") - (V.fromList . Set.toList) - (Set.fromList . V.toList) + (transform (V.fromList . Set.toList) (Set.fromList . V.toList)) (array itemSchema) RejectInputDuplicates -> let @@ -401,8 +370,7 @@ set handling itemSchema = in validateNamed (unqualifiedName $ "Set [" <> nameUnqualified (schemaName itemSchema) <> "]") - (V.fromList . Set.toList) - validateNoDuplicates + (mkValidator (V.fromList . Set.toList) validateNoDuplicates) (array itemSchema) nonEmptyText :: Fleece schema => schema NET.NonEmptyText @@ -415,8 +383,7 @@ nonEmptyText = in validateNamed (unqualifiedName "NonEmptyText") - NET.toText - validateNonEmptyText + (mkValidator NET.toText validateNonEmptyText) text integer :: Fleece schema => schema Integer @@ -445,8 +412,7 @@ unboundedIntegralNumberNamed name = in validateNamed name - fromIntegral - validateInteger + (mkValidator fromIntegral validateInteger) number unboundedIntegralNumber :: @@ -480,8 +446,7 @@ boundedIntegralNumberNamed name = in validateNamed name - fromIntegral - validateInteger + (mkValidator fromIntegral validateInteger) number boundedIntegralNumber :: @@ -553,14 +518,13 @@ realFloatNamed :: Name -> schema f realFloatNamed name = - transformNamed + validateNamed name - fromFloatDigits - toRealFloat + (transform fromFloatDigits toRealFloat) number string :: Fleece schema => schema String -string = transform T.pack T.unpack text +string = validate (transform T.pack T.unpack) text utcTime :: Fleece schema => schema Time.UTCTime utcTime = @@ -602,8 +566,7 @@ timeWithFormat typeName formatString = in validateNamed (unqualifiedName $ typeName <> " in " <> formatString <> " format") - (Time.formatTime Time.defaultTimeLocale formatString) - decode + (mkValidator (Time.formatTime Time.defaultTimeLocale formatString) decode) string bareOrJSONString :: Fleece schema => schema a -> schema a @@ -632,10 +595,9 @@ bareOrJSONString baseSchema = (unionMemberWithIndex index0 baseSchema) (unionMemberWithIndex index1 (jsonString baseSchema)) in - transformNamed + validateNamed name - toUnion - fromUnion + (transform toUnion fromUnion) unionSchema -- An internal helper for building building time schemes @@ -662,6 +624,5 @@ iso8601Formatted name format parser = in validateNamed (unqualifiedName name) - (T.pack . ISO8601.formatShow format) - parseTime + (mkValidator (T.pack . ISO8601.formatShow format) parseTime) text diff --git a/json-fleece-core/src/Fleece/Core/Validator.hs b/json-fleece-core/src/Fleece/Core/Validator.hs new file mode 100644 index 00000000..7d641567 --- /dev/null +++ b/json-fleece-core/src/Fleece/Core/Validator.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Fleece.Core.Validator + ( FleeceValidator (..) + , coercion + , transform + , mapCheck + , mapUncheck + , identity + , StandardValidator (..) + , NoOpValidator (..) + ) where + +import Control.Monad ((<=<)) +import qualified Data.Coerce as Coerce + +class FleeceValidator validator where + mkValidator :: (b -> a) -> (a -> Either String b) -> validator a b + compose :: validator b c -> validator a b -> validator a c + +coercion :: (Coerce.Coercible a b, FleeceValidator validator) => validator a b +coercion = mkValidator Coerce.coerce (pure . Coerce.coerce) + +transform :: FleeceValidator validator => (b -> a) -> (a -> b) -> validator a b +transform f g = mkValidator f (pure . g) + +mapCheck :: FleeceValidator validator => (c -> b) -> (b -> c) -> validator a b -> validator a c +mapCheck f g v = mkValidator f (pure . g) `compose` v + +mapUncheck :: FleeceValidator validator => (c -> a) -> (a -> c) -> validator c b -> validator a b +mapUncheck f g v = v `compose` mkValidator f (pure . g) + +identity :: FleeceValidator validator => validator a a +identity = mkValidator id pure + +data StandardValidator a b = StandardValidator + { uncheck :: b -> a + , check :: a -> Either String b + } + +instance FleeceValidator StandardValidator where + mkValidator = StandardValidator + compose (StandardValidator f1 g1) (StandardValidator f2 g2) = StandardValidator (f2 . f1) (g1 <=< g2) + +data NoOpValidator a b = NoOpValidator + +instance FleeceValidator NoOpValidator where + mkValidator _ _ = NoOpValidator + compose _ _ = NoOpValidator diff --git a/json-fleece-examples/json-fleece-examples.cabal b/json-fleece-examples/json-fleece-examples.cabal index 5bc59149..dfa9b87f 100644 --- a/json-fleece-examples/json-fleece-examples.cabal +++ b/json-fleece-examples/json-fleece-examples.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-examples -version: 0.2.3.0 +version: 0.3.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -35,7 +35,7 @@ library build-depends: base >=4.7 && <5 , containers ==0.6.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , scientific >=0.3.7 && <0.4 , shrubbery ==0.2.* , text >=1.2 && <2.1 @@ -44,3 +44,21 @@ library ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors else ghc-options: -Wall + +test-suite json-fleece-examples-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_json_fleece_examples + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , hedgehog + , json-fleece-examples + default-language: Haskell2010 + if flag(strict) + ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors + else + ghc-options: -Wall diff --git a/json-fleece-examples/package.yaml b/json-fleece-examples/package.yaml index 8d3ce1d3..08ef278b 100644 --- a/json-fleece-examples/package.yaml +++ b/json-fleece-examples/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-examples -version: 0.2.3.0 +version: 0.3.0.0 github: "flipstone/json-fleece/json-fleece-examples" license: BSD3 author: "Author name here" @@ -17,11 +17,6 @@ description: Please see the README on GitHub at = 4.7 && < 5 -- containers >= 0.6 && < 0.7 -- json-fleece-core >= 0.7 && < 0.8 -- scientific >= 0.3.7 && < 0.4 -- shrubbery >= 0.2 && < 0.3 -- text >= 1.2 && < 2.1 flags: strict: @@ -54,3 +49,21 @@ library: source-dirs: src exposed-modules: - Fleece.Examples + dependencies: + - containers >= 0.6 && < 0.7 + - json-fleece-core >= 0.8 && < 0.9 + - scientific >= 0.3.7 && < 0.4 + - shrubbery >= 0.2 && < 0.3 + - text >= 1.2 && < 2.1 + +tests: + json-fleece-examples-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - json-fleece-examples + - hedgehog diff --git a/json-fleece-examples/src/Fleece/Examples.hs b/json-fleece-examples/src/Fleece/Examples.hs index 448402a0..b985901f 100644 --- a/json-fleece-examples/src/Fleece/Examples.hs +++ b/json-fleece-examples/src/Fleece/Examples.hs @@ -1,5 +1,11 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Fleece.Examples @@ -32,45 +38,80 @@ module Fleece.Examples , personObject , Company (..) , companyObject + , SchemaValidatorInfo (..) + , ValidatorInfo (..) + , CustomValidatorObject (..) + , customValidatorObjectExampleSchema + , PositiveInt (..) + , NegativeInt (..) + , CustomValidator (..) + , CustomValidatorInfo (..) ) where import qualified Data.Map as Map import Data.Scientific (Scientific) import qualified Data.Text as T +import Data.Typeable (Typeable) import Shrubbery (type (@=)) import qualified Shrubbery import Fleece.Core - ( Fleece + ( AdditionalFields + , Field + , Fleece + , FleeceValidator + , Name , NothingEncoding (EmitNull, OmitKey) , Null , Object + , TaggedUnionMembers + , UnionMembers + , Validator + , additional , additionalFields + , annotateName + , array , bareOrJSONString , boolean , boundedEnum + , boundedEnumNamed + , compose , constructor + , field + , identity , int , jsonString , list + , mapField + , mkValidator + , null , nullable , number , object + , objectNamed , optional , optionalNullable , required + , schemaName + , taggedUnionCombine , taggedUnionMember + , taggedUnionMemberWithTag , taggedUnionNamed , text + , unboundedIntegralNumber + , unionCombine , unionMember + , unionMemberWithIndex , unionNamed , unqualifiedName , validate + , validateNamed , (#*) , (#+) , (#@) , (#|) ) +import qualified Fleece.Core as FC data FooBar = FooBar { foo :: T.Text @@ -102,8 +143,10 @@ newtype Validation = Validation T.Text validationSchema :: Fleece schema => schema Validation validationSchema = validate - (\(Validation t) -> t) - (\t -> if T.length t > 12 then Left "At most 12 characters allowed" else Right (Validation t)) + ( mkValidator + (\(Validation t) -> t) + (\t -> if T.length t > 12 then Left "At most 12 characters allowed" else Right (Validation t)) + ) text data OptionalField = OptionalField @@ -243,3 +286,188 @@ companyObject = constructor Company #+ required "name" companyName text #+ required "tooBigToFail" companyIsToBigToFail boolean + +-- A custom class that extends Fleece validation. +class CustomValidator validator where + integralMaximum :: Integral n => n -> validator n n + integralMinimum :: Integral n => n -> validator n n + +-- Implement the 'CustomValidator' class for the associated 'Validator' types of 'Fleece' +-- instances you want to use. The 'Validator' types in @json-fleece@ are either 'StandardValidator' +-- or 'NoOpValidator', so you can use packages like @json-fleece-aeson@ by implementing the +-- 'CustomValidator' class for them: +instance CustomValidator FC.StandardValidator where + integralMaximum n = + FC.mkValidator + id + (\x -> if x > n then Left "Too big" else Right x) + integralMinimum n = + FC.mkValidator + id + (\x -> if x < n then Left "Too small" else Right x) + +instance CustomValidator FC.NoOpValidator where + integralMaximum _ = FC.NoOpValidator + integralMinimum _ = FC.NoOpValidator + +-- To use your custom validation class in schemas, use a constraint on the 'Validator' type: +type CustomFleece schema = + ( Fleece schema + , CustomValidator (FC.Validator schema) + ) + +boundedIntegral :: (Integral n, CustomFleece schema, Typeable n) => Maybe n -> Maybe n -> schema n +boundedIntegral mbMin mbMax = + let + validator = + maybe identity integralMinimum mbMin + `compose` maybe identity integralMaximum mbMax + in + validate + validator + unboundedIntegralNumber + +newtype PositiveInt = PositiveInt Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +positiveIntSchema :: CustomFleece schema => schema PositiveInt +positiveIntSchema = + boundedIntegral @PositiveInt (Just 0) Nothing + +newtype NegativeInt = NegativeInt Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral) + +negativeIntSchema :: CustomFleece schema => schema NegativeInt +negativeIntSchema = + boundedIntegral @NegativeInt Nothing (Just (-1)) + +data CustomValidatorObject = CustomValidatorObject + { customValidatorObjectPositiveInt :: PositiveInt + , customValidatorObjectNegativeInt :: NegativeInt + } + deriving (Eq, Show) + +customValidatorObjectExampleSchema :: CustomFleece schema => schema CustomValidatorObject +customValidatorObjectExampleSchema = + object $ + constructor CustomValidatorObject + #+ required "positive_int" customValidatorObjectPositiveInt positiveIntSchema + #+ required "negative_int" customValidatorObjectNegativeInt negativeIntSchema + +-- The extended validator allows us to extract static information about the validations being performed +-- by implementing a new 'Fleece' instance. This example instance collects information about the custom +-- validations used by the schema. +data SchemaValidatorInfo a = SchemaValidatorInfo + { schemaValidatorInfoName :: Name + , schemaValidatorInfo :: ValidatorInfo + } + deriving (Eq, Show) + +primInfo :: String -> SchemaValidatorInfo a +primInfo name = SchemaValidatorInfo (unqualifiedName name) (ValidatorInfo [] []) + +data ValidatorInfo = ValidatorInfo + { validatorInfoCustomValidatorInfo :: [CustomValidatorInfo] + , validatorInfoChildren :: [ValidatorInfo] + } + deriving (Eq, Show) + +appendValidatorInfo :: ValidatorInfo -> CollectValidatorInfo a b -> ValidatorInfo +appendValidatorInfo (ValidatorInfo infos1 cs) (CollectValidatorInfo infos2) = + ValidatorInfo (infos1 <> infos2) cs + +-- This type will serve as our 'Validator' associated type +newtype CollectValidatorInfo a b = CollectValidatorInfo [CustomValidatorInfo] + deriving (Semigroup, Monoid) + +retag :: CollectValidatorInfo a b -> CollectValidatorInfo c d +retag (CollectValidatorInfo x) = CollectValidatorInfo x + +instance FleeceValidator CollectValidatorInfo where + mkValidator _ _ = CollectValidatorInfo mempty + compose a b = retag a <> retag b + +instance CustomValidator CollectValidatorInfo where + integralMaximum n = CollectValidatorInfo [IntegralMaximum $ toInteger n] + integralMinimum n = CollectValidatorInfo [IntegralMinimum $ toInteger n] + +data CustomValidatorInfo + = IntegralMinimum Integer + | IntegralMaximum Integer + deriving (Eq, Show) + +instance Fleece SchemaValidatorInfo where + newtype Object SchemaValidatorInfo _a _b = Object [ValidatorInfo] + + newtype Field SchemaValidatorInfo _a _b = Field ValidatorInfo + + newtype AdditionalFields SchemaValidatorInfo _a _b = AdditionalFields ValidatorInfo + + newtype UnionMembers SchemaValidatorInfo _a _b = UnionMembers [ValidatorInfo] + + newtype TaggedUnionMembers SchemaValidatorInfo _a _b = TaggedUnionMembers [ValidatorInfo] + + -- Derive the instance of 'CustomValidator' using @GeneralizedNewtypeDeriving@ + type Validator SchemaValidatorInfo = CollectValidatorInfo + + schemaName (SchemaValidatorInfo n _) = n + + number = primInfo "scientific" + + text = primInfo "text" + + boolean = primInfo "boolean" + + array (SchemaValidatorInfo a b) = SchemaValidatorInfo (a `annotateName` "array") b + + null = primInfo "null" + + nullable (SchemaValidatorInfo a b) = SchemaValidatorInfo (a `annotateName` "nullable") b + + required _ _ (SchemaValidatorInfo _ info) = Field info + + optional _ _ (SchemaValidatorInfo _ info) = Field info + + mapField _ (Field f) = + Field f + + additionalFields _ (SchemaValidatorInfo _ info) = + AdditionalFields info + + objectNamed n (Object infos) = + SchemaValidatorInfo n (ValidatorInfo [] infos) + + constructor _ = + Object mempty + + field (Object objInfos) (Field fieldInfo) = + Object (fieldInfo : objInfos) + + additional (Object objInfos) (AdditionalFields fieldsInfo) = + Object (fieldsInfo : objInfos) + + validateNamed n collectValidatorInfo (SchemaValidatorInfo _ info) = + SchemaValidatorInfo n (appendValidatorInfo info collectValidatorInfo) + + boundedEnumNamed n _ = + SchemaValidatorInfo n (ValidatorInfo [] []) + + unionNamed n (UnionMembers infos) = + SchemaValidatorInfo n (ValidatorInfo [] infos) + + unionMemberWithIndex _ (SchemaValidatorInfo _ info) = + UnionMembers [info] + + unionCombine (UnionMembers infos1) (UnionMembers infos2) = + UnionMembers (infos1 <> infos2) + + taggedUnionNamed n _ (TaggedUnionMembers infos) = + SchemaValidatorInfo n (ValidatorInfo [] infos) + + taggedUnionMemberWithTag _ (Object info) = + TaggedUnionMembers info + + taggedUnionCombine (TaggedUnionMembers info1) (TaggedUnionMembers info2) = + TaggedUnionMembers (info1 <> info2) + + jsonString s = s diff --git a/json-fleece-examples/test/Spec.hs b/json-fleece-examples/test/Spec.hs new file mode 100644 index 00000000..2231c162 --- /dev/null +++ b/json-fleece-examples/test/Spec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main + ( main + ) where + +import Hedgehog ((===)) +import qualified Hedgehog as HH +import qualified Hedgehog.Main as HHM + +import qualified Fleece.Examples as Examples + +main :: IO () +main = + HHM.defaultMain $ [HH.checkParallel (HH.Group "json-fleece-examples" tests)] + +tests :: [(HH.PropertyName, HH.Property)] +tests = + [ ("prop_SchemaValidatorInfo_CustomValidatorObject", prop_SchemaValidatorInfo_CustomValidatorObject) + ] + +prop_SchemaValidatorInfo_CustomValidatorObject :: HH.Property +prop_SchemaValidatorInfo_CustomValidatorObject = + HH.withTests 1 . HH.property $ do + let + info = Examples.schemaValidatorInfo Examples.customValidatorObjectExampleSchema + expected = + Examples.ValidatorInfo + { Examples.validatorInfoCustomValidatorInfo = [] + , Examples.validatorInfoChildren = + [ Examples.ValidatorInfo + { Examples.validatorInfoCustomValidatorInfo = + [ Examples.IntegralMaximum (-1) + ] + , Examples.validatorInfoChildren = [] + } + , Examples.ValidatorInfo + { Examples.validatorInfoCustomValidatorInfo = + [ Examples.IntegralMinimum 0 + ] + , Examples.validatorInfoChildren = [] + } + ] + } + info === expected diff --git a/json-fleece-hermes/json-fleece-hermes.cabal b/json-fleece-hermes/json-fleece-hermes.cabal index 61617730..35eae179 100644 --- a/json-fleece-hermes/json-fleece-hermes.cabal +++ b/json-fleece-hermes/json-fleece-hermes.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-hermes -version: 0.1.1.0 +version: 0.2.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -37,7 +37,7 @@ library , bytestring ==0.11.* , containers ==0.6.* , hermes-json ==0.6.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , shrubbery ==0.2.* , text >=2.0 default-language: Haskell2010 @@ -60,7 +60,7 @@ test-suite json-fleece-hermes-test , bytestring ==0.11.* , containers ==0.6.* , hedgehog - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-examples , json-fleece-hermes , scientific >=0.3.7 && <0.4 @@ -91,7 +91,7 @@ benchmark json-fleece-hermes-bench , deepseq , hermes-json , json-fleece-aeson - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-hermes , tasty-bench , text diff --git a/json-fleece-hermes/package.yaml b/json-fleece-hermes/package.yaml index 33c53b6d..c9ab198a 100644 --- a/json-fleece-hermes/package.yaml +++ b/json-fleece-hermes/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-hermes -version: 0.1.1.0 +version: 0.2.0.0 github: "flipstone/json-fleece/json-fleece-hermes" license: BSD3 author: "Author name here" @@ -18,7 +18,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 - bytestring >= 0.11 && < 0.12 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 - text >= 2.0 # This could be problematic for anyone using LTS 20 or below flags: diff --git a/json-fleece-hermes/src/Fleece/Hermes.hs b/json-fleece-hermes/src/Fleece/Hermes.hs index 9a378ddb..38b61f26 100644 --- a/json-fleece-hermes/src/Fleece/Hermes.hs +++ b/json-fleece-hermes/src/Fleece/Hermes.hs @@ -58,6 +58,8 @@ instance FC.Fleece Decoder where newtype TaggedUnionMembers Decoder allTags _handledTags = TaggedUnionMembers (Map.Map T.Text (H.FieldsDecoder (Shrubbery.TaggedUnion allTags))) + type Validator Decoder = FC.StandardValidator + schemaName (Decoder name _parseValue) = name @@ -160,10 +162,10 @@ instance FC.Fleece Decoder where <> " enum: " <> show textValue - validateNamed name _uncheck check (Decoder _unvalidatedName parseValue) = + validateNamed name validator (Decoder _unvalidatedName parseValue) = Decoder name $ do uncheckedValue <- parseValue - case check uncheckedValue of + case FC.check validator uncheckedValue of Right checkedValue -> pure checkedValue Left err -> fail $ "Error validating " <> FC.nameToString name <> ": " <> err diff --git a/json-fleece-markdown/json-fleece-markdown.cabal b/json-fleece-markdown/json-fleece-markdown.cabal index daf5bccd..d25ad1cc 100644 --- a/json-fleece-markdown/json-fleece-markdown.cabal +++ b/json-fleece-markdown/json-fleece-markdown.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-markdown -version: 0.5.0.0 +version: 0.6.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -39,7 +39,7 @@ library base >=4.7 && <5 , containers ==0.6.* , dlist ==1.0.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , text >=1.2 && <2.1 default-language: Haskell2010 if flag(strict) diff --git a/json-fleece-markdown/package.yaml b/json-fleece-markdown/package.yaml index a85023fa..419872fb 100644 --- a/json-fleece-markdown/package.yaml +++ b/json-fleece-markdown/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-markdown -version: 0.5.0.0 +version: 0.6.0.0 github: "flipstone/json-fleece/json-fleece-markdown" license: BSD3 author: "Author name here" @@ -52,9 +52,9 @@ library: exposed-modules: - Fleece.Markdown dependencies: - - json-fleece-core >= 0.7 && < 0.8 - containers >= 0.6 && < 0.7 - dlist >= 1.0 && < 1.1 + - json-fleece-core >= 0.8 && < 0.9 tests: json-fleece-markdown-test: diff --git a/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs b/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs index 31fedbe5..92cee007 100644 --- a/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs +++ b/json-fleece-markdown/src/Fleece/Markdown/FleeceInstance.hs @@ -59,6 +59,8 @@ instance FC.Fleece Markdown where newtype TaggedUnionMembers Markdown _allTags _handledTags = TaggedUnionMembers (DList.DList TaggedUnionMemberDocumentation) + type Validator Markdown = FC.NoOpValidator + schemaName (Markdown schemaDoc) = schemaName schemaDoc @@ -122,7 +124,7 @@ instance FC.Fleece Markdown where , schemaReferences = foldMap (schemaSelfReference . fieldSchemaDocs) fields } - validateNamed _name _check _unvalidate (Markdown schemaDocs) = + validateNamed _validator _unvalidate (Markdown schemaDocs) = Markdown schemaDocs boundedEnumNamed name toText = diff --git a/json-fleece-openapi3/examples/star-trek/package.yaml b/json-fleece-openapi3/examples/star-trek/package.yaml index ba4ca2b9..0357f78c 100644 --- a/json-fleece-openapi3/examples/star-trek/package.yaml +++ b/json-fleece-openapi3/examples/star-trek/package.yaml @@ -13,7 +13,7 @@ dependencies: - base >= 4.7 && < 5 - text - scientific - - json-fleece-core >= 0.1.3 && < 0.8 + - json-fleece-core >= 0.1.3 && < 0.9 - json-fleece-aeson-beeline >= 0.2 && < 0.3 - beeline-routing >= 0.2.4 && < 0.3 - beeline-http-client >= 0.8 && < 0.9 diff --git a/json-fleece-openapi3/examples/star-trek/star-trek.cabal b/json-fleece-openapi3/examples/star-trek/star-trek.cabal index 5e236d9d..eb3db32f 100644 --- a/json-fleece-openapi3/examples/star-trek/star-trek.cabal +++ b/json-fleece-openapi3/examples/star-trek/star-trek.cabal @@ -1870,7 +1870,7 @@ library , beeline-http-client ==0.8.* , beeline-routing >=0.2.4 && <0.3 , json-fleece-aeson-beeline ==0.2.* - , json-fleece-core >=0.1.3 && <0.8 + , json-fleece-core >=0.1.3 && <0.9 , scientific , text , time diff --git a/json-fleece-openapi3/examples/test-cases/package.yaml b/json-fleece-openapi3/examples/test-cases/package.yaml index e747d5f2..4475bdb7 100644 --- a/json-fleece-openapi3/examples/test-cases/package.yaml +++ b/json-fleece-openapi3/examples/test-cases/package.yaml @@ -14,7 +14,7 @@ dependencies: - containers - text - scientific - - json-fleece-core >= 0.1.3 && < 0.8 + - json-fleece-core >= 0.1.3 && < 0.9 - json-fleece-aeson-beeline >= 0.2 && < 0.3 - beeline-routing >= 0.2.4 && < 0.3 - beeline-http-client >= 0.8 && < 0.9 diff --git a/json-fleece-openapi3/examples/test-cases/test-cases.cabal b/json-fleece-openapi3/examples/test-cases/test-cases.cabal index c9d67306..0f8b88d0 100644 --- a/json-fleece-openapi3/examples/test-cases/test-cases.cabal +++ b/json-fleece-openapi3/examples/test-cases/test-cases.cabal @@ -198,7 +198,7 @@ library , beeline-routing >=0.2.4 && <0.3 , containers , json-fleece-aeson-beeline ==0.2.* - , json-fleece-core >=0.1.3 && <0.8 + , json-fleece-core >=0.1.3 && <0.9 , scientific , shrubbery ==0.2.* , text diff --git a/json-fleece-pretty-print/json-fleece-pretty-print.cabal b/json-fleece-pretty-print/json-fleece-pretty-print.cabal index 0d49fcc1..e2197aad 100644 --- a/json-fleece-pretty-print/json-fleece-pretty-print.cabal +++ b/json-fleece-pretty-print/json-fleece-pretty-print.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: json-fleece-pretty-print -version: 0.1.3.0 +version: 0.2.0.0 description: Please see the README on GitHub at homepage: https://github.com/flipstone/json-fleece#readme bug-reports: https://github.com/flipstone/json-fleece/issues @@ -36,7 +36,7 @@ library base >=4.7 && <5 , containers ==0.6.* , dlist ==1.0.* - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , scientific ==0.3.* , shrubbery ==0.2.* , text >=1.2 && <2.1 @@ -58,7 +58,7 @@ test-suite json-fleece-pretty-print-test base >=4.7 && <5 , containers ==0.6.* , hedgehog - , json-fleece-core ==0.7.* + , json-fleece-core ==0.8.* , json-fleece-examples , json-fleece-pretty-print , shrubbery ==0.2.* diff --git a/json-fleece-pretty-print/package.yaml b/json-fleece-pretty-print/package.yaml index 7bc00d00..7d9bf5b2 100644 --- a/json-fleece-pretty-print/package.yaml +++ b/json-fleece-pretty-print/package.yaml @@ -1,5 +1,5 @@ name: json-fleece-pretty-print -version: 0.1.3.0 +version: 0.2.0.0 github: "flipstone/json-fleece/json-fleece-pretty-print" license: BSD3 author: "Author name here" @@ -17,7 +17,7 @@ description: Please see the README on GitHub at = 4.7 && < 5 -- json-fleece-core >= 0.7 && < 0.8 +- json-fleece-core >= 0.8 && < 0.9 - shrubbery >= 0.2 && < 0.3 - text >= 1.2 && < 2.1 diff --git a/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs b/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs index 3d531408..cf31fe9c 100644 --- a/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs +++ b/json-fleece-pretty-print/src/Fleece/PrettyPrint.hs @@ -88,6 +88,8 @@ instance FC.Fleece PrettyPrinter where newtype TaggedUnionMembers PrettyPrinter _allTags handledTags = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTags (T.Text, DList.DList Pretty)) + type Validator PrettyPrinter = FC.StandardValidator + schemaName (PrettyPrinter name _toBuilder) = name @@ -166,11 +168,11 @@ instance FC.Fleece PrettyPrinter where , Indent (Block (map (\f -> f object) (DList.toList fields))) ] - validateNamed name unvalidate _check (PrettyPrinter _name toPretty) = + validateNamed name validator (PrettyPrinter _name toPretty) = PrettyPrinter name $ \value -> prefixConstructor (renderName name) - (toPretty (unvalidate value)) + (toPretty (FC.uncheck validator value)) boundedEnumNamed name toText = PrettyPrinter name (showInline . toText) diff --git a/json-fleece-swagger2/examples/uber/package.yaml b/json-fleece-swagger2/examples/uber/package.yaml index c66e5155..e2891b41 100644 --- a/json-fleece-swagger2/examples/uber/package.yaml +++ b/json-fleece-swagger2/examples/uber/package.yaml @@ -13,7 +13,7 @@ dependencies: - base >= 4.7 && < 5 - text - scientific - - json-fleece-core >= 0.1.3 && < 0.8 + - json-fleece-core >= 0.8 && < 0.9 - json-fleece-aeson-beeline >= 0.2 && < 0.3 - beeline-routing >= 0.2.4 && < 0.3 - beeline-http-client >= 0.8 && < 0.9 diff --git a/json-fleece-swagger2/examples/uber/uber.cabal b/json-fleece-swagger2/examples/uber/uber.cabal index c6df8a0a..ed85cd52 100644 --- a/json-fleece-swagger2/examples/uber/uber.cabal +++ b/json-fleece-swagger2/examples/uber/uber.cabal @@ -73,7 +73,7 @@ library , beeline-http-client ==0.8.* , beeline-routing >=0.2.4 && <0.3 , json-fleece-aeson-beeline ==0.2.* - , json-fleece-core >=0.1.3 && <0.8 + , json-fleece-core ==0.8.* , scientific , text , time