;;;; Copyright (C) 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 (rnrs bytevectors)

  #:use-module (srfi srfi-1)

  #:use-module (test-modules result)

  #:use-module ((rdf entailment simple) #:prefix simple:)

  #:use-module (rdf rdf)

  #:use-module (srfi srfi-1)

  #:use-module (turtle tordf)

  #:use-module (web client)

  #:use-module (web response)

  #:export (run-test-suite

            run-test-suites))

(define (get-objects triples predicate)

  (map

    rdf-triple-object

    (filter

      (lambda (t)

        (equal? (rdf-triple-predicate t) predicate))

      triples)))

(define (lexical->value value)

  (cond

    ((rdf-literal? value)

     (rdf-literal-lexical-form value))

    ((blank-node? value)

     (string-append "_:" (number->string value)))

    (else value)))

(define (execute-test test)

  (let* ((predicates (test-case-document test))

         (type (car (get-objects predicates "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))

         (type (car (reverse (string-split type #\#))))

         (action (car (get-objects predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action"))))

    (turtle->rdf (get-test-doc action) action)))

(define (run-test test)

  (let* ((predicates (test-case-document test))

         (type (car (get-objects predicates "http://www.w3.org/1999/02/22-rdf-syntax-ns#type")))

         (type (car (reverse (string-split type #\#))))

         (result

           (catch #t

             (lambda ()

               (execute-test test))

             (lambda (key . value)

               (cons key value)))))

    (cond

      ((member type '("TestTurtlePositiveSyntax" "TestTriGPositiveSyntax"

                      "TestNTriplesPositiveSyntax" "TestNQuadsPositiveSyntax"))

       (match result

         (((? symbol? key) . value)

          (update-test-case test

            #:result 'fail

            #:reason (format #f "failed with ~a: ~a" key value)))

         (_ (update-test-case test #:result 'pass))))

      ((member type '("TestTurtleNegativeSyntax" "TestTriGNegativeSyntax"

                      "TestNTriplesNegativeSyntax" "TestNQuadsNegativeSyntax"

                      "TestXMLNegativeSyntax" "TestTurtleNegativeEval"))

       (match result

         (((? symbol? key) . value) (update-test-case test #:result 'pass))

         (_ (update-test-case test

              #:result 'fail

              #:reason "Expected failure but got success"))))

      ((equal? type "TestTurtleEval")

       (let* ((expected (car (get-objects predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#result")))

              (expected

                (catch #t

                  (lambda ()

                    (if expected

                        (turtle->rdf (get-test-doc expected) expected)

                        #f))

                  (lambda (key . value)

                    (cons key value)))))

         (match result

           (((? symbol? key) . value)

            (update-test-case test

              #:result 'fail

              #:reason (format #f "failed with ~a: ~a" key value)))

           (_

             (if (rdf-isomorphic? result expected)

                 (update-test-case test #:result 'pass)

                 (update-test-case test

                   #:result 'fail

                   #:reason (format #f "expected ~a but got ~a"

                                    expected result)))))))

      ((member type '("PositiveEntailmentTest" "NegativeEntailmentTest"))

       (let* ((regime (rdf-literal-lexical-form

                        (car

                          (get-objects

                            predicates

                            (string-append

                              "http://www.w3.org/2001/sw/DataAccess/tests/"

                              "test-manifest#entailmentRegime")))))

              (expected

                (car

                  (get-objects

                    predicates

                    (string-append "http://www.w3.org/2001/sw/DataAccess/tests/"

                                   "test-manifest#result"))))

              (expected

                (catch #t

                  (lambda ()

                    (if expected

                        (turtle->rdf (get-test-doc expected) expected)

                        #f))

                  (lambda (key . value)

                    (cons key value)))))

         (match regime

           ("simple"

            (if (if (equal? expected #f)

                    (simple:consistent-graph? result)

                    (simple:entails? result expected))

                (if (equal? type "PositiveEntailmentTest")

                    (update-test-case test #:result 'pass)

                    (update-test-case test

                      #:result 'fail

                      #:reason "Expected negative result, got positive"))

                (if (equal? type "PositiveEntailmentTest")

                    (update-test-case test

                      #:result 'fail

                      #:reason (format #f "Expected positive result, got negative"))

                    (update-test-case test #:result 'pass))))

           (_ (update-test-case test

                #:result 'skip

                #:reason (format #f "Unrecognized entailment regime: ~a"

                                 regime))))))

      (else

        (update-test-case test

          #:result 'skip

          #:reason (format #f "Unrecognized test type: ~a" type))))))

(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}."

  (call-with-values

    (lambda ()

      (http-get url))

    (lambda (hdr body)

      (if (equal? (response-code hdr) 200)

          (if (string? body)

              body

              (utf8->string body))

          (throw 'error-fetching-test-manifest (response-code hdr))))))

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

  (define document (get-test-doc url))

  (define manifest (turtle->rdf document url))

  (define tests-node

    (rdf-triple-object

      (car

        (filter

          (lambda (triple)

            (and (equal? (rdf-triple-subject triple) url)

                 (equal? (rdf-triple-predicate triple)

                         (string-append "http://www.w3.org/2001/sw/DataAccess/"

                                        "tests/test-manifest#entries"))))

          manifest))))

  (define (find-rest node)

    (rdf-triple-object

      (car

        (filter

          (lambda (triple)

            (and (equal? (rdf-triple-subject triple) node)

                 (equal? (rdf-triple-predicate triple)

                         (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"

                                        "#rest"))))

          manifest))))

  (define (find-first node)

    (rdf-triple-object

      (car

        (filter

          (lambda (triple)

            (and (equal? (rdf-triple-subject triple) node)

                 (equal? (rdf-triple-predicate triple)

                         (string-append "http://www.w3.org/1999/02/22-rdf-syntax-ns"

                                        "#first"))))

          manifest))))

  (define tests

    (let loop ((tests-node tests-node) (tests '()))

      (let ((first (find-first tests-node))

            (tests-node (find-rest tests-node)))

        (if (blank-node? tests-node)

            (loop tests-node (cons first tests))

            tests))))

  (cdr

    (fold

      (lambda (test result)

        (let* ((num (car result))

               (result (cdr result))

               (test-predicates (filter

                                  (lambda (t)

                                    (equal? (rdf-triple-subject t) test))

                                  manifest))

               (name (lexical->value (car (get-objects test-predicates "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#name"))))

               (description (lexical->value (car (get-objects test-predicates "http://www.w3.org/2000/01/rdf-schema#comment")))))

          (cons (+ 1 num)

                (cons (make-test-case test num name description

                                      (filter

                                        (lambda (t)

                                          (equal? (rdf-triple-subject t) test))

                                        manifest)

                                      #f #f)

                      result))))

      `(,num . ())

      tests)))

(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))))