Welcome to the CHICKEN Scheme pasting service

(use test data-generators)

(define (make-falsified-property-condition value rounds)
  (make-property-condition
   'falsified-property
   'value value
   'rounds rounds))

(define (check-property property value round)
  (handle-exceptions exn (signal
                          (make-composite-condition
                           (make-falsified-property-condition value round)
                           exn))
                     (property value)))

(define (run-property-test sample-size gen property)
  (let ((rounds 0))
    (gen-for-each
     sample-size
     (lambda (value)
       (set! rounds (add1 rounds))
       (unless (check-property property value rounds)
         (signal
          (make-composite-condition
           (make-property-condition 'exn 'message (sprintf "falsified with ~a after ~a try(s)" value rounds))
           (make-falsified-property-condition value round)))))
     gen)
    #t))


(define current-sample-size (make-parameter 100))

(define test-property
  (case-lambda
    ((description gen property)
     (test-assert description
           (run-property-test (current-sample-size) gen property)))
    ((description amount gen property)
     (test-assert description
           (run-property-test amount gen property)))))




;; example
(test-property "it's always positive" 100 (gen-transform abs (gen-fixnum)) positive?)
(test-property "it fails" (gen-fixnum) positive?)

(define (gen-awful-hash-table)
  (gen-hash-table-of-verbose (gen-awful-key) (gen-procedure)))

(define (gen-awful-key)
  (let ((gen-string  (gen-string-of (gen-char char-set:letter+digit))))
     (gen-tuple-of gen-string gen-string (gen-symbol))))

(define-syntax make-procedure-generator
  (ir-macro-transformer
   (lambda (exp inj cmp)
     (let ((arity (cadr exp)))
       `(generator
         (lambda (,@(list-tabulate arity (constantly '_)))
           #f))))))

(define (gen-procedure)
  (case (<- (gen-fixnum 0 10))
    ((0) (make-procedure-generator 0))
    ((1) (make-procedure-generator 1))
    ((2) (make-procedure-generator 2))
    ((3) (make-procedure-generator 3))
    ((4) (make-procedure-generator 4))
    ((5) (make-procedure-generator 5))
    ((6) (make-procedure-generator 6))
    ((7) (make-procedure-generator 7))
    ((8) (make-procedure-generator 8))
    ((9)  (make-procedure-generator 9))
    ((10) (make-procedure-generator 10))))

(let ((samples 500))
  (with-size (range 0 10)
             ;; (test-property "construct" samples (gen-pair-of (gen-scheme-value 4) (gen-scheme-value 4)) prop-insert)
             ;; (test-property "retrieve values" samples (gen-hash-table-for-test) prop-retrieve-value)
             ;; (test-property "retrieve values with defaults" samples (gen-hash-table-for-test) prop-retrieve-value/default)
             (test-property "awful construct" samples (gen-pair-of (gen-awful-key) (gen-procedure)) prop-insert)
             (test-property "awful retrieve values" samples (gen-awful-hash-table) prop-retrieve-value)
             (test-property "awful retrieve values with default" samples (gen-awful-hash-table) prop-retrieve-value/default)))