hjsonschema 0.4.0.0 → 0.5.0.0

raw patch · 6 files changed

+291/−268 lines, 6 filesdep ~lensPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: lens

API changes (from Hackage documentation)

Files

• changelog.txt +6/−0
• hjsonschema.cabal +6/−5
• src/Data/JsonSchema.hs +1/−1
• src/Data/JsonSchema/Helpers.hs +178/−0
• src/Data/JsonSchema/Utils.hs +0/−71
• src/Data/JsonSchema/Validators.hs +100/−191

@@ -0,0 +1,6 @@+# 0.5+++ Start changelog.++ Rename Utils.hs to Helpers.hs.++ Move all non-ValidatorGen functions in Validators.hs to Helpers.hs.++ Various touchups.

@@ -1,6 +1,6 @@ name:                   hjsonschema-version:                0.4.0.0-synopsis:               Haskell implementation of JSON Schema Draft 4.+version:                0.5.0.0+synopsis:               JSON Schema Draft 4 library homepage:               https://github.com/seagreen/hjsonschema license:                MIT license-file:           MIT-LICENSE.txt@@ -9,7 +9,8 @@ category:               Data build-type:             Simple cabal-version:          >=1.10-extra-source-files:     draft4.json+extra-source-files:     changelog.txt+                        draft4.json                         JSON-Schema-Test-Suite/tests/draft4/*.json                         README.md                         tests/Lib.hs@@ -17,8 +18,8 @@ library   hs-source-dirs:       src   exposed-modules:      Data.JsonSchema+                      , Data.JsonSchema.Helpers                       , Data.JsonSchema.Reference-                      , Data.JsonSchema.Utils                       , Data.JsonSchema.Validators   other-modules:        Data.JsonSchema.Core   default-language:     Haskell2010@@ -32,7 +33,7 @@                       , hashable             >= 1.2   && < 1.3                       , hjsonpointer         >= 0.1   && < 0.2                       , http-types           >= 0.8   && < 0.9-                      , lens                 >= 4.7   && < 4.8+                      , lens                 >= 4.7   && < 4.9                       , regexpr              >= 0.5   && < 0.6                       , scientific           >= 0.3   && < 0.4                       , unordered-containers >= 0.2   && < 0.3

@@ -12,8 +12,8 @@ import           Data.Foldable import qualified Data.HashMap.Strict        as H import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers import           Data.JsonSchema.Reference-import           Data.JsonSchema.Utils import           Data.JsonSchema.Validators import           Data.Maybe import           Data.Text                  (Text)

