69 lines
2.5 KiB
Scheme
69 lines
2.5 KiB
Scheme
#lang scheme/base
|
|
|
|
#|
|
|
|
|
improve method arity mismatch contract violation error messages?
|
|
(abstract out -> and friends even more?)
|
|
|
|
|#
|
|
|
|
|
|
|
|
(provide (rename-out [-contract contract])
|
|
recursive-contract
|
|
current-contract-region)
|
|
|
|
(require (for-syntax scheme/base)
|
|
scheme/stxparam
|
|
"guts.ss"
|
|
"helpers.ss")
|
|
|
|
(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference)))
|
|
|
|
(define-syntax (-contract stx)
|
|
(syntax-case stx ()
|
|
[(_ a-contract to-check pos-blame-e neg-blame-e)
|
|
(let ([s (syntax/loc stx here)])
|
|
(quasisyntax/loc stx
|
|
(contract/proc a-contract to-check pos-blame-e neg-blame-e
|
|
(list (make-srcloc (quote-syntax #,s)
|
|
#,(syntax-line s)
|
|
#,(syntax-column s)
|
|
#,(syntax-position s)
|
|
#,(syntax-span s))
|
|
#f))))]
|
|
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
|
|
(syntax/loc stx
|
|
(begin
|
|
(contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))]))
|
|
|
|
(define (contract/proc a-contract-raw name pos-blame neg-blame src-info)
|
|
(let ([a-contract (coerce-contract 'contract a-contract-raw)])
|
|
|
|
(unless (or (and (list? src-info)
|
|
(= 2 (length src-info))
|
|
(srcloc? (list-ref src-info 0))
|
|
(or (string? (list-ref src-info 1))
|
|
(not (list-ref src-info 1))))
|
|
(syntax? src-info))
|
|
(error 'contract "expected syntax or a list of two elements (srcloc and string or #f) as last argument, given: ~e, other args ~e ~e ~e ~e"
|
|
src-info
|
|
(unpack-blame neg-blame)
|
|
(unpack-blame pos-blame)
|
|
a-contract-raw
|
|
name))
|
|
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract) #t)
|
|
name)))
|
|
|
|
(define-syntax (recursive-contract stx)
|
|
(syntax-case stx ()
|
|
[(_ arg)
|
|
(syntax (make-proj-contract
|
|
'(recursive-contract arg)
|
|
(λ (pos-blame neg-blame src str positive-position?)
|
|
(let ([ctc (coerce-contract 'recursive-contract arg)])
|
|
(let ([proc (contract-proc ctc)])
|
|
(λ (val)
|
|
((proc pos-blame neg-blame src str positive-position?) val)))))
|
|
#f))]))
|