suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

2nd attempt at generators for records/structs.

Browse Source 
This time, with feeling.
This commit is contained in:
Mike Sperber 2010-10-11 13:34:16 +02:00
parent cc79890f71
commit eebe5b2e2b
7 changed files with 70 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/deinprogramm/define-record-procedures.rkt
View File

@ -12,7 +12,8 @@
mzlib/pretty
deinprogramm/signature/signature
deinprogramm/signature/signature-german
deinprogramm/signature/signature-syntax)
deinprogramm/signature/signature-syntax
(only-in deinprogramm/quickcheck/quickcheck arbitrary-record))
(require (for-syntax scheme/base)
(for-syntax deinprogramm/syntax-checkers)

19
collects/deinprogramm/define-record-procedures.scm
View File

@ -183,10 +183,21 @@
component-signature ...)))
;; lazy signatures
#'(define (?signature-constructor-name ?param ...)
(make-lazy-wrap-signature '?type-name #t
type-descriptor raw-predicate
(list ?param ...)
#'?type-name)))
(let* ((sigs (list ?param ...))
(sig
(make-lazy-wrap-signature '?type-name #t
type-descriptor raw-predicate
sigs
#'?type-name)))
(let ((arbs (map signature-arbitrary sigs)))
(when (andmap values arbs)
(set-signature-arbitrary!
sig
(apply arbitrary-record
?constructor
(list raw-accessor-proc ...)
arbs))))
sig)))
'stepper-skip-completely
#t)))
#'(begin

2
collects/deinprogramm/quickcheck/quickcheck.rkt
View File

@ -13,6 +13,7 @@
arbitrary-pair
arbitrary-list
arbitrary-vector
arbitrary-tuple arbitrary-record
arbitrary-string
arbitrary-ascii-string arbitrary-printable-ascii-string
arbitrary-symbol
@ -26,6 +27,7 @@
collect
)
(require srfi/9
racket/promise
"random.ss")
(provide exn:assertion-violation?

30
collects/deinprogramm/quickcheck/quickcheck.scm
View File

@ -39,7 +39,7 @@
(define choose-ascii-letter
(lift->generator (lambda (i)
(string-ref
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"))
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz" i))
(choose-integer 0 51)))
(define choose-printable-ascii-char
@ -163,10 +163,10 @@
(define generator-bind >>=)
(define generator-sequence sequence)
; (list (generator a)) -> (generator a)
; (list (promise (generator a))) -> (generator a)
(define (choose-mixed gens)
(>>= (choose-one-of gens)
values))
force))
; (list (pair int (generator a))) -> (generator a)
(define (choose-with-frequencies lis)
@ -272,17 +272,17 @@
(denominator fr) gen))))))
(define (arbitrary-mixed pred+arbitrary-list)
(define (arbitrary-mixed pred+arbitrary-promise-list)
(make-arbitrary (choose-mixed (map (lambda (p)
(arbitrary-generator (cdr p)))
pred+arbitrary-list))
(delay (arbitrary-generator (force (cdr p)))))
pred+arbitrary-promise-list))
(lambda (val gen)
(let loop ((lis pred+arbitrary-list) (n 0))
(let loop ((lis pred+arbitrary-promise-list) (n 0))
(cond
((null? lis)
(assertion-violation 'arbitrary-mixed
"value matches none of the predicates"
val pred+arbitrary-list))
val pred+arbitrary-promise-list))
(((caar lis) val)
(variant n gen))
(else
@ -327,6 +327,20 @@
(recur (cdr arbitrary-els)
(cdr lis))))))))
(define (arbitrary-record construct accessors . arbitrary-els)
(make-arbitrary (apply lift->generator
construct
(map arbitrary-generator arbitrary-els))
(lambda (rec gen)
(let recur ((arbitrary-els arbitrary-els)
(lis (map (lambda (accessor) (accessor rec)) accessors)))
(if (null? arbitrary-els)
gen
((arbitrary-transformer (car arbitrary-els))
(car lis)
(recur (cdr arbitrary-els)
(cdr lis))))))))
(define (arbitrary-sequence choose-sequence sequence->list arbitrary-el)
(make-arbitrary (sized
(lambda (n)

20
collects/deinprogramm/signature/signature-unit.rkt
View File

@ -207,14 +207,18 @@
(delay (make-mixed-info (force alternative-signatures-promise)))
#:arbitrary-promise
(delay
(let ((arbitraries (map force (map signature-arbitrary-promise (force alternative-signatures-promise)))))
(if (andmap values arbitraries)
(arbitrary-mixed
(map (lambda (sig arb)
(cons (signature->predicate sig)
arb))
(force alternative-signatures-promise) arbitraries))
#f)))
(let* ((arbitrary-promises (map signature-arbitrary-promise alternative-signatures))
(raising-promises
(map (lambda (prm)
(delay
(or (force prm)
(error "Signatur hat keinen Generator")))) ; #### src location
arbitrary-promises)))
(arbitrary-mixed
(map (lambda (sig arbp)
(cons (signature->predicate sig)
arbp))
alternative-signatures raising-promises))))
#:=?-proc
(lambda (this-info other-info)
(and (mixed-info? other-info)

2
collects/deinprogramm/signature/signature.rkt
View File

@ -58,7 +58,7 @@
(display "#<signature>" port)))))
(define (make-signature name enforcer syntax-promise
#:arbitrary-promise (arbitrary-promise #f)
#:arbitrary-promise (arbitrary-promise (delay #f))
#:info-promise (info-promise (delay #f))
#:<=?-proc (<=?-proc
(lambda (this-info other-info)

21
collects/lang/private/teach.rkt
View File

@ -894,11 +894,22 @@
(combined (at name_ (predicate raw-predicate))
(at field_ (signature:property getter-name field_/no-loc)) ...)))
#`(define (#,parametric-signature-name field_ ...)
(make-lazy-wrap-signature 'name_ #t
type-descriptor
raw-predicate
(list field_/no-loc ...)
#'name_)))
(let* ((sigs (list field_/no-loc ...))
(sig
(make-lazy-wrap-signature 'name_ #t
type-descriptor
raw-predicate
sigs
#'name_)))
(let ((arbs (map signature-arbitrary sigs)))
(when (andmap values arbs)
(set-signature-arbitrary!
sig
(apply arbitrary-record
#,constructor-name
(list #,@getter-names)
arbs))))
sig)))
(values #,signature-name #,parametric-signature-name proc-name ...)))
'stepper-define-struct-hint