;;;; 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 rdf) #:prefix rdf:)

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

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

  #:use-module (rdf rdf)

  #:use-module ((rdf xsd) #:prefix xsd:)

  #:use-module (srfi srfi-1)

  #:use-module (nquads tordf)

  #:use-module (turtle tordf)

  #:use-module (web client)

  #:use-module (web response)

  #:export (run-test-suite

            run-test-suites))

(define (find-rest node graph)

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

        graph))))

(define (find-first node graph)

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

        graph))))

(define (find-list node graph)

  (if (blank-node? node)

      (let loop ((node node) (result '()))

        (let ((first (find-first node graph))

              (node (find-rest node graph)))

          (if (blank-node? node)

              (loop node (cons first result))

              (cons first result))))

      '()))

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

    (cond

      ((member type '("TestTurtlePositiveSyntax" "TestTurtleNegativeSyntax"

                      "TestTurtleEval" "PositiveEntailmentTest"

                      "NegativeEntailmentTest"))

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

      ((member type '("TestNQuadsNegativeSyntax" "TestNQuadsPositiveSyntax"))

       (nquads->rdf (get-test-doc 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 (string? 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"))

       (pk 'predicates predicates)

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

                        (car

                          (get-objects

                            predicates

                            (string-append

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

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

              (recognized

                (car

                  (pk 'recognized-nodes

                  (get-objects

                    predicates

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

                                   "test-manifest#recognizedDatatypes"))))

                )

              (recognized (pk 'lst-reco (find-list recognized predicates)))

              (recognized

                (map

                  (lambda (iri)

                    (let loop ((types (cons* rdf:XMLLiteral rdf:langString

                                             xsd:datatypes)))

                      (match types

                        (() (throw 'didnotrecognize iri))

                        ((type types ...)

                         (if (member iri (rdf-datatype-iris type))

                             (pk 'recognized-type type)

                             (loop types))))))

                  recognized))

              (recognized (pk 'reco (append (list xsd:string rdf:langString) recognized)))

              (vocabulary (make-rdf-vocabulary recognized xsd:order xsd:compatible?))

              (expected

                (car

                  (get-objects

                    predicates

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

                                   "test-manifest#result"))))

              (expected

                (catch #t

                  (lambda ()

                    (if (string? expected)

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

                        #f))

                  (lambda (key . value)

                    (cons key value)))))

         (match regime

           ("simple"

            (if (if (equal? expected #f)

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

           ("RDF"

            (if (if (equal? expected #f)

                    (not (rdf:consistent-graph? result vocabulary))

                    (rdf:entails? result expected vocabulary))

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

           ("RDFS"

            (if (if (equal? expected #f)

                    (not (rdfs:consistent-graph? result vocabulary))

                    (rdfs:entails? result expected vocabulary))

                (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 tests (find-list tests-node manifest))

  (define (subgraph-at graph node)

    (let ((nodes (filter

                   (lambda (t)

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

                   graph)))

      (if (null? nodes)

          '()

          (apply append nodes

                 (map

                   (lambda (n)

                     (subgraph-at graph (rdf-triple-object n)))

                   nodes)))))

  (cdr

    (fold

      (lambda (test result)

        (let* ((num (car result))

               (result (cdr result))

               (test-predicates (subgraph-at manifest test))

               (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 test-predicates

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