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