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

  #:use-module (ice-9 match)

  #:use-module (rdf rdf)

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

  #:use-module (srfi srfi-9)

  #:export (test-case

            make-test-case

            test-case?

            test-case-id

            test-case-name

            test-case-regime

            test-case-recognized

            test-case-unrecognized

            test-case-action

            test-case-result

            rdf->test-plan))

;; A test case is the result of running a test.  It has an identifier, a name

;; and a description.  Its result is a symbol, which can be 'skiped, 'pass,

;; 'fail, 'xpass, or 'xfail.  The reason is a string or #f that explains the

;; result

(define-record-type test-case

  (make-test-case type name regime recognized unrecognized action result)

  test-case?

  (type         test-case-type)

  (name         test-case-name)

  (regime       test-case-regime)

  (recognized   test-case-recognized)

  (unrecognized test-case-unrecognized)

  (action       test-case-action)

  (result       test-case-result))

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

  "When @var{node} represents a list, traverse it to find all its elements, and

return a list of nodes corresponding to the elements of the list."

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

  "Return every objects in the @var{triples} that use @var{predicate}."

  (map

    rdf-triple-object

    (filter

      (lambda (t)

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

      triples)))

(define (get-object triples predicate)

  "Return the only object in the @var{triples} that uses @var{predicate}."

  (match (get-objects triples predicate)

    ((object) object)

    (() #f)

    (objects (throw 'too-many objects))))

(define (lexical->value value)

  (cond

    ((and (rdf-literal? value)

          (equal? (rdf-literal-type value)

                  "http://www.w3.org/2001/XMLSchema#boolean"))

     (equal? (rdf-literal-lexical-form value) "true"))

    ((rdf-literal? value)

     (rdf-literal-lexical-form value))

    ((blank-node? value)

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

    (else value)))

(define (mf v)

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

                 v))

(define (qt v)

  (string-append "http://www.w3.org/2001/sw/DataAccess/tests/test-query#" v))

(define (rdf v)

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

(define (rdfs v)

  (string-append "http://www.w3.org/2000/01/rdf-schema#" v))

(define (subgraph-at graph node)

  "When @var{graph} is a list of triples, find the triples whose subjects is

@var{node}, or the objects these triples, recursively.  Return the subgraph

that is rooted at @var{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)))))

(define (rdf->test-plan manifest url)

  "Return a list of test-case objects from @var{manifest}, an rdf document that

was downloaded from @var{url}."

  (define tests-node

    (get-object manifest (mf "entries")))

  ;;The list of test node IDs

  (define tests

    (find-list tests-node manifest))

  (map

    (lambda (test-id)

      (let* ((subgraph (subgraph-at manifest test-id))

             (name (get-object subgraph (mf "name")))

             (type (get-object subgraph (rdf "type")))

             (action (get-object subgraph (mf "action")))

             (regime (get-object subgraph (mf "entailmentRegime")))

             (recognized (get-object subgraph (mf "recognizedDatatypes")))

             (unrecognized (get-object subgraph (mf "unrecognizedDatatypes")))

             (result (get-object subgraph (mf "result"))))

        (make-test-case

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

          (lexical->value name)

          (if regime (lexical->value regime) #f)

          (if recognized

              (map

                (lambda (iri)

                  ;; find types to recognize from the list of types below

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

                                           xsd:datatypes)))

                    (match types

                      (() (throw 'didnotrecognize iri))

                      ((type types ...)

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

                           type

                           (loop types))))))

                (find-list recognized subgraph))

              '())

          '(); XXX: unrecognized

          (lexical->value action)

          (lexical->value result))))

    tests))