guile-jsonld

online.scm

;;;; Copyright (C) 2019, 2020 Julien Lepiller <julien@lepiller.eu>
;;;; 
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 3 of the License, or (at your option) any later version.
;;;; 
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
;;;; 

(define-module (test-modules online)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (test-modules download)
  #:use-module (test-modules result)
  #:use-module (test-modules testsuite)
  #:use-module (iri iri)
  #:use-module (jsonld download)
  #:use-module (jsonld json)
  #:use-module (jsonld)
  #:use-module (jsonld options)
  #:use-module (rdf rdf)
  #:use-module (nquads fromrdf)
  #:export (run-test-suite
            run-test-suites
            get-test-doc))

;; The JsonLD specification comes with a test suite.  It consists in on JsonLD
;; document per API function.  The test suite is designed for the latest
;; version of the API, but can be used for older versions.  Tests for newer
;; versions or specific to older versions are clearly marked, so we can
;; select them.
;; Each JsonLD document is a manifest listing a huge list of tests that require
;; us to download a few other JsonLD documents, run a function on them and compare
;; the result.  This is what this file does.

(define (download-document url)
  (match (car (reverse (string-split url #\.)))
    ("nq" (download-nq url))
    (_ (json-document-document (download-json url)))))

(define (good-result? result expected)
  (if (rdf-dataset? result)
      (begin
        (with-output-to-file "test-result.nq"
          (lambda _
            (format #t "~a~%" (rdf->nquads result))))
        (pk 'result result)
        (pk 'expected expected)
        (rdf-dataset-isomorphic? result expected))
      (same-json? result expected)))

(define (execute-test test)
  "Execute one test described by a Json object @var{test}.  Return a Json object
as the output of the test, or throws an exception if something went wrong."
  (let* ((document (test-case-document test))
         (input (assoc-ref document "input"))
         (context (assoc-ref document "context"))
         (type (array->list (assoc-ref document "@type")))
         (options (assoc-ref document "option"))
         (requires (assoc-ref document "requires"))
         (spec-version (assoc-ref options "specVersion"))
         (document-loader (get-test-document-loader options)))
    (cond
      ((equal? spec-version "json-ld-1.0")
       (throw 'unsupported-spec 1.0))
      ((member "jld:CompactTest" type)
       (compact (string-append jsonld-test-url input)
                (string-append jsonld-test-url context)
                #:options
                (apply
                  new-jsonld-options
                  #:ordered? #t
                  #:document-loader document-loader
                  `(,@(if (assoc-ref options "base")
                          `(#:base ,(assoc-ref options "base"))
                          '())
                    ,@(if (assoc-ref options "processingMode")
                          `(#:processing-mode ,(assoc-ref options "processingMode"))
                          '())
                    ,@(if (assoc-ref options "extractAllScripts")
                          `(#:extract-all-scripts?
                            ,(assoc-ref options "extractAllScripts"))
                          '())
                    ,@(if (json-has-key? options "compactArrays")
                          `(#:compact-arrays? ,(assoc-ref options "compactArrays"))
                          '())))))
      ((member "jld:ExpandTest" type)
       (expand (string-append jsonld-test-url input)
               #:options
               (apply
                 new-jsonld-options
                 #:ordered? #t
                 #:document-loader document-loader
                 `(,@(if (assoc-ref options "base")
                         `(#:base ,(assoc-ref options "base"))
                         '())
                   ,@(if (assoc-ref options "extractAllScripts")
                         `(#:extract-all-scripts?
                           ,(assoc-ref options "extractAllScripts"))
                         '())
                   ,@(if (assoc-ref options "processingMode")
                         `(#:processing-mode ,(assoc-ref options "processingMode"))
                         '())
                   ,@(if (assoc-ref options "expandContext")
                         `(#:expand-context ,(string-append jsonld-test-url
                                                            (assoc-ref options "expandContext")))
                         '())))))
      ((member "jld:FlattenTest" type)
       (flatten (string-append jsonld-test-url input)
                #:context
                (if context
                  (string-append jsonld-test-url context)
                  #f)
                #:options
                (apply
                  new-jsonld-options
                  #:ordered? #t
                  #:document-loader document-loader
                  `(,@(if (assoc-ref options "base")
                          `(#:base ,(assoc-ref options "base"))
                          '())
                    ,@(if (assoc-ref options "processingMode")
                          `(#:processing-mode ,(assoc-ref options "processingMode"))
                          '())
                    ,@(if (assoc-ref options "extractAllScripts")
                          `(#:extract-all-scripts?
                            ,(assoc-ref options "extractAllScripts"))
                          '())
                    ,@(if (json-has-key? options "compactArrays")
                          `(#:compact-arrays? ,(assoc-ref options "compactArrays"))
                          '())))))
      ((member "jld:ToRDFTest" type)
       (when (equal? requires "GeneralizedRdf")
         (throw 'cannot-run-test "Expected file is not in a valid nquads format"))
       (jsonld->rdf (string-append jsonld-test-url input)
                    #:options
                    (apply
                      new-jsonld-options
                      #:ordered? #t
                      #:document-loader document-loader
                      `(,@(if (assoc-ref options "base")
                              `(#:base ,(assoc-ref options "base"))
                              '())
                        ,@(if (assoc-ref options "processingMode")
                              `(#:processing-mode ,(assoc-ref options "processingMode"))
                              '())
                        ,@(if (assoc-ref options "produceGeneralizedRdf")
                              `(#:produce-generalized-rdf? #t)
                              `(#:produce-generalized-rdf? #f))
                        ,@(if (assoc-ref options "expandContext")
                              `(#:expand-context ,(string-append
                                                    jsonld-test-url
                                                    (assoc-ref options "expandContext")))
                              '())
                        ,@(if (assoc-ref options "rdfDirection")
                              `(#:rdf-direction
                                ,(assoc-ref options "rdfDirection"))
                              '())))))
      ((member "jld:FromRDFTest" type)
       (rdf->jsonld (download-nq (string-append jsonld-test-url input))
                    #:options
                    (apply
                      new-jsonld-options
                      #:ordered? #t
                      #:document-loader document-loader
                      `(,@(if (assoc-ref options "base")
                              `(#:base ,(assoc-ref options "base"))
                              '())
                        ,@(if (assoc-ref options "processingMode")
                              `(#:processing-mode ,(assoc-ref options "processingMode"))
                              '())
                        ,@(if (assoc-ref options "produceGeneralizedRdf")
                              `(#:produce-generalized-rdf? #t)
                              `(#:produce-generalized-rdf? #f))
                        ,@(if (assoc-ref options "expandContext")
                              `(#:expand-context ,(string-append
                                                    jsonld-test-url
                                                    (assoc-ref options "expandContext")))
                              '())
                        ,@(if (assoc-ref options "useNativeTypes")
                              `(#:use-native-types? #t)
                              '())
                        ,@(if (assoc-ref options "useRdfType")
                              `(#:use-rdf-type? #t)
                              '())
                        ,@(if (assoc-ref options "rdfDirection")
                              `(#:rdf-direction
                                ,(assoc-ref options "rdfDirection"))
                              '())))))
      (else (throw 'unrecognized-test type)))))

(define (run-test test)
  "Run one test described by the Json object @var{test}, whose @var{id} is
an identifier.  @var{id} is used as the test number for the test driver.  Return
is undefined.  As a side-effect, outputs one line on the standard output to
report the test status."
  (let* ((document (test-case-document test))
         (description (or (assoc-ref document "purpose") (test-case-name test)))
         (description (string-append (test-case-id test) ": " description))
         (expect (assoc-ref document "expect"))
         (expect-error (assoc-ref document "expectErrorCode"))
         (type (array->list (assoc-ref document "@type")))
         (option (assoc-ref document "option"))
         (result
           (catch #t
             (lambda ()
               (execute-test test))
             (lambda (key . value)
               (cons key value)))))
    (if (member "jld:NegativeEvaluationTest" type)
      (match result
        (((? symbol? key) . value)
         (cond
           ((equal? key 'unrecognized-test)
            (update-test-case test
              #:result 'skip
              #:reason "unrecognized test type"))
           ((equal? key 'unsupported-spec)
            (update-test-case test
              #:result 'skip
              #:reason "unsupported specification version"))
           ((equal? key 'unsupported-version-test)
            (update-test-case test
              #:result 'skip
              #:reason "unsupported JsonLD version"))
           ((equal? key 'cannot-run-test)
            (update-test-case test
              #:result 'skip
              #:reason (format #f "impossible to run test: ~a" value)))
           ((equal? (jsonld-error->string key) expect-error)
            (update-test-case test #:result 'pass))
           (else
             (update-test-case test
               #:result 'fail
               #:reason (format #f "Expected ~a but got ~a: ~a"
                                expect-error key value)))))
        (_ (begin
             (update-test-case test
               #:result 'fail
               #:reason (format #f "Expected ~a but got success"
                                expect-error)))))
      (match result
        (((? symbol? key) . value)
         (cond
           ((equal? key 'unrecognized-test)
            (update-test-case test
              #:result 'skip
              #:reason "unrecognized test type"))
           ((equal? key 'unsupported-spec)
            (update-test-case test
              #:result 'skip
              #:reason "unsupported specification version"))
           ((equal? key 'unsupported-version-test)
            (update-test-case test
              #:result 'skip
              #:reason "unsupported JsonLD version"))
           ((equal? key 'cannot-run-test)
            (update-test-case test
              #:result 'skip
              #:reason (format #f "impossible to run test: ~a" value)))
           (else
            (update-test-case test
              #:result 'fail
              #:reason (format #f "Expected success but got ~a: ~a"
                               key value)))))
        (_ (if (member "jld:PositiveSyntaxTest" type)
               (update-test-case test #:result 'pass)
               (let ((expected (download-document
                                 (string-append jsonld-test-url expect))))
                 (if (good-result? result expected)
                     (update-test-case test #:result 'pass)
                     (update-test-case test
                       #:result 'fail
                       #:reason (format #f "Expected ~a but got ~a"
                                        expected result))))))))))

(define (run-tests tests expected-failures driver)
  "Run all the tests of the @var{tests} test suite, using identifiers starting
from @var{id}.  Return is undefined."
  (fold
    (lambda (test results)
      (let* ((result (run-test test))
             (result
               (if (assoc-ref expected-failures (test-case-id test))
                   (update-test-case result
                     #:result (cond
                                ((equal? 'skip (test-case-result result))
                                 'skip)
                                ((equal? 'fail (test-case-result result))
                                 'xfail)
                                ((equal? 'pass (test-case-result result))
                                 'xpass))
                     #:reason (assoc-ref expected-failures (test-case-id test)))
                   result)))
        ((test-driver-print driver) result)
        (cons result results)))
    '()
    tests))

(define (get-test-doc url)
  "Get a test suite object from the manifest at @var{url}."
  (assoc-ref (json-document-document (download-json url)) "sequence"))

(define* (get-test-plan url #:key (num 1))
  (define document (get-test-doc url))

  (cdr
    (fold
      (lambda (test result)
        (let* ((num (car result))
               (result (cdr result))
               (name (assoc-ref test "name"))
               (@id (assoc-ref test "@id"))
               (name (string-append @id ": " name))
               (context (string-join
                          (reverse (cdr (reverse (string-split url #\.))))
                          "."))
               (description (or (assoc-ref test "purpose") name))
               (description (string-append @id ": " description)))
          (cons (+ 1 num)
                (cons (make-test-case (string-append context @id)
                                      num name description test #f #f)
                      result))))
      `(,num . ())
      (array->list document))))

(define (run-test-suite manifest expected-failures driver)
  "Run a test suite described by @var{manifest}."
  (let* ((plan (reverse (get-test-plan manifest))))
    ((test-driver-init driver) plan)
    ((test-driver-finalize driver) (run-tests plan expected-failures driver))))

(define (run-test-suites manifests expected-failures driver)
  "Run multiple test suites described by @var{manifests}."
  (let* ((plan
           (fold
             (lambda (manifest plan)
               (append plan (reverse (get-test-plan
                                       manifest #:num (+ (length plan) 1)))))
             '()
             manifests)))
    ((test-driver-init driver) plan)
    ((test-driver-finalize driver) (run-tests plan expected-failures driver))))


1	;;;; Copyright (C) 2019, 2020 Julien Lepiller <julien@lepiller.eu>
2	;;;;
3	;;;; This library is free software; you can redistribute it and/or
4	;;;; modify it under the terms of the GNU Lesser General Public
5	;;;; License as published by the Free Software Foundation; either
6	;;;; version 3 of the License, or (at your option) any later version.
7	;;;;
8	;;;; This library is distributed in the hope that it will be useful,
9	;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
10	;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11	;;;; Lesser General Public License for more details.
12	;;;;
13	;;;; You should have received a copy of the GNU Lesser General Public
14	;;;; License along with this library; if not, write to the Free Software
15	;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
16	;;;;
17
18	(define-module (test-modules online)
19	#:use-module (ice-9 match)
20	#:use-module (srfi srfi-1)
21	#:use-module (srfi srfi-9)
22	#:use-module (test-modules download)
23	#:use-module (test-modules result)
24	#:use-module (test-modules testsuite)
25	#:use-module (iri iri)
26	#:use-module (jsonld download)
27	#:use-module (jsonld json)
28	#:use-module (jsonld)
29	#:use-module (jsonld options)
30	#:use-module (rdf rdf)
31	#:use-module (nquads fromrdf)
32	#:export (run-test-suite
33	run-test-suites
34	get-test-doc))
35
36	;; The JsonLD specification comes with a test suite. It consists in on JsonLD
37	;; document per API function. The test suite is designed for the latest
38	;; version of the API, but can be used for older versions. Tests for newer
39	;; versions or specific to older versions are clearly marked, so we can
40	;; select them.
41	;; Each JsonLD document is a manifest listing a huge list of tests that require
42	;; us to download a few other JsonLD documents, run a function on them and compare
43	;; the result. This is what this file does.
44
45	(define (download-document url)
46	(match (car (reverse (string-split url #\.)))
47	("nq" (download-nq url))
48	(_ (json-document-document (download-json url)))))
49
50	(define (good-result? result expected)
51	(if (rdf-dataset? result)
52	(begin
53	(with-output-to-file "test-result.nq"
54	(lambda _
55	(format #t "~a~%" (rdf->nquads result))))
56	(pk 'result result)
57	(pk 'expected expected)
58	(rdf-dataset-isomorphic? result expected))
59	(same-json? result expected)))
60
61	(define (execute-test test)
62	"Execute one test described by a Json object @var{test}. Return a Json object
63	as the output of the test, or throws an exception if something went wrong."
64	(let* ((document (test-case-document test))
65	(input (assoc-ref document "input"))
66	(context (assoc-ref document "context"))
67	(type (array->list (assoc-ref document "@type")))
68	(options (assoc-ref document "option"))
69	(requires (assoc-ref document "requires"))
70	(spec-version (assoc-ref options "specVersion"))
71	(document-loader (get-test-document-loader options)))
72	(cond
73	((equal? spec-version "json-ld-1.0")
74	(throw 'unsupported-spec 1.0))
75	((member "jld:CompactTest" type)
76	(compact (string-append jsonld-test-url input)
77	(string-append jsonld-test-url context)
78	#:options
79	(apply
80	new-jsonld-options
81	#:ordered? #t
82	#:document-loader document-loader
83	`(,@(if (assoc-ref options "base")
84	`(#:base ,(assoc-ref options "base"))
85	'())
86	,@(if (assoc-ref options "processingMode")
87	`(#:processing-mode ,(assoc-ref options "processingMode"))
88	'())
89	,@(if (assoc-ref options "extractAllScripts")
90	`(#:extract-all-scripts?
91	,(assoc-ref options "extractAllScripts"))
92	'())
93	,@(if (json-has-key? options "compactArrays")
94	`(#:compact-arrays? ,(assoc-ref options "compactArrays"))
95	'())))))
96	((member "jld:ExpandTest" type)
97	(expand (string-append jsonld-test-url input)
98	#:options
99	(apply
100	new-jsonld-options
101	#:ordered? #t
102	#:document-loader document-loader
103	`(,@(if (assoc-ref options "base")
104	`(#:base ,(assoc-ref options "base"))
105	'())
106	,@(if (assoc-ref options "extractAllScripts")
107	`(#:extract-all-scripts?
108	,(assoc-ref options "extractAllScripts"))
109	'())
110	,@(if (assoc-ref options "processingMode")
111	`(#:processing-mode ,(assoc-ref options "processingMode"))
112	'())
113	,@(if (assoc-ref options "expandContext")
114	`(#:expand-context ,(string-append jsonld-test-url
115	(assoc-ref options "expandContext")))
116	'())))))
117	((member "jld:FlattenTest" type)
118	(flatten (string-append jsonld-test-url input)
119	#:context
120	(if context
121	(string-append jsonld-test-url context)
122	#f)
123	#:options
124	(apply
125	new-jsonld-options
126	#:ordered? #t
127	#:document-loader document-loader
128	`(,@(if (assoc-ref options "base")
129	`(#:base ,(assoc-ref options "base"))
130	'())
131	,@(if (assoc-ref options "processingMode")
132	`(#:processing-mode ,(assoc-ref options "processingMode"))
133	'())
134	,@(if (assoc-ref options "extractAllScripts")
135	`(#:extract-all-scripts?
136	,(assoc-ref options "extractAllScripts"))
137	'())
138	,@(if (json-has-key? options "compactArrays")
139	`(#:compact-arrays? ,(assoc-ref options "compactArrays"))
140	'())))))
141	((member "jld:ToRDFTest" type)
142	(when (equal? requires "GeneralizedRdf")
143	(throw 'cannot-run-test "Expected file is not in a valid nquads format"))
144	(jsonld->rdf (string-append jsonld-test-url input)
145	#:options
146	(apply
147	new-jsonld-options
148	#:ordered? #t
149	#:document-loader document-loader
150	`(,@(if (assoc-ref options "base")
151	`(#:base ,(assoc-ref options "base"))
152	'())
153	,@(if (assoc-ref options "processingMode")
154	`(#:processing-mode ,(assoc-ref options "processingMode"))
155	'())
156	,@(if (assoc-ref options "produceGeneralizedRdf")
157	`(#:produce-generalized-rdf? #t)
158	`(#:produce-generalized-rdf? #f))
159	,@(if (assoc-ref options "expandContext")
160	`(#:expand-context ,(string-append
161	jsonld-test-url
162	(assoc-ref options "expandContext")))
163	'())
164	,@(if (assoc-ref options "rdfDirection")
165	`(#:rdf-direction
166	,(assoc-ref options "rdfDirection"))
167	'())))))
168	((member "jld:FromRDFTest" type)
169	(rdf->jsonld (download-nq (string-append jsonld-test-url input))
170	#:options
171	(apply
172	new-jsonld-options
173	#:ordered? #t
174	#:document-loader document-loader
175	`(,@(if (assoc-ref options "base")
176	`(#:base ,(assoc-ref options "base"))
177	'())
178	,@(if (assoc-ref options "processingMode")
179	`(#:processing-mode ,(assoc-ref options "processingMode"))
180	'())
181	,@(if (assoc-ref options "produceGeneralizedRdf")
182	`(#:produce-generalized-rdf? #t)
183	`(#:produce-generalized-rdf? #f))
184	,@(if (assoc-ref options "expandContext")
185	`(#:expand-context ,(string-append
186	jsonld-test-url
187	(assoc-ref options "expandContext")))
188	'())
189	,@(if (assoc-ref options "useNativeTypes")
190	`(#:use-native-types? #t)
191	'())
192	,@(if (assoc-ref options "useRdfType")
193	`(#:use-rdf-type? #t)
194	'())
195	,@(if (assoc-ref options "rdfDirection")
196	`(#:rdf-direction
197	,(assoc-ref options "rdfDirection"))
198	'())))))
199	(else (throw 'unrecognized-test type)))))
200
201	(define (run-test test)
202	"Run one test described by the Json object @var{test}, whose @var{id} is
203	an identifier. @var{id} is used as the test number for the test driver. Return
204	is undefined. As a side-effect, outputs one line on the standard output to
205	report the test status."
206	(let* ((document (test-case-document test))
207	(description (or (assoc-ref document "purpose") (test-case-name test)))
208	(description (string-append (test-case-id test) ": " description))
209	(expect (assoc-ref document "expect"))
210	(expect-error (assoc-ref document "expectErrorCode"))
211	(type (array->list (assoc-ref document "@type")))
212	(option (assoc-ref document "option"))
213	(result
214	(catch #t
215	(lambda ()
216	(execute-test test))
217	(lambda (key . value)
218	(cons key value)))))
219	(if (member "jld:NegativeEvaluationTest" type)
220	(match result
221	(((? symbol? key) . value)
222	(cond
223	((equal? key 'unrecognized-test)
224	(update-test-case test
225	#:result 'skip
226	#:reason "unrecognized test type"))
227	((equal? key 'unsupported-spec)
228	(update-test-case test
229	#:result 'skip
230	#:reason "unsupported specification version"))
231	((equal? key 'unsupported-version-test)
232	(update-test-case test
233	#:result 'skip
234	#:reason "unsupported JsonLD version"))
235	((equal? key 'cannot-run-test)
236	(update-test-case test
237	#:result 'skip
238	#:reason (format #f "impossible to run test: ~a" value)))
239	((equal? (jsonld-error->string key) expect-error)
240	(update-test-case test #:result 'pass))
241	(else
242	(update-test-case test
243	#:result 'fail
244	#:reason (format #f "Expected ~a but got ~a: ~a"
245	expect-error key value)))))
246	(_ (begin
247	(update-test-case test
248	#:result 'fail
249	#:reason (format #f "Expected ~a but got success"
250	expect-error)))))
251	(match result
252	(((? symbol? key) . value)
253	(cond
254	((equal? key 'unrecognized-test)
255	(update-test-case test
256	#:result 'skip
257	#:reason "unrecognized test type"))
258	((equal? key 'unsupported-spec)
259	(update-test-case test
260	#:result 'skip
261	#:reason "unsupported specification version"))
262	((equal? key 'unsupported-version-test)
263	(update-test-case test
264	#:result 'skip
265	#:reason "unsupported JsonLD version"))
266	((equal? key 'cannot-run-test)
267	(update-test-case test
268	#:result 'skip
269	#:reason (format #f "impossible to run test: ~a" value)))
270	(else
271	(update-test-case test
272	#:result 'fail
273	#:reason (format #f "Expected success but got ~a: ~a"
274	key value)))))
275	(_ (if (member "jld:PositiveSyntaxTest" type)
276	(update-test-case test #:result 'pass)
277	(let ((expected (download-document
278	(string-append jsonld-test-url expect))))
279	(if (good-result? result expected)
280	(update-test-case test #:result 'pass)
281	(update-test-case test
282	#:result 'fail
283	#:reason (format #f "Expected ~a but got ~a"
284	expected result))))))))))
285
286	(define (run-tests tests expected-failures driver)
287	"Run all the tests of the @var{tests} test suite, using identifiers starting
288	from @var{id}. Return is undefined."
289	(fold
290	(lambda (test results)
291	(let* ((result (run-test test))
292	(result
293	(if (assoc-ref expected-failures (test-case-id test))
294	(update-test-case result
295	#:result (cond
296	((equal? 'skip (test-case-result result))
297	'skip)
298	((equal? 'fail (test-case-result result))
299	'xfail)
300	((equal? 'pass (test-case-result result))
301	'xpass))
302	#:reason (assoc-ref expected-failures (test-case-id test)))
303	result)))
304	((test-driver-print driver) result)
305	(cons result results)))
306	'()
307	tests))
308
309	(define (get-test-doc url)
310	"Get a test suite object from the manifest at @var{url}."
311	(assoc-ref (json-document-document (download-json url)) "sequence"))
312
313	(define* (get-test-plan url #:key (num 1))
314	(define document (get-test-doc url))
315
316	(cdr
317	(fold
318	(lambda (test result)
319	(let* ((num (car result))
320	(result (cdr result))
321	(name (assoc-ref test "name"))
322	(@id (assoc-ref test "@id"))
323	(name (string-append @id ": " name))
324	(context (string-join
325	(reverse (cdr (reverse (string-split url #\.))))
326	"."))
327	(description (or (assoc-ref test "purpose") name))
328	(description (string-append @id ": " description)))
329	(cons (+ 1 num)
330	(cons (make-test-case (string-append context @id)
331	num name description test #f #f)
332	result))))
333	`(,num . ())
334	(array->list document))))
335
336	(define (run-test-suite manifest expected-failures driver)
337	"Run a test suite described by @var{manifest}."
338	(let* ((plan (reverse (get-test-plan manifest))))
339	((test-driver-init driver) plan)
340	((test-driver-finalize driver) (run-tests plan expected-failures driver))))
341
342	(define (run-test-suites manifests expected-failures driver)
343	"Run multiple test suites described by @var{manifests}."
344	(let* ((plan
345	(fold
346	(lambda (manifest plan)
347	(append plan (reverse (get-test-plan
348	manifest #:num (+ (length plan) 1)))))
349	'()
350	manifests)))
351	((test-driver-init driver) plan)
352	((test-driver-finalize driver) (run-tests plan expected-failures driver))))
353