Switch tests to srfi-64

Julien LepillerWed Oct 07 01:14:41+0200 2020

5118e5d

Switch tests to srfi-64

Makefile.am

2525 
  tests/turtle.scm
2626 
2727 
TEST_EXTENSIONS = .scm
28-
SCM_LOG_DRIVER = env AM_TAP_AWK='$(AWK)' $(SHELL) $(top_srcdir)/tap-driver.sh --color-tests yes --ignore-exit
28+
SCM_LOG_DRIVER = \
29+
  $(top_builddir)/pre-inst-env $(GUILE) --no-auto-compile -e main \
30+
  $(top_srcdir)/test-driver.scm
2931 
TESTS = tests/turtle.scm tests/semantics.scm tests/nquads.scm
30-
EXTRA_DIST += $(TEST_MODULES)
32+
EXTRA_DIST += $(TEST_MODULES) test-driver.scm
guix.scm
4343 
        "00l03j8ajkd1a7sg1zycbpdaz71mscrncw7rwjzqk2ia6j04rwxm"))))
4444 
  (build-system gnu-build-system)
4545 
  (inputs
46-
   `(("guile" ,guile-next)))
46+
   `(("guile" ,guile-3.0)))
4747 
  (native-inputs
4848 
   `(("automake" ,automake)
4949 
     ("autoconf" ,autoconf)
test-driver.scm unknown status 1
1+
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
2+
3+
(define script-version "2017-03-22.13") ;UTC
4+
5+
;;; Copyright ?? 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
6+
;;;
7+
;;; This program is free software; you can redistribute it and/or modify it
8+
;;; under the terms of the GNU General Public License as published by
9+
;;; the Free Software Foundation; either version 3 of the License, or (at
10+
;;; your option) any later version.
11+
;;;
12+
;;; This program is distributed in the hope that it will be useful, but
13+
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14+
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15+
;;; GNU General Public License for more details.
16+
;;;
17+
;;; You should have received a copy of the GNU General Public License
18+
;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
19+
20+
;;;; Commentary:
21+
;;;
22+
;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
23+
;;; test suites.  SRFI-64 is distributed with Guile since version 2.0.9.
24+
;;;
25+
;;;; Code:
26+
27+
(use-modules (ice-9 getopt-long)
28+
             (ice-9 pretty-print)
29+
             (srfi srfi-26)
30+
             (srfi srfi-64))
31+
32+
(define (show-help)
33+
  (display "Usage:
34+
   test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
35+
               [--expect-failure={yes|no}] [--color-tests={yes|no}]
36+
               [--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
37+
               TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
38+
The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
39+
40+
(define %options
41+
  '((test-name                 (value #t))
42+
    (log-file                  (value #t))
43+
    (trs-file                  (value #t))
44+
    (color-tests               (value #t))
45+
    (expect-failure            (value #t)) ;XXX: not implemented yet
46+
    (enable-hard-errors        (value #t)) ;not implemented in SRFI-64
47+
    (brief                     (value #t))
48+
    (help    (single-char #\h) (value #f))
49+
    (version (single-char #\V) (value #f))))
50+
51+
(define (option->boolean options key)
52+
  "Return #t if the value associated with KEY in OPTIONS is \"yes\"."
53+
  (and=> (option-ref options key #f) (cut string=? <> "yes")))
54+
55+
(define* (test-display field value  #:optional (port (current-output-port))
56+
                       #:key pretty?)
57+
  "Display \"FIELD: VALUE\\n\" on PORT."
58+
  (if pretty?
59+
      (begin
60+
        (format port "~A:~%" field)
61+
        (pretty-print value port #:per-line-prefix "+ "))
62+
      (format port "~A: ~S~%" field value)))
63+
64+
(define* (result->string symbol #:key colorize?)
65+
  "Return SYMBOL as an upper case string.  Use colors when COLORIZE is #t."
66+
  (let ((result (string-upcase (symbol->string symbol))))
67+
    (if colorize?
68+
        (string-append (case symbol
69+
                         ((pass)       "")  ;green
70+
                         ((xfail)      "")  ;light green
71+
                         ((skip)       "")  ;blue
72+
                         ((fail xpass) "")  ;red
73+
                         ((error)      "")) ;magenta
74+
                       result
75+
                       "")          ;no color
76+
        result)))
77+
78+
(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
79+
  "Return an custom SRFI-64 test runner.  TEST-NAME is a string specifying the
80+
file name of the current the test.  COLOR? specifies whether to use colors,
81+
and BRIEF?, well, you know.  OUT-PORT and TRS-PORT must be output ports.  The
82+
current output port is supposed to be redirected to a '.log' file."
83+
84+
  (define (test-on-test-begin-gnu runner)
85+
    ;; Procedure called at the start of an individual test case, before the
86+
    ;; test expression (and expected value) are evaluated.
87+
    (let ((result (cute assq-ref (test-result-alist runner) <>)))
88+
      (format #t "test-name: ~A~%" (result 'test-name))
89+
      (format #t "location: ~A~%"
90+
              (string-append (result 'source-file) ":"
91+
                             (number->string (result 'source-line))))
92+
      (test-display "source" (result 'source-form) #:pretty? #t)))
93+
94+
  (define (test-on-test-end-gnu runner)
95+
    ;; Procedure called at the end of an individual test case, when the result
96+
    ;; of the test is available.
97+
    (let* ((results (test-result-alist runner))
98+
           (result? (cut assq <> results))
99+
           (result  (cut assq-ref results <>)))
100+
      (unless brief?
101+
        ;; Display the result of each test case on the console.
102+
        (format out-port "~A: ~A - ~A~%"
103+
                (result->string (test-result-kind runner) #:colorize? color?)
104+
                test-name (test-runner-test-name runner)))
105+
      (when (result? 'expected-value)
106+
        (test-display "expected-value" (result 'expected-value)))
107+
      (when (result? 'expected-error)
108+
        (test-display "expected-error" (result 'expected-error) #:pretty? #t))
109+
      (when (result? 'actual-value)
110+
        (test-display "actual-value" (result 'actual-value)))
111+
      (when (result? 'actual-error)
112+
        (test-display "actual-error" (result 'actual-error) #:pretty? #t))
113+
      (format #t "result: ~a~%" (result->string (result 'result-kind)))
114+
      (newline)
115+
      (format trs-port ":test-result: ~A ~A~%"
116+
              (result->string (test-result-kind runner))
117+
              (test-runner-test-name runner))))
118+
119+
  (define (test-on-group-end-gnu runner)
120+
    ;; Procedure called by a 'test-end', including at the end of a test-group.
121+
    (let ((fail (or (positive? (test-runner-fail-count runner))
122+
                    (positive? (test-runner-xpass-count runner))))
123+
          (skip (or (positive? (test-runner-skip-count runner))
124+
                    (positive? (test-runner-xfail-count runner)))))
125+
      ;; XXX: The global results need some refinements for XPASS.
126+
      (format trs-port ":global-test-result: ~A~%"
127+
              (if fail "FAIL" (if skip "SKIP" "PASS")))
128+
      (format trs-port ":recheck: ~A~%"
129+
              (if fail "yes" "no"))
130+
      (format trs-port ":copy-in-global-log: ~A~%"
131+
              (if (or fail skip) "yes" "no"))
132+
      (when brief?
133+
        ;; Display the global test group result on the console.
134+
        (format out-port "~A: ~A~%"
135+
                (result->string (if fail 'fail (if skip 'skip 'pass))
136+
                                #:colorize? color?)
137+
                test-name))
138+
      #f))
139+
140+
  (let ((runner (test-runner-null)))
141+
    (test-runner-on-test-begin! runner test-on-test-begin-gnu)
142+
    (test-runner-on-test-end! runner test-on-test-end-gnu)
143+
    (test-runner-on-group-end! runner test-on-group-end-gnu)
144+
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
145+
    runner))
146+
147+

148+
;;;
149+
;;; Entry point.
150+
;;;
151+
152+
(define (main . args)
153+
  (let* ((opts   (getopt-long (command-line) %options))
154+
         (option (cut option-ref opts <> <>)))
155+
    (cond
156+
     ((option 'help #f)    (show-help))
157+
     ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
158+
     (else
159+
      (let ((log (open-file (option 'log-file "") "w0"))
160+
            (trs (open-file (option 'trs-file "") "wl"))
161+
            (out (duplicate-port (current-output-port) "wl")))
162+
        (redirect-port log (current-output-port))
163+
        (redirect-port log (current-warning-port))
164+
        (redirect-port log (current-error-port))
165+
        (test-with-runner
166+
            (test-runner-gnu (option 'test-name #f)
167+
                             #:color? (option->boolean opts 'color-tests)
168+
                             #:brief? (option->boolean opts 'brief)
169+
                             #:out-port out #:trs-port trs)
170+
          (load-from-path (option 'test-name #f)))
171+
        (close-port log)
172+
        (close-port trs)
173+
        (close-port out))))
174+
    (exit 0)))
175+
176+
;;; Local Variables:
177+
;;; eval: (add-hook 'write-file-functions 'time-stamp)
178+
;;; time-stamp-start: "(define script-version \""
179+
;;; time-stamp-format: "%:y-%02m-%02d.%02H"
180+
;;; time-stamp-time-zone: "UTC"
181+
;;; time-stamp-end: "\") ;UTC"
182+
;;; End:
183+
184+
;;;; test-driver.scm ends here.
test-modules/online.scm
1717 
1818 
(define-module (test-modules online)
1919 
  #:use-module (ice-9 match)
20-
  #:use-module (rnrs bytevectors)
21-
  #:use-module (srfi srfi-1)
22-
  #:use-module (test-modules result)
20+
  #:use-module (ice-9 binary-ports)
21+
  #:use-module (nquads tordf)
2322 
  #:use-module ((rdf entailment rdf) #:prefix rdf:)
2423 
  #:use-module ((rdf entailment rdfs) #:prefix rdfs:)
2524 
  #:use-module ((rdf entailment simple) #:prefix simple:)
2625 
  #:use-module (rdf rdf)
2726 
  #:use-module ((rdf xsd) #:prefix xsd:)
28-
  #:use-module (srfi srfi-1)
29-
  #:use-module (nquads tordf)
27+
  #:use-module (rnrs bytevectors)
28+
  #:use-module (srfi srfi-64)
29+
  #:use-module (test-modules test-case)
3030 
  #:use-module (turtle tordf)
3131 
  #:use-module (web client)
3232 
  #:use-module (web response)
33-
  #:export (run-test-suite
34-
            run-test-suites))
35-
36-
(define (find-rest node graph)
37-
  (rdf-triple-object
38-
    (car
39-
      (filter
40-
        (lambda (triple)
41-
          (and (equal? (rdf-triple-subject triple) node)
42-
               (equal? (rdf-triple-predicate triple)
43-
                       (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
44-
                                      "#rest"))))
45-
        graph))))
46-
47-
(define (find-first node graph)
48-
  (rdf-triple-object
49-
    (car
50-
      (filter
51-
        (lambda (triple)
52-
          (and (equal? (rdf-triple-subject triple) node)
53-
               (equal? (rdf-triple-predicate triple)
54-
                       (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
55-
                                      "#first"))))
56-
        graph))))
57-
58-
(define (find-list node graph)
59-
  (if (blank-node? node)
60-
      (let loop ((node node) (result '()))
61-
        (let ((first (find-first node graph))
62-
              (node (find-rest node graph)))
63-
          (if (blank-node? node)
64-
              (loop node (cons first result))
65-
              (cons first result))))
66-
      '()))
67-
68-
(define (get-objects triples predicate)
69-
  (map
70-
    rdf-triple-object
71-
    (filter
72-
      (lambda (t)
73-
        (equal? (rdf-triple-predicate t) predicate))
74-
      triples)))
75-
76-
(define (lexical->value value)
77-
  (cond
78-
    ((rdf-literal? value)
79-
     (rdf-literal-lexical-form value))
80-
    ((blank-node? value)
81-
     (string-append "_:" (number->string value)))
82-
    (else value)))
33+
  #:export (run-test-suite))
8334 
84-
(define (execute-test test)
85-
  (let* ((predicates (test-case-document test))
86-
         (type (car (get-objects predicates "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))
87-
         (type (car (reverse (string-split type #\#))))
88-
         (action (car (get-objects predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action"))))
89-
    (cond
90-
      ((member type '("TestTurtlePositiveSyntax" "TestTurtleNegativeSyntax"
91-
                      "TestTurtleEval" "TestTurtleNegativeEval"
92-
                      "PositiveEntailmentTest" "NegativeEntailmentTest"))
93-
       (turtle->rdf (get-test-doc action) action))
94-
      ((member type '("TestNQuadsNegativeSyntax" "TestNQuadsPositiveSyntax"))
95-
       (nquads->rdf (get-test-doc action))))))
9635 
9736 
(define (run-test test)
98-
  (let* ((predicates (test-case-document test))
99-
         (type (car (get-objects predicates "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))
100-
         (type (car (reverse (string-split type #\#))))
101-
         (result
102-
           (catch #t
103-
             (lambda ()
104-
               (execute-test test))
105-
             (lambda (key . value)
106-
               (cons key value)))))
107-
    (cond
108-
      ((member type '("TestTurtlePositiveSyntax" "TestTriGPositiveSyntax"
109-
                      "TestNTriplesPositiveSyntax" "TestNQuadsPositiveSyntax"))
110-
       (match result
111-
         (((? symbol? key) . value)
112-
          (update-test-case test
113-
            #:result 'fail
114-
            #:reason (format #f "failed with ~a: ~a" key value)))
115-
         (_ (update-test-case test #:result 'pass))))
116-
      ((member type '("TestTurtleNegativeSyntax" "TestTriGNegativeSyntax"
117-
                      "TestNTriplesNegativeSyntax" "TestNQuadsNegativeSyntax"
118-
                      "TestXMLNegativeSyntax" "TestTurtleNegativeEval"))
119-
       (match result
120-
         (((? symbol? key) . value) (update-test-case test #:result 'pass))
121-
         (_ (update-test-case test
122-
              #:result 'fail
123-
              #:reason "Expected failure but got success"))))
124-
      ((equal? type "TestTurtleEval")
125-
       (let* ((expected (car (get-objects predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#result")))
126-
              (expected
127-
                (catch #t
128-
                  (lambda ()
129-
                    (if (string? expected)
130-
                        (turtle->rdf (get-test-doc expected) expected)
131-
                        #f))
132-
                  (lambda (key . value)
133-
                    (cons key value)))))
134-
         (match result
135-
           (((? symbol? key) . value)
136-
            (update-test-case test
137-
              #:result 'fail
138-
              #:reason (format #f "failed with ~a: ~a" key value)))
139-
           (_
140-
             (if (rdf-isomorphic? result expected)
141-
                 (update-test-case test #:result 'pass)
142-
                 (update-test-case test
143-
                   #:result 'fail
144-
                   #:reason (format #f "expected ~a but got ~a"
145-
                                    expected result)))))))
146-
      ((member type '("PositiveEntailmentTest" "NegativeEntailmentTest"))
147-
       (pk 'predicates predicates)
148-
       (let* ((regime (rdf-literal-lexical-form
149-
                        (car
150-
                          (get-objects
151-
                            predicates
152-
                            (string-append
153-
                              "http://www.w3.org/2001/sw/DataAccess/tests/"
154-
                              "test-manifest#entailmentRegime")))))
155-
              (recognized
156-
                (car
157-
                  (pk 'recognized-nodes
158-
                  (get-objects
159-
                    predicates
160-
                    (string-append "http://www.w3.org/2001/sw/DataAccess/tests/"
161-
                                   "test-manifest#recognizedDatatypes"))))
162-
                )
163-
              (recognized (pk 'lst-reco (find-list recognized predicates)))
164-
              (recognized
165-
                (map
166-
                  (lambda (iri)
167-
                    (let loop ((types (cons* rdf:XMLLiteral rdf:langString
168-
                                             xsd:datatypes)))
169-
                      (match types
170-
                        (() (throw 'didnotrecognize iri))
171-
                        ((type types ...)
172-
                         (if (member iri (rdf-datatype-iris type))
173-
                             (pk 'recognized-type type)
174-
                             (loop types))))))
175-
                  recognized))
176-
              (recognized (pk 'reco (append (list xsd:string rdf:langString) recognized)))
177-
              (vocabulary (make-rdf-vocabulary recognized xsd:order xsd:compatible?))
178-
              (expected
179-
                (car
180-
                  (get-objects
181-
                    predicates
182-
                    (string-append "http://www.w3.org/2001/sw/DataAccess/tests/"
183-
                                   "test-manifest#result"))))
184-
              (expected
185-
                (catch #t
186-
                  (lambda ()
187-
                    (if (string? expected)
188-
                        (turtle->rdf (get-test-doc expected) expected)
189-
                        #f))
190-
                  (lambda (key . value)
191-
                    (cons key value)))))
192-
         (match regime
193-
           ("simple"
194-
            (if (if (equal? expected #f)
195-
                    (not (simple:consistent-graph? result))
196-
                    (simple:entails? result expected))
197-
                (if (equal? type "PositiveEntailmentTest")
198-
                    (update-test-case test #:result 'pass)
199-
                    (update-test-case test
200-
                      #:result 'fail
201-
                      #:reason "Expected negative result, got positive"))
202-
                (if (equal? type "PositiveEntailmentTest")
203-
                    (update-test-case test
204-
                      #:result 'fail
205-
                      #:reason (format #f "Expected positive result, got negative"))
206-
                    (update-test-case test #:result 'pass))))
207-
           ("RDF"
208-
            (if (if (equal? expected #f)
209-
                    (not (rdf:consistent-graph? result vocabulary))
210-
                    (rdf:entails? result expected vocabulary))
211-
                (if (equal? type "PositiveEntailmentTest")
212-
                    (update-test-case test #:result 'pass)
213-
                    (update-test-case test
214-
                      #:result 'fail
215-
                      #:reason "Expected negative result, got positive"))
216-
                (if (equal? type "PositiveEntailmentTest")
217-
                    (update-test-case test
218-
                      #:result 'fail
219-
                      #:reason (format #f "Expected positive result, got negative"))
220-
                    (update-test-case test #:result 'pass))))
221-
           ("RDFS"
222-
            (if (if (equal? expected #f)
223-
                    (not (rdfs:consistent-graph? result vocabulary))
224-
                    (rdfs:entails? result expected vocabulary))
225-
                (if (equal? type "PositiveEntailmentTest")
226-
                    (update-test-case test #:result 'pass)
227-
                    (update-test-case test
228-
                      #:result 'fail
229-
                      #:reason "Expected negative result, got positive"))
230-
                (if (equal? type "PositiveEntailmentTest")
231-
                    (update-test-case test
232-
                      #:result 'fail
233-
                      #:reason (format #f "Expected positive result, got negative"))
234-
                    (update-test-case test #:result 'pass))))
235-
           (_ (update-test-case test
236-
                #:result 'skip
237-
                #:reason (format #f "Unrecognized entailment regime: ~a"
238-
                                 regime))))))
239-
      (else
240-
        (update-test-case test
241-
          #:result 'skip
242-
          #:reason (format #f "Unrecognized test type: ~a" type))))))
243-
244-
(define (run-tests tests expected-failures driver)
245-
  "Run all the tests of the @var{tests} test suite, using identifiers starting
246-
from @var{id}.  Return is undefined."
247-
  (fold
248-
    (lambda (test results)
249-
      (let* ((result (run-test test))
250-
             (result
251-
               (if (assoc-ref expected-failures (test-case-id test))
252-
                   (update-test-case result
253-
                     #:result (cond
254-
                                ((equal? 'skip (test-case-result result))
255-
                                 'skip)
256-
                                ((equal? 'fail (test-case-result result))
257-
                                 'xfail)
258-
                                ((equal? 'pass (test-case-result result))
259-
                                 'xpass))
260-
                     #:reason (assoc-ref expected-failures (test-case-id test)))
261-
                   result)))
262-
        ((test-driver-print driver) result)
263-
        (cons result results)))
264-
    '()
265-
    tests))
37+
  (define (entailment-test action-doc action regime vocabulary expected-doc)
38+
    "Run an entailment test."
39+
    (let ((result (turtle->rdf action-doc action))
40+
          (entails? (match regime
41+
                      ("simple" simple:entails?)
42+
                      ("RDF"
43+
                       (lambda (g e)
44+
                         (rdf:entails? g e vocabulary)))
45+
                      ("RDFS"
46+
                       (lambda (g e)
47+
                         (rdfs:entails? g e vocabulary)))
48+
                      (_ (throw 'unknown-regime regime))))
49+
          (consistent-graph?
50+
            (match regime
51+
              ("simple" simple:consistent-graph?)
52+
              ("RDF" (lambda (g)
53+
                       (rdf:consistent-graph? g vocabulary)))
54+
              ("RDFS" (lambda (g)
55+
                        (rdfs:consistent-graph? g vocabulary))))))
56+
      (if expected-doc
57+
          (entails? result expected-doc)
58+
          (not (consistent-graph? result)))))
59+
60+
  (match test
61+
    (($ test-case type name regime recognized unrecognized action result)
62+
     (let ((action-doc (get-test-doc action))
63+
           (vocabulary (make-rdf-vocabulary
64+
                         (cons* xsd:string rdf:langString recognized)
65+
                         xsd:order xsd:compatible?))
66+
           (expected-doc (if result
67+
                             (turtle->rdf (get-test-doc result) result)
68+
                             #f)))
69+
       (match type
70+
         ("TestTurtlePositiveSyntax"
71+
          (test-assert name (turtle->rdf action-doc action)))
72+
         ("TestTurtleNegativeSyntax"
73+
          (test-error name #t (turtle->rdf action-doc action)))
74+
         ("TestTurtleNegativeEval"
75+
          (test-error name #t (turtle->rdf action-doc action)))
76+
         ("TestTurtleEval"
77+
          (test-assert name (rdf-isomorphic? (turtle->rdf action-doc action)
78+
                                             expected-doc)))
79+
         ("TestNQuadsPositiveSyntax"
80+
          (test-assert name (nquads->rdf action-doc)))
81+
         ("TestNQuadsNegativeSyntax"
82+
          (test-error name #t (nquads->rdf action-doc)))
83+
         ("PositiveEntailmentTest"
84+
          (test-assert name (entailment-test action-doc action regime vocabulary
85+
                                             expected-doc)))
86+
         ("NegativeEntailmentTest"
87+
          (test-assert name
88+
                       (not (entailment-test action-doc action regime vocabulary
89+
                                             expected-doc))))
90+
         (_ (throw 'unrecognized-type type)))))))
26691 
26792 
(define (get-test-doc url)
26893 
  "Get a test suite object from the manifest at @var{url}."
269-
  (call-with-values
270-
    (lambda ()
271-
      (http-get url))
272-
    (lambda (hdr body)
273-
      (if (equal? (response-code hdr) 200)
274-
          (if (string? body)
275-
              body
276-
              (utf8->string body))
277-
          (throw 'error-fetching-test-manifest (response-code hdr))))))
278-
279-
(define* (get-test-plan url #:key (num 1))
280-
  (define document (get-test-doc url))
281-
282-
  (define manifest (turtle->rdf document url))
283-
284-
  (define tests-node
285-
    (rdf-triple-object
286-
      (car
287-
        (filter
288-
          (lambda (triple)
289-
            (and (equal? (rdf-triple-subject triple) url)
290-
                 (equal? (rdf-triple-predicate triple)
291-
                         (string-append "http://www.w3.org/2001/sw/DataAccess/"
292-
                                        "tests/test-manifest#entries"))))
293-
          manifest))))
294-
295-
  (define tests (find-list tests-node manifest))
296-
297-
  (define (subgraph-at graph node)
298-
    (let ((nodes (filter
299-
                   (lambda (t)
300-
                     (equal? (rdf-triple-subject t) node))
301-
                   graph)))
302-
      (if (null? nodes)
303-
          '()
304-
          (apply append nodes
305-
                 (map
306-
                   (lambda (n)
307-
                     (subgraph-at graph (rdf-triple-object n)))
308-
                   nodes)))))
309-
310-
  (cdr
311-
    (fold
312-
      (lambda (test result)
313-
        (let* ((num (car result))
314-
               (result (cdr result))
315-
               (test-predicates (subgraph-at manifest test))
316-
               (name (lexical->value (car (get-objects test-predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#name"))))
317-
               (description (lexical->value (car (get-objects test-predicates "http://www.w3.org/2000/01/rdf-schema#comment")))))
318-
          (cons (+ 1 num)
319-
                (cons (make-test-case test num name description test-predicates
320-
                                      #f #f)
321-
                      result))))
322-
      `(,num . ())
323-
      tests)))
