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

  #:use-module (srfi srfi-9)

  #:use-module (srfi srfi-19)

  #:use-module (ice-9 match)

  #:export (make-test-case

            test-case?

            test-case-id

            test-case-num

            test-case-name

            test-case-document

            test-case-result

            test-case-reason

            update-test-case

            make-test-driver

            test-driver?

            test-driver-init

            test-driver-print

            test-driver-finalize

            tap-driver

            earl-driver))

;; 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 id num name description document result reason)

  test-case?

  (id           test-case-id)

  (num          test-case-num)

  (name         test-case-name)

  (description  test-case-description)

  (document     test-case-document)

  (result       test-case-result)

  (reason       test-case-reason))

(define* (update-test-case test-case #:key

                           (id           (test-case-id test-case))

                           (num          (test-case-num test-case))

                           (name         (test-case-name test-case))

                           (description  (test-case-description test-case))

                           (document     (test-case-document test-case))

                           (result       (test-case-result test-case))

                           (reason       (test-case-reason test-case)))

  (make-test-case id num name description document result reason))

;; A test driver is called at the beginning, on each test result and at the

;; end of the tests.

(define-record-type test-driver

  (make-test-driver init print finalize)

  test-driver?

  (init     test-driver-init) ; list test-case -> ()

  (print    test-driver-print) ; test-case -> ()

  (finalize test-driver-finalize)) ; list test-case -> ()

(define tap-driver

  (make-test-driver

    (lambda (cases)

      (format #t "1..~a~%" (length cases)))

    (match-lambda

      (($ test-case id num name description document result reason)

       (match result

         ('skip

          (format #t "ok ~a ~a # SKIP ~a~%" num name reason))

         ('pass

          (format #t "ok ~a ~a~%" num name))

         ('fail

          (format #t "not ok ~a ~a: ~a~%" num name reason))

         ('xfail

          (format #t "not ok ~a ~a # TODO ~a~%" num name reason))

         ('xpass

          (format #t "ok ~a ~a # TODO ~a~%" num name reason)))

       (force-output)))

    (const #t)))

(define (get-date)

  (let* ((date (date->string (current-date) "~4"))

         (len (string-length date)))

    (string-append

      (substring date 0 (- len 2))

      ":"

      (substring date (- len 2)))))

(define (earl-driver port)

  "A driver that creates a turtle file report using the earl vocabulary.  It

doesn't use any internal representation for RDF or Turtle, it only manipulates

strings."

  (make-test-driver

    (lambda (cases)

      (format port "@prefix dc: <http://purl.org/dc/terms/> .~%")

      (format port "@prefix earl: <http://www.w3.org/ns/earl#> .~%")

      (format port "@prefix doap: <http://usefulinc.com/ns/doap#> .~%")

      (format port "@prefix foaf: <http://xmlns.com/foaf/0.1/> .~%")

      (format port "@prefix xsd: <http://www.w3.org/2001/XMLSchema#> .~%")

      (format port "~%")

      (format port "<https://framagit.org/tyreunom/guile-jsonld> a doap:Project;~%")

      (format port "   dc:creator <https://lepiller.eu/#me>;~%")

      (format port "   doap:bug-database <https://framait.org/tyreunom/guile-jsonld/issues>;~%")

      (format port "   doap:description \"Guile implementation of the JsonLD API defined by the W3C.\"@en;~%")

      (format port "   doap:developer <https://lepiller.eu/#me>;~%")

      (format port "   doap:homepage <https://framagit.org/tyreunom/guile-jsonld/>;~%")

      (format port "   doap:implements <https://www.w3.org/TR/json-ld11/>,~%")

      (format port "     <https://www.w3.org/TR/json-ld11-api/>;~%")

      (format port "   doap:license <https://www.gnu.org/licenses/gpl-3.0.html>;~%")

      (format port "   doap:name \"guile-jsonld\"^^xsd:string;~%")

      (format port "   doap:programming-language \"GNU Guile\"^^xsd:string;~%")

      (format port "   doap:shortdesc \"JSON-LD support for GNU Guile.\"@en;~%")

      (format port "   doap:release [~%")

      (format port "      doap:name \"guile-jsonld-1.0.0\";~%")

      (format port "      doap:revision \"1.0.0\";~%")

      (format port "      doap:created \"2020-03-29\"^^xsd:date;~%")

      (format port "   ] .~%")

      (format port "~%")

      (format port "<https://lepiller.eu/#me> a earl:Assertor, foaf:Person;~%")

      (format port "   foaf:homepage <https://lepiller.eu>;~%")

      (format port "   foaf:mbox <mailto:julien@lepiller.eu>;~%")

      (format port "   foaf:name \"Julien Lepiller\"^^xsd:string .~%")

      (format port "~%")

      (format port "<> foaf:primaryTopic <https://framagit.org/tyreunom/guile-jsonld>;~%")

      (format port "  dc:issued \"~a\"^^xsd:dateTime;~%" (get-date))

      (format port "  foaf:maker <https://lepiller.eu/#me> .~%")

      (format port "~%")

      (format #t "~a test cases for report~%" (length cases)))

    (lambda (test-case)

      (format port "[ a earl:Assertion;~%")

      (format port "  earl:assertedBy <https://lepiller.eu/#me>;~%")

      (format port "  earl:subject <https://framagit.org/tyreunom/guile-jsonld>;~%")

      (format port "  earl:test <~a>;~%" (test-case-id test-case))

      (format port "  earl:result [~%")

      (format port "    a earl:TestResult;~%")

      (format port "    earl:outcome earl:~a;~%"

              (match (test-case-result test-case)

                ('skip "inapplicable")

                ('pass "passed")

                ('fail "failed")

                ('xpass "cantTell")

                ('xfail "untested")))

      (format port "    dc:date \"~a\"^^xsd:dateTime ] ;~%" (get-date))

      (format port "  earl:mode earl:automatic ] .~%")

      (format port "~%")

      (format #t "Tested ~a: ~a~%"

              (test-case-num test-case) (test-case-result test-case)))

    (lambda _

      (close-port port))))