|
|
@ -2,43 +2,45 @@
|
|
|
|
(require (for-syntax racket/base racket/syntax) racket/contract "../define.rkt" "base.rkt")
|
|
|
|
(require (for-syntax racket/base racket/syntax) racket/contract "../define.rkt" "base.rkt")
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-syntax-rule (make-blame-handler try-proc expected-sym)
|
|
|
|
(define-syntax-rule (make-blame-handler PROC EXPECTED)
|
|
|
|
(λ(b)
|
|
|
|
(λ (b)
|
|
|
|
(λ(x)
|
|
|
|
(λ (x) (with-handlers ([exn:fail? (λ (exn)
|
|
|
|
(with-handlers ([exn:fail? (λ(e)
|
|
|
|
(raise-blame-error b x
|
|
|
|
(raise-blame-error
|
|
|
|
|
|
|
|
b x
|
|
|
|
|
|
|
|
'(expected: "~a" given: "~e")
|
|
|
|
'(expected: "~a" given: "~e")
|
|
|
|
expected-sym x))])
|
|
|
|
EXPECTED x))])
|
|
|
|
(try-proc x)))))
|
|
|
|
(PROC x)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(provide+safe make-coercion-contract)
|
|
|
|
(provide+safe make-coercion-contract)
|
|
|
|
(define-syntax (make-coercion-contract stx)
|
|
|
|
(define-syntax (make-coercion-contract stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
(syntax-case stx ()
|
|
|
|
[(_ stem coerce-proc)
|
|
|
|
[(_ STEM COERCE-PROC)
|
|
|
|
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]
|
|
|
|
(with-syntax ([COERCE/STEM? (format-id stx "coerce/~a?" #'STEM)]
|
|
|
|
[can-be-stem? (format-id stx "can-be-~a?" #'stem)])
|
|
|
|
[STEMISH? (format-id stx "~aish?" #'STEM)])
|
|
|
|
#'(make-contract
|
|
|
|
#'(make-contract
|
|
|
|
#:name 'coerce/stem?
|
|
|
|
#:name 'COERCE/STEM?
|
|
|
|
#:projection (make-blame-handler coerce-proc 'can-be-stem?)))]
|
|
|
|
#:projection (make-blame-handler COERCE-PROC 'STEMISH?)))]
|
|
|
|
[(_ stem)
|
|
|
|
[(MACRO-NAME STEM)
|
|
|
|
(with-syntax ([->stem (format-id stx "->~a" #'stem)])
|
|
|
|
(with-syntax ([->STEM (format-id stx "->~a" #'STEM)])
|
|
|
|
#'(make-coercion-contract stem ->stem))]))
|
|
|
|
#'(MACRO-NAME STEM ->STEM))]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define-syntax (define+provide-coercion-contract stx)
|
|
|
|
(define-syntax (define+provide-coercion-contract stx)
|
|
|
|
(syntax-case stx ()
|
|
|
|
(syntax-case stx ()
|
|
|
|
[(_ stem)
|
|
|
|
[(_ STEM)
|
|
|
|
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)])
|
|
|
|
(with-syntax ([COERCE/STEM? (format-id stx "coerce/~a?" #'STEM)])
|
|
|
|
#'(begin
|
|
|
|
#'(begin
|
|
|
|
(provide+safe coerce/stem?)
|
|
|
|
(provide+safe COERCE/STEM?)
|
|
|
|
(define coerce/stem? (make-coercion-contract stem))))]))
|
|
|
|
(define COERCE/STEM? (make-coercion-contract STEM))))]))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(define+provide-coercion-contract int)
|
|
|
|
(define-syntax-rule (define+provide-coercion-contracts STEM ...)
|
|
|
|
(define+provide-coercion-contract string)
|
|
|
|
(begin (define+provide-coercion-contract STEM) ...))
|
|
|
|
(define+provide-coercion-contract symbol)
|
|
|
|
|
|
|
|
(define+provide-coercion-contract path)
|
|
|
|
|
|
|
|
(define+provide-coercion-contract boolean)
|
|
|
|
(define+provide-coercion-contracts int
|
|
|
|
(define+provide-coercion-contract list)
|
|
|
|
string
|
|
|
|
|
|
|
|
symbol
|
|
|
|
|
|
|
|
path
|
|
|
|
|
|
|
|
boolean
|
|
|
|
|
|
|
|
list)
|
|
|
|