Multiple schemata to validator support

Author: ktakashi

sitelib/text/json/schema/validators.scm

@@ -77,7 +77,7 @@
     (let ((r (validator v ctx)))
       (or (and lint-mode?
 	       (cond ((*json-schema:validator-error-reporter*) =>
-		      (lambda (reporter) (reporter ctx) #f))
+		      (lambda (reporter) (reporter ctx) r))
 		     (else r)))
 	  r))))
 
@@ -101,9 +101,23 @@
 	      (lambda (validator source version id)
 		((n (run-validator validator)) source version id)))))
 
-(define (json-schema->json-validator schema . referencing-validators)
+(define (json-schema->json-validator schema . dependency-schemata)
+  (define (ensure-schema schema/validator)
+    (cond ((json-schema-validator? schema/validator)
+	   (json-schema-validator-source schema/validator))
+	  ((json-schema? schema/validator) schema/validator)
+	  (else
+	   (assertion-violation 'json-schema->json-validator
+	    "dependency must be JSON Schema or json-schema-validator"
+	    dependency-schemata))))
+  (define (compile-dependency schema context)
+    (let ((dependency-context (make-disjoint-context schema context)))
+      (initial-schema-context->schema-validator dependency-context)))
+
   (let* ((root (make-root-context *version-specifics*))
 	 (context (make-initial-schema-context schema root)))
+    (for-each (lambda (schema) (compile-dependency schema context))
+	      (map ensure-schema dependency-schemata))
     (make-json-schema-validator
      (schema-validator->core-validator
       (initial-schema-context->schema-validator context))

sitelib/text/json/schema/validators/core.scm

@@ -90,8 +90,7 @@
   (schema-context:mark-dynamic-anchor! context value)
   (lambda (e ctx)
     (validator-context:set-dynamic-context! ctx context value)
-    #t)
-  )
+    #t))
 
 (define (($defs-handler name) value context schema-path)
   (define this-path (build-schema-path schema-path name))
@@ -105,8 +104,7 @@
     (assertion-violation 'json-schema:$defs
 			 "$defs must contain JSON object" value))
   (vector-for-each compile-definition value)
-  #f
-  )
+  #f)
 
 (define json-schema:definitions ($defs-handler "definitions"))
 (define json-schema:$defs ($defs-handler "$defs"))

test/tests/text/json/schema/validators.scm

@@ -9,5 +9,85 @@
 (test-error (json-schema->json-validator ""))
 (test-error (json-schema->json-validator #(("if" . ""))))
 
+;; schemata from https://json-schema.org/blog/posts/dynamicref-and-generics
+(define list-of-t
+  #(
+    ("$schema" . "https://json-schema.org/draft/2020-12/schema")
+    ("$id" . "https://json-schema.example/list-of-t")
+    ("type" . "array")
+    ("items" .
+     #(
+       ("$dynamicRef" . "#T")
+       ))
+    ("$defs" .
+     #(
+       ("content" .
+	#(
+	  ("$dynamicAnchor" . "T")
+	  ("not" . #t)
+	  ))
+       )
+     )
+    ))
+
+(define list-of-string
+  #(
+    ("$schema" . "https://json-schema.org/draft/2020-12/schema")
+    ("$id" . "https://json-schema.example/list-of-string")
+    ("$ref" . "list-of-t")
+    ("$defs" .
+     #(
+       ("string-items" .
+	#(
+	  ("$dynamicAnchor" . "T")
+	  ("type" . "string")
+	  )
+	)
+       )
+     )
+    ))
+
+(define list-of-int
+  #(
+    ("$schema" . "https://json-schema.org/draft/2020-12/schema")
+    ("$id" . "https://json-schema.example/list-of-int")
+    ("$ref" . "list-of-t")
+    ("$defs" .
+     #(
+       ("int-items" .
+	#(
+	  ("$dynamicAnchor" . "T")
+	  ("type" . "integer")
+	  )
+	)
+       )
+     )
+    ))
+
+(define (test-validator validator . inputs)
+  (for-each (lambda (expects&input)
+	      (let ((expects (car expects&input))
+		    (input (cadr expects&input)))
+		(test-equal input expects (validate-json validator input))))
+	    inputs))
+
+(test-validator (json-schema->json-validator list-of-string list-of-t)
+		'(#t ("a" "b"))
+		'(#f (null))
+		'(#f (1 2))
+		'(#f (#() ())))
+
+(test-validator (json-schema->json-validator list-of-int list-of-t)
+		'(#f ("a" "b"))
+		'(#f (null))
+		'(#t (1 2))
+		'(#f (#() ())))
+
+(test-validator (json-schema->json-validator
+		 list-of-string (json-schema->json-validator list-of-t))
+		'(#t ("a" "b"))
+		'(#f (null))
+		'(#f (1 2))
+		'(#f (#() ())))
 
 (test-end)