870c8d28f4
change the implementation to special case struct procedures and to use it in provide/contract. This speeds up the rendering phase of the Guide documentation by more than 2x. Thanks to Matthew for spotting the opportunity!
439 lines
14 KiB
Racket
439 lines
14 KiB
Racket
#lang racket/base
|
|
(require racket/contract racket/dict racket/match)
|
|
|
|
(define path-piece?
|
|
(or/c path-string? (symbols 'up 'same)))
|
|
|
|
(define port-number? (between/c 1 65535))
|
|
(define tcp-listen-port? (between/c 0 65535))
|
|
|
|
(define (non-empty-string? x)
|
|
(and (string? x) (not (zero? (string-length x)))))
|
|
(define (non-empty-bytes? x)
|
|
(and (bytes? x) (not (zero? (bytes-length x)))))
|
|
(define (non-empty-vector? x)
|
|
(and (vector? x) (not (zero? (vector-length x)))))
|
|
(define (non-empty-list? x)
|
|
(and (list? x) (pair? x)))
|
|
(define (singleton-list? x)
|
|
(and (pair? x) (null? (cdr x))))
|
|
|
|
;; ryanc added:
|
|
|
|
;; (if/c predicate then/c else/c) applies then/c to satisfying
|
|
;; predicate, else/c to those that don't.
|
|
(define (if/c predicate then/c else/c)
|
|
#|
|
|
Naive version:
|
|
(or/c (and/c predicate then/c)
|
|
(and/c (not/c predicate) else/c))
|
|
But that applies predicate twice.
|
|
|#
|
|
(let ([then-ctc (coerce-contract 'if/c then/c)]
|
|
[else-ctc (coerce-contract 'if/c else/c)])
|
|
(define name (build-compound-type-name 'if/c predicate then-ctc else-ctc))
|
|
;; Special case: if both flat contracts, make a flat contract.
|
|
(if (and (flat-contract? then-ctc)
|
|
(flat-contract? else-ctc))
|
|
;; flat contract
|
|
(let ([then-pred (flat-contract-predicate then-ctc)]
|
|
[else-pred (flat-contract-predicate else-ctc)])
|
|
(define (pred x)
|
|
(if (predicate x) (then-pred x) (else-pred x)))
|
|
(flat-named-contract name pred))
|
|
;; ho contract
|
|
(let ([then-proj (contract-projection then-ctc)]
|
|
[then-fo (contract-first-order then-ctc)]
|
|
[else-proj (contract-projection else-ctc)]
|
|
[else-fo (contract-first-order else-ctc)])
|
|
(define ((proj blame) x)
|
|
(if (predicate x)
|
|
((then-proj blame) x)
|
|
((else-proj blame) x)))
|
|
(make-contract
|
|
#:name name
|
|
#:projection proj
|
|
#:first-order
|
|
(lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
|
|
|
|
;; failure-result/c : contract
|
|
;; Describes the optional failure argument passed to hash-ref, for example.
|
|
;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise
|
|
;; the argument is simply the value to return.
|
|
(define failure-result/c
|
|
(if/c procedure? (-> any) any/c))
|
|
|
|
;; rename-contract : contract any/c -> contract
|
|
;; If the argument is a flat contract, so is the result.
|
|
(define (rename-contract ctc name)
|
|
(let ([ctc (coerce-contract 'rename-contract ctc)])
|
|
(if (flat-contract? ctc)
|
|
(flat-named-contract name (flat-contract-predicate ctc))
|
|
(let* ([ctc-fo (contract-first-order ctc)]
|
|
[proj (contract-projection ctc)])
|
|
(make-contract #:name name
|
|
#:projection proj
|
|
#:first-order ctc-fo)))))
|
|
|
|
;; Added by asumu
|
|
;; option/c : contract -> contract
|
|
(define (option/c ctc-arg)
|
|
(define ctc (coerce-contract 'option/c ctc-arg))
|
|
(cond [(flat-contract? ctc) (flat-option/c ctc)]
|
|
[(chaperone-contract? ctc) (chaperone-option/c ctc)]
|
|
[else (impersonator-option/c ctc)]))
|
|
|
|
(define (option/c-name ctc)
|
|
(build-compound-type-name 'option/c (base-option/c-ctc ctc)))
|
|
|
|
(define (option/c-projection ctc)
|
|
(define ho-proj (contract-projection (base-option/c-ctc ctc)))
|
|
(λ (blame)
|
|
(define partial (ho-proj blame))
|
|
(λ (val)
|
|
(if (not val) val (partial val)))))
|
|
|
|
(define ((option/c-first-order ctc) v)
|
|
(or (not v) (contract-first-order-passes? (base-option/c-ctc ctc) v)))
|
|
|
|
(define (option/c-stronger? this that)
|
|
(and (base-option/c? that)
|
|
(contract-stronger? (base-option/c-ctc this)
|
|
(base-option/c-ctc that))))
|
|
|
|
(struct base-option/c (ctc))
|
|
|
|
(struct flat-option/c base-option/c ()
|
|
#:property prop:flat-contract
|
|
(build-flat-contract-property
|
|
#:name option/c-name
|
|
#:first-order option/c-first-order
|
|
#:stronger option/c-stronger?))
|
|
|
|
(struct chaperone-option/c base-option/c ()
|
|
#:property prop:chaperone-contract
|
|
(build-chaperone-contract-property
|
|
#:name option/c-name
|
|
#:first-order option/c-first-order
|
|
#:projection option/c-projection
|
|
#:stronger option/c-stronger?))
|
|
|
|
(struct impersonator-option/c base-option/c ()
|
|
#:property prop:contract
|
|
(build-contract-property
|
|
#:name option/c-name
|
|
#:first-order option/c-first-order
|
|
#:projection option/c-projection
|
|
#:stronger option/c-stronger?))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Flat Contracts
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define nat/c
|
|
(flat-named-contract '|natural number| exact-nonnegative-integer?))
|
|
|
|
(define pos/c
|
|
(flat-named-contract '|positive integer| exact-positive-integer?))
|
|
|
|
(define truth/c
|
|
(flat-named-contract '|truth value| (lambda (x) #t)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Syntax Contracts
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (syntax-datum/c datum)
|
|
(let* ([datum/c (coerce-contract datum datum)])
|
|
(flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c)
|
|
(lambda (v)
|
|
(and (syntax? v)
|
|
((flat-contract-predicate datum/c)
|
|
(syntax->datum v)))))))
|
|
|
|
(define (syntax-listof/c elem)
|
|
(let* ([elem/c (coerce-contract elem elem)])
|
|
(flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c)
|
|
(lambda (v)
|
|
(and (syntax? v)
|
|
((flat-contract-predicate (listof elem/c))
|
|
(syntax->list v)))))))
|
|
|
|
(define (syntax-list/c . elems)
|
|
(let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)])
|
|
(flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs)
|
|
(lambda (v)
|
|
(and (syntax? v)
|
|
((flat-contract-predicate (apply list/c elem/cs))
|
|
(syntax->list v)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Function Contracts
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define thunk/c (-> any/c))
|
|
(define unary/c (-> any/c any/c))
|
|
(define binary/c (-> any/c any/c any/c))
|
|
(define comparison/c (-> any/c any/c boolean?))
|
|
(define predicate-like/c (-> any/c truth/c))
|
|
(define comparison-like/c (-> any/c any/c truth/c))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Contracted Sequences
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (sequence/c . elem/cs)
|
|
(let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
|
|
(coerce-contract 'sequence/c elem/c))]
|
|
[n-cs (length elem/cs)])
|
|
(make-proj-contract
|
|
(apply build-compound-type-name 'sequence/c elem/cs)
|
|
(lambda (pos neg src name blame)
|
|
(lambda (seq)
|
|
(unless (sequence? seq)
|
|
(raise-contract-error
|
|
seq src pos name
|
|
"expected a sequence, got: ~e"
|
|
seq))
|
|
(make-do-sequence
|
|
(lambda ()
|
|
(let*-values ([(more? next) (sequence-generate seq)])
|
|
(values
|
|
(lambda (idx)
|
|
(call-with-values next
|
|
(lambda elems
|
|
(define n-elems (length elems))
|
|
(unless (= n-elems n-cs)
|
|
(raise-contract-error
|
|
seq src pos name
|
|
"expected a sequence of ~a values, got ~a values: ~s"
|
|
n-cs n-elems elems))
|
|
(apply
|
|
values
|
|
(for/list ([elem (in-list elems)]
|
|
[elem/c (in-list elem/cs)])
|
|
(((contract-proc elem/c) pos neg src name blame) elem))))))
|
|
(lambda (idx) idx)
|
|
#f
|
|
(lambda (idx) (more?))
|
|
(lambda elems #t)
|
|
(lambda (idx . elems) #t)))))))
|
|
sequence?)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Contracted Dictionaries
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; A CDict is (make-contracted-dictionary (Listof (Cons Proj Proj)) Dict)
|
|
;; A Proj is (make-projection Contract Symbol Symbol Any Any)
|
|
(define-struct contracted-dictionary [projections bindings])
|
|
(define-struct projection [contract out in source name blame])
|
|
|
|
(define (dict/c key/c value/c)
|
|
(let* ([key/c (coerce-contract 'dict/c key/c)]
|
|
[value/c (coerce-contract 'dict/c value/c)])
|
|
(make-proj-contract
|
|
(build-compound-type-name 'dict/c key/c value/c)
|
|
(lambda (pos neg src name blame)
|
|
(lambda (dict)
|
|
(unless (dict? dict)
|
|
(raise-contract-error dict src pos name
|
|
"expected a dictionary, got: ~e"
|
|
dict))
|
|
(wrap
|
|
(cons (cons (make-projection key/c pos neg src name blame)
|
|
(make-projection value/c pos neg src name blame))
|
|
(dict->projections dict))
|
|
(dict->bindings dict))))
|
|
dict?)))
|
|
|
|
(define-match-expander cdict
|
|
(syntax-rules () [(_ p b) (struct contracted-dictionary [p b])]))
|
|
|
|
(define-match-expander proj
|
|
(syntax-rules () [(_ c o i s n b) (struct projection [c o i s n b])]))
|
|
|
|
(define -ref
|
|
(case-lambda
|
|
[(dict key)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(let* ([key (key-in projs key)])
|
|
(value-out projs (dict-ref binds key)))])]
|
|
[(dict key failure)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(let* ([key (key-in projs key)])
|
|
(let/ec return
|
|
(define (fail)
|
|
(return (if (procedure? failure) (failure) failure)))
|
|
(value-out projs (dict-ref binds key fail))))])]))
|
|
|
|
(define (-set! dict key value)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(dict-set! binds (key-in projs key) (value-in projs value))]))
|
|
|
|
(define (-set dict key value)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(wrap projs (dict-set binds (key-in projs key) (value-in projs value)))]))
|
|
|
|
(define (-rem! dict key)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(dict-remove! binds (key-in projs key))]))
|
|
|
|
(define (-rem dict key)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(wrap projs (dict-remove binds (key-in projs key)))]))
|
|
|
|
(define (-size dict)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(dict-count binds)]))
|
|
|
|
(define (-fst dict)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(dict-iterate-first binds)]))
|
|
|
|
(define (-nxt dict iter)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(dict-iterate-next binds iter)]))
|
|
|
|
(define (-key dict iter)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(key-out projs (dict-iterate-key binds iter))]))
|
|
|
|
(define (-val dict iter)
|
|
(match dict
|
|
[(cdict projs binds)
|
|
(value-out projs (dict-iterate-value binds iter))]))
|
|
|
|
(define (key-in projs key)
|
|
(if (null? projs)
|
|
key
|
|
(key-in (cdr projs) (project-in (caar projs) key))))
|
|
|
|
(define (value-in projs value)
|
|
(if (null? projs)
|
|
value
|
|
(value-in (cdr projs) (project-in (cdar projs) value))))
|
|
|
|
(define (key-out projs key)
|
|
(if (null? projs)
|
|
key
|
|
(project-out (caar projs) (key-out (cdr projs) key))))
|
|
|
|
(define (value-out projs value)
|
|
(if (null? projs)
|
|
value
|
|
(project-out (cdar projs) (value-out (cdr projs) value))))
|
|
|
|
(define (project-in p x)
|
|
(match p
|
|
[(proj c o i s n b)
|
|
(((contract-proc c) i o s n (not b)) x)]))
|
|
|
|
(define (project-out p x)
|
|
(match p
|
|
[(proj c o i s n b)
|
|
(((contract-proc c) o i s n b) x)]))
|
|
|
|
(define (dict->bindings dict)
|
|
(match dict
|
|
[(cdict projs binds) binds]
|
|
[_ dict]))
|
|
|
|
(define (dict->projections dict)
|
|
(match dict
|
|
[(cdict projs binds) projs]
|
|
[_ null]))
|
|
|
|
(define (wrap projs binds)
|
|
((dict->wrapper binds) projs binds))
|
|
|
|
(define (dict->wrapper dict)
|
|
(if (dict-mutable? dict)
|
|
(if (dict-can-functional-set? dict)
|
|
(if (dict-can-remove-keys? dict) make-:!+- make-:!+_)
|
|
(if (dict-can-remove-keys? dict) make-:!_- make-:!__))
|
|
(if (dict-can-functional-set? dict)
|
|
(if (dict-can-remove-keys? dict) make-:_+- make-:_+_)
|
|
(if (dict-can-remove-keys? dict) make-:__- make-:___))))
|
|
|
|
;; The __- case (removal without functional or mutable update) is nonsensical.
|
|
(define prop:!+- (vector -ref -set! -set -rem! -rem -size -fst -nxt -key -val))
|
|
(define prop:!+_ (vector -ref -set! -set #f #f -size -fst -nxt -key -val))
|
|
(define prop:!_- (vector -ref -set! #f -rem! #f -size -fst -nxt -key -val))
|
|
(define prop:!__ (vector -ref -set! #f #f #f -size -fst -nxt -key -val))
|
|
(define prop:_+- (vector -ref #f -set #f -rem -size -fst -nxt -key -val))
|
|
(define prop:_+_ (vector -ref #f -set #f -rem -size -fst -nxt -key -val))
|
|
(define prop:__- (vector -ref #f #f #f #f -size -fst -nxt -key -val))
|
|
(define prop:___ (vector -ref #f #f #f #f -size -fst -nxt -key -val))
|
|
|
|
;; The __- case (removal without functional or mutable update) is nonsensical.
|
|
(define-struct (:!+- contracted-dictionary) [] #:property prop:dict prop:!+-)
|
|
(define-struct (:!+_ contracted-dictionary) [] #:property prop:dict prop:!+_)
|
|
(define-struct (:!_- contracted-dictionary) [] #:property prop:dict prop:!_-)
|
|
(define-struct (:!__ contracted-dictionary) [] #:property prop:dict prop:!__)
|
|
(define-struct (:_+- contracted-dictionary) [] #:property prop:dict prop:_+-)
|
|
(define-struct (:_+_ contracted-dictionary) [] #:property prop:dict prop:_+_)
|
|
(define-struct (:__- contracted-dictionary) [] #:property prop:dict prop:__-)
|
|
(define-struct (:___ contracted-dictionary) [] #:property prop:dict prop:___)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Exports
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(provide/contract
|
|
[path-piece? contract?]
|
|
[port-number? contract?]
|
|
[tcp-listen-port? contract?]
|
|
|
|
[non-empty-string? predicate/c]
|
|
[non-empty-bytes? predicate/c]
|
|
[non-empty-vector? predicate/c]
|
|
[non-empty-list? predicate/c]
|
|
[singleton-list? predicate/c]
|
|
|
|
[if/c (-> procedure? contract? contract? contract?)]
|
|
[failure-result/c contract?]
|
|
[rename-contract (-> contract? any/c contract?)]
|
|
[option/c (-> contract? contract?)]
|
|
|
|
[nat/c flat-contract?]
|
|
[pos/c flat-contract?]
|
|
[truth/c flat-contract?]
|
|
|
|
[thunk/c contract?]
|
|
[unary/c contract?]
|
|
[binary/c contract?]
|
|
[comparison/c contract?]
|
|
[predicate-like/c contract?]
|
|
[comparison-like/c contract?]
|
|
|
|
[syntax-datum/c (-> flat-contract? flat-contract?)]
|
|
[syntax-listof/c (-> flat-contract? flat-contract?)]
|
|
[syntax-list/c
|
|
(->* [] [] #:rest (listof flat-contract?) flat-contract?)]
|
|
|
|
[sequence/c (->* [] [] #:rest (listof contract?) contract?)]
|
|
[dict/c (-> contract? contract? contract?)])
|