Added unstable/cce/contract contents to unstable/contract.
This commit is contained in:
Carl Eastlund
parent
70858e93e5
commit
286319d723
80
collects/tests/unstable/contract.rkt
Normal file
80
collects/tests/unstable/contract.rkt
Normal file
|
|
@ -0,0 +1,80 @@
|
|||
#lang racket
|
||||
|
||||
(require rackunit rackunit/text-ui unstable/contract "helpers.rkt")
|
||||
|
||||
(run-tests
|
||||
(test-suite "contract.ss"
|
||||
(test-suite "Flat Contracts"
|
||||
(test-suite "nat/c"
|
||||
(test-ok (with/c nat/c 1))
|
||||
(test-ok (with/c nat/c 0))
|
||||
(test-bad (with/c nat/c -1))
|
||||
(test-bad (with/c nat/c 'non-numeric)))
|
||||
(test-suite "pos/c"
|
||||
(test-ok (with/c pos/c 1))
|
||||
(test-bad (with/c pos/c 0))
|
||||
(test-bad (with/c pos/c -1))
|
||||
(test-bad (with/c pos/c 'non-numeric)))
|
||||
(test-suite "truth/c"
|
||||
(test-ok (with/c truth/c #t))
|
||||
(test-ok (with/c truth/c #f))
|
||||
(test-ok (with/c truth/c '(x)))))
|
||||
(test-suite "Higher Order Contracts"
|
||||
(test-suite "thunk/c"
|
||||
(test-ok ([with/c thunk/c gensym]))
|
||||
(test-bad ([with/c thunk/c gensym] 'x))
|
||||
(test-bad ([with/c thunk/c cons])))
|
||||
(test-suite "unary/c"
|
||||
(test-ok ([with/c unary/c list] 'x))
|
||||
(test-bad ([with/c unary/c list] 'x 'y))
|
||||
(test-bad ([with/c unary/c cons] 1)))
|
||||
(test-suite "binary/c"
|
||||
(test-ok ([with/c binary/c +] 1 2))
|
||||
(test-bad ([with/c binary/c +] 1 2 3))
|
||||
(test-bad ([with/c binary/c symbol->string] 'x 'y)))
|
||||
(test-suite "predicate/c"
|
||||
(test-ok ([with/c predicate/c integer?] 1))
|
||||
(test-ok ([with/c predicate/c integer?] 1/2))
|
||||
(test-bad ([with/c predicate/c values] 'x)))
|
||||
(test-suite "predicate-like/c"
|
||||
(test-ok ([with/c predicate-like/c integer?] 1))
|
||||
(test-ok ([with/c predicate-like/c integer?] 1/2))
|
||||
(test-ok ([with/c predicate-like/c values] 'x)))
|
||||
(test-suite "comparison/c"
|
||||
(test-ok ([with/c comparison/c equal?] 1 1))
|
||||
(test-ok ([with/c comparison/c equal?] 1 2))
|
||||
(test-bad ([with/c comparison/c list] 1 2)))
|
||||
(test-suite "comparison-like/c"
|
||||
(test-ok ([with/c comparison-like/c equal?] 1 1))
|
||||
(test-ok ([with/c comparison-like/c equal?] 1 2))
|
||||
(test-ok ([with/c comparison-like/c list] 1 2))))
|
||||
(test-suite "Collection Contracts"
|
||||
(test-suite "sequence/c"
|
||||
(test-ok
|
||||
(for ([x (with/c (sequence/c integer?) (list 1 2 3 4))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([x (with/c (sequence/c integer?) (list 1 2 'c 4))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([x (with/c (sequence/c integer? symbol?) (list 1 2 3 4))])
|
||||
(void))))
|
||||
(test-suite "dict/c"
|
||||
(test-ok
|
||||
(for ([(x y)
|
||||
(in-dict
|
||||
(with/c (dict/c integer? symbol?)
|
||||
#hash([1 . a] [2 . b])))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([(x y)
|
||||
(in-dict
|
||||
(with/c (dict/c integer? symbol?)
|
||||
#hash([1 . a] [three . b])))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([(x y)
|
||||
(in-dict
|
||||
(with/c (dict/c integer? symbol?)
|
||||
#hash([1 . a] [2 . "b"])))])
|
||||
(void)))))))
|
||||
|
|
@ -1,268 +0,0 @@
|
|||
#lang scheme
|
||||
|
||||
(require (for-syntax syntax/parse))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; 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)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Function Contracts
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define thunk/c (-> any/c))
|
||||
(define unary/c (-> any/c any/c))
|
||||
(define binary/c (-> any/c any/c any/c))
|
||||
(define predicate/c (-> any/c boolean?))
|
||||
(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)])
|
||||
((((proj-get elem/c) elem/c) pos neg src name blame) elem))))))
|
||||
(lambda (idx) idx)
|
||||
#f
|
||||
(lambda (idx) (more?))
|
||||
(lambda (elem) #t)
|
||||
(lambda (idx elem) #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)
|
||||
((((proj-get c) c) i o s n (not b)) x)]))
|
||||
|
||||
(define (project-out p x)
|
||||
(match p
|
||||
[(proj c o i s n b)
|
||||
((((proj-get c) 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
|
||||
|
||||
[nat/c flat-contract?]
|
||||
[pos/c flat-contract?]
|
||||
[truth/c flat-contract?]
|
||||
|
||||
[thunk/c contract?]
|
||||
[unary/c contract?]
|
||||
[binary/c contract?]
|
||||
[predicate/c contract?]
|
||||
[comparison/c contract?]
|
||||
[predicate-like/c contract?]
|
||||
[comparison-like/c contract?]
|
||||
|
||||
[sequence/c (->* [] [] #:rest (listof contract?) contract?)]
|
||||
[dict/c (-> contract? contract? contract?)]
|
||||
)
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require "define.ss" "contract.ss")
|
||||
(require unstable/contract "define.ss")
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1,131 +0,0 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
scribble/eval
|
||||
"../scribble.ss"
|
||||
"eval.ss")
|
||||
@(require (for-label scheme unstable/cce/contract))
|
||||
|
||||
@title[#:style 'quiet #:tag "cce-contract"]{Contracts}
|
||||
|
||||
@defmodule[unstable/cce/contract]
|
||||
|
||||
This module provides useful contracts and contract constructors.
|
||||
|
||||
@section{Flat Contracts}
|
||||
|
||||
@defthing[nat/c flat-contract?]{
|
||||
|
||||
This contract recognizes natural numbers that satisfy
|
||||
@scheme[exact-nonnegative-integer?].
|
||||
|
||||
}
|
||||
|
||||
@defthing[pos/c flat-contract?]{
|
||||
|
||||
This contract recognizes positive integers that satisfy
|
||||
@scheme[exact-positive-integer?].
|
||||
|
||||
}
|
||||
|
||||
@defthing[truth/c flat-contract?]{
|
||||
|
||||
This contract recognizes Scheme truth values, i.e., any value, but with a more
|
||||
informative name and description. Use it in negative positions for arguments
|
||||
that accept arbitrary truth values that may not be booleans.
|
||||
|
||||
}
|
||||
|
||||
@section{Higher-Order Contracts}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[thunk/c contract?]
|
||||
@defthing[unary/c contract?]
|
||||
@defthing[binary/c contract?]
|
||||
)]{
|
||||
|
||||
These contracts recognize functions that accept 0, 1, or 2 arguments,
|
||||
respectively, and produce a single result.
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[predicate/c contract?]
|
||||
@defthing[predicate-like/c contract?]
|
||||
)]{
|
||||
|
||||
These contracts recognize predicates: functions of a single argument that
|
||||
produce a boolean result.
|
||||
|
||||
The first constrains its output to satisfy @scheme[boolean?]. Use
|
||||
@scheme[predicate/c] in positive position for predicates that guarantee a result
|
||||
of @scheme[#t] or @scheme[#f].
|
||||
|
||||
The second constrains its output to satisfy @scheme[truth/c]. Use
|
||||
@scheme[predicate-like/c] in negative position for predicates passed as
|
||||
arguments that may return arbitrary values as truth values.
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[comparison/c contract?]
|
||||
@defthing[comparison-like/c contract?]
|
||||
)]{
|
||||
|
||||
These contracts recognize comparisons: functions of two arguments that
|
||||
produce a boolean result.
|
||||
|
||||
The first constrains its output to satisfy @scheme[boolean?]. Use
|
||||
@scheme[comparison/c] in positive position for comparisons that guarantee a
|
||||
result of @scheme[#t] or @scheme[#f].
|
||||
|
||||
The second constrains its output to satisfy @scheme[truth/c]. Use
|
||||
@scheme[comparison-like/c] in negative position for comparisons passed as
|
||||
arguments that may return arbitrary values as truth values.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(sequence/c [elem/c contract?] ...) contract?]{
|
||||
|
||||
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequence},
|
||||
obligating it to produce as many values as there are @scheme[elem/c] contracts,
|
||||
and obligating each value to satisfy the corresponding @scheme[elem/c]. The
|
||||
result is not guaranteed to be the same kind of sequence as the original value;
|
||||
for instance, a wrapped list is not guaranteed to satisfy @scheme[list?].
|
||||
|
||||
@defexamples[
|
||||
#:eval (evaluator 'unstable/cce/contract)
|
||||
(define/contract predicates
|
||||
(sequence/c (-> any/c boolean?))
|
||||
(list integer? string->symbol))
|
||||
(for ([P predicates])
|
||||
(printf "~s\n" (P "cat")))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@defproc[(dict/c [key/c contract?] [value/c contract?]) contract?]{
|
||||
|
||||
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{dictionary},
|
||||
obligating its keys to satisfy @scheme[key/c] and their corresponding values to
|
||||
satisfy @scheme[value/c]. The result is not guaranteed to be the same kind of
|
||||
dictionary as the original value; for instance, a wrapped hash table is not
|
||||
guaranteed to satisfy @scheme[hash?].
|
||||
|
||||
@defexamples[
|
||||
#:eval (evaluator 'unstable/cce/contract)
|
||||
(define/contract table
|
||||
(dict/c symbol? string?)
|
||||
(make-immutable-hash (list (cons 'A "A") (cons 'B 2) (cons 3 "C"))))
|
||||
(dict-ref table 'A)
|
||||
(dict-ref table 'B)
|
||||
(dict-ref table 3)
|
||||
]
|
||||
|
||||
@emph{Warning:} Bear in mind that key and value contracts are re-wrapped on
|
||||
every dictionary operation, and dictionaries wrapped in @scheme[dict/c] multiple
|
||||
times will perform the checks as many times for each operation. Especially for
|
||||
immutable dictionaries (which may be passed through a constructor that involves
|
||||
@scheme[dict/c] on each update), contract-wrapped dictionaries may be much less
|
||||
efficient than the original dictionaries.
|
||||
|
||||
}
|
||||
|
|
@ -297,4 +297,4 @@ wrapped dictionary during functional update using @scheme[wrap].
|
|||
@section{Contracted Dictionaries}
|
||||
|
||||
This library re-provides @scheme[dict/c] from
|
||||
@schememodname[unstable/cce/contract].
|
||||
@schememodname[unstable/contract].
|
||||
|
|
|
|||
|
|
@ -21,8 +21,6 @@
|
|||
|
||||
@include-section["class.scrbl"]
|
||||
|
||||
@include-section["contract.scrbl"]
|
||||
|
||||
@include-section["require-provide.scrbl"]
|
||||
@include-section["planet.scrbl"]
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
@(require scribble/manual
|
||||
"../scribble.ss"
|
||||
(for-label slideshow
|
||||
unstable/cce/contract
|
||||
unstable/contract
|
||||
unstable/cce/slideshow))
|
||||
|
||||
@title[#:style 'quiet #:tag "cce-slideshow"]{Slideshow Presentations}
|
||||
|
|
|
|||
|
|
@ -8,14 +8,14 @@
|
|||
syntax/kerncase
|
||||
setup/main-collects
|
||||
planet/planet-archives
|
||||
unstable/contract
|
||||
unstable/text
|
||||
(for-template scheme/base)
|
||||
(for-syntax scheme/base)
|
||||
(for-label scheme)
|
||||
"private/syntax-core.ss"
|
||||
"private/define-core.ss"
|
||||
(for-template "private/define-core.ss")
|
||||
"contract.ss")
|
||||
(for-template "private/define-core.ss"))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
|
|
|||
|
|
@ -1,83 +0,0 @@
|
|||
#lang scheme
|
||||
|
||||
(require "checks.ss"
|
||||
"../contract.ss")
|
||||
|
||||
(provide contract-suite)
|
||||
|
||||
(define contract-suite
|
||||
(test-suite "contract.ss"
|
||||
(test-suite "Flat Contracts"
|
||||
(test-suite "nat/c"
|
||||
(test-ok (with/c nat/c 1))
|
||||
(test-ok (with/c nat/c 0))
|
||||
(test-bad (with/c nat/c -1))
|
||||
(test-bad (with/c nat/c 'non-numeric)))
|
||||
(test-suite "pos/c"
|
||||
(test-ok (with/c pos/c 1))
|
||||
(test-bad (with/c pos/c 0))
|
||||
(test-bad (with/c pos/c -1))
|
||||
(test-bad (with/c pos/c 'non-numeric)))
|
||||
(test-suite "truth/c"
|
||||
(test-ok (with/c truth/c #t))
|
||||
(test-ok (with/c truth/c #f))
|
||||
(test-ok (with/c truth/c '(x)))))
|
||||
(test-suite "Higher Order Contracts"
|
||||
(test-suite "thunk/c"
|
||||
(test-ok ([with/c thunk/c gensym]))
|
||||
(test-bad ([with/c thunk/c gensym] 'x))
|
||||
(test-bad ([with/c thunk/c cons])))
|
||||
(test-suite "unary/c"
|
||||
(test-ok ([with/c unary/c list] 'x))
|
||||
(test-bad ([with/c unary/c list] 'x 'y))
|
||||
(test-bad ([with/c unary/c cons] 1)))
|
||||
(test-suite "binary/c"
|
||||
(test-ok ([with/c binary/c +] 1 2))
|
||||
(test-bad ([with/c binary/c +] 1 2 3))
|
||||
(test-bad ([with/c binary/c symbol->string] 'x 'y)))
|
||||
(test-suite "predicate/c"
|
||||
(test-ok ([with/c predicate/c integer?] 1))
|
||||
(test-ok ([with/c predicate/c integer?] 1/2))
|
||||
(test-bad ([with/c predicate/c values] 'x)))
|
||||
(test-suite "predicate-like/c"
|
||||
(test-ok ([with/c predicate-like/c integer?] 1))
|
||||
(test-ok ([with/c predicate-like/c integer?] 1/2))
|
||||
(test-ok ([with/c predicate-like/c values] 'x)))
|
||||
(test-suite "comparison/c"
|
||||
(test-ok ([with/c comparison/c equal?] 1 1))
|
||||
(test-ok ([with/c comparison/c equal?] 1 2))
|
||||
(test-bad ([with/c comparison/c list] 1 2)))
|
||||
(test-suite "comparison-like/c"
|
||||
(test-ok ([with/c comparison-like/c equal?] 1 1))
|
||||
(test-ok ([with/c comparison-like/c equal?] 1 2))
|
||||
(test-ok ([with/c comparison-like/c list] 1 2))))
|
||||
(test-suite "Collection Contracts"
|
||||
(test-suite "sequence/c"
|
||||
(test-ok
|
||||
(for ([x (with/c (sequence/c integer?) (list 1 2 3 4))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([x (with/c (sequence/c integer?) (list 1 2 'c 4))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([x (with/c (sequence/c integer? symbol?) (list 1 2 3 4))])
|
||||
(void))))
|
||||
(test-suite "dict/c"
|
||||
(test-ok
|
||||
(for ([(x y)
|
||||
(in-dict
|
||||
(with/c (dict/c integer? symbol?)
|
||||
#hash([1 . a] [2 . b])))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([(x y)
|
||||
(in-dict
|
||||
(with/c (dict/c integer? symbol?)
|
||||
#hash([1 . a] [three . b])))])
|
||||
(void)))
|
||||
(test-bad
|
||||
(for ([(x y)
|
||||
(in-dict
|
||||
(with/c (dict/c integer? symbol?)
|
||||
#hash([1 . a] [2 . "b"])))])
|
||||
(void)))))))
|
||||
|
|
@ -2,7 +2,6 @@
|
|||
|
||||
(require "checks.ss"
|
||||
"test-class.ss"
|
||||
"test-contract.ss"
|
||||
"test-debug.ss"
|
||||
"test-define.ss"
|
||||
"test-dict.ss"
|
||||
|
|
@ -20,7 +19,6 @@
|
|||
(run-tests
|
||||
(test-suite "scheme.plt"
|
||||
class-suite
|
||||
contract-suite
|
||||
debug-suite
|
||||
define-suite
|
||||
dict-suite
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang racket/base
|
||||
(require racket/contract)
|
||||
(require racket/contract racket/dict racket/match)
|
||||
|
||||
(define path-element?
|
||||
(or/c path-string? (symbols 'up 'same)))
|
||||
|
|
@ -62,9 +62,271 @@
|
|||
#:projection proj
|
||||
#:first-order ctc-fo)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; 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)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; Function Contracts
|
||||
;;
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define thunk/c (-> any/c))
|
||||
(define unary/c (-> any/c any/c))
|
||||
(define binary/c (-> any/c any/c any/c))
|
||||
(define predicate/c (-> any/c boolean?))
|
||||
(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)])
|
||||
((((proj-get elem/c) elem/c) pos neg src name blame) elem))))))
|
||||
(lambda (idx) idx)
|
||||
#f
|
||||
(lambda (idx) (more?))
|
||||
(lambda (elem) #t)
|
||||
(lambda (idx elem) #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)
|
||||
((((proj-get c) c) i o s n (not b)) x)]))
|
||||
|
||||
(define (project-out p x)
|
||||
(match p
|
||||
[(proj c o i s n b)
|
||||
((((proj-get c) 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
|
||||
[non-empty-string/c contract?]
|
||||
[path-element? contract?]
|
||||
[port-number? contract?]
|
||||
[if/c (-> procedure? contract? contract? contract?)]
|
||||
[rename-contract (-> contract? any/c contract?)])
|
||||
[rename-contract (-> contract? any/c contract?)]
|
||||
|
||||
[nat/c flat-contract?]
|
||||
[pos/c flat-contract?]
|
||||
[truth/c flat-contract?]
|
||||
|
||||
[thunk/c contract?]
|
||||
[unary/c contract?]
|
||||
[binary/c contract?]
|
||||
[predicate/c contract?]
|
||||
[comparison/c contract?]
|
||||
[predicate-like/c contract?]
|
||||
[comparison-like/c contract?]
|
||||
|
||||
[sequence/c (->* [] [] #:rest (listof contract?) contract?)]
|
||||
[dict/c (-> contract? contract? contract?)])
|
||||
|
|
|
|||
|
|
@ -1,10 +1,5 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/base
|
||||
scribble/manual
|
||||
"utils.rkt"
|
||||
(for-label unstable/contract
|
||||
racket/contract
|
||||
racket/base))
|
||||
#lang scribble/manual
|
||||
@(require scribble/eval "utils.rkt" (for-label racket unstable/contract))
|
||||
|
||||
@title[#:tag "contract"]{Contracts}
|
||||
|
||||
|
|
@ -58,3 +53,124 @@ Produces a contract that acts like @racket[contract] but with the name
|
|||
The resulting contract is a flat contract if @racket[contract] is a
|
||||
flat contract.
|
||||
}
|
||||
|
||||
@addition[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
|
||||
|
||||
@section{Flat Contracts}
|
||||
|
||||
@defthing[nat/c flat-contract?]{
|
||||
|
||||
This contract recognizes natural numbers that satisfy
|
||||
@scheme[exact-nonnegative-integer?].
|
||||
|
||||
}
|
||||
|
||||
@defthing[pos/c flat-contract?]{
|
||||
|
||||
This contract recognizes positive integers that satisfy
|
||||
@scheme[exact-positive-integer?].
|
||||
|
||||
}
|
||||
|
||||
@defthing[truth/c flat-contract?]{
|
||||
|
||||
This contract recognizes Scheme truth values, i.e., any value, but with a more
|
||||
informative name and description. Use it in negative positions for arguments
|
||||
that accept arbitrary truth values that may not be booleans.
|
||||
|
||||
}
|
||||
|
||||
@section{Higher-Order Contracts}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[thunk/c contract?]
|
||||
@defthing[unary/c contract?]
|
||||
@defthing[binary/c contract?]
|
||||
)]{
|
||||
|
||||
These contracts recognize functions that accept 0, 1, or 2 arguments,
|
||||
respectively, and produce a single result.
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[predicate/c contract?]
|
||||
@defthing[predicate-like/c contract?]
|
||||
)]{
|
||||
|
||||
These contracts recognize predicates: functions of a single argument that
|
||||
produce a boolean result.
|
||||
|
||||
The first constrains its output to satisfy @scheme[boolean?]. Use
|
||||
@scheme[predicate/c] in positive position for predicates that guarantee a result
|
||||
of @scheme[#t] or @scheme[#f].
|
||||
|
||||
The second constrains its output to satisfy @scheme[truth/c]. Use
|
||||
@scheme[predicate-like/c] in negative position for predicates passed as
|
||||
arguments that may return arbitrary values as truth values.
|
||||
|
||||
}
|
||||
|
||||
@deftogether[(
|
||||
@defthing[comparison/c contract?]
|
||||
@defthing[comparison-like/c contract?]
|
||||
)]{
|
||||
|
||||
These contracts recognize comparisons: functions of two arguments that
|
||||
produce a boolean result.
|
||||
|
||||
The first constrains its output to satisfy @scheme[boolean?]. Use
|
||||
@scheme[comparison/c] in positive position for comparisons that guarantee a
|
||||
result of @scheme[#t] or @scheme[#f].
|
||||
|
||||
The second constrains its output to satisfy @scheme[truth/c]. Use
|
||||
@scheme[comparison-like/c] in negative position for comparisons passed as
|
||||
arguments that may return arbitrary values as truth values.
|
||||
|
||||
}
|
||||
|
||||
@defproc[(sequence/c [elem/c contract?] ...) contract?]{
|
||||
|
||||
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequence},
|
||||
obligating it to produce as many values as there are @scheme[elem/c] contracts,
|
||||
and obligating each value to satisfy the corresponding @scheme[elem/c]. The
|
||||
result is not guaranteed to be the same kind of sequence as the original value;
|
||||
for instance, a wrapped list is not guaranteed to satisfy @scheme[list?].
|
||||
|
||||
@defexamples[
|
||||
#:eval (eval/require 'racket/contract 'unstable/contract)
|
||||
(define/contract predicates
|
||||
(sequence/c (-> any/c boolean?))
|
||||
(list integer? string->symbol))
|
||||
(for ([P predicates])
|
||||
(printf "~s\n" (P "cat")))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@defproc[(dict/c [key/c contract?] [value/c contract?]) contract?]{
|
||||
|
||||
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{dictionary},
|
||||
obligating its keys to satisfy @scheme[key/c] and their corresponding values to
|
||||
satisfy @scheme[value/c]. The result is not guaranteed to be the same kind of
|
||||
dictionary as the original value; for instance, a wrapped hash table is not
|
||||
guaranteed to satisfy @scheme[hash?].
|
||||
|
||||
@defexamples[
|
||||
#:eval (eval/require 'racket/contract 'racket/dict 'unstable/contract)
|
||||
(define/contract table
|
||||
(dict/c symbol? string?)
|
||||
(make-immutable-hash (list (cons 'A "A") (cons 'B 2) (cons 3 "C"))))
|
||||
(dict-ref table 'A)
|
||||
(dict-ref table 'B)
|
||||
(dict-ref table 3)
|
||||
]
|
||||
|
||||
@emph{Warning:} Bear in mind that key and value contracts are re-wrapped on
|
||||
every dictionary operation, and dictionaries wrapped in @scheme[dict/c] multiple
|
||||
times will perform the checks as many times for each operation. Especially for
|
||||
immutable dictionaries (which may be passed through a constructor that involves
|
||||
@scheme[dict/c] on each update), contract-wrapped dictionaries may be much less
|
||||
efficient than the original dictionaries.
|
||||
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user