;;;; 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 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 (substring type (string-length "http://www.w3.org/ns/rdftest#")))
         (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 (substring type (string-length "http://www.w3.org/ns/rdftest#")))
         (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"))
       (match result
         (((? symbol? key) . value) (update-test-case test #:result 'pass))
         (_ (update-test-case test
              #:result 'fail
              #:reason "Expected failure but got success"))))
      (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)
    (pk '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))))