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