77 lines
2.4 KiB
Scheme
77 lines
2.4 KiB
Scheme
(module intermediate-contracts mzscheme
|
|
|
|
(require "hilighters.ss"
|
|
"contracts-helpers.ss"
|
|
(lib "etc.ss"))
|
|
|
|
(require (lib "list.ss"))
|
|
|
|
(provide vector-contract
|
|
listof-contract
|
|
vectorof-contract
|
|
boxof-contract)
|
|
|
|
(define vector-contract (lambda (stx) (build-flat-contract vector? 'vector stx)))
|
|
|
|
(define (somethingof-contract thing enforcer predicate cnt stx)
|
|
(if (not (flat-contract? cnt))
|
|
(error 'contracts "~a contracts can only be created with flat values!" thing)
|
|
(make-flat-contract
|
|
enforcer
|
|
(mk-listof-hilighter (contract-hilighter cnt))
|
|
(syntax-source stx)
|
|
(syntax-line stx)
|
|
(syntax-column stx)
|
|
(syntax-position stx)
|
|
(syntax-span stx)
|
|
predicate)))
|
|
|
|
(define (listof-contract cnt stx)
|
|
(rec me
|
|
(somethingof-contract
|
|
'listof
|
|
(lambda (l)
|
|
(if (null? l) l
|
|
(if (pair? l)
|
|
(let loop ([list l])
|
|
(catch-contract-error 'car me ((contract-enforcer cnt) (car list)))
|
|
(if (null? (cdr list))
|
|
l
|
|
(loop (cdr list))))
|
|
(contract-error l me '()))))
|
|
|
|
(lambda (x) (or (null? x) (and (pair? x) (andmap (flat-contract-predicate cnt) x))))
|
|
cnt
|
|
stx)))
|
|
|
|
(define (vectorof-contract cnt stx)
|
|
(rec me
|
|
(somethingof-contract
|
|
'vectorof
|
|
(lambda (v)
|
|
(if (vector? v)
|
|
(let loop ([i 0])
|
|
(catch-contract-error 'car me ((contract-enforcer cnt) (vector-ref v i)))
|
|
(if (< (+ 1 i) (vector-length v))
|
|
(loop (+ i 1))
|
|
v))
|
|
(contract-error v me '())))
|
|
|
|
(lambda (x) (and (vector? x) (andmap (flat-contract-predicate cnt) (vector->list x))))
|
|
cnt
|
|
stx)))
|
|
|
|
(define (boxof-contract cnt stx)
|
|
(rec me
|
|
(somethingof-contract
|
|
'boxof
|
|
(lambda (v)
|
|
(if (box? v)
|
|
(begin
|
|
(catch-contract-error 'car me ((contract-enforcer cnt) (unbox v)))
|
|
v)
|
|
(contract-error v me '())))
|
|
(lambda (v) (and (box? v) ((flat-contract-predicate cnt) (unbox v))))
|
|
cnt
|
|
stx))))
|