324-
325-
(define (run-test-suite manifest expected-failures driver)
326-
  "Run a test suite described by @var{manifest}."
327-
  (let* ((plan (reverse (get-test-plan manifest))))
328-
    ((test-driver-init driver) plan)
329-
    ((test-driver-finalize driver) (run-tests plan expected-failures driver))))
33094 
331-
(define (run-test-suites manifests expected-failures driver)
332-
  "Run multiple test suites described by @var{manifests}."
333-
  (let* ((plan
334-
           (fold
335-
             (lambda (manifest plan)
336-
               (append plan (reverse (get-test-plan
337-
                                       manifest #:num (+ (length plan) 1)))))
338-
             '()
339-
             manifests)))
340-
    ((test-driver-init driver) plan)
341-
    ((test-driver-finalize driver) (run-tests plan expected-failures driver))))
95+
  (define cache-filename
96+
    (string-append "test-files/" (substring url
97+
                                            (string-length "http://www.w3.org/2013/"))))
98+
99+
  (if (file-exists? cache-filename)
100+
      (let ((bv (call-with-input-file cache-filename get-bytevector-all)))
101+
        (if (eof-object? bv)
102+
            ""
103+
            (utf8->string bv)))
104+
      (call-with-values
105+
        (lambda ()
106+
          (http-get url))
107+
        (lambda (hdr body)
108+
          (if (equal? (response-code hdr) 200)
109+
              (if (string? body)
110+
                  body
111+
                  (utf8->string body))
112+
              (throw 'error-fetching-test-manifest (response-code hdr)))))))
113+
114+
(define (run-test-suite manifest expected-failures name)
115+
  (test-begin name)
116+
  (let ((plan (rdf->test-plan
117+
                 (turtle->rdf (get-test-doc manifest) manifest)
118+
                 manifest)))
119+
    (for-each run-test plan)
120+
    (test-end name)))
test-modules/result.scm unknown status 2
1-
;;;; Copyright (C) 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 result)
19-
  #:use-module (srfi srfi-9)
20-
  #:use-module (srfi srfi-19)
21-
  #:use-module (ice-9 match)
22-
  #:export (make-test-case
23-
            test-case?
24-
            test-case-id
25-
            test-case-num
26-
            test-case-name
27-
            test-case-document
28-
            test-case-result
29-
            test-case-reason
30-
            update-test-case
31-
32-
            make-test-driver
33-
            test-driver?
34-
            test-driver-init
35-
            test-driver-print
36-
            test-driver-finalize
37-
38-
            tap-driver
39-
            earl-driver))
40-
41-
;; A test case is the result of running a test.  It has an identifier, a name
42-
;; and a description.  Its result is a symbol, which can be 'skiped, 'pass,
43-
;; 'fail, 'xpass, or 'xfail.  The reason is a string or #f that explains the
44-
;; result
45-
(define-record-type test-case
46-
  (make-test-case id num name description document result reason)
47-
  test-case?
48-
  (id           test-case-id)
49-
  (num          test-case-num)
50-
  (name         test-case-name)
51-
  (description  test-case-description)
52-
  (document     test-case-document)
53-
  (result       test-case-result)
54-
  (reason       test-case-reason))
55-
56-
(define* (update-test-case test-case #:key
57-
                           (id           (test-case-id test-case))
58-
                           (num          (test-case-num test-case))
59-
                           (name         (test-case-name test-case))
60-
                           (description  (test-case-description test-case))
61-
                           (document     (test-case-document test-case))
62-
                           (result       (test-case-result test-case))
63-
                           (reason       (test-case-reason test-case)))
64-
  (make-test-case id num name description document result reason))
65-
66-
;; A test driver is called at the beginning, on each test result and at the
67-
;; end of the tests.
68-
(define-record-type test-driver
69-
  (make-test-driver init print finalize)
70-
  test-driver?
71-
  (init     test-driver-init) ; list test-case -> ()
72-
  (print    test-driver-print) ; test-case -> ()
73-
  (finalize test-driver-finalize)) ; list test-case -> ()
74-
75-
(define tap-driver
76-
  (make-test-driver
77-
    (lambda (cases)
78-
      (format #t "1..~a~%" (length cases)))
79-
    (match-lambda
80-
      (($ test-case id num name description document result reason)
81-
       (match result
82-
         ('skip
83-
          (format #t "ok ~a ~a # SKIP ~a~%" num name reason))
84-
         ('pass
85-
          (format #t "ok ~a ~a~%" num name))
86-
         ('fail
87-
          (format #t "not ok ~a ~a: ~a~%" num name reason))
88-
         ('xfail
89-
          (format #t "not ok ~a ~a # TODO ~a~%" num name reason))
90-
         ('xpass
91-
          (format #t "ok ~a ~a # TODO ~a~%" num name reason)))
92-
       (force-output)))
93-
    (const #t)))
94-
95-
(define (earl-driver port)
96-
  "A driver that creates a turtle file report using the earl vocabulary.  It
97-
doesn't use any internal representation for RDF or Turtle, it only manipulates
98-
strings."
99-
  (make-test-driver
100-
    (lambda (cases)
101-
      (format port "@prefix dc: <http://purl.org/dc/terms/> .~%")
102-
      (format port "@prefix earl: <http://www.w3.org/ns/earl#> .~%")
103-
      (format port "@prefix doap: <http://usefulinc.com/ns/doap#> .~%")
104-
      (format port "@prefix foaf: <http://xmlns.com/foaf/0.1/> .~%")
105-
      (format port "@prefix xsd: <http://www.w3.org/2001/XMLSchema#> .~%")
106-
      (format port "~%")
107-
      (format port "<https://framagit.org/tyreunom/guile-jsonld> a doap:Project;~%")
108-
      (format port "   dc:creator <https://lepiller.eu/#me>;~%")
109-
      (format port "   doap:bug-database <https://framait.org/tyreunom/guile-jsonld/issues>;~%")
110-
      (format port "   doap:description \"Guile implementation of the JsonLD API defined by the W3C.\"@en;~%")
111-
      (format port "   doap:developer <https://lepiller.eu/#me>;~%")
112-
      (format port "   doap:homepage <https://framagit.org/tyreunom/guile-jsonld/>;~%")
113-
      (format port "   doap:implements <https://www.w3.org/TR/json-ld11/>,~%")
114-
      (format port "     <https://www.w3.org/TR/json-ld11-api/>;~%")
115-
      (format port "   doap:license <https://www.gnu.org/licenses/gpl-3.0.html>;~%")
116-
      (format port "   doap:name \"guile-jsonld\"^^xsd:string;~%")
117-
      (format port "   doap:platform \"GNU Guile\"^^xsd:string;~%")
118-
      (format port "   doap:shortdesc \"JSON-LD support for GNU Guile.\"@en;~%")
119-
      (format port "   doap:release [~%")
120-
      (format port "      doap:name \"guile-jsonld-1.0-pre1\";~%")
121-
      (format port "      doap:revision \"1.0-pre1\";~%")
122-
      (format port "      doap:created \"2020-03-29\"^^xsd:date;~%")
123-
      (format port "   ] .~%")
124-
      (format port "~%")
125-
      (format port "<https://lepiller.eu/#me> a earl:Assertor, foaf:Person;~%")
126-
      (format port "   foaf:homepage <https://lepiller.eu>;~%")
127-
      (format port "   foaf:mbox <mailto:julien@lepiller.eu>;~%")
128-
      (format port "   foaf:name \"Julien Lepiller\"^^xsd:string .~%")
129-
      (format port "~%")
130-
      (format port "<> foaf:primaryTopic <https://framagit.org/tyreunom/guile-jsonld>;~%")
131-
      (format port "  dc:issued \"~a\"^^xsd:dateTime;~%"
132-
              (date->string (current-date) "~4"))
133-
      (format port "  foaf:maker <https://lepiller.eu/#me> .~%")
134-
      (format port "~%")
135-
      (format #t "~a test cases for report~%" (length cases)))
136-
    (lambda (test-case)
137-
      (format port "[ a earl:Assertion;~%")
138-
      (format port "  earl:assertedBy <https://lepiller.eu/#me>;~%")
139-
      (format port "  earl:subject <https://framagit.org/tyreunom/guile-jsonld>;~%")
140-
      (format port "  earl:test <~a>;~%" (test-case-id test-case))
141-
      (format port "  earl:result [~%")
142-
      (format port "    a earl:TestResult;~%")
143-
      (format port "    earl:outcome earl:~a;~%"
144-
              (match (test-case-result test-case)
145-
                ('skip "inapplicable")
146-
                ('pass "passed")
147-
                ('fail "failed")
148-
                ('xpass "cantTell")
149-
                ('xfail "untested")))
150-
      (format port "    dc:date \"~a\"^^xsd:dateTime~%"
151-
              (date->string (current-date) "~4"))
152-
      (format port "  earl:mode earl:automatic ] .~%")
153-
      (format port "~%")
154-
      (format #t "Tested ~a: ~a~%"
155-
              (test-case-num test-case) (test-case-result test-case)))
156-
    (lambda _
157-
      (close-port port))))
test-modules/test-case.scm unknown status 1
1+
;;;; Copyright (C) 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 test-case)
19+
  #:use-module (ice-9 match)
20+
  #:use-module (rdf rdf)
21+
  #:use-module ((rdf xsd) #:prefix xsd:)
22+
  #:use-module (srfi srfi-9)
23+
  #:export (test-case
24+
            make-test-case
25+
            test-case?
26+
            test-case-id
27+
            test-case-name
28+
            test-case-regime
29+
            test-case-recognized
30+
            test-case-unrecognized
31+
            test-case-action
32+
            test-case-result
33+
34+
            rdf->test-plan))
35+
36+
;; A test case is the result of running a test.  It has an identifier, a name
37+
;; and a description.  Its result is a symbol, which can be 'skiped, 'pass,
38+
;; 'fail, 'xpass, or 'xfail.  The reason is a string or #f that explains the
39+
;; result
40+
(define-record-type test-case
41+
  (make-test-case type name regime recognized unrecognized action result)
42+
  test-case?
43+
  (type         test-case-type)
44+
  (name         test-case-name)
45+
  (regime       test-case-regime)
46+
  (recognized   test-case-recognized)
47+
  (unrecognized test-case-unrecognized)
48+
  (action       test-case-action)
49+
  (result       test-case-result))
50+
51+
(define (find-rest node graph)
52+
  (rdf-triple-object
53+
    (car
54+
      (filter
55+
        (lambda (triple)
56+
          (and (equal? (rdf-triple-subject triple) node)
57+
               (equal? (rdf-triple-predicate triple)
58+
                       (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
59+
                                      "#rest"))))
60+
        graph))))
61+
62+
(define (find-first node graph)
63+
  (rdf-triple-object
64+
    (car
65+
      (filter
66+
        (lambda (triple)
67+
          (and (equal? (rdf-triple-subject triple) node)
68+
               (equal? (rdf-triple-predicate triple)
69+
                       (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"
70+
                                      "#first"))))
71+
        graph))))
72+
73+
(define (find-list node graph)
74+
  "When @var{node} represents a list, traverse it to find all its elements, and
75+
return a list of nodes corresponding to the elements of the list."
76+
  (if (blank-node? node)
77+
      (let loop ((node node) (result '()))
78+
        (let ((first (find-first node graph))
79+
              (node (find-rest node graph)))
80+
          (if (blank-node? node)
81+
              (loop node (cons first result))
82+
              (cons first result))))
83+
      '()))
84+
85+
(define (get-objects triples predicate)
86+
  "Return every objects in the @var{triples} that use @var{predicate}."
87+
  (map
88+
    rdf-triple-object
89+
    (filter
90+
      (lambda (t)
91+
        (equal? (rdf-triple-predicate t) predicate))
92+
      triples)))
93+
94+
(define (get-object triples predicate)
95+
  "Return the only object in the @var{triples} that uses @var{predicate}."
96+
  (match (get-objects triples predicate)
97+
    ((object) object)
98+
    (() #f)
99+
    (objects (throw 'too-many objects))))
100+
101+
(define (lexical->value value)
102+
  (cond
103+
    ((and (rdf-literal? value)
104+
          (equal? (rdf-literal-type value)
105+
                  "http://www.w3.org/2001/XMLSchema#boolean"))
106+
     (equal? (rdf-literal-lexical-form value) "true"))
107+
    ((rdf-literal? value)
108+
     (rdf-literal-lexical-form value))
109+
    ((blank-node? value)
110+
     (string-append "_:" (number->string value)))
111+
    (else value)))
112+
113+
(define (mf v)
114+
  (string-append "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#"
115+
                 v))
116+
(define (qt v)
117+
  (string-append "http://www.w3.org/2001/sw/DataAccess/tests/test-query#" v))
118+
(define (rdf v)
119+
  (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns#" v))
120+
(define (rdfs v)
121+
  (string-append "http://www.w3.org/2000/01/rdf-schema#" v))
122+
123+
(define (subgraph-at graph node)
124+
  "When @var{graph} is a list of triples, find the triples whose subjects is
125+
@var{node}, or the objects these triples, recursively.  Return the subgraph
126+
that is rooted at @var{node}."
127+
  (let ((nodes (filter
128+
                 (lambda (t)
129+
                   (equal? (rdf-triple-subject t) node))
130+
                 graph)))
131+
    (if (null? nodes)
132+
        '()
133+
        (apply append nodes
134+
               (map
135+
                 (lambda (n)
136+
                   (subgraph-at graph (rdf-triple-object n)))
137+
                 nodes)))))
138+
139+
(define (rdf->test-plan manifest url)
140+
  "Return a list of test-case objects from @var{manifest}, an rdf document that
141+
was downloaded from @var{url}."
142+
  (define tests-node
143+
    (get-object manifest (mf "entries")))
144+
145+
  ;;The list of test node IDs
146+
  (define tests
147+
    (find-list tests-node manifest))
148+
149+
  (map
150+
    (lambda (test-id)
151+
      (let* ((subgraph (subgraph-at manifest test-id))
152+
             (name (get-object subgraph (mf "name")))
153+
             (type (get-object subgraph (rdf "type")))
154+
             (action (get-object subgraph (mf "action")))
155+
             (regime (get-object subgraph (mf "entailmentRegime")))
156+
             (recognized (get-object subgraph (mf "recognizedDatatypes")))
157+
             (unrecognized (get-object subgraph (mf "unrecognizedDatatypes")))
158+
             (result (get-object subgraph (mf "result"))))
159+
        (make-test-case
160+
          (car (reverse (string-split type #\#)))
161+
          (lexical->value name)
162+
          (if regime (lexical->value regime) #f)
163+
          (if recognized
164+
              (map
165+
                (lambda (iri)
166+
                  ;; find types to recognize from the list of types below
167+
                  (let loop ((types (cons* rdf:XMLLiteral rdf:langString
168+
                                           xsd:datatypes)))
169+
                    (match types
170+
                      (() (throw 'didnotrecognize iri))
171+
                      ((type types ...)
172+
                       (if (member iri (rdf-datatype-iris type))
173+
                           type
174+
                           (loop types))))))
175+
                (find-list recognized subgraph))
176+
              '())
177+
          '(); XXX: unrecognized
178+
          (lexical->value action)
179+
          (lexical->value result))))
180+
    tests))
test-modules/testsuite.scm
1919 
  #:export (expected-failures
2020 
            turtle-test-manifest
2121 
            nquads-test-manifest
22-
            semantics-test-manifest))
22+
            semantics-test-manifest
23+
            manifests))
2324 
2425 
(define expected-failures
2526 
  '())
2627 
2728 
(define turtle-test-manifest "http://www.w3.org/2013/TurtleTests/manifest.ttl")
2829 
(define nquads-test-manifest "http://www.w3.org/2013/N-QuadsTests/manifest.ttl")
29-
(define semantics-test-manifest
30-
  "https://www.w3.org/2013/rdf-mt-tests/manifest.ttl")
30+
(define semantics-test-manifest "https://www.w3.org/2013/rdf-mt-tests/manifest.ttl")
31+
(define manifests
32+
  (list turtle-test-manifest nquads-test-manifest semantics-test-manifest))
tests/nquads.scm.in
1818 
;;;; 
1919 
2020 
(use-modules (test-modules online))
21-
(use-modules (test-modules result))
2221 
(use-modules (test-modules testsuite))
2322 
24-
(run-test-suite nquads-test-manifest expected-failures tap-driver)
23+
(run-test-suite nquads-test-manifest expected-failures "nquads")
tests/semantics.scm.in
1818 
;;;; 
1919 
2020 
(use-modules (test-modules online))
21-
(use-modules (test-modules result))
2221 
(use-modules (test-modules testsuite))
2322 
24-
(run-test-suite semantics-test-manifest expected-failures tap-driver)
23+
(run-test-suite semantics-test-manifest expected-failures "semantics")
tests/turtle.scm.in
1818 
;;;; 
1919 
2020 
(use-modules (test-modules online))
21-
(use-modules (test-modules result))
2221 
(use-modules (test-modules testsuite))
2322 
24-
(run-test-suite turtle-test-manifest expected-failures tap-driver)
23+
(run-test-suite turtle-test-manifest expected-failures "turtle")