benign stylistic refactoring

dev-refac-2020
Matthew Butterick 7 years ago
parent 569b3d4453
commit fbdde8eeb2

@ -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 '(expected: "~a" given: "~e")
b x EXPECTED x))])
'(expected: "~a" given: "~e") (PROC x)))))
expected-sym x))])
(try-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)

Loading…
Cancel
Save