@@ -1,14 +1,16 @@
11
22module JSONSchema.Validator.Draft4.Any where
33
4−import Import
4+import Import hiding ((<>))
55
6+import Data.Aeson.TH (constructorTagModifier)
7+import Data.Char (toLower)
68import Data.List.NonEmpty (NonEmpty((:|)))
79import qualified Data.List.NonEmpty as NE
810import qualified Data.Scientific as SCI
9−import Data.Semigroup (Semigroup) -- for older GHCs
11+import Data.Semigroup
1012import Data.Set (Set)
11−import qualified Data.Set as S
13+import qualified Data.Set as Set
1214import Data.Text.Encoding.Error (UnicodeException)
1315import qualified JSONPointer as JP
1416import Network.HTTP.Types.URI (urlDecode)
@@ -201,7 +203,10 @@ instance Arbitrary EnumValidator where
201203 Just ne -> pure (EnumValidator ne)
202204 where
203205 toUnique :: [Value] -> [Value]
204− toUnique = fmap UT._unOrdValue . S.toList . S.fromList . fmap UT.OrdValue
206+ toUnique = fmap UT._unOrdValue
207+ . Set.toList
208+ . Set.fromList
209+ . fmap UT.OrdValue
205210
206211data EnumInvalid
207212 = EnumInvalid EnumValidator Value
@@ -229,10 +234,25 @@ instance FromJSON TypeContext where
229234 TypeContext <$> o .: "type"
230235
231236data TypeValidator
232− = TypeValidatorString Text
233− | TypeValidatorArray (Set Text)
237+ = TypeValidatorString SchemaType
238+ | TypeValidatorArray (Set SchemaType)
234239 deriving (Eq, Show)
235240
241+instance Semigroup TypeValidator where
242+ (<>) x y
243+ | isEmpty x = x
244+ | isEmpty y = y
245+ | x == y = x
246+ | otherwise = TypeValidatorArray (setFromTypeValidator x
247+ `Set.union`
248+ setFromTypeValidator y)
249+ where
250+ isEmpty :: TypeValidator -> Bool
251+ isEmpty (TypeValidatorString _) = False
252+ isEmpty (TypeValidatorArray ts) = Set.null ts
253+
254+ stimes = stimesIdempotent
255+
236256instance FromJSON TypeValidator where
237257 parseJSON v = fmap TypeValidatorString (parseJSON v)
238258 <|> fmap TypeValidatorArray (parseJSON v)
@@ -242,40 +262,63 @@ instance ToJSON TypeValidator where
242262 toJSON (TypeValidatorArray ts) = toJSON ts
243263
244264instance Arbitrary TypeValidator where
245− arbitrary = oneof [ TypeValidatorString <$> UT.arbitraryText
246− , TypeValidatorArray <$> UT.arbitrarySetOfText
265+ arbitrary = oneof [ TypeValidatorString <$> arbitrary
266+ , TypeValidatorArray <$> arbitrary
247267 ]
248268
269+data SchemaType
270+ = SchemaObject
271+ | SchemaArray
272+ | SchemaString
273+ | SchemaNumber
274+ | SchemaInteger
275+ | SchemaBoolean
276+ | SchemaNull
277+ deriving (Eq, Ord, Show, Bounded, Enum, Generic)
278+
279+instance FromJSON SchemaType where
280+ parseJSON = genericParseJSON
281+ defaultOptions
282+ { constructorTagModifier = fmap toLower . drop 6 }
283+
284+instance ToJSON SchemaType where
285+ toJSON = genericToJSON
286+ defaultOptions
287+ { constructorTagModifier = fmap toLower . drop 6 }
288+
289+instance Arbitrary SchemaType where
290+ arbitrary = arbitraryBoundedEnum
291+
249292data TypeValidatorInvalid
250293 = TypeValidatorInvalid TypeValidator Value
251294 deriving (Eq, Show)
252295
253296typeVal :: TypeContext -> Value -> Maybe TypeValidatorInvalid
254297typeVal (TypeContext tv) x
255− | S.null matches = Just (TypeValidatorInvalid tv x)
256− | otherwise = Nothing
298+ | Set.null matches = Just (TypeValidatorInvalid tv x)
299+ | otherwise = Nothing
257300 where
258301 -- There can be more than one match because a 'Value' can be both a
259302 -- @"number"@ and an @"integer"@.
260− matches :: Set Text
261− matches = S.intersection okTypes (setFromTypeValidator tv)
303+ matches :: Set SchemaType
304+ matches = Set.intersection okTypes (setFromTypeValidator tv)
262305
263− okTypes :: Set Text
306+ okTypes :: Set SchemaType
264307 okTypes =
265308 case x of
266− Null -> S.singleton "null"
267− (Array _) -> S.singleton "array"
268− (Bool _) -> S.singleton "boolean"
269− (Object _) -> S.singleton "object"
270− (String _) -> S.singleton "string"
309+ Null -> Set.singleton SchemaNull
310+ (Array _) -> Set.singleton SchemaArray
311+ (Bool _) -> Set.singleton SchemaBoolean
312+ (Object _) -> Set.singleton SchemaObject
313+ (String _) -> Set.singleton SchemaString
271314 (Number y) ->
272315 if SCI.isInteger y
273− then S.fromList ["number", "integer"]
274− else S.singleton "number"
316+ then Set.fromList [SchemaNumber, SchemaInteger]
317+ else Set.singleton SchemaNumber
275318
276319-- | Internal.
277−setFromTypeValidator :: TypeValidator -> Set Text
278−setFromTypeValidator (TypeValidatorString t) = S.singleton t
320+setFromTypeValidator :: TypeValidator -> Set SchemaType
321+setFromTypeValidator (TypeValidatorString t) = Set.singleton t
279322setFromTypeValidator (TypeValidatorArray ts) = ts
280323
281324--------------------------------------------------