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