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

add context into the blame record for struct-type-property/c

Browse Source 
and use the standard contract printer
This commit is contained in:
Robby Findler 2014-07-18 10:30:31 -05:00
parent f4978d2fdb
commit 4a996cce6b
1 changed files with 19 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
racket/collects/racket/contract/private/struct-prop.rkt
View File

@ -6,28 +6,30 @@
(provide (rename-out [struct-type-property/c* struct-type-property/c])) (provide (rename-out [struct-type-property/c* struct-type-property/c]))
(define (get-stpc-proj stpc) (define (get-stpc-proj stpc)
(let ([get-val-proj (define get-val-proj
(contract-projection (contract-projection
(struct-type-property/c-value-contract stpc))]) (struct-type-property/c-value-contract stpc)))
(lambda (blame) (λ (input-blame)
(let ([val-proj (get-val-proj (blame-swap blame))]) (define blame (blame-add-context input-blame "the struct property value of" #:swap? #t))
(lambda (x) (define val-proj (get-val-proj blame))
(unless (struct-type-property? x) (λ (x)
(raise-blame-error blame x (unless (struct-type-property? x)
'(expected "struct-type-property" given: "~e") (raise-blame-error input-blame x
x)) '(expected "struct-type-property" given: "~e")
(let-values ([(nprop _pred _acc) x))
(make-struct-type-property (define-values (nprop _pred _acc)
(wrap-name x) (make-struct-type-property
(lambda (val _info) (wrap-name x)
(val-proj val)) (lambda (val _info)
(list (cons x values)))]) (val-proj val))
nprop)))))) (list (cons x values))))
nprop)))
(define (wrap-name x) (define (wrap-name x)
(string->symbol (format "wrapped-~a" (object-name x)))) (string->symbol (format "wrapped-~a" (object-name x))))
(struct struct-type-property/c (value-contract) (struct struct-type-property/c (value-contract)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:name (lambda (c) #:name (lambda (c)