Provide English and German versions of deinprogramm/signature/signature.
This commit is contained in:
parent
b98b83b672
commit
87da2f35b9
|
@ -4,7 +4,7 @@
|
|||
(require mzlib/pretty
|
||||
mzlib/struct)
|
||||
|
||||
(require deinprogramm/signature/signature)
|
||||
(require deinprogramm/signature/signature-german)
|
||||
|
||||
(require scheme/include)
|
||||
(include "convert-explicit.scm")
|
||||
|
|
|
@ -11,6 +11,7 @@
|
|||
mzlib/pconvert-prop
|
||||
mzlib/pretty
|
||||
deinprogramm/signature/signature
|
||||
deinprogramm/signature/signature-german
|
||||
deinprogramm/signature/signature-syntax)
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
|
|
14
collects/deinprogramm/signature/signature-english.rkt
Normal file
14
collects/deinprogramm/signature/signature-english.rkt
Normal file
|
@ -0,0 +1,14 @@
|
|||
#lang scheme/base
|
||||
(require deinprogramm/signature/signature-unit
|
||||
racket/unit)
|
||||
|
||||
(provide-signature-elements signatures^)
|
||||
|
||||
(define recursive-signature-message "recursive signature")
|
||||
(define parameter-count-mismatch-message "wrong number of parameters")
|
||||
(define argument-count-mismatch-message "wrong number of arguments")
|
||||
|
||||
(define-values/invoke-unit signatures@
|
||||
(import signature-messages^)
|
||||
(export signatures^))
|
||||
|
14
collects/deinprogramm/signature/signature-german.rkt
Normal file
14
collects/deinprogramm/signature/signature-german.rkt
Normal file
|
@ -0,0 +1,14 @@
|
|||
#lang scheme/base
|
||||
(require deinprogramm/signature/signature-unit
|
||||
racket/unit)
|
||||
|
||||
(provide-signature-elements signatures^)
|
||||
|
||||
(define recursive-signature-message "rekursive Signatur")
|
||||
(define parameter-count-mismatch-message "falsche Anzahl von Parametern")
|
||||
(define argument-count-mismatch-message "falsche Anzahl von Argumenten")
|
||||
|
||||
(define-values/invoke-unit signatures@
|
||||
(import signature-messages^)
|
||||
(export signatures^))
|
||||
|
|
@ -7,6 +7,7 @@
|
|||
-> mixed one-of predicate combined property list-of)
|
||||
|
||||
(require deinprogramm/signature/signature
|
||||
deinprogramm/signature/signature-german
|
||||
scheme/promise
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax syntax/stx)
|
||||
|
|
652
collects/deinprogramm/signature/signature-unit.rkt
Normal file
652
collects/deinprogramm/signature/signature-unit.rkt
Normal file
|
@ -0,0 +1,652 @@
|
|||
#lang scheme/base
|
||||
(provide signature-messages^ signatures^ signatures@)
|
||||
|
||||
(require racket/unit)
|
||||
|
||||
(require scheme/promise
|
||||
mzlib/struct
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax stepper/private/shared))
|
||||
|
||||
(require deinprogramm/signature/signature)
|
||||
|
||||
(require deinprogramm/quickcheck/quickcheck)
|
||||
|
||||
(define-signature signature-messages^
|
||||
(recursive-signature-message
|
||||
parameter-count-mismatch-message
|
||||
argument-count-mismatch-message))
|
||||
|
||||
(define-signature signatures^
|
||||
(make-delayed-signature
|
||||
make-call-signature
|
||||
make-property-signature
|
||||
make-predicate-signature
|
||||
make-type-variable-signature
|
||||
make-list-signature
|
||||
make-mixed-signature
|
||||
make-combined-signature
|
||||
make-case-signature
|
||||
make-procedure-signature
|
||||
procedure-signature-info?
|
||||
procedure-signature-info-arg-signatures procedure-signature-info-return-signature
|
||||
make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors
|
||||
prop:lazy-wrap lazy-wrap? lazy-wrap-ref
|
||||
make-lazy-wrap-signature
|
||||
check-lazy-wraps!
|
||||
make-pair-signature checked-car checked-cdr))
|
||||
|
||||
(define-unit signatures@
|
||||
(import signature-messages^)
|
||||
(export signatures^)
|
||||
|
||||
(define (make-delayed-signature name promise)
|
||||
(make-signature name
|
||||
(lambda (self obj)
|
||||
((signature-enforcer (force promise)) self obj))
|
||||
(delay (signature-syntax (force promise)))
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(force (signature-arbitrary-promise (force promise))))
|
||||
#:info-promise
|
||||
(delay
|
||||
(force (signature-info-promise (force promise))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
((signature-<=?-proc (force promise)) this-info other-info))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
((signature-=?-proc (force promise)) this-info other-info))))
|
||||
|
||||
; specialized version of the above, supports comparison
|
||||
; the promise must produce the result of (proc . args), but its passed separately
|
||||
; to give us the right location on backtrace
|
||||
(define (make-call-signature name promise proc-promise args-promise syntax)
|
||||
(make-signature name
|
||||
(lambda (self obj)
|
||||
((signature-enforcer (force promise)) self obj))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(force (signature-arbitrary-promise (force promise))))
|
||||
#:info-promise
|
||||
(delay
|
||||
(make-call-info promise (force proc-promise) (force args-promise)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (call-info? other-info)
|
||||
(eqv? (force proc-promise) (call-info-proc other-info))
|
||||
(equal? (force args-promise) (call-info-args other-info))))))
|
||||
|
||||
(define-struct call-info (promise proc args) #:transparent)
|
||||
|
||||
; klude to support mixed
|
||||
(define (real-signature-info sig)
|
||||
(let ((raw-info (force (signature-info-promise sig))))
|
||||
(if (call-info? raw-info)
|
||||
(real-signature-info (force (call-info-promise raw-info)))
|
||||
(force raw-info))))
|
||||
|
||||
(define (make-property-signature name access signature syntax)
|
||||
(let ((enforce (signature-enforcer signature)))
|
||||
(make-signature name
|
||||
(lambda (self obj)
|
||||
(enforce self (access obj)) ; #### problematic: enforcement doesn't stick
|
||||
obj)
|
||||
syntax)))
|
||||
|
||||
(define (make-predicate-signature name predicate-promise syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj) ; dynamic binding because of syntax remapping via `signature-update-syntax'
|
||||
(if ((force predicate-promise) obj)
|
||||
obj
|
||||
(begin
|
||||
(signature-violation obj self #f #f)
|
||||
obj)))
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay (make-predicate-info (force predicate-promise)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (predicate-info? other-info)
|
||||
(eq? (force predicate-promise)
|
||||
(predicate-info-predicate other-info))))))
|
||||
|
||||
(define-struct predicate-info (predicate) #:transparent)
|
||||
|
||||
(define (make-type-variable-signature name syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj) obj)
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay (make-type-variable-info))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(type-variable-info? other-info))))
|
||||
|
||||
; maps lists to pairs of signature, enforced value
|
||||
(define lists-table (make-weak-hasheq))
|
||||
|
||||
(define (make-list-signature name arg-signature syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
;;(write (list 'list obj) (current-error-port)) (newline (current-error-port))
|
||||
(let recur ((l obj))
|
||||
|
||||
(define (go-on)
|
||||
(let ((enforced (cons (apply-signature arg-signature (car l))
|
||||
(recur (cdr l)))))
|
||||
(hash-set! lists-table l (cons self enforced))
|
||||
(hash-set! lists-table enforced (cons self enforced))
|
||||
enforced))
|
||||
|
||||
(cond
|
||||
((null? l)
|
||||
l)
|
||||
((not (pair? l))
|
||||
(signature-violation obj self #f #f)
|
||||
obj)
|
||||
((hash-ref lists-table l #f)
|
||||
=> (lambda (seen)
|
||||
;;(write (list 'seen seen (eq? self (car seen))) (current-error-port)) (newline (current-error-port))
|
||||
(if (eq? self (car seen))
|
||||
(cdr seen)
|
||||
(go-on))))
|
||||
(else
|
||||
(go-on)))))
|
||||
syntax
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(lift->arbitrary arbitrary-list arg-signature))
|
||||
#:info-promise
|
||||
(delay (make-list-info arg-signature))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (list-info? other-info)
|
||||
(signature=? arg-signature (list-info-arg-signature other-info))))))
|
||||
|
||||
(define-struct list-info (arg-signature) #:transparent)
|
||||
|
||||
(define (lift->arbitrary proc . signatures)
|
||||
(let ((arbitraries (map force (map signature-arbitrary-promise signatures))))
|
||||
(if (andmap values arbitraries)
|
||||
(apply proc arbitraries)
|
||||
#f)))
|
||||
|
||||
(define (make-mixed-signature name alternative-signatures syntax)
|
||||
(letrec ((alternative-signatures-promise
|
||||
(delay
|
||||
(normalize-mixed-signatures mixed-signature alternative-signatures)))
|
||||
(mixed-signature
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
(let loop ((alternative-signatures (force alternative-signatures-promise)))
|
||||
(cond
|
||||
((null? alternative-signatures)
|
||||
(signature-violation obj self #f #f)
|
||||
obj)
|
||||
((eq? (car alternative-signatures) self)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(if name
|
||||
(format "~a: ~a" recursive-signature-message)
|
||||
recursive-signature-message))
|
||||
(current-continuation-marks))))
|
||||
(else
|
||||
(check-signature (car alternative-signatures)
|
||||
obj
|
||||
values
|
||||
(lambda () (loop (cdr alternative-signatures))))))))
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(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)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (mixed-info? other-info)
|
||||
(andmap signature=?
|
||||
(mixed-info-signatures this-info)
|
||||
(mixed-info-signatures other-info))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (mixed-info? other-info)
|
||||
(mixed-signature<=? (mixed-info-signatures this-info)
|
||||
(mixed-info-signatures other-info)))))))
|
||||
mixed-signature))
|
||||
|
||||
(define (mixed-signature<=? sigs1 sigs2)
|
||||
(andmap (lambda (sig1)
|
||||
(ormap (lambda (sig2)
|
||||
(signature<=? sig1 sig2))
|
||||
sigs2))
|
||||
sigs1))
|
||||
|
||||
; Flatten out mixed signatures, and fold in in the lazy-wrap
|
||||
; signatures
|
||||
|
||||
(define (normalize-mixed-signatures mixed-signature sigs)
|
||||
(fold-lazy-wrap-signatures mixed-signature (flatten-mixed-signatures sigs)))
|
||||
|
||||
(define (flatten-mixed-signatures sigs)
|
||||
(apply append
|
||||
(map (lambda (sig)
|
||||
(let ((info (force (signature-info-promise sig))))
|
||||
(if (mixed-info? info)
|
||||
(mixed-info-signatures info)
|
||||
(list sig))))
|
||||
sigs)))
|
||||
|
||||
(define-struct mixed-info (signatures) #:transparent)
|
||||
|
||||
(define (check-signature sig val success fail)
|
||||
((let/ec exit
|
||||
(let ((enforced
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (signature syntax msg blame)
|
||||
(exit fail))
|
||||
(lambda ()
|
||||
(apply-signature sig val)))))
|
||||
(lambda () (success enforced))))))
|
||||
|
||||
(define (signature->predicate sig)
|
||||
(lambda (val)
|
||||
(check-signature sig val (lambda (_) #t) (lambda () #f))))
|
||||
|
||||
(define (make-combined-signature name signatures syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
(let ((old-violation-proc (signature-violation-proc)))
|
||||
((let/ec exit
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (signature syntax msg blame)
|
||||
(exit
|
||||
(lambda ()
|
||||
(old-violation-proc signature syntax msg blame)
|
||||
obj)))
|
||||
(lambda ()
|
||||
(let loop ((signatures signatures)
|
||||
(obj obj))
|
||||
(if (null? signatures)
|
||||
(lambda () obj)
|
||||
(loop (cdr signatures)
|
||||
(apply-signature (car signatures) obj))))))))))
|
||||
(delay syntax)))
|
||||
|
||||
(define (make-case-signature name cases =? syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
(let loop ((cases cases))
|
||||
(cond
|
||||
((null? cases)
|
||||
(signature-violation obj self #f #f)
|
||||
obj)
|
||||
((=? (car cases) obj)
|
||||
obj)
|
||||
(else
|
||||
(loop (cdr cases))))))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay (apply arbitrary-one-of =? cases))))
|
||||
|
||||
(define signature-key (gensym 'signature-key))
|
||||
|
||||
(define-struct procedure-signature-info (arg-signatures return-signature) #:transparent)
|
||||
|
||||
(define (make-procedure-signature name arg-signatures return-signature syntax)
|
||||
(let ((arg-count (length arg-signatures)))
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self thing)
|
||||
(let-values (((proc blame-syntax)
|
||||
(if (procedure-to-blame? thing)
|
||||
(values (procedure-to-blame-proc thing)
|
||||
(procedure-to-blame-syntax thing))
|
||||
(values thing #f))))
|
||||
(cond
|
||||
((not (procedure? proc))
|
||||
(signature-violation proc self #f #f)
|
||||
thing)
|
||||
((not (procedure-arity-includes? proc arg-count)) ; #### variable arity
|
||||
(signature-violation proc self parameter-count-mismatch-message #f)
|
||||
thing)
|
||||
(else
|
||||
(attach-name
|
||||
(object-name proc)
|
||||
(procedure-reduce-arity
|
||||
(lambda args
|
||||
(call-with-immediate-continuation-mark
|
||||
signature-key
|
||||
(lambda (maybe)
|
||||
(if (not (= (length args) arg-count))
|
||||
(begin
|
||||
(signature-violation proc self argument-count-mismatch-message #f)
|
||||
(apply-signature return-signature (apply proc args)))
|
||||
(let* ((old-violation-proc (signature-violation-proc))
|
||||
(arg-violation? #f)
|
||||
(args
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (obj signature message blame)
|
||||
(set! arg-violation? #t)
|
||||
(old-violation-proc obj signature message blame))
|
||||
(lambda ()
|
||||
(map apply-signature arg-signatures args)))))
|
||||
(if (eq? maybe return-signature)
|
||||
(apply proc args)
|
||||
(let ((retval
|
||||
(with-continuation-mark
|
||||
signature-key return-signature
|
||||
(apply proc args))))
|
||||
(if arg-violation?
|
||||
retval
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (obj signature message _)
|
||||
;; blame the procedure
|
||||
(old-violation-proc obj signature message blame-syntax))
|
||||
(lambda ()
|
||||
(apply-signature return-signature retval)))))))))))
|
||||
(procedure-arity proc)))))))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(apply lift->arbitrary arbitrary-procedure return-signature arg-signatures))
|
||||
#:info-promise
|
||||
(delay
|
||||
(make-procedure-signature-info arg-signatures return-signature)))))
|
||||
|
||||
(define (attach-name name thing)
|
||||
(if (and (procedure? thing)
|
||||
(symbol? name))
|
||||
(procedure-rename thing name)
|
||||
thing))
|
||||
|
||||
; Lazy signature checking for structs
|
||||
|
||||
;; This is attached prop:lazy-wrap property of struct types subject to
|
||||
;; lazy checking.
|
||||
(define-struct lazy-wrap-info
|
||||
(constructor
|
||||
raw-accessors raw-mutators
|
||||
;; procedures for referencing or setting an additional field within the struct
|
||||
;; that field contains a list of lists of unchecked field signatures
|
||||
ref-proc set!-proc))
|
||||
|
||||
; value should be a lazy-wrap-info
|
||||
(define-values (prop:lazy-wrap lazy-wrap? lazy-wrap-ref)
|
||||
(make-struct-type-property 'lazy-wrap))
|
||||
|
||||
; The field accessed by ref-proc and set!-proc contains one of these:
|
||||
|
||||
(define-struct lazy-wrap-log
|
||||
;; list of lazy-log-not-checked
|
||||
(not-checked
|
||||
;; list of lists of field signatures
|
||||
checked)
|
||||
#:transparent)
|
||||
|
||||
; This situation makes trouble:
|
||||
; (make-mixed-signature (make-lazy-wrap-signature ...) (make-lazy-wrap-signature ...) ...)
|
||||
|
||||
; We need to push the `mixed' signature inside the lazy-wrap
|
||||
; signature, which is why the struct-map signature has an implicit
|
||||
; `mixed'.
|
||||
; To this end, a `lazy-log-not-checked' object tracks a list of
|
||||
; `mixed' alternatives. The `mixed-signature' field tracks from which
|
||||
; `mixed' contract the mixture has originally come from.
|
||||
; (It may be #f, in which case the `field-signatures-list' is a one-element list.)
|
||||
(define-struct lazy-log-not-checked
|
||||
(mixed-signature field-signatures-list)
|
||||
#:transparent)
|
||||
|
||||
(define (make-lazy-wrap-signature name type-descriptor predicate field-signatures syntax)
|
||||
(really-make-lazy-wrap-signature name type-descriptor predicate #f (list field-signatures) syntax))
|
||||
|
||||
; The lists of signatures in `field-signatures-list' form an implicit mixed signature.
|
||||
(define (really-make-lazy-wrap-signature name type-descriptor predicate
|
||||
mixed-signature field-signatures-list
|
||||
syntax)
|
||||
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
|
||||
(not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list))
|
||||
(lazy-wrap-signature-info (make-lazy-wrap-signature-info type-descriptor predicate field-signatures-list)))
|
||||
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
|
||||
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
|
||||
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
|
||||
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self thing)
|
||||
|
||||
(if (not (predicate thing))
|
||||
(signature-violation thing self #f #f)
|
||||
(let ((log (wrap-ref thing)))
|
||||
(cond
|
||||
((not log)
|
||||
(wrap-set! thing
|
||||
(make-lazy-wrap-log (list not-checked) '())))
|
||||
((not (let ()
|
||||
(define (<=? sigs1 sigs2)
|
||||
(andmap signature<=? sigs1 sigs2))
|
||||
(define (check wrap-field-signatures)
|
||||
(ormap (lambda (field-signatures)
|
||||
(<=? wrap-field-signatures field-signatures))
|
||||
field-signatures-list))
|
||||
(or (ormap (lambda (wrap-not-checked)
|
||||
(andmap check
|
||||
(lazy-log-not-checked-field-signatures-list wrap-not-checked)))
|
||||
(lazy-wrap-log-not-checked log))
|
||||
(ormap check (lazy-wrap-log-checked log)))))
|
||||
(wrap-set! thing
|
||||
(make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log))
|
||||
(lazy-wrap-log-checked log)))))))
|
||||
|
||||
thing)
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay lazy-wrap-signature-info)
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (lazy-wrap-signature-info? other-info)
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)
|
||||
(eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info))
|
||||
(andmap (lambda (this-field-signatures)
|
||||
(andmap (lambda (other-field-signatures)
|
||||
(andmap signature=? this-field-signatures other-field-signatures))
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)))
|
||||
(lazy-wrap-signature-info-field-signatures-list this-info))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (lazy-wrap-signature-info? other-info)
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)
|
||||
(eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info))
|
||||
(andmap (lambda (this-field-signatures)
|
||||
(ormap (lambda (other-field-signatures)
|
||||
(andmap signature<=? this-field-signatures other-field-signatures))
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)))
|
||||
(lazy-wrap-signature-info-field-signatures-list this-info))))))))
|
||||
|
||||
(define-struct lazy-wrap-signature-info (descriptor predicate field-signatures-list) #:transparent)
|
||||
|
||||
(define (check-lazy-wraps! descriptor thing)
|
||||
(let ((lazy-wrap-info (lazy-wrap-ref descriptor)))
|
||||
|
||||
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
|
||||
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
|
||||
(raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info))
|
||||
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
|
||||
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
|
||||
|
||||
(let ((log (wrap-ref thing)))
|
||||
(when (and log (pair? (lazy-wrap-log-not-checked log)))
|
||||
(let loop ((field-vals (map (lambda (raw-accessor)
|
||||
(raw-accessor thing))
|
||||
raw-accessors))
|
||||
(now-checked '())
|
||||
(not-checkeds (lazy-wrap-log-not-checked log)))
|
||||
(if (null? not-checkeds)
|
||||
(begin
|
||||
(for-each (lambda (raw-mutator field-val)
|
||||
(raw-mutator thing field-val))
|
||||
raw-mutators field-vals)
|
||||
(wrap-set! thing
|
||||
(make-lazy-wrap-log '()
|
||||
(append now-checked
|
||||
(lazy-wrap-log-checked log)))))
|
||||
(let ((not-checked (car not-checkeds)))
|
||||
(let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked))
|
||||
(mixed-signature (lazy-log-not-checked-mixed-signature not-checked)))
|
||||
(if (not mixed-signature) ; one-element list
|
||||
(loop (map apply-signature (car field-signatures-list) field-vals)
|
||||
(cons (car field-signatures-list) now-checked)
|
||||
(cdr not-checkeds))
|
||||
(let inner ((field-signatures-list field-signatures-list)) ; implicit mixed
|
||||
(if (null? field-signatures-list)
|
||||
(signature-violation thing mixed-signature #f #f)
|
||||
(let map ((sigs (car field-signatures-list))
|
||||
(field-vals field-vals)
|
||||
(new-field-vals '()))
|
||||
(if (null? sigs)
|
||||
(loop (reverse new-field-vals)
|
||||
(cons (car field-signatures-list) now-checked)
|
||||
(cdr not-checkeds))
|
||||
(check-signature (car sigs)
|
||||
(car field-vals)
|
||||
(lambda (new-val)
|
||||
(map (cdr sigs)
|
||||
(cdr field-vals)
|
||||
(cons new-val new-field-vals)))
|
||||
(lambda ()
|
||||
(inner (cdr field-signatures-list))))))))))))))))))
|
||||
|
||||
; pushes down mixed contracts
|
||||
(define (fold-lazy-wrap-signatures mixed-signature sigs)
|
||||
(let ((lazy-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures
|
||||
|
||||
(define (push-down-lazy-wrap-sigs)
|
||||
(hash-map lazy-wrap-sigs
|
||||
(lambda (type-desc signatures)
|
||||
(really-make-lazy-wrap-signature
|
||||
(signature-name (car signatures)) type-desc
|
||||
(lazy-wrap-signature-info-predicate (real-signature-info (car signatures)))
|
||||
mixed-signature
|
||||
(apply append
|
||||
(map (lambda (sig)
|
||||
(lazy-wrap-signature-info-field-signatures-list (real-signature-info sig)))
|
||||
signatures))
|
||||
(signature-syntax (car signatures))))))
|
||||
|
||||
(let loop ((sigs sigs)
|
||||
(vanilla-sigs '()))
|
||||
(if (null? sigs)
|
||||
(append (push-down-lazy-wrap-sigs)
|
||||
(reverse vanilla-sigs))
|
||||
(let* ((sig (car sigs))
|
||||
(info (real-signature-info sig)))
|
||||
(if (lazy-wrap-signature-info? info)
|
||||
(let ((type-desc (lazy-wrap-signature-info-descriptor info)))
|
||||
(hash-update! lazy-wrap-sigs
|
||||
type-desc
|
||||
(lambda (old)
|
||||
(cons sig old))
|
||||
(lambda ()
|
||||
(list sig)))
|
||||
(loop (cdr sigs) vanilla-sigs))
|
||||
(loop (cdr sigs) (cons sig vanilla-sigs))))))))
|
||||
|
||||
(define checked-pair-table (make-weak-hasheq))
|
||||
|
||||
(define-struct checked-pair
|
||||
(car cdr log)
|
||||
#:mutable)
|
||||
|
||||
(define (checked-pair-access checked-access raw-access)
|
||||
(lambda (p)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> checked-access)
|
||||
(else (raw-access p)))))
|
||||
|
||||
(define checked-raw-car (checked-pair-access checked-pair-car car))
|
||||
(define checked-raw-cdr (checked-pair-access checked-pair-cdr cdr))
|
||||
|
||||
(define (checked-raw-set! checked-set!)
|
||||
(lambda (p new)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> (lambda (cp)
|
||||
(checked-set! cp new)))
|
||||
(else
|
||||
(let ((cp (make-checked-pair (car p) (cdr p) #f)))
|
||||
(checked-set! cp new)
|
||||
(hash-set! checked-pair-table p cp))))))
|
||||
|
||||
(define checked-raw-set-car! (checked-raw-set! set-checked-pair-car!))
|
||||
(define checked-raw-set-cdr! (checked-raw-set! set-checked-pair-cdr!))
|
||||
|
||||
(define (checked-pair-get-log p)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> checked-pair-log)
|
||||
(else #f)))
|
||||
|
||||
(define (checked-pair-set-log! p new)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> (lambda (cp)
|
||||
(set-checked-pair-log! cp new)))
|
||||
(else
|
||||
(hash-set! checked-pair-table p
|
||||
(make-checked-pair (car p) (cdr p) new)))))
|
||||
|
||||
(define checked-pair-lazy-wrap-info
|
||||
(make-lazy-wrap-info cons
|
||||
(list checked-raw-car checked-raw-cdr)
|
||||
(list checked-raw-set-car! checked-raw-set-cdr!)
|
||||
checked-pair-get-log
|
||||
checked-pair-set-log!))
|
||||
|
||||
(define checked-pair-descriptor
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(make-struct-type 'dummy-checked-pair #f 0 0 #f
|
||||
(list
|
||||
(cons prop:lazy-wrap checked-pair-lazy-wrap-info))))
|
||||
(lambda (desc . _)
|
||||
desc)))
|
||||
|
||||
(define (make-pair-signature car-sig cdr-sig)
|
||||
(make-lazy-wrap-signature 'pair checked-pair-descriptor pair? (list car-sig cdr-sig) #'pair))
|
||||
|
||||
(define (checked-car p)
|
||||
(car p)
|
||||
(check-lazy-wraps! checked-pair-descriptor p)
|
||||
(checked-raw-car p))
|
||||
|
||||
(define (checked-cdr p)
|
||||
(cdr p)
|
||||
(check-lazy-wraps! checked-pair-descriptor p)
|
||||
(checked-raw-cdr p))
|
||||
|
||||
)
|
|
@ -1,31 +1,20 @@
|
|||
#lang scheme/base
|
||||
|
||||
(provide signature?
|
||||
signature-name signature-syntax
|
||||
(provide make-signature signature?
|
||||
signature-name signature-syntax signature-enforcer
|
||||
signature-arbitrary-promise
|
||||
signature-<=?-proc signature-=?-proc
|
||||
signature-arbitrary set-signature-arbitrary!
|
||||
signature-info-promise
|
||||
signature-violation
|
||||
signature-violation-proc call-with-signature-violation-proc
|
||||
make-delayed-signature
|
||||
make-call-signature
|
||||
make-property-signature
|
||||
make-predicate-signature
|
||||
make-type-variable-signature
|
||||
make-list-signature
|
||||
make-mixed-signature
|
||||
make-combined-signature
|
||||
make-case-signature
|
||||
make-procedure-signature
|
||||
signature-update-syntax signature-update-info-promise
|
||||
apply-signature apply-signature/blame
|
||||
procedure-signature-info?
|
||||
procedure-signature-info-arg-signatures procedure-signature-info-return-signature
|
||||
make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors
|
||||
prop:lazy-wrap lazy-wrap? lazy-wrap-ref
|
||||
make-lazy-wrap-signature
|
||||
check-lazy-wraps!
|
||||
make-pair-signature checked-car checked-cdr
|
||||
signature=? signature<=?)
|
||||
signature=? signature<=?
|
||||
make-procedure-to-blame
|
||||
procedure-to-blame?
|
||||
procedure-to-blame-proc procedure-to-blame-syntax
|
||||
make-type-variable-info type-variable-info?)
|
||||
|
||||
(require scheme/promise
|
||||
mzlib/struct
|
||||
|
@ -108,220 +97,6 @@
|
|||
(parameterize ((signature-violation-proc proc))
|
||||
(thunk)))
|
||||
|
||||
(define (make-delayed-signature name promise)
|
||||
(make-signature name
|
||||
(lambda (self obj)
|
||||
((signature-enforcer (force promise)) self obj))
|
||||
(delay (signature-syntax (force promise)))
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(force (signature-arbitrary-promise (force promise))))
|
||||
#:info-promise
|
||||
(delay
|
||||
(force (signature-info-promise (force promise))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
((signature-<=?-proc (force promise)) this-info other-info))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
((signature-=?-proc (force promise)) this-info other-info))))
|
||||
|
||||
; specialized version of the above, supports comparison
|
||||
; the promise must produce the result of (proc . args), but its passed separately
|
||||
; to give us the right location on backtrace
|
||||
(define (make-call-signature name promise proc-promise args-promise syntax)
|
||||
(make-signature name
|
||||
(lambda (self obj)
|
||||
((signature-enforcer (force promise)) self obj))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(force (signature-arbitrary-promise (force promise))))
|
||||
#:info-promise
|
||||
(delay
|
||||
(make-call-info promise (force proc-promise) (force args-promise)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (call-info? other-info)
|
||||
(eqv? (force proc-promise) (call-info-proc other-info))
|
||||
(equal? (force args-promise) (call-info-args other-info))))))
|
||||
|
||||
(define-struct call-info (promise proc args) #:transparent)
|
||||
|
||||
; klude to support mixed
|
||||
(define (real-signature-info sig)
|
||||
(let ((raw-info (force (signature-info-promise sig))))
|
||||
(if (call-info? raw-info)
|
||||
(real-signature-info (force (call-info-promise raw-info)))
|
||||
(force raw-info))))
|
||||
|
||||
(define (make-property-signature name access signature syntax)
|
||||
(let ((enforce (signature-enforcer signature)))
|
||||
(make-signature name
|
||||
(lambda (self obj)
|
||||
(enforce self (access obj)) ; #### problematic: enforcement doesn't stick
|
||||
obj)
|
||||
syntax)))
|
||||
|
||||
(define (make-predicate-signature name predicate-promise syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj) ; dynamic binding because of syntax remapping via `signature-update-syntax'
|
||||
(if ((force predicate-promise) obj)
|
||||
obj
|
||||
(begin
|
||||
(signature-violation obj self #f #f)
|
||||
obj)))
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay (make-predicate-info (force predicate-promise)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (predicate-info? other-info)
|
||||
(eq? (force predicate-promise)
|
||||
(predicate-info-predicate other-info))))))
|
||||
|
||||
(define-struct predicate-info (predicate) #:transparent)
|
||||
|
||||
(define (make-type-variable-signature name syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj) obj)
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay (make-type-variable-info))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(type-variable-info? other-info))))
|
||||
|
||||
(define-struct type-variable-info ())
|
||||
|
||||
; maps lists to pairs of signature, enforced value
|
||||
(define lists-table (make-weak-hasheq))
|
||||
|
||||
(define (make-list-signature name arg-signature syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
;;(write (list 'list obj) (current-error-port)) (newline (current-error-port))
|
||||
(let recur ((l obj))
|
||||
|
||||
(define (go-on)
|
||||
(let ((enforced (cons (apply-signature arg-signature (car l))
|
||||
(recur (cdr l)))))
|
||||
(hash-set! lists-table l (cons self enforced))
|
||||
(hash-set! lists-table enforced (cons self enforced))
|
||||
enforced))
|
||||
|
||||
(cond
|
||||
((null? l)
|
||||
l)
|
||||
((not (pair? l))
|
||||
(signature-violation obj self #f #f)
|
||||
obj)
|
||||
((hash-ref lists-table l #f)
|
||||
=> (lambda (seen)
|
||||
;;(write (list 'seen seen (eq? self (car seen))) (current-error-port)) (newline (current-error-port))
|
||||
(if (eq? self (car seen))
|
||||
(cdr seen)
|
||||
(go-on))))
|
||||
(else
|
||||
(go-on)))))
|
||||
syntax
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(lift->arbitrary arbitrary-list arg-signature))
|
||||
#:info-promise
|
||||
(delay (make-list-info arg-signature))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (list-info? other-info)
|
||||
(signature=? arg-signature (list-info-arg-signature other-info))))))
|
||||
|
||||
(define-struct list-info (arg-signature) #:transparent)
|
||||
|
||||
(define (lift->arbitrary proc . signatures)
|
||||
(let ((arbitraries (map force (map signature-arbitrary-promise signatures))))
|
||||
(if (andmap values arbitraries)
|
||||
(apply proc arbitraries)
|
||||
#f)))
|
||||
|
||||
(define (make-mixed-signature name alternative-signatures syntax)
|
||||
(letrec ((alternative-signatures-promise
|
||||
(delay
|
||||
(normalize-mixed-signatures mixed-signature alternative-signatures)))
|
||||
(mixed-signature
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
(let loop ((alternative-signatures (force alternative-signatures-promise)))
|
||||
(cond
|
||||
((null? alternative-signatures)
|
||||
(signature-violation obj self #f #f)
|
||||
obj)
|
||||
((eq? (car alternative-signatures) self)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(string->immutable-string
|
||||
(if name
|
||||
(format "rekursive Signatur: ~a" name)
|
||||
"rekursive Signatur"))
|
||||
(current-continuation-marks))))
|
||||
(else
|
||||
(check-signature (car alternative-signatures)
|
||||
obj
|
||||
values
|
||||
(lambda () (loop (cdr alternative-signatures))))))))
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(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)))
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (mixed-info? other-info)
|
||||
(andmap signature=?
|
||||
(mixed-info-signatures this-info)
|
||||
(mixed-info-signatures other-info))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (mixed-info? other-info)
|
||||
(mixed-signature<=? (mixed-info-signatures this-info)
|
||||
(mixed-info-signatures other-info)))))))
|
||||
mixed-signature))
|
||||
|
||||
(define (mixed-signature<=? sigs1 sigs2)
|
||||
(andmap (lambda (sig1)
|
||||
(ormap (lambda (sig2)
|
||||
(signature<=? sig1 sig2))
|
||||
sigs2))
|
||||
sigs1))
|
||||
|
||||
; Flatten out mixed signatures, and fold in in the lazy-wrap
|
||||
; signatures
|
||||
|
||||
(define (normalize-mixed-signatures mixed-signature sigs)
|
||||
(fold-lazy-wrap-signatures mixed-signature (flatten-mixed-signatures sigs)))
|
||||
|
||||
(define (flatten-mixed-signatures sigs)
|
||||
(apply append
|
||||
(map (lambda (sig)
|
||||
(let ((info (force (signature-info-promise sig))))
|
||||
(if (mixed-info? info)
|
||||
(mixed-info-signatures info)
|
||||
(list sig))))
|
||||
sigs)))
|
||||
|
||||
(define-struct mixed-info (signatures) #:transparent)
|
||||
|
||||
(define (check-signature sig val success fail)
|
||||
((let/ec exit
|
||||
(let ((enforced
|
||||
|
@ -336,392 +111,9 @@
|
|||
(lambda (val)
|
||||
(check-signature sig val (lambda (_) #t) (lambda () #f))))
|
||||
|
||||
(define (make-combined-signature name signatures syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
(let ((old-violation-proc (signature-violation-proc)))
|
||||
((let/ec exit
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (signature syntax msg blame)
|
||||
(exit
|
||||
(lambda ()
|
||||
(old-violation-proc signature syntax msg blame)
|
||||
obj)))
|
||||
(lambda ()
|
||||
(let loop ((signatures signatures)
|
||||
(obj obj))
|
||||
(if (null? signatures)
|
||||
(lambda () obj)
|
||||
(loop (cdr signatures)
|
||||
(apply-signature (car signatures) obj))))))))))
|
||||
(delay syntax)))
|
||||
|
||||
(define (make-case-signature name cases =? syntax)
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self obj)
|
||||
(let loop ((cases cases))
|
||||
(cond
|
||||
((null? cases)
|
||||
(signature-violation obj self #f #f)
|
||||
obj)
|
||||
((=? (car cases) obj)
|
||||
obj)
|
||||
(else
|
||||
(loop (cdr cases))))))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay (apply arbitrary-one-of =? cases))))
|
||||
|
||||
(define-struct procedure-to-blame (proc syntax)
|
||||
#:property prop:procedure 0)
|
||||
|
||||
(define signature-key (gensym 'signature-key))
|
||||
|
||||
(define-struct procedure-signature-info (arg-signatures return-signature) #:transparent)
|
||||
|
||||
(define (make-procedure-signature name arg-signatures return-signature syntax)
|
||||
(let ((arg-count (length arg-signatures)))
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self thing)
|
||||
(let-values (((proc blame-syntax)
|
||||
(if (procedure-to-blame? thing)
|
||||
(values (procedure-to-blame-proc thing)
|
||||
(procedure-to-blame-syntax thing))
|
||||
(values thing #f))))
|
||||
(cond
|
||||
((not (procedure? proc))
|
||||
(signature-violation proc self #f #f)
|
||||
thing)
|
||||
((not (procedure-arity-includes? proc arg-count)) ; #### variable arity
|
||||
(signature-violation proc self "falsche Anzahl von Parametern" #f)
|
||||
thing)
|
||||
(else
|
||||
(attach-name
|
||||
(object-name proc)
|
||||
(procedure-reduce-arity
|
||||
(lambda args
|
||||
(call-with-immediate-continuation-mark
|
||||
signature-key
|
||||
(lambda (maybe)
|
||||
(if (not (= (length args) arg-count))
|
||||
(begin
|
||||
(signature-violation proc self "falsche Anzahl von Argumenten" #f)
|
||||
(apply-signature return-signature (apply proc args)))
|
||||
(let* ((old-violation-proc (signature-violation-proc))
|
||||
(arg-violation? #f)
|
||||
(args
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (obj signature message blame)
|
||||
(set! arg-violation? #t)
|
||||
(old-violation-proc obj signature message blame))
|
||||
(lambda ()
|
||||
(map apply-signature arg-signatures args)))))
|
||||
(if (eq? maybe return-signature)
|
||||
(apply proc args)
|
||||
(let ((retval
|
||||
(with-continuation-mark
|
||||
signature-key return-signature
|
||||
(apply proc args))))
|
||||
(if arg-violation?
|
||||
retval
|
||||
(call-with-signature-violation-proc
|
||||
(lambda (obj signature message _)
|
||||
;; blame the procedure
|
||||
(old-violation-proc obj signature message blame-syntax))
|
||||
(lambda ()
|
||||
(apply-signature return-signature retval)))))))))))
|
||||
(procedure-arity proc)))))))
|
||||
(delay syntax)
|
||||
#:arbitrary-promise
|
||||
(delay
|
||||
(apply lift->arbitrary arbitrary-procedure return-signature arg-signatures))
|
||||
#:info-promise
|
||||
(delay
|
||||
(make-procedure-signature-info arg-signatures return-signature)))))
|
||||
|
||||
(define (attach-name name thing)
|
||||
(if (and (procedure? thing)
|
||||
(symbol? name))
|
||||
(procedure-rename thing name)
|
||||
thing))
|
||||
|
||||
; Lazy signature checking for structs
|
||||
|
||||
;; This is attached prop:lazy-wrap property of struct types subject to
|
||||
;; lazy checking.
|
||||
(define-struct lazy-wrap-info
|
||||
(constructor
|
||||
raw-accessors raw-mutators
|
||||
;; procedures for referencing or setting an additional field within the struct
|
||||
;; that field contains a list of lists of unchecked field signatures
|
||||
ref-proc set!-proc))
|
||||
|
||||
; value should be a lazy-wrap-info
|
||||
(define-values (prop:lazy-wrap lazy-wrap? lazy-wrap-ref)
|
||||
(make-struct-type-property 'lazy-wrap))
|
||||
|
||||
; The field accessed by ref-proc and set!-proc contains one of these:
|
||||
|
||||
(define-struct lazy-wrap-log
|
||||
;; list of lazy-log-not-checked
|
||||
(not-checked
|
||||
;; list of lists of field signatures
|
||||
checked)
|
||||
#:transparent)
|
||||
|
||||
; This situation makes trouble:
|
||||
; (make-mixed-signature (make-lazy-wrap-signature ...) (make-lazy-wrap-signature ...) ...)
|
||||
|
||||
; We need to push the `mixed' signature inside the lazy-wrap
|
||||
; signature, which is why the struct-map signature has an implicit
|
||||
; `mixed'.
|
||||
; To this end, a `lazy-log-not-checked' object tracks a list of
|
||||
; `mixed' alternatives. The `mixed-signature' field tracks from which
|
||||
; `mixed' contract the mixture has originally come from.
|
||||
; (It may be #f, in which case the `field-signatures-list' is a one-element list.)
|
||||
(define-struct lazy-log-not-checked
|
||||
(mixed-signature field-signatures-list)
|
||||
#:transparent)
|
||||
|
||||
(define (make-lazy-wrap-signature name type-descriptor predicate field-signatures syntax)
|
||||
(really-make-lazy-wrap-signature name type-descriptor predicate #f (list field-signatures) syntax))
|
||||
|
||||
; The lists of signatures in `field-signatures-list' form an implicit mixed signature.
|
||||
(define (really-make-lazy-wrap-signature name type-descriptor predicate
|
||||
mixed-signature field-signatures-list
|
||||
syntax)
|
||||
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
|
||||
(not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list))
|
||||
(lazy-wrap-signature-info (make-lazy-wrap-signature-info type-descriptor predicate field-signatures-list)))
|
||||
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
|
||||
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
|
||||
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
|
||||
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
|
||||
(make-signature
|
||||
name
|
||||
(lambda (self thing)
|
||||
|
||||
(if (not (predicate thing))
|
||||
(signature-violation thing self #f #f)
|
||||
(let ((log (wrap-ref thing)))
|
||||
(cond
|
||||
((not log)
|
||||
(wrap-set! thing
|
||||
(make-lazy-wrap-log (list not-checked) '())))
|
||||
((not (let ()
|
||||
(define (<=? sigs1 sigs2)
|
||||
(andmap signature<=? sigs1 sigs2))
|
||||
(define (check wrap-field-signatures)
|
||||
(ormap (lambda (field-signatures)
|
||||
(<=? wrap-field-signatures field-signatures))
|
||||
field-signatures-list))
|
||||
(or (ormap (lambda (wrap-not-checked)
|
||||
(andmap check
|
||||
(lazy-log-not-checked-field-signatures-list wrap-not-checked)))
|
||||
(lazy-wrap-log-not-checked log))
|
||||
(ormap check (lazy-wrap-log-checked log)))))
|
||||
(wrap-set! thing
|
||||
(make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log))
|
||||
(lazy-wrap-log-checked log)))))))
|
||||
|
||||
thing)
|
||||
(delay syntax)
|
||||
#:info-promise
|
||||
(delay lazy-wrap-signature-info)
|
||||
#:=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (lazy-wrap-signature-info? other-info)
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)
|
||||
(eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info))
|
||||
(andmap (lambda (this-field-signatures)
|
||||
(andmap (lambda (other-field-signatures)
|
||||
(andmap signature=? this-field-signatures other-field-signatures))
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)))
|
||||
(lazy-wrap-signature-info-field-signatures-list this-info))))
|
||||
#:<=?-proc
|
||||
(lambda (this-info other-info)
|
||||
(and (lazy-wrap-signature-info? other-info)
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)
|
||||
(eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info))
|
||||
(andmap (lambda (this-field-signatures)
|
||||
(ormap (lambda (other-field-signatures)
|
||||
(andmap signature<=? this-field-signatures other-field-signatures))
|
||||
(lazy-wrap-signature-info-field-signatures-list other-info)))
|
||||
(lazy-wrap-signature-info-field-signatures-list this-info))))))))
|
||||
|
||||
(define-struct lazy-wrap-signature-info (descriptor predicate field-signatures-list) #:transparent)
|
||||
|
||||
(define (check-lazy-wraps! descriptor thing)
|
||||
(let ((lazy-wrap-info (lazy-wrap-ref descriptor)))
|
||||
|
||||
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
|
||||
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
|
||||
(raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info))
|
||||
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
|
||||
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
|
||||
|
||||
(let ((log (wrap-ref thing)))
|
||||
(when (and log (pair? (lazy-wrap-log-not-checked log)))
|
||||
(let loop ((field-vals (map (lambda (raw-accessor)
|
||||
(raw-accessor thing))
|
||||
raw-accessors))
|
||||
(now-checked '())
|
||||
(not-checkeds (lazy-wrap-log-not-checked log)))
|
||||
(if (null? not-checkeds)
|
||||
(begin
|
||||
(for-each (lambda (raw-mutator field-val)
|
||||
(raw-mutator thing field-val))
|
||||
raw-mutators field-vals)
|
||||
(wrap-set! thing
|
||||
(make-lazy-wrap-log '()
|
||||
(append now-checked
|
||||
(lazy-wrap-log-checked log)))))
|
||||
(let ((not-checked (car not-checkeds)))
|
||||
(let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked))
|
||||
(mixed-signature (lazy-log-not-checked-mixed-signature not-checked)))
|
||||
(if (not mixed-signature) ; one-element list
|
||||
(loop (map apply-signature (car field-signatures-list) field-vals)
|
||||
(cons (car field-signatures-list) now-checked)
|
||||
(cdr not-checkeds))
|
||||
(let inner ((field-signatures-list field-signatures-list)) ; implicit mixed
|
||||
(if (null? field-signatures-list)
|
||||
(signature-violation thing mixed-signature #f #f)
|
||||
(let map ((sigs (car field-signatures-list))
|
||||
(field-vals field-vals)
|
||||
(new-field-vals '()))
|
||||
(if (null? sigs)
|
||||
(loop (reverse new-field-vals)
|
||||
(cons (car field-signatures-list) now-checked)
|
||||
(cdr not-checkeds))
|
||||
(check-signature (car sigs)
|
||||
(car field-vals)
|
||||
(lambda (new-val)
|
||||
(map (cdr sigs)
|
||||
(cdr field-vals)
|
||||
(cons new-val new-field-vals)))
|
||||
(lambda ()
|
||||
(inner (cdr field-signatures-list))))))))))))))))))
|
||||
|
||||
; pushes down mixed contracts
|
||||
(define (fold-lazy-wrap-signatures mixed-signature sigs)
|
||||
(let ((lazy-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures
|
||||
|
||||
(define (push-down-lazy-wrap-sigs)
|
||||
(hash-map lazy-wrap-sigs
|
||||
(lambda (type-desc signatures)
|
||||
(really-make-lazy-wrap-signature
|
||||
(signature-name (car signatures)) type-desc
|
||||
(lazy-wrap-signature-info-predicate (real-signature-info (car signatures)))
|
||||
mixed-signature
|
||||
(apply append
|
||||
(map (lambda (sig)
|
||||
(lazy-wrap-signature-info-field-signatures-list (real-signature-info sig)))
|
||||
signatures))
|
||||
(signature-syntax (car signatures))))))
|
||||
|
||||
(let loop ((sigs sigs)
|
||||
(vanilla-sigs '()))
|
||||
(if (null? sigs)
|
||||
(append (push-down-lazy-wrap-sigs)
|
||||
(reverse vanilla-sigs))
|
||||
(let* ((sig (car sigs))
|
||||
(info (real-signature-info sig)))
|
||||
(if (lazy-wrap-signature-info? info)
|
||||
(let ((type-desc (lazy-wrap-signature-info-descriptor info)))
|
||||
(hash-update! lazy-wrap-sigs
|
||||
type-desc
|
||||
(lambda (old)
|
||||
(cons sig old))
|
||||
(lambda ()
|
||||
(list sig)))
|
||||
(loop (cdr sigs) vanilla-sigs))
|
||||
(loop (cdr sigs) (cons sig vanilla-sigs))))))))
|
||||
|
||||
(define checked-pair-table (make-weak-hasheq))
|
||||
|
||||
(define-struct checked-pair
|
||||
(car cdr log)
|
||||
#:mutable)
|
||||
|
||||
(define (checked-pair-access checked-access raw-access)
|
||||
(lambda (p)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> checked-access)
|
||||
(else (raw-access p)))))
|
||||
|
||||
(define checked-raw-car (checked-pair-access checked-pair-car car))
|
||||
(define checked-raw-cdr (checked-pair-access checked-pair-cdr cdr))
|
||||
|
||||
(define (checked-raw-set! checked-set!)
|
||||
(lambda (p new)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> (lambda (cp)
|
||||
(checked-set! cp new)))
|
||||
(else
|
||||
(let ((cp (make-checked-pair (car p) (cdr p) #f)))
|
||||
(checked-set! cp new)
|
||||
(hash-set! checked-pair-table p cp))))))
|
||||
|
||||
(define checked-raw-set-car! (checked-raw-set! set-checked-pair-car!))
|
||||
(define checked-raw-set-cdr! (checked-raw-set! set-checked-pair-cdr!))
|
||||
|
||||
(define (checked-pair-get-log p)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> checked-pair-log)
|
||||
(else #f)))
|
||||
|
||||
(define (checked-pair-set-log! p new)
|
||||
(cond
|
||||
((hash-ref checked-pair-table
|
||||
p
|
||||
(lambda () #f))
|
||||
=> (lambda (cp)
|
||||
(set-checked-pair-log! cp new)))
|
||||
(else
|
||||
(hash-set! checked-pair-table p
|
||||
(make-checked-pair (car p) (cdr p) new)))))
|
||||
|
||||
(define checked-pair-lazy-wrap-info
|
||||
(make-lazy-wrap-info cons
|
||||
(list checked-raw-car checked-raw-cdr)
|
||||
(list checked-raw-set-car! checked-raw-set-cdr!)
|
||||
checked-pair-get-log
|
||||
checked-pair-set-log!))
|
||||
|
||||
(define checked-pair-descriptor
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(make-struct-type 'dummy-checked-pair #f 0 0 #f
|
||||
(list
|
||||
(cons prop:lazy-wrap checked-pair-lazy-wrap-info))))
|
||||
(lambda (desc . _)
|
||||
desc)))
|
||||
|
||||
(define (make-pair-signature car-sig cdr-sig)
|
||||
(make-lazy-wrap-signature 'pair checked-pair-descriptor pair? (list car-sig cdr-sig) #'pair))
|
||||
|
||||
(define (checked-car p)
|
||||
(car p)
|
||||
(check-lazy-wraps! checked-pair-descriptor p)
|
||||
(checked-raw-car p))
|
||||
|
||||
(define (checked-cdr p)
|
||||
(cdr p)
|
||||
(check-lazy-wraps! checked-pair-descriptor p)
|
||||
(checked-raw-cdr p))
|
||||
|
||||
|
||||
; like apply-signature, but can track more precise blame into the signature itself
|
||||
(define-syntax apply-signature/blame
|
||||
(lambda (stx)
|
||||
|
@ -754,6 +146,8 @@
|
|||
(define (apply-signature signature val)
|
||||
((signature-enforcer signature) signature val))
|
||||
|
||||
(define-struct type-variable-info ())
|
||||
|
||||
; "do the values that fulfill c1 also fulfill c2?"
|
||||
(define (signature<=? c1 c2)
|
||||
(or (signature=? c1 c2)
|
||||
|
@ -762,5 +156,3 @@
|
|||
(or (type-variable-info? i2) ; kludge, maybe dispatch should be on second arg
|
||||
(and i1 i2
|
||||
((signature-<=?-proc c1) i1 i2))))))
|
||||
|
||||
|
||||
|
|
|
@ -6,6 +6,7 @@
|
|||
-> mixed one-of predicate combined property list-of)
|
||||
|
||||
(require deinprogramm/signature/signature
|
||||
deinprogramm/signature/signature-english
|
||||
scheme/promise
|
||||
(for-syntax scheme/base)
|
||||
(for-syntax syntax/stx)
|
||||
|
|
|
@ -42,6 +42,7 @@
|
|||
"set-result.ss"
|
||||
(only racket/base define-struct)
|
||||
racket/struct-info
|
||||
deinprogramm/signature/signature-english
|
||||
(all-except deinprogramm/signature/signature signature-violation)
|
||||
(all-except lang/private/signature-syntax property)
|
||||
(rename lang/private/signature-syntax signature:property property)
|
||||
|
|
|
@ -17,7 +17,8 @@ namespace.
|
|||
(require mzlib/list
|
||||
mzlib/math
|
||||
mzlib/etc
|
||||
deinprogramm/signature/signature)
|
||||
deinprogramm/signature/signature
|
||||
deinprogramm/signature/signature-english)
|
||||
|
||||
(define-syntax (define-teach stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
@ -5,6 +5,7 @@
|
|||
(require rackunit
|
||||
deinprogramm/define-record-procedures
|
||||
deinprogramm/signature/signature
|
||||
deinprogramm/signature/signature-german
|
||||
deinprogramm/signature/signature-syntax)
|
||||
|
||||
(require scheme/promise)
|
||||
|
|
Loading…
Reference in New Issue
Block a user