;; This file is part of scheme-GNUnet.
;; Copyright (C) 2021 GNUnet e.V.
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; scheme-GNUnet 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
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL3.0-or-later
(use-modules (gnu gnunet config value-parser)
	     (srfi srfi-26)
	     (srfi srfi-43)
	     (quickcheck)
	     (quickcheck generator)
	     (quickcheck property)
	     (quickcheck arbitrary)
	     ((rnrs conditions) #:select (&assertion))
	     ((rnrs base) #:select (assert mod)))

;; (Incomplete) recollection of bugs found with these tests:
;; * [A] some exception types were not exported
;; * [A] off-by-one in value->choice
;; * [A] float-regex is too permissive, leading to crashes
;; * [A] incorrect detection of leading 0 in value->natural
;; * [A] some imports are missing
;; * [A] missing arguments to string-skip in convert-with-table
;; * [A] missing detection of empty number string in convert-with-table
;; * [A] incorrect detection of empty number string or missing unit
;;       in convert-with-table, leading to crashes
;; * [A] comparison of character with number
;; * [A] variable naming errors in convert-with-table
;; * [A] value->natural allows too much syntax
;; * [A] size-values is missing an entry
;; * [A] missing argument to make-value-parse/size-error
;;
;; Tally: 14 [A]
;;
;; [A]: bug caught before patch was merged

;; Fresh object that is not eq? to anything else.
(define *object* (cons '#f '#f))
(define-syntax-rule (test-x-error value->x x msg text arg ...)
  (test-equal msg
    `(x ,text)
    (with-exception-handler
	(lambda (e)
	  `(x ,(value-parse-error-text e)))
      (lambda ()
	(cons *object* (value->x text arg ...)))
      #:unwind? #t
      #:unwind-for-type x)))

(define-syntax-rule (define-test-x-error test-y-error value->y y)
  (define-syntax test-y-error
    (syntax-rules ::: ()
      ((test-y-error msg text arg :::)
       (test-x-error value->y y msg text arg :::)))))

(define-test-x-error test-natural-error
  value->natural &value-parse/natural-error)
(define-test-x-error test-float-error
  value->float &value-parse/float-error)
(define-test-x-error test-boolean-error
  value->boolean &value-parse/boolean-error)
(define-test-x-error test-size-error
  value->size &value-parse/size-error)
(define-test-x-error test-choice-error
  value->choice &value-parse/choice-error)

(test-begin "value-parser")

(test-equal "value->natural, valid"
  (iota 23)
  (map (compose value->natural number->string) (iota 23)))
(test-equal "value->natural, valid (2)"
  #xdeadbeef (value->natural (number->string #xdeadbeef)))

(test-natural-error "value->natural, multiple leading zeros" "00")
(test-natural-error "value->natural, multiple leading zeros (2)" "001")
(test-natural-error "value->natural, leading zero" "01")
(test-natural-error "value->natural, empty string" "")
(test-natural-error "value->natural, leading space" " 1")
(test-natural-error "value->natural, trailing space" "1 ")
(test-natural-error "value->natural, spaces" " ")
(test-natural-error "value->natural, hexadecimal" "#xdeadbeef")


;; IEEE 754 makes a distinction between positive zero
;; and negative zero, with (/ 1 +0.0) = +inf.0 and
;; (/ 1 -0.0) = -inf.0
;;
;; In Guile 3.?, 0.0 and -0.0 are = but not eqv?.

(test-skip (if (eqv? 0.0 -0.0) 1 0))
(test-eqv "value->float, positive 0 (a)"
  0.0
  (value->float "0.0"))
(test-eqv "value->float, positive 0 (b)"
  0.0
  (value->float "0."))
(test-eqv "value->float, positive 0 (c)"
  0.0
  (value->float ".0"))
(test-eqv "value->float, positive 0 (d)"
  0.0
  (value->float "0"))

(test-equal "value->float, nothing before dot"
  (list 0.1 0.3 0.19 0.22)
  (map value->float '(".1" ".3" ".19" ".22")))

(test-float-error "value->float, multiple 0" "00")
(test-float-error "value->float, leading 0" "01")
(test-equal "value->float, 0 and dot"
  0.1
  (value->float "0.1"))
(test-equal "value->float, leading 0 after dot"
  1.001
  (value->float "1.001"))
(test-equal "value->float, multiple 0 after dot"
  1.0
  (value->float "1.000"))

(test-float-error "value->float, hexadecimal" "#xdeadbeef")
(test-equal "value->float, exact->inexact naturals"
  (map exact->inexact (iota 20))
  (map (compose value->float number->string) (iota 20)))

;; Powers of two are exactly representable in IEEE 754
;; (if exponent is not too large).  Even then, (value->float "0.5")
;; should return a flonum and not the exact rational 1/2.
(test-skip (if (equal? (map (compose inexact->exact exact->inexact
				     (cut expt 2 <>))
			    (iota 10 -5))
		       (map (cut expt 2 <>) (iota 10 -5)))
	       0 1))
(test-equal "value->float, exact->inexact fractionals"
  (map (compose exact->inexact (cut expt 2 <>))
       (iota 10 -5))
  (map (compose value->float number->string exact->inexact
		(cut expt 2 <>))
       (iota 10 -5)))

;; Whitespace is not allowed!
(test-float-error "value->float, no leading spaces" " 1.0")
(test-float-error "value->float, no trailing spaces" "1.0 ")
(test-float-error "value->float, not empty!" "")
(test-float-error "value->float, not only space!" " ")
(test-float-error "value->float, not a single .!" ".")


;; TODO: should exponential notation 2e-3 = (* 2 (expt 10 -3))
;; be accepted?

(test-equal "value->boolean, YES"
  #t
  (value->boolean "YES"))

(test-equal "value->boolean, NO"
  #f
  (value->boolean "NO"))

(define-syntax-rule (test-bool-error text extra)
  (test-boolean-error (string-append "value->boolean, " text extra)
		      text))

;; We're not simply looking at the first or second
;; character or the length of the string.
(test-bool-error "Y" " (invalid)")
(test-bool-error "YE" " (invalid)")
(test-bool-error "NOS" " (invalid)")
(test-bool-error "NOSE" " (invalid)")
(test-bool-error "N" " (invalid)")
(test-bool-error "YES! " " (invalid)")

;; Case sensitive!
(test-bool-error "yes" " (invalid case, 0)")
(test-bool-error "Yes" " (invalid case, 1)")
(test-bool-error "yEs" " (invalid case, 2)")
(test-bool-error "yeS" " (invalid case, 3)")
(test-bool-error "no" " (invalid case, 0)")
(test-bool-error "No" " (invalid case, 1)")
(test-bool-error "nO" " (invalid case, 2)")

;; Space are not allowed!
(test-bool-error " YES" " (leading space)")
(test-bool-error " NO" " (leading space)")
(test-bool-error "YES " " (trailing space)")
(test-bool-error "NO " " (trailing space)")
(test-bool-error "" " (empty string)")
(test-bool-error " " " (only space)")


(define-syntax-rule (test-size-equal msg text val)
  (test-equal (string-append "value->size, " msg) val
	      (value->size text)))
(define-syntax-rule (test-binary-unit unit value exponent)
  (begin
    (assert (= value (expt 1024 exponent)))
    (test-size-equal (string-append "unit " unit)
		     (string-append "1 " unit)
		     (expt 1024 exponent))))
;; XXX not actually decimal
(define-syntax-rule (test-decimal-unit unit value exponent)
  (begin
    (assert (= value (expt 1000 exponent)))
    (test-size-equal (string-append "unit " unit)
		     (string-append "1 " unit)
		     (expt 1000 exponent))))

(define-syntax-rule (test-binary-units (unit value exponent) ...)
  (begin (test-binary-unit unit value exponent) ...))

(define-syntax-rule (test-decimal-units (unit value exponent) ...)
  (begin (test-decimal-unit unit value exponent) ...))

;; Verify the unit table and some parsing code.
;; Sizes are copied from (coreutils)Block size
(test-binary-units
 ("B" 1 0) ("KiB" 1024 1) ("MiB" 1048576 2) ("GiB" 1073741824 3)
 ("TiB" 1099511627776 4) ("PiB" 1125899906842624 5)
 ("EiB" 1152921504606846976 6))
(test-decimal-units
 ("kB" 1000 1) ("MB" 1000000 2) ("GB" 1000000000 3)
 ("TB" 1000000000000 4) ("PB" 1000000000000000 5)
 ("EB" 1000000000000000000 6))

(test-size-equal "value->size, multiple space in-between" "1  B" 1)

(test-size-error "value->size, only space" " ")
(test-size-error "value->size, empty string" "")
(test-size-error "value->size, leading space" " 1 B")
(test-size-error "value->size, trailing space" "1 B ")
(test-size-error "value->size, negative" "-1 B")
(test-size-error "value->size, fraction" "3/2 B")
(test-size-error "value->size, flonum, 1" "1.5 B")
(test-size-error "value->size, flonum, 2" "1. B")
(test-size-error "value->size, flonum, 3" ".1 B")
(test-size-error "value->size, leading zero" "01 B")

(define (factorial n)
  (assert (and (integer? n)
	       (exact? n)
	       (>= n 0)))
  (let loop ((acc 1)
	     (n n))
    (if (> n 1)
	(loop (* acc n) (- n 1))
	acc)))
(assert (= (factorial 0) 1))
(assert (= (factorial 1) 1))
(assert (= (factorial 2) 2))
(assert (= (factorial 3) 6))
(assert (= (factorial 4) 24))

(define (choose-permutation size)
  (choose-integer 0 (- (factorial size) 1)))

;; The Fisher-Yates shuffle, as described on Wikipedia,
;; but with random numbers extracted from PERMUTATION.
(define (shuffle-vector vector permutation)
  (assert (and (integer? permutation)
	       (exact? permutation)
	       (>= permutation 0)))
  (let ((v (make-vector (vector-length vector))))
    (let loop ((i 0)
	       (permutation permutation))
      (if (< i (vector-length v))
	  (let ((j (mod permutation (+ i 1)))
		(rest (floor/ permutation (+ i 1))))
	    ;; Except this assignment is unconditional.
	    ;; (On Wikipedia "if j != i" is added.)
	    (vector-set! v i (vector-ref v j))
	    (vector-set! v j (vector-ref vector i))
	    (loop (+ i 1) rest))
	  (begin
	    (assert (= permutation 0))
	    v)))))

(define choose-unit
  (choose-one (map generator-return '("KiB" "MiB" "GiB" "B" "kB" "MB"))))
(define choose-value choose-byte) ; large enough
(define choose-required-space-count (choose-integer 1 2))
(define choose-optional-space-count (choose-integer 0 2))

(define (choose-part-vector n)
  (choose-vector
   (generator-lift
    vector choose-required-space-count choose-value
    choose-optional-space-count choose-unit)
   (+ 1 n)))

(define (parts->string part-vector)
  (call-with-output-string
    (lambda (out)
      (vector-for-each
       (lambda (i val)
	 (apply (lambda (spaces-before value spaces-between unit)
		  (unless (= i 0)
		    (for-each (lambda _ (display " " out))
			      (iota spaces-before)))
		  (display value out)
		  (for-each (lambda _ (display " " out))
			    (iota spaces-between))
		  (display unit out))
		(vector->list val)))
       part-vector))))

(test-assert "value->size, morphism: (string-append, +)"
  (quickcheck
   (property ((parts (arbitrary
		      (gen (sized-generator choose-part-vector))
		      (xform #f))))
     (= (value->size (parts->string parts))
	(apply + (vector->list
		  (vector-map
		   (lambda (_ e)
		     ((compose value->size parts->string vector) e))
		   parts)))))))

(test-assert "value->size, invariant under permutation"
  (quickcheck
   (property ((parts+property
	       (arbitrary
		(gen (sized-generator
		      (lambda (size)
			(generator-lift cons
					(choose-permutation size)
					(choose-part-vector size)))))
		(xform #f))))
     (= (value->size (parts->string (cdr parts+property)))
	(value->size (parts->string
		      (shuffle-vector (cdr parts+property)
				      (car parts+property))))))))


(test-eq "value->choice, direct match"
  'x
  (value->choice "x" #("x" x)))

(test-eq "value->choice, match later"
  'y
  (value->choice "y" #("x" x "y" y)))

(test-eq "value->choice, match early"
  'x
  (value->choice "x" #("x" x "y" y)))

(test-choice-error "value->choice, empty vector"
		   "x" #())
(test-error "value->choice, bad text"
  &assertion
  (value->choice 0 #("x" x)))
(test-error "value->choice, bad choices"
  &assertion
  (value->choice "x" '(("x" x))))

(test-eq "value->choice, whitespace (left) left intact"
  'y
  (value->choice " y" #("y" x " y" y)))

(test-eq "value->choice, whitespace (right) left intact"
  'y
  (value->choice " y" #("y" x " y" y)))

(test-eq "value->choice, case sensitive (1)"
  'upper
  (value->choice "X" #("x" lower "X" upper)))

(test-eq "value->choice, case sensitive (2)"
  'mixed
  (value->choice "Xy" #("XY" upper "xy" lower "Xy" mixed)))

(test-eq "value->choice, case sensitive (3)"
  'lower
  (value->choice "xy" #("xy" lower)))

(test-assert "value->file-name, no-op"
  (quickcheck
   (property ((text ($string $char)))
     (string=? (value->file-name text) text))))

(test-error "value->file-name, text must be a string"
  &assertion
  (value->file-name 'bad))

(test-end "value-parser")