@@ -0,0 +1,178 @@+-- | Embedded schema layouts and functions for use in Validators.hs.+--+-- 'Data.JsonSchema.fetchRefs' uses embedded schema layouts to+-- correctly find subschemas so it can check for "$ref" and "id"+-- keywords.++module Data.JsonSchema.Helpers where++import           Control.Applicative+import           Control.Monad+import           Data.Aeson+import           Data.Hashable+import           Data.HashMap.Strict  (HashMap)+import qualified Data.HashMap.Strict  as H+import           Data.JsonSchema.Core+import           Data.List+import           Data.Monoid+import           Data.Scientific+import           Data.Text            (Text)+import qualified Data.Text            as T+import           Data.Traversable+import           Data.Vector          (Vector)+import qualified Data.Vector          as V+import           Text.RegexPR++--------------------------------------------------+-- Embedded Schema Layouts+--------------------------------------------------++noEm :: Text -> Value -> Vector RawSchema+noEm _ _ = V.empty++objEmbed :: Text -> Value -> Vector RawSchema+objEmbed t (Object o) = V.singleton $ RawSchema t o+objEmbed _ _ = V.empty++-- TODO: optimize+arrayEmbed :: Text -> Value -> Vector RawSchema+arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs+arrayEmbed _ _ = V.empty++objOrArrayEmbed :: Text -> Value -> Vector RawSchema+objOrArrayEmbed t v@(Object _) = objEmbed t v+objOrArrayEmbed t v@(Array _) = arrayEmbed t v+objOrArrayEmbed _ _ = V.empty++objMembersEmbed :: Text -> Value -> Vector RawSchema+objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o+objMembersEmbed _ _ = V.empty++--------------------------------------------------+-- Validator Helpers+--------------------------------------------------++propertiesMatches+  :: Spec+  -> Graph+  -> RawSchema+  -> Value+  -> Maybe (Value -> (Vector ValErr, Value))+propertiesMatches spec g s (Object val) = do+  os <- traverse toObj val+  let oss = compile spec g . RawSchema (_rsURI s) <$> os+  Just (\x ->+    case x of+      Object y -> ( join . vectorOfElems $ H.intersectionWith validate oss y+                  , Object $ H.difference y oss)+      z        -> (mempty, z))+propertiesMatches _ _ _ _ = Nothing++patternPropertiesMatches+  :: Spec+  -> Graph+  -> RawSchema+  -> Value+  -> Maybe (Value -> (Vector ValErr, Value))+patternPropertiesMatches spec g s (Object val) = do+  os <- traverse toObj val+  let vs = compile spec g . RawSchema (_rsURI s) <$> os+  Just (\x ->+    case x of+      Object y -> let ms = matches (hmToVector vs) <$> hmToVector y+                  in (ms >>= runVals, leftovers ms)+      _        -> (mempty, x))+  where+    matches+      :: Vector (Text, Schema)+      -> (Text, Value)+      -> (Text, Value, Vector Schema)+    matches ss (k, v) = (k, v, ss >>= match k)++    match :: Text -> (Text, Schema) -> Vector Schema+    match k (r, sc) =+      case matchRegexPR (T.unpack r) (T.unpack k) of+        Nothing -> mempty+        Just _  -> V.singleton sc++    runVals :: (Text, Value, Vector Schema) -> Vector ValErr+    runVals (_,v,ss) = join $ validate <$> ss <*> pure v++    leftovers :: Vector (Text, Value, Vector Schema) -> Value+    leftovers possiblyMatched =+      let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched+      in Object . vectorToHm $ (\(v,k,_) -> (v,k)) <$> unmatched++patternPropertiesMatches _ _ _ _ = Nothing++isJsonType :: Value -> Vector Text -> Vector ValErr+isJsonType x xs =+  case x of+    (Null)     -> f "null"    xs ("null" :: Text)+    (Array y)  -> f "array"   xs y+    (Bool y)   -> f "boolean" xs y+    (Object y) -> f "object"  xs y+    (String y) -> f "string"  xs y+    (Number y) ->+      case toBoundedInteger y :: Maybe Int of+        Nothing -> f "number" xs y+        Just _  -> if V.elem "number" xs || V.elem "integer" xs+                     then mempty+                     else mkErr y xs+  where+    f :: (Show a) => Text -> Vector Text -> a -> Vector ValErr+    f t ts d = if V.elem t ts then mempty else mkErr d ts++    mkErr :: (Show a) => a -> Vector Text -> Vector ValErr+    mkErr y ts = V.singleton $ tshow y <> " is not one of the types " <> tshow ts++--------------------------------------------------+-- Utils+--------------------------------------------------++vectorOfElems :: HashMap k a -> Vector a+vectorOfElems = V.fromList . H.elems++hmToVector :: HashMap k a -> Vector (k, a)+hmToVector = V.fromList . H.toList++vectorToHm :: (Eq k, Hashable k) => Vector (k, a) -> HashMap k a+vectorToHm = H.fromList . V.toList++runMaybeVal :: Maybe Validator -> Value -> Vector ValErr+runMaybeVal Nothing _ = mempty+runMaybeVal (Just val) d = val d++runMaybeVal'+  :: Maybe (Value -> (Vector ValErr, Value))+  -> Value+  -> (Vector ValErr, Value)+runMaybeVal' Nothing d = (mempty, d)+runMaybeVal' (Just val) d = val d++-- TODO: optimize+-- see here: http://comments.gmane.org/gmane.comp.lang.haskell.cafe/106242+allUnique :: (Eq a) => Vector a -> Bool+allUnique bs = length (nub (V.toList bs)) == V.length bs++-- TODO: optimize+count :: (Eq a) => a -> Vector a -> Int+count b bs = V.length $ V.filter (== b) bs++toObj :: Value -> Maybe (HashMap Text Value)+toObj (Object a) = Just a+toObj _ = Nothing++fromJSONInt :: Value -> Maybe Int+fromJSONInt (Number n) = toBoundedInteger n+fromJSONInt _ = Nothing++toTxt :: Value -> Maybe Text+toTxt (String t) = Just t+toTxt _ = Nothing++greaterThanZero :: (Num a, Ord a) => a -> Maybe ()+greaterThanZero n = if n <= 0 then Nothing else Just ()++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -1,71 +0,0 @@-module Data.JsonSchema.Utils where--import           Data.Aeson-import           Data.HashMap.Strict  (HashMap)-import           Data.JsonSchema.Core-import           Data.List-import           Data.Monoid-import           Data.Scientific-import           Data.Text            (Text)-import qualified Data.Text            as T-import           Data.Vector          (Vector)-import qualified Data.Vector          as V--isJsonType :: Value -> Vector Text -> Vector ValErr-isJsonType x xs =-  case x of-    (Null)     -> f "null"    xs ("null" :: Text)-    (Array y)  -> f "array"   xs y-    (Bool y)   -> f "boolean" xs y-    (Object y) -> f "object"  xs y-    (String y) -> f "string"  xs y-    (Number y) ->-      case toBoundedInteger y :: Maybe Int of-        Nothing -> f "number" xs y-        Just _  -> if V.elem "number" xs || V.elem "integer" xs-                     then mempty-                     else mkErr y xs-  where-    f :: (Show a) => Text -> Vector Text -> a -> Vector ValErr-    f t ts d = if V.elem t ts then mempty else mkErr d ts--    mkErr :: (Show a) => a -> Vector Text -> Vector ValErr-    mkErr y ts = V.singleton $ tshow y <> " is not one of the types " <> tshow ts--runMaybeVal :: Maybe Validator -> Value -> Vector ValErr-runMaybeVal Nothing _ = mempty-runMaybeVal (Just val) d = val d--runMaybeVal'-  :: Maybe (Value -> (Vector ValErr, Value))-  -> Value-  -> (Vector ValErr, Value)-runMaybeVal' Nothing d = (mempty, d)-runMaybeVal' (Just val) d = val d---- TODO: optimize--- see here: http://comments.gmane.org/gmane.comp.lang.haskell.cafe/106242-allUnique :: (Eq a) => Vector a -> Bool-allUnique bs = length (nub (V.toList bs)) == V.length bs---- TODO: optimize-count :: (Eq a) => a -> Vector a -> Int-count b bs = V.length $ V.filter (== b) bs--toObj :: Value -> Maybe (HashMap Text Value)-toObj (Object a) = Just a-toObj _ = Nothing--fromJSONInt :: Value -> Maybe Int-fromJSONInt (Number n) = toBoundedInteger n-fromJSONInt _ = Nothing--toTxt :: Value -> Maybe Text-toTxt (String t) = Just t-toTxt _ = Nothing--greaterThanZero :: (Num a, Ord a) => a -> Maybe ()-greaterThanZero n = if n <= 0 then Nothing else Just ()--tshow :: Show a => a -> Text-tshow = T.pack . show

@@ -1,85 +1,34 @@ -- | This is generally meant to be an internal module. -- It's only exposed in case you want to make your own--- 'Spec'. If you just want to use JSON Schema Draft 4--- use the preassembled 'Data.JsonSchema.draft4' instead.------ This module exposes three types of functions. To describe--- them we'll use the properties validators as an example.------ 1. Functions which describe how subschemas (if any)--- are embedded in this validator. This is how 'fetchRefs'--- is able to find "$refs" and "ids".------ 2. Functions that aren't followed by apostrophes have the--- type 'ValidatorGen' and are meant to be used in a 'Spec'.--- Examples are 'properties' and 'additionalProperties'.------ 3. Functions that are followed by a single apostrophe, such--- as 'additionalProperties'', aren't meant to be used standalone--- in a 'Spec'. Instead they're used by other validators. For--- instance, 'additionalProperties' disables itself if the key--- "properties" is present to allow 'additionalProperties' to--- handle its validation. Placing the actual meat of--- 'additionalProperties' in 'additionalProperties'' allows for--- code reuse between 'properties' and 'additionalProperties'.------ 4. Functions that are followed by a double apostrophe, such--- as 'patternProperties''', return an enhanced validator. It--- not only reports errors, but also the parts of the target--- data that it matches. These functions also aren't used in--- a 'Spec' instance, but are necessary helpers for actual--- validators in certain situations.+-- 'Data.JsonSchema.Core.Spec'. If you just want to use+-- JSON Schema Draft 4 use the preassembled+-- 'Data.JsonSchema.draft4' instead.  module Data.JsonSchema.Validators where  import           Control.Applicative import           Control.Monad import           Data.Aeson-import           Data.Fixed                    (mod')+import           Data.Fixed                (mod') import           Data.Hashable-import           Data.HashMap.Strict           (HashMap)-import qualified Data.HashMap.Strict           as H+import           Data.HashMap.Strict       (HashMap)+import qualified Data.HashMap.Strict       as H import           Data.JsonPointer import           Data.JsonSchema.Core+import           Data.JsonSchema.Helpers import           Data.JsonSchema.Reference-import           Data.JsonSchema.Utils import           Data.Maybe import           Data.Monoid-import           Data.Text                     (Text)-import qualified Data.Text                     as T+import           Data.Text                 (Text)+import qualified Data.Text                 as T import           Data.Text.Encoding import           Data.Traversable-import           Data.Vector                   (Vector)-import qualified Data.Vector                   as V+import           Data.Vector               (Vector)+import qualified Data.Vector               as V import           Network.HTTP.Types.URI import           Text.RegexPR  ----------------------------------------------------- Embedded Schema Layouts-----------------------------------------------------noEm :: Text -> Value -> Vector RawSchema-noEm _ _ = V.empty--objEmbed :: Text -> Value -> Vector RawSchema-objEmbed t (Object o) = V.singleton $ RawSchema t o-objEmbed _ _ = V.empty---- TODO: optimize-arrayEmbed :: Text -> Value -> Vector RawSchema-arrayEmbed t (Array vs) = V.concat . V.toList $ objEmbed t <$> vs-arrayEmbed _ _ = V.empty--objOrArrayEmbed :: Text -> Value -> Vector RawSchema-objOrArrayEmbed t v@(Object _) = objEmbed t v-objOrArrayEmbed t v@(Array _) = arrayEmbed t v-objOrArrayEmbed _ _ = V.empty--objMembersEmbed :: Text -> Value -> Vector RawSchema-objMembersEmbed t (Object o) = V.concat $ objEmbed t <$> H.elems o-objMembersEmbed _ _ = V.empty---------------------------------------------------- -- Number Validators -------------------------------------------------- @@ -88,9 +37,10 @@   greaterThanZero val   Just (\x ->     case x of-      (Number y) -> if y `mod'` val /= 0-        then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val-        else mempty+      Number y ->+        if y `mod'` val /= 0+          then V.singleton $ tshow y <> " isn't a multiple of " <> tshow val+          else mempty       _ -> mempty) multipleOf _ _ _ _ = Nothing @@ -101,9 +51,10 @@             _             -> (>)   in Just (\x ->     case x of-      (Number y) -> if y `f` val-        then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val-        else mempty+      Number y ->+        if y `f` val+          then V.singleton $ tshow y <> " fails to validate against maximum " <> tshow val+          else mempty       _ -> mempty) maximumVal _ _ _ _ = Nothing @@ -114,9 +65,10 @@             _             -> (<)   in Just (\x ->     case x of-      (Number y) -> if y `f` val-        then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val-        else mempty+      Number y ->+        if y `f` val+          then V.singleton $ tshow y <> " fails to validate against minimum " <> tshow val+          else mempty       _ -> mempty) minimumVal _ _ _ _ = Nothing @@ -130,9 +82,10 @@   greaterThanZero val   Just (\x ->     case x of-      (String y) -> if T.length y > val-        then V.singleton $ y <> " is greater than maxLength " <> tshow val-        else mempty+      String y ->+        if T.length y > val+          then V.singleton $ y <> " is greater than maxLength " <> tshow val+          else mempty       _ -> mempty)  minLength :: ValidatorGen@@ -141,16 +94,17 @@   greaterThanZero val   Just (\x ->     case x of-      (String y) -> if T.length y < val-        then V.singleton $ y <> " is less than minLength " <> tshow val-        else mempty+      String y ->+        if T.length y < val+          then V.singleton $ y <> " is less than minLength " <> tshow val+          else mempty       _ -> mempty)  pattern :: ValidatorGen pattern _ _ _ (String val) =   Just (\x ->     case x of-      (String t) ->+      String t ->         case matchRegexPR (T.unpack val) (T.unpack t) of           Nothing -> V.singleton $ t <> " fails to validate against pattern " <> val           Just _  -> mempty@@ -162,22 +116,19 @@ --------------------------------------------------  -- | Also covers additionalItems.------ We can leave additionalItems out of the spec HashMap, since items defaults to {},--- and if it isn't present additionalItems will always validate successfully. items :: ValidatorGen items spec g s (Object val) =   let sub = compile spec g (RawSchema (_rsURI s) val)   in Just (\x ->     case x of-      (Array ys) -> ys >>= validate sub-      _          -> mempty)+      Array ys -> ys >>= validate sub+      _        -> mempty) items spec g s (Array vs) = do   os <- traverse toObj vs   let ss = compile spec g . RawSchema (_rsURI s) <$> os   let addItems = do         a <- H.lookup "additionalItems" (_rsObject s)-        additionalItems' spec g s a+        additionalItems spec g s a   Just (\x ->     case x of       (Array ys) ->@@ -186,21 +137,25 @@       _ -> mempty) items _ _ _ _ = Nothing -additionalItems' :: ValidatorGen-additionalItems' _ _ _ (Bool val) =+-- | Not included directly in the 'draft4' spec hashmap because it always+-- validates data unless 'items' is also present. This is because 'items'+-- defaults to {}.+additionalItems :: ValidatorGen+additionalItems _ _ _ (Bool val) =   Just (\x ->     case x of-      (Array ys) -> if not val && V.length ys > 0-        then V.singleton ("Val error against additionalItems false for: " <> tshow x)-        else mempty+      Array ys ->+        if not val && V.length ys > 0+          then V.singleton ("Val error against additionalItems false for: " <> tshow x)+          else mempty       _ -> mempty)-additionalItems' spec g s (Object val) =+additionalItems spec g s (Object val) =   let sub = compile spec g (RawSchema (_rsURI s) val)   in Just (\x ->     case x of-      (Array ys) -> ys >>= validate sub-      _          -> mempty)-additionalItems' _ _ _ _ = Nothing+      Array ys -> ys >>= validate sub+      _        -> mempty)+additionalItems _ _ _ _ = Nothing  maxItems :: ValidatorGen maxItems _ _ _ v = do@@ -208,9 +163,10 @@   greaterThanZero val   Just (\x ->     case x of-      (Array ys) -> if V.length ys > val-        then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val-        else mempty+      Array ys ->+        if V.length ys > val+          then V.singleton $ tshow ys <> " has more items than maxItems " <> tshow val+          else mempty       _ -> mempty)  minItems :: ValidatorGen@@ -219,9 +175,10 @@   greaterThanZero val   Just (\x ->     case x of-      (Array ys) -> if V.length ys < val-        then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val-        else mempty+      Array ys ->+        if V.length ys < val+          then V.singleton $ tshow ys <> " has fewer items than minItems " <> tshow val+          else mempty       _ -> mempty)  uniqueItems :: ValidatorGen@@ -231,8 +188,7 @@     case x of       (Array ys) -> if allUnique ys         then mempty-        else V.singleton-          ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)+        else V.singleton ("Val error against uniqueItems " <> tshow val <> " for: " <> tshow x)       _ -> mempty) uniqueItems _ _ _ _ = Nothing @@ -246,9 +202,10 @@   greaterThanZero val   Just (\x ->     case x of-      (Object o) -> if H.size o > val-        then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val-        else mempty+      Object o ->+        if H.size o > val+          then V.singleton $ tshow o <> " has more members than maxProperties " <> tshow val+          else mempty       _ -> mempty)  minProperties :: ValidatorGen@@ -257,145 +214,95 @@   greaterThanZero val   Just (\x ->     case x of-      (Object o) -> if H.size o < val-        then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val-        else mempty+      Object o ->+        if H.size o < val+          then V.singleton $ tshow o <> " has fewer members than minProperties " <> tshow val+          else mempty       _ -> mempty)  required :: ValidatorGen required _ _ _ (Array vs) = do   when (V.length vs == 0) Nothing   ts <- traverse toTxt vs-  let a = vectorToMap ts+  let a = vectorToMapSet ts   when (H.size a /= V.length ts) Nothing   Just (\x ->     case x of-      (Object o) -> if H.size (H.difference a o) > 0-        then V.singleton $ "the keys of " <> tshow o-          <> " don't contain all the required elements " <> tshow vs-        else mempty+      Object o ->+        if H.size (H.difference a o) > 0+          then V.singleton $ "the keys of " <> tshow o <>+            " don't contain all the required elements " <> tshow vs+          else mempty       _ -> mempty)   where-    -- TODO: optimize-    vectorToMap :: (Eq a, Hashable a) => Vector a -> HashMap a Bool-    vectorToMap vec = H.fromList $ zip (V.toList vec) (repeat True)+    vectorToMapSet :: (Eq a, Hashable a) => Vector a -> HashMap a Bool+    vectorToMapSet vec = vectorToHm $ (\x -> (x, True)) <$> vec required _ _ _ _ = Nothing --- TODO: Fix up the properties* validators. They're all a huge mess, but at least+-- TODO: Fix up the properties validators. They're all a huge mess, but at least -- they work. -- -- In order of what's tried: properties, patternProperties, additionalProperties properties :: ValidatorGen properties spec g s v = do-  let mProps = properties'' spec g s v+  let mProps = propertiesMatches spec g s v   let mPatProp = do                   aV <- H.lookup "patternProperties" (_rsObject s)-                  patternProperties'' spec g s aV+                  patternPropertiesMatches spec g s aV   let mAdd = do               aVal <- H.lookup "additionalProperties" (_rsObject s)-              additionalProperties' spec g s aVal+              runAdditionalProperties spec g s aVal   when (isNothing mProps && isNothing mPatProp && isNothing mAdd) Nothing   Just (\x ->     case x of-      (Object y) -> -- Got myself into a mess here.+      Object y -> -- Got myself into a mess here.         let (e1s, remaining) = runMaybeVal' mProps (Object y)             (_, remaining') = runMaybeVal' mPatProp remaining             (e2s, _) = runMaybeVal' mPatProp (Object y)         in e1s <> e2s <> runMaybeVal mAdd remaining'       _ -> mempty) --- TODO: optimize-properties''-  :: Spec-  -> Graph-  -> RawSchema-  -> Value-  -> Maybe (Value -> (Vector ValErr, Value))-properties'' spec g s (Object val) = do-  os <- traverse toObj val-  let oss = compile spec g . RawSchema (_rsURI s) <$> os-  Just (\x ->-    case x of-      (Object y) -> ( join . V.fromList . H.elems $ H.intersectionWith validate oss y-                    , Object (H.difference y oss))-      z          -> (mempty, z))-properties'' _ _ _ _ = Nothing---- TODO: optimize-patternProperties''-  :: Spec-  -> Graph-  -> RawSchema-  -> Value-  -> Maybe (Value -> (Vector ValErr, Value))-patternProperties'' spec g s (Object val) = do-  os <- traverse toObj val-  let vs = compile spec g . RawSchema (_rsURI s) <$> os-  Just (\x ->-    case x of-      (Object y) -> let ms = matches (V.fromList . H.toList $ vs) <$> (V.fromList . H.toList $ y)-                    in (ms >>= runVals, leftovers ms)-      _          -> (mempty, x))-  where-    matches :: Vector (Text, Schema) -> (Text, Value) -> (Text, Value, Vector Schema)-    matches ss (k, v) = (k, v, ss >>= match k)--    match :: Text -> (Text, Schema) -> Vector Schema-    match k (r, sc) =-      case matchRegexPR (T.unpack r) (T.unpack k) of-        Nothing -> mempty-        Just _  -> V.singleton sc--    runVals :: (Text, Value, Vector Schema) -> Vector ValErr-    runVals (_,v,ss) = join $ validate <$> ss <*> pure v--    leftovers :: Vector (Text, Value, Vector Schema) -> Value-    leftovers possiblyMatched =-      let unmatched = V.filter (\(_,_,ss) -> V.length ss == 0) possiblyMatched-      in Object . H.fromList . V.toList $ (\(v,k,_) -> (v,k)) <$> unmatched--patternProperties'' _ _ _ _ = Nothing- patternProperties :: ValidatorGen patternProperties spec g s v = do   when (H.member "properties" (_rsObject s)) Nothing-  let mPatProp = patternProperties'' spec g s v+  let mPatProp = patternPropertiesMatches spec g s v   -- TODO: checking additionalProperties as well doesn't help with tests   let mAdd = do               aVal <- H.lookup "additionalProperties" (_rsObject s)-              additionalProperties' spec g s aVal+              runAdditionalProperties spec g s aVal   when (isNothing mPatProp && isNothing mAdd) Nothing   Just (\x ->     case x of-      (Object y) ->+      Object y ->         let (e2s, remaining') = runMaybeVal' mPatProp (Object y)         in e2s <> runMaybeVal mAdd remaining'       _ -> mempty) -additionalProperties' :: ValidatorGen-additionalProperties' _ _ _ (Bool val) =+-- | An implementation of the "additionalProperties" keyword that never+-- disables itself. Not included directly in the 'draft4' spec hashmap.+runAdditionalProperties :: ValidatorGen+runAdditionalProperties _ _ _ (Bool val) =   Just (\x ->     case x of-      (Object y) -> if not val && H.size y > 0-        then V.singleton ("Val error against additionalProperties false for: " <> tshow x)-        else mempty+      Object y ->+        if not val && H.size y > 0+          then V.singleton ("Val error against additionalProperties false for: " <> tshow x)+          else mempty       _ -> mempty)-additionalProperties' spec g s (Object val) =+runAdditionalProperties spec g s (Object val) =   let sub = compile spec g (RawSchema (_rsURI s) val)   in Just (\x ->     case x of-      (Object y) -> (V.fromList . H.elems $ y) >>= validate sub -- TODO: optimize-      _          -> mempty)-additionalProperties' _ _ _ _ = Nothing+      Object y -> vectorOfElems y >>= validate sub+      _        -> mempty)+runAdditionalProperties _ _ _ _ = Nothing  additionalProperties :: ValidatorGen additionalProperties spec g s v = do   when (H.member "properties" (_rsObject s)) Nothing   when (H.member "patternProperties" (_rsObject s)) Nothing-  additionalProperties' spec g s v+  runAdditionalProperties spec g s v --- TODO: optimize--- -- http://json-schema.org/latest/json-schema-validation.html#anchor70 -- --  This keyword's value MUST be an object.@@ -409,17 +316,19 @@ -- This is called a property dependency. dependencies :: ValidatorGen dependencies spec g s (Object val) = do-  let vs = V.fromList $ H.toList val+  let vs = hmToVector val   let schemaDeps = vs >>= toSchemaDep spec g   let propDeps = vs >>= toPropDep   when (V.length schemaDeps + V.length propDeps /= V.length vs) Nothing   Just (\x ->     case x of-      (Object y) -> join $ (valSD <$> schemaDeps <*> pure y) <> (valPD <$> propDeps <*> pure y)-      _          -> mempty)+      Object y -> join $ (valSD <$> schemaDeps <*> pure y)+                         <> (valPD <$> propDeps <*> pure y)+      _        -> mempty)   where     toSchemaDep :: Spec -> Graph -> (Text, Value) -> Vector (Text, Schema)-    toSchemaDep spc gr (t, Object o) = V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)+    toSchemaDep spc gr (t, Object o) =+      V.singleton (t, compile spc gr $ RawSchema (_rsURI s) o)     toSchemaDep _ _ _ = mempty      toPropDep :: (Text, Value) -> Vector (Text, Vector Text)