;;;; Copyright (C) 2019, 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 (srfi srfi-1)

  #:use-module (srfi srfi-9)

  #:use-module (test-modules download)

  #:use-module (test-modules result)

  #:use-module (test-modules testsuite)

  #:use-module (jsonld download)

  #:use-module (jsonld json)

  #:use-module (jsonld)

  #:use-module (jsonld options)

  #:use-module (jsonld iri)

  #:export (run-test-suite

            run-test-suites

            get-test-doc))

;; The JsonLD specification comes with a test suite.  It consists in on JsonLD

;; document per API function.  The test suite is designed for the latest

;; version of the API, but can be used for older versions.  Tests for newer

;; versions or specific to older versions are clearly marked, so we can

;; select them.

;; Each JsonLD document is a manifest listing a huge list of tests that require

;; us to download a few other JsonLD documents, run a function on them and compare

;; the result.  This is what this file does.

(define (execute-test test)

  "Execute one test described by a Json object @var{test}.  Return a Json object

as the output of the test, or throws an exception if something went wrong."

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

         (input (assoc-ref document "input"))

         (context (assoc-ref document "context"))

         (type (array->list (assoc-ref document "@type")))

         (options (assoc-ref document "option"))

         (spec-version (assoc-ref options "specVersion"))

         (document-loader (get-test-document-loader options)))

    (cond

      ((equal? spec-version "json-ld-1.0")

       (throw 'unsupported-spec 1.0))

      ((member "jld:CompactTest" type)

       (compact (string-append jsonld-test-url input)

                (string-append jsonld-test-url context)

                #:options

                (apply

                  new-jsonld-options

                  #:ordered? #t

                  #:document-loader document-loader

                  `(,@(if (assoc-ref options "base")

                          `(#:base ,(assoc-ref options "base"))

                          '())

                    ,@(if (assoc-ref options "processingMode")

                          `(#:processing-mode ,(assoc-ref options "processingMode"))

                          '())

                    ,@(if (assoc-ref options "extractAllScripts")

                          `(#:extract-all-scripts?

                            ,(assoc-ref options "extractAllScripts"))

                          '())

                    ,@(if (json-has-key? options "compactArrays")

                          `(#:compact-arrays? ,(assoc-ref options "compactArrays"))

                          '())))))

      ((member "jld:ExpandTest" type)

       (expand (string-append jsonld-test-url input)

               #:options

               (apply

                 new-jsonld-options

                 #:ordered? #t

                 #:document-loader document-loader

                 `(,@(if (assoc-ref options "base")

                         `(#:base ,(assoc-ref options "base"))

                         '())

                   ,@(if (assoc-ref options "extractAllScripts")

                         `(#:extract-all-scripts?

                           ,(assoc-ref options "extractAllScripts"))

                         '())

                   ,@(if (assoc-ref options "processingMode")

                         `(#:processing-mode ,(assoc-ref options "processingMode"))

                         '())

                   ,@(if (assoc-ref options "expandContext")

                         `(#:expand-context ,(string-append jsonld-test-url

                                                            (assoc-ref options "expandContext")))

                         '())))))

      ((member "jld:FlattenTest" type)

       (flatten (string-append jsonld-test-url input)

                #:context

                (if context

                  (string-append jsonld-test-url context)

                  #f)

                #:options

                (apply

                  new-jsonld-options

                  #:ordered? #t

                  #:document-loader document-loader

                  `(,@(if (assoc-ref options "base")

                          `(#:base ,(assoc-ref options "base"))

                          '())

                    ,@(if (assoc-ref options "processingMode")

                          `(#:processing-mode ,(assoc-ref options "processingMode"))

                          '())

                    ,@(if (assoc-ref options "extractAllScripts")

                          `(#:extract-all-scripts?

                            ,(assoc-ref options "extractAllScripts"))

                          '())

                    ,@(if (json-has-key? options "compactArrays")

                          `(#:compact-arrays? ,(assoc-ref options "compactArrays"))

                          '())))))

      (else (throw 'unrecognized-test type)))))

(define (run-test test)

  "Run one test described by the Json object @var{test}, whose @var{id} is

an identifier.  @var{id} is used as the test number for the test driver.  Return

is undefined.  As a side-effect, outputs one line on the standard output to

report the test status."

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

         (description (or (assoc-ref document "purpose") (test-case-name test)))

         (description (string-append (test-case-id test) ": " description))

         (expect (assoc-ref document "expect"))

         (expect-error (assoc-ref document "expectErrorCode"))

         (type (array->list (assoc-ref document "@type")))

         (option (assoc-ref document "option"))

         (result

           (catch #t

             (lambda ()

               (execute-test test))

             (lambda (key . value)

               (cons key value)))))

    (if (member "jld:NegativeEvaluationTest" type)

      (match result

        (((? symbol? key) . value)

         (cond

           ((equal? key 'unrecognized-test)

            (update-test-case test

              #:result 'skip

              #:reason "unrecognized test type"))

           ((equal? key 'unsupported-spec)

            (update-test-case test

              #:result 'skip

              #:reason "unsupported specification version"))

           ((equal? key 'unsupported-version-test)

            (update-test-case test

              #:result 'skip

              #:reason "unsupported JsonLD version"))

           ((equal? (jsonld-error->string key) expect-error)

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

           (else

             (update-test-case test

               #:result 'fail

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

                                expect-error key value)))))

        (_ (begin

             (update-test-case test

               #:result 'fail

               #:reason (format #f "Expected ~a but got success"

                                expect-error)))))

      (match result

        (((? symbol? key) . value)

         (cond

           ((equal? key 'unrecognized-test)

            (update-test-case test

              #:result 'skip

              #:reason "unrecognized test type"))

           ((equal? key 'unsupported-spec)

            (update-test-case test

              #:result 'skip

              #:reason "unsupported specification version"))

           ((equal? key 'unsupported-version-test)

            (update-test-case test

              #:result 'skip

              #:reason "unsupported JsonLD version"))

           (else

            (update-test-case test

              #:result 'fail

              #:reason (format #f "Expected success but got ~a: ~a"

                               key value)))))

        (_ (let ((expected (json-document-document

                             (download-json

                               (string-append jsonld-test-url expect)))))

             (if (same-json? result expected)

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

                 (update-test-case test

                   #:result 'fail

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

                                    expected result)))))))))

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

  (assoc-ref (json-document-document (download-json url)) "sequence"))

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

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

  (cdr

    (fold

      (lambda (test result)

        (let* ((num (car result))

               (result (cdr result))

               (name (assoc-ref test "name"))

               (@id (assoc-ref test "@id"))

               (name (string-append @id ": " name))

               (description (or (assoc-ref test "purpose") name))

               (description (string-append @id ": " description)))

          (cons (+ 1 num)

                (cons (make-test-case (string-append url @id)

                                      num name description test #f #f)

                      result))))

      `(,num . ())

      (array->list document))))

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