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

Fix wrap-expr/c and expr/c to reflect the intended use

Browse Source 
The expr/c syntax class, as well as its underlying implementation
function, wrap-expr/c, previously produced misleading error messages.
The main purpose of these tools is to ensure a user-provided expression
conforms to a macro-provided contract. However, contract errors produced
by these forms were consistent with situations where both value and
contract were provided by the same party.

This fixes the discrepancy by changing how these forms assign blame to
emulate contract errors that arise from improper function arguments,
since most expressions provided to macros are semantically similar to
function arguments. All examples within the documentation itself
reflect this use case.

These changes alter the contents of error messages raised by expr/c and
wrap-expr/c, which could theoretically break some test suites, but it’s
extremely unlikely that any non-test code would depend on the precise
wording of contract error messages, and the interface is otherwise
completely backwards-compatible.

fixes #1412
This commit is contained in:
Alexis King 2017-02-06 15:06:37 -08:00 committed by Ryan Culpepper
parent a5e7972bde
commit 6632beeca9
1 changed files with 37 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
racket/collects/syntax/contract.rkt
View File

@ -19,6 +19,27 @@
#:context (or/c syntax? #f))
syntax?)])
(module macro-arg/c racket/base
(require racket/contract/base
racket/contract/combinator)
(provide macro-arg/c)
(define (macro-arg/c macro-name ctc)
(let ([ctc-project (get/build-late-neg-projection (coerce-contract 'wrap-expr/c ctc))])
((cond [(flat-contract? ctc) make-flat-contract]
[(chaperone-contract? ctc) make-chaperone-contract]
[else make-contract])
#:name (contract-name ctc)
#:first-order (contract-first-order ctc)
#:late-neg-projection
(λ (blame)
(let ([blame* (if macro-name (blame-add-context blame #f #:important macro-name) blame)])
(ctc-project (blame-swap blame*))))
#:list-contract? (list-contract? ctc)))))
(require (for-template 'macro-arg/c))
(define (wrap-expr/c ctc-expr expr
#:positive [pos-source 'use-site]
#:negative [neg-source 'from-macro]
@ -31,42 +52,47 @@
[neg-source-expr
(get-source-expr neg-source
(if (identifier? macro-name) macro-name ctx))]
[expr-name
(if (identifier? expr-name)
(syntax-e expr-name)
expr-name)]
[macro-name
(cond [(identifier? macro-name) (syntax-e macro-name)]
[(or (string? macro-name) (symbol? macro-name)) macro-name]
[(syntax? ctx)
(syntax-case ctx ()
[(x . _) (identifier? #'x) (syntax-e #'x)]
[x (identifier? #'#'x)]
[x (identifier? #'x) (syntax-e #'x)]
[_ #f])]
[else #f])])
(base-wrap-expr/c expr ctc-expr
#:positive #'(quote-module-name)
(base-wrap-expr/c expr #`(macro-arg/c '#,macro-name #,ctc-expr)
#:positive pos-source-expr
#:negative neg-source-expr
#:expr-name (cond [(and expr-name macro-name)
(format "~a of ~a" expr-name macro-name)]
[expr-name expr-name]
[else #f])
#:expr-name (cond [(and macro-name expr-name)
(format "~a of ~a" expr-name macro-name)]
[(or macro-name expr-name)
=> (λ (name) (format "~a" name))]
[else #f])
#:source #`(quote-syntax #,expr))))
(define (base-wrap-expr/c expr ctc-expr
#:positive positive
#:negative negative
#:expr-name [expr-name #f]
#:source [source #f])
#:expr-name expr-name
#:source source)
(let ([expr-name (or expr-name #'#f)]
[source (or source #'#f)])
(quasisyntax/loc expr
(contract #,ctc-expr
#,expr
#,positive
#,negative
#,positive
#,expr-name
#,source))))
(define (get-source-expr source ctx)
(cond [(eq? source 'use-site)
#'(quote-module-name)]
#'(quote-module-path)]
[(eq? source 'unknown)
#'(quote "unknown")]
[(eq? source 'from-macro)