Disarchive/tests/kinds.scm

;;; Disarchive
;;; Copyright © 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/>.

(define-module (tests kinds)
  #:use-module (disarchive kinds binary-string)
  #:use-module (disarchive kinds octal)
  #:use-module (disarchive kinds zero-string)
  #:use-module (disarchive utils)
  #:use-module (quickcheck arbitrary)
  #:use-module (quickcheck generator)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-26)
  #:export ($binary-string
            $zero-string
            $octal
            $non-bytevector-pax-records
            $pax-records
            $gnu-path
            $gnu-linkpath
            $tar-header))

;;; Commentary:
;;;
;;; This module provides QuickCheck types for generating random
;;; instances of the various Disarchive "kinds".  The generators here
;;; are not intended to be perfect.  Rather, they only need to be good
;;; enough to work with the help of "test-when" and a validation
;;; predicate.
;;;
;;; Code:

(define (tweak-generator arb proc)
  (arbitrary
   (gen (proc (arbitrary-gen arb)))
   (xform (arbitrary-xform arb))))

(define false? not)

(define $false ($const #f))

(define $binary-string
  (let (($raw ($choose
               (string? ($string $char))
               (bytevector? $bytevector))))
    (tweak-generator $raw
      (lambda (gen)
        (generator-let* ((str gen))
          (if (and (bytevector? str) (zero? (bytevector-length str)))
              (generator-return "")
              (generator-return str)))))))

(define $zero-string
  ($record make-zero-string
    (zero-string-value $binary-string)
    (zero-string-trailer $binary-string)))

(define $padded-octal
  ($record make-padded-octal
    (padded-octal-value $natural)
    (padded-octal-width $natural)
    (padded-octal-padding $char)
    (padded-octal-trailer $binary-string)))

(define (fix-unstructured-octal-value octal)
  (define (first-octal-value str)
    (match (string-tokenize str (string->char-set "01234567"))
      ((first . rest) (string->number first 8))
      (_ #f)))

  (match (zero-string-value (unstructured-octal-source octal))
    ((? string? str)
     (let ((value (or (first-octal-value str)
                      0)))
       (make-unstructured-octal value (unstructured-octal-source octal))))
    ((? bytevector?)
     (make-unstructured-octal 0 (unstructured-octal-source octal)))))

(define $unstructured-octal
  (let (($raw ($record make-unstructured-octal
                (unstructured-octal-value $natural)
                (unstructured-octal-source $zero-string))))
    (tweak-generator $raw
      (cut generator-lift fix-unstructured-octal-value <>))))

(define $octal
  ($choose
   (padded-octal? $padded-octal)
   (unstructured-octal? $unstructured-octal)))

(define $non-bytevector-pax-records
  ($list ($pair $binary-string $binary-string)))

(define (binary-string+binary-string? obj)
  (match obj
    (((? binary-string?) . (? binary-string?)) #t)
    (_ #f)))

(define $pax-records
  ($list
   ($choose
    (binary-string+binary-string? ($pair $binary-string $binary-string))
    (bytevector? $bytevector))))

(define ($singleton x)
  (tweak-generator ($list x) (cut resize-generator 1 <>)))

(define $gnu-path
  ($singleton ($pair ($const "path") $zero-string)))
(define $gnu-linkpath
  ($singleton ($pair ($const "linkpath") $zero-string)))

;;; Local Variables:
;;; eval: (put 'tweak-generator 'scheme-indent-function 1))
;;; End: