Disarchive/tests/kinds/octal.scm

;;; Disarchive
;;; Copyright © 2020, 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of Disarchive.
;;;
;;; Disarchive is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Disarchive 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Disarchive.  If not, see <http://www.gnu.org/licenses/>.

(use-modules (disarchive kinds octal)
             (disarchive kinds zero-string)
             (disarchive serialization)
             (quickcheck)
             (quickcheck arbitrary)
             (quickcheck generator)
             (quickcheck property)
             (rnrs bytevectors)
             (srfi srfi-64)
             (tests kinds))

(define (char-set->arbitrary cs)
  (arbitrary
   (gen (choose-char cs))
   (xform (lambda (chr gen)
            (generator-variant (char->integer chr) gen)))))

(define char-set:octal (string->char-set "01234567"))

(define $ascii-char
  (char-set->arbitrary char-set:ascii))

(define $octal-char
  (char-set->arbitrary char-set:octal))

(define $non-octal-ascii-char
  (let ((char-set:non-octal (char-set-complement char-set:octal)))
    (char-set->arbitrary (char-set-intersection char-set:non-octal
                                                char-set:ascii))))

(configure-quickcheck
 ;; Perform 1000 tests per property...
 (stop? (lambda (success-count _)
          (>= success-count 1000)))
 ;; ...over input sizes from 0 to 10.
 (size (lambda (test-number)
         (if (zero? test-number)
             0
             (1+ (quotient test-number 100)))))
 ;; XXX: Only give up if we hit a rate of 500 discards per success.
 ;; This is because the '$octal' generator is not precise enough.
 (give-up? (lambda (success-count discard-count)
             (>= (/ discard-count (max 1 success-count)) 500))))

(define (string->octal str)
  (decode-octal (string->utf8 str)))

(test-begin "kinds--octal")

(test-equal "Recognizes a zero-padded 1"
  (make-padded-octal 1 6 #\0 "")
  (string->octal "000001"))

(test-equal "Recognizes a space-padded 1"
  (make-padded-octal 1 6 #\space "")
  (string->octal "     1"))

(test-equal "Recognizes a zero-padded 0"
  (make-padded-octal 0 6 #\0 "")
  (string->octal "000000"))

(test-equal "Recognizes a space-padded 0"
  (make-padded-octal 0 6 #\space "")
  (string->octal "     0"))

(test-equal "Padding defaults to 0"
  (make-padded-octal #o123 3 #\0 "")
  (string->octal "123"))

(test-equal "Does not treat '111112' as padded"
  (make-padded-octal #o111112 6 #\0 "")
  (string->octal "111112"))

(test-equal "Recognizes 'abc123' as unstructured"
  (make-unstructured-octal #o123 (make-zero-string "abc123" ""))
  (string->octal "abc123"))

(test-equal "Recognizes 'abc123xyz' as unstructured"
  (make-unstructured-octal #o123 (make-zero-string "abc123xyz" ""))
  (string->octal "abc123xyz"))

(test-equal "Recognizes '0x' as unstructured"
  (make-unstructured-octal 0 (make-zero-string "0x" ""))
  (string->octal "0x"))

(test-assert "[prop] Reading is reversible"
  (quickcheck
   (property ((bv $bytevector))
     (let ((bv* (make-bytevector (bytevector-length bv))))
       (encode-octal (decode-octal bv) bv*)
       (equal? bv bv*)))))

(test-assert "[prop] Reading produces a valid result"
  (quickcheck
   (property ((bv $bytevector))
     (valid-octal? (decode-octal bv)))))

(test-assert "[prop] The first valid number is recognized"
  (quickcheck
   (property ((intro ($string $non-octal-ascii-char))
              (n $natural)
              (outro-delim $non-octal-ascii-char)
              (outro ($string $ascii-char)))
     (test-when (not (string-index intro #\nul))
       (let* ((number (number->string n 8))
              (str (string-append intro number (string outro-delim) outro))
              (octal (string->octal str)))
         (= n (octal-value octal)))))))

(test-assert "[prop] Writing is reversible"
  (quickcheck
   (property ((octal $octal))
     (test-when (valid-octal? octal)
       (begin
         (equal? octal (decode-octal (encode-octal octal))))))))

(test-assert "[prop] Serializing is reversible"
  (quickcheck
   (property ((octal $octal))
     (test-when (valid-octal? octal)
       (equal? octal (serdeser -octal- octal))))))

(test-end "kinds--octal")