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-property-sample-size (make-parameter 100))

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


(use srfi-69)

(define (gen-scheme-value nesting)
  (generator
   (if (positive? nesting)
       (<- (gen-sample-of (gen-scalar-scheme-value) (gen-composite-scheme-value (sub1 nesting))))
       (<- (gen-scalar-scheme-value)))))

(define (gen-symbol)
  (gen-transform string->symbol (gen-string-of (gen-char char-set:letter) (range 0 15))))

(define (gen-scalar-scheme-value)
  (generator
   (<- (gen-sample-of
        (gen-symbol)
        (gen-fixnum)
        (gen-bool)
        (gen-real)
        (gen-string-of (gen-char))))))

(define (gen-composite-scheme-value nesting)
  (generator
   (<- (gen-sample-of
        (gen-list-of   (gen-scheme-value (sub1 nesting)))
        (gen-vector-of (gen-scheme-value (sub1 nesting)))
        (gen-alist-of  (gen-symbol) (gen-scheme-value (sub1 nesting)))
        (gen-pair-of   (gen-scheme-value (sub1 nesting)) (gen-scheme-value (sub1 nesting)))))))

(define gen-hash-table-of-verbose
  (case-lambda
    ((key-gen value-gen) (gen-hash-table-of key-gen value-gen (gen-current-default-size)))
    ((key-gen value-gen size-spec)
     (let ((size-gen (size-spec->gen size-spec)))
       (generator
	(let ((size (<- size-gen)))
	  (do ((i 0 (add1 i))
	       (ht (make-hash-table)))
	      ((>= i size) ht)
            (let ((key (<- key-gen)))
              (print "key is" key)
              (hash-table-set! ht key (<- value-gen))))))))))

(define (prop-retrieve-value ht)
  (every (lambda (key) (handle-exceptions _ #f (hash-table-ref ht key))) (hash-table-keys ht)))

(define (prop-insert pair)
  (let ((ht (make-hash-table)))
    (hash-table-set! ht (car pair) (cdr pair))))

(define (prop-retrieve-value/default ht)
  (every (lambda (key) (hash-table-ref/default ht key #f)) (hash-table-keys ht)))

(define (gen-hash-table-for-test)
  (gen-hash-table-of (gen-scheme-value 4) (gen-fixnum) 10))

(let ((samples 300))
  (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)))