7.8 Building New Contracts
Contracts are represented internally as functions that accept information about the contract (who is to blame, source locations, etc.) and produce projections (in the spirit of Dana Scott) that enforce the contract.
In a general sense, a projection is a function that accepts an arbitrary value, and returns a value that satisfies the corresponding contract. For example, a projection that accepts only integers corresponds to the contract (flat-contract integer?), and can be written like this:
(define int-proj (λ (x) (if (integer? x) x (signal-contract-violation))))
As a second example, a projection that accepts unary functions on integers looks like this:
(define int->int-proj (λ (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (x) (int-proj (f (int-proj x)))) (signal-contract-violation))))
Although these projections have the right error behavior, they are not quite ready for use as contracts, because they do not accommodate blame and do not provide good error messages. In order to accommodate these, contracts do not just use simple projections, but use functions that accept a blame object encapsulating the names of two parties that are the candidates for blame, as well as a record of the source location where the contract was established and the name of the contract. They can then, in turn, pass that information to raise-blame-error to signal a good error message.
(define (int-proj blame) (λ (x) (if (integer? x) x (raise-blame-error blame x '(expected: "<integer>" given: "~e") x))))
Contracts, in this system, are always established between two parties. One party, called the server, provides some value according to the contract, and the other, the client, consumes the value, also according to the contract. The server is called the positive position and the client the negative position. So, in the case of just the integer contract, the only thing that can go wrong is that the value provided is not an integer. Thus, only the positive party (the server) can ever accrue blame. The raise-blame-error function always blames the positive party.
Compare that to the projection for our function contract:
(define (int->int-proj blame) (define dom (int-proj (blame-swap blame))) (define rng (int-proj blame)) (λ (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (x) (rng (f (dom x)))) (raise-blame-error blame f '(expected "a procedure of one argument" given: "~e") f))))
In this case, the only explicit blame covers the situation where either a non-procedure is supplied to the contract or the procedure does not accept one argument. As with the integer projection, the blame here also lies with the producer of the value, which is why raise-blame-error is passed blame unchanged.
The checking for the domain and range are delegated to the int-proj function, which is supplied its arguments in the first two lines of the int->int-proj function. The trick here is that, even though the int->int-proj function always blames what it sees as positive, we can swap the blame parties by calling blame-swap on the given blame object, replacing the positive party with the negative party and vice versa.
This technique is not merely a cheap trick to get the example to work, however. The reversal of the positive and the negative is a natural consequence of the way functions behave. That is, imagine the flow of values in a program between two modules. First, one module (the server) defines a function, and then that module is required by another (the client). So far, the function itself has to go from the original, providing module to the requiring module. Now, imagine that the requiring module invokes the function, supplying it an argument. At this point, the flow of values reverses. The argument is traveling back from the requiring module to the providing module! The client is “serving” the argument to the server, and the server is receiving that value as a client. And finally, when the function produces a result, that result flows back in the original direction from server to client. Accordingly, the contract on the domain reverses the positive and the negative blame parties, just like the flow of values reverses.
We can use this insight to generalize the function contracts and build a function that accepts any two contracts and returns a contract for functions between them.
This projection also goes further and uses blame-add-context to improve the error messages when a contract violation is detected.
(define (make-simple-function-contract dom-proj range-proj) (λ (blame) (define dom (dom-proj (blame-add-context blame "the argument of" #:swap? #t))) (define rng (range-proj (blame-add-context blame "the range of"))) (λ (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (x) (rng (f (dom x)))) (raise-blame-error blame f '(expected "a procedure of one argument" given: "~e") f)))))
(define (int->int-proj blame) (define dom-blame (blame-add-context blame "the argument of" #:swap? #t)) (define rng-blame (blame-add-context blame "the range of")) (define (check-int v to-blame neg-party) (unless (integer? v) (raise-blame-error to-blame #:missing-party neg-party v '(expected "an integer" given: "~e") v))) (λ (f neg-party) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (x) (check-int x dom-blame neg-party) (define ans (f x)) (check-int ans rng-blame neg-party) ans) (raise-blame-error blame #:missing-party neg-party f '(expected "a procedure of one argument" given: "~e") f))))
One final problem remains before this contract can be used with the rest of the contract system. In the function above, the contract is implemented by creating a wrapper function for f, but this wrapper function does not cooperate with equal?, nor does it let the runtime system know that there is a relationship between the result function and f, the input function.
To remedy these two problems, we should use chaperones instead of just using λ to create the wrapper function. Here is the int->int-proj function rewritten to use a chaperone:
(define (int->int-proj blame) (define dom-blame (blame-add-context blame "the argument of" #:swap? #t)) (define rng-blame (blame-add-context blame "the range of")) (define (check-int v to-blame neg-party) (unless (integer? v) (raise-blame-error to-blame #:missing-party neg-party v '(expected "an integer" given: "~e") v))) (λ (f neg-party) (if (and (procedure? f) (procedure-arity-includes? f 1)) (chaperone-procedure f (λ (x) (check-int x dom-blame neg-party) (values (λ (ans) (check-int ans rng-blame neg-party) ans) x))) (raise-blame-error blame #:missing-party neg-party f '(expected "a procedure of one argument" given: "~e") f))))
(define int->int-contract (make-contract #:name 'int->int #:late-neg-projection int->int-proj))
(define/contract (f x) int->int-contract "not an int")
> (f #f) f: contract violation;
expected an integer
given: #f
in: the argument of
int->int
contract from: (function f)
blaming: top-level
(assuming the contract is correct)
at: eval:5:0
> (f 1) f: broke its own contract;
promised an integer
produced: "not an int"
in: the range of
int->int
contract from: (function f)
blaming: (function f)
(assuming the contract is correct)
at: eval:5:0
7.8.1 Contract Struct Properties
The make-chaperone-contract function is okay for one-off contracts, but often you want to make many different contracts that differ only in some pieces. The best way to do that is to use a struct with either prop:contract, prop:chaperone-contract, or prop:flat-contract.
(struct simple-arrow (dom rng) #:property prop:chaperone-contract (build-chaperone-contract-property #:name (λ (arr) (simple-arrow-name arr)) #:late-neg-projection (λ (arr) (simple-arrow-late-neg-proj arr))))
(define (simple-arrow-contract dom rng) (simple-arrow (coerce-contract 'simple-arrow-contract dom) (coerce-contract 'simple-arrow-contract rng)))
(define (simple-arrow-name arr) `(-> ,(contract-name (simple-arrow-dom arr)) ,(contract-name (simple-arrow-rng arr))))
(define (simple-arrow-late-neg-proj arr) (define dom-ctc (get/build-late-neg-projection (simple-arrow-dom arr))) (define rng-ctc (get/build-late-neg-projection (simple-arrow-rng arr))) (λ (blame) (define dom+blame (dom-ctc (blame-add-context blame "the argument of" #:swap? #t))) (define rng+blame (rng-ctc (blame-add-context blame "the range of"))) (λ (f neg-party) (if (and (procedure? f) (procedure-arity-includes? f 1)) (chaperone-procedure f (λ (arg) (values (λ (result) (rng+blame result neg-party)) (dom+blame arg neg-party)))) (raise-blame-error blame #:missing-party neg-party f '(expected "a procedure of one argument" given: "~e") f)))))
(define/contract (f x) (simple-arrow-contract integer? boolean?) "not a boolean")
> (f #f) f: contract violation
expected: integer?
given: #f
in: the argument of
(-> integer? boolean?)
contract from: (function f)
blaming: top-level
(assuming the contract is correct)
at: eval:12:0
> (f 1) f: broke its own contract
promised: boolean?
produced: "not a boolean"
in: the range of
(-> integer? boolean?)
contract from: (function f)
blaming: (function f)
(assuming the contract is correct)
at: eval:12:0
7.8.2 With all the Bells and Whistles
There are a number of optional pieces to a contract that simple-arrow-contract did not add. In this section, we walk through all of them to show examples of how they can be implemented.
(define (simple-arrow-first-order ctc) (λ (v) (and (procedure? v) (procedure-arity-includes? v 1))))
The next is random generation. Random generation in the contract library consists of two pieces: the ability to randomly generate values satisfying the contract and the ability to exercise values that match the contract that are given, in the hopes of finding bugs in them (and also to try to get them to produce interesting values to be used elsewhere during generation).
(define (simple-arrow-contract-exercise arr) (define env (contract-random-generate-get-current-environment)) (λ (fuel) (define dom-generate (contract-random-generate/choose (simple-arrow-dom arr) fuel)) (cond [dom-generate (values (λ (f) (contract-random-generate-stash env (simple-arrow-rng arr) (f (dom-generate)))) (list (simple-arrow-rng arr)))] [else (values void '())])))
If we cannot, then we simply return a function that does no exercising (void) and the empty list (indicating that we won’t generate any values).
(define (simple-arrow-contract-generate arr) (λ (fuel) (define env (contract-random-generate-get-current-environment)) (define rng-generate (contract-random-generate/choose (simple-arrow-rng arr) fuel)) (cond [rng-generate (λ () (λ (arg) (contract-random-generate-stash env (simple-arrow-dom arr) arg) (rng-generate)))] [else #f])))
When the random generation pulls something out of the environment, it needs to be able to tell if a value that has been passed to contract-random-generate-stash is a candidate for the contract it is trying to generate. Of course, it the contract passed to contract-random-generate-stash is an exact match, then it can use it. But it can also use the value if the contract is stronger (in the sense that it accepts fewer values).
(define (simple-arrow-first-stronger? this that) (and (simple-arrow? that) (contract-stronger? (simple-arrow-dom that) (simple-arrow-dom this)) (contract-stronger? (simple-arrow-rng this) (simple-arrow-rng that))))
(struct simple-arrow (dom rng) #:property prop:custom-write contract-custom-write-property-proc #:property prop:chaperone-contract (build-chaperone-contract-property #:name (λ (arr) (simple-arrow-name arr)) #:late-neg-projection (λ (arr) (simple-arrow-late-neg-proj arr)) #:first-order simple-arrow-first-order #:stronger simple-arrow-first-stronger? #:generate simple-arrow-contract-generate #:exercise simple-arrow-contract-exercise))
(define (simple-arrow-contract dom rng) (simple-arrow (coerce-contract 'simple-arrow-contract dom) (coerce-contract 'simple-arrow-contract rng)))
(define a-random-function (contract-random-generate (simple-arrow-contract integer? integer?)))
> (a-random-function 0) 138
> (a-random-function 1) 1
(define/contract (misbehaved-f f) (-> (simple-arrow-contract integer? boolean?) any) (f "not an integer"))
> (contract-exercise misbehaved-f) misbehaved-f: broke its own contract
promised: integer?
produced: "not an integer"
in: the argument of
the 1st argument of
(-> (-> integer? boolean?) any)
contract from: (function misbehaved-f)
blaming: (function misbehaved-f)
(assuming the contract is correct)
at: eval:25:0
(define/contract (maybe-accepts-a-function f) (or/c (simple-arrow-contract real? real?) (-> real? real? real?) real?) (if (procedure? f) (if (procedure-arity-includes f 1) (f 1132) (f 11 2)) f))
> (maybe-accepts-a-function sqrt) maybe-accepts-a-function: contract violation
expected: real?
given: #<procedure:sqrt>
in: the argument of
a part of the or/c of
(or/c
(-> real? real?)
(-> real? real? real?)
real?)
contract from:
(function maybe-accepts-a-function)
blaming: top-level
(assuming the contract is correct)
at: eval:27:0
> (maybe-accepts-a-function 123) 123