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

add context information into the error messages for option contracts

Browse Source 
Also, minor code cleanup (don't create a function and pass it
around when has only one thing in its closure and you can
just pass that around, especially when passing the function around
makes the code harder to read and the created function has to
have a "dot" arglist and use "apply" in its body)
This commit is contained in:
Robby Findler 2013-02-24 09:01:02 -06:00
parent 4b8813bb0e
commit b3e803c757
1 changed files with 12 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/unstable/options.rkt
View File

@ -132,7 +132,7 @@
(define (check-option c val fail)
(define (check-option c val blame)
(let ([orig-ctc (option-orig-ctc c)]
[structid (option-structid c)]
[invariant (option-invariant c)]
@ -141,14 +141,17 @@
(when (and (eq? invariant 'dont-care)
(or (not (eq? immutable 'dont-care))
(not (eq? flat #f))))
(fail val '(expected "an invariant keyword argument (based on presence of other keyword arguments)")))
(raise-blame-error
blame
val
'(expected "an invariant keyword argument (based on presence of other keyword arguments)")))
(unless (or (and (procedure? val) (eq? structid 'none))
(and (vector? val) (eq? structid 'none))
(and (hash? val) (eq? structid 'none))
(and (not (eq? structid 'none)) (same-type val structid)))
(if (eq? structid 'none)
(fail val '(expected "a procedure or a vector or a hash" given: "~e") val)
(fail val '(expected "a struct of type ~a" given: "~e") (fourth structid) val)))))
(raise-blame-error blame val '(expected "a procedure or a vector or a hash" given: "~e") val)
(raise-blame-error blame val '(expected "a struct of type ~a" given: "~e") (fourth structid) val)))))
@ -169,10 +172,8 @@
#:projection
(λ (ctc)
(λ (blame)
(define raise-blame (λ (val . args)
(apply raise-blame-error blame val args)))
(λ (val)
(check-option ctc val raise-blame)
(check-option ctc val blame)
(let* ([tester (option-tester ctc)]
[invariant (option-invariant ctc)]
[flat (option-flat ctc)]
@ -183,7 +184,10 @@
[exec-ctc (build-orig-proj ctc invariant flat immutable structid here)])
(unless (symbol? tester)
(run-tester tester val orig-ctc blame here))
(build-proxy ctc val (contract-projection exec-ctc) blame)))))))
(build-proxy ctc val (contract-projection exec-ctc)
(blame-add-context
blame
"the option of"))))))))
(define (build-option ctc
#:tester [tester 'dont-care]