#lang scribble/doc @(require scribble/manual scribble/eval "utils.rkt" (for-label racket/contract racket/gui)) @(define ex-eval (make-base-eval)) @(ex-eval '(require racket/contract)) @title{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. 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 @racket[(flat-contract integer?)], and can be written like this: @racketblock[ (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: @racketblock[ (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 @deftech{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 @racket[raise-blame-error] to signal a good error message. Here is the first of those two projections, rewritten for use in the contract system: @racketblock[ (define (int-proj blame) (λ (x) (if (integer? x) x (raise-blame-error blame x '(expected: "" given: "~e") x)))) ] The new argument specifies who is to be blamed for positive and negative contract violations. 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 @racket[raise-blame-error] function always blames the positive party. Compare that to the projection for our function contract: @racketblock[ (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 @racket[raise-blame-error] is passed @racket[blame] unchanged. The checking for the domain and range are delegated to the @racket[int-proj] function, which is supplied its arguments in the first two lines of the @racket[int->int-proj] function. The trick here is that, even though the @racket[int->int-proj] function always blames what it sees as positive, we can swap the blame parties by calling @racket[blame-swap] on the given @tech{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 providing 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 @racket[blame-add-context] to improve the error messages when a contract violation is detected. @racketblock[ (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))))) ] While these projections are supported by the contract library and can be used to build new contracts, the contract library also supports a different API for projections that can be more efficient. Specifically, a @deftech{val first projection} accepts a blame object without the negative blame information and then returns a function that accepts the value to be contracted, and then finally accepts the name of the negative party to the contract before returning the value with the contract. Rewriting @racket[int->int-proj] to use this API looks like this: @interaction/no-prompt[#:eval ex-eval (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) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (neg-party) (λ (x) (check-int x dom-blame neg-party) (define ans (f x)) (check-int ans rng-blame neg-party) ans)) (λ (neg-party) (raise-blame-error blame #:missing-party neg-party f '(expected "a procedure of one argument" given: "~e") f)))))] The advantage of this style of contract is that the @racket[_blame] and @racket[_v] arguments can be supplied on the server side of the contract boundary and the result can be used for every different client. With the simpler situation, a new blame object has to be created for each client. Projections like the ones described above, but suited to other, new kinds of value you might make, can be used with the contract library primitives. Specifically, we can use @racket[make-chaperone-contract] to build it: @interaction/no-prompt[#:eval ex-eval (define int->int-contract (make-contract #:name 'int->int #:val-first-projection int->int-proj))] and then combine it with a value and get some contract checking. @def+int[#:eval ex-eval (define/contract (f x) int->int-contract "not an int") (f #f) (f 1)] @section{Contract Struct Properties} The @racket[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 @racket[struct] with either @racket[prop:contract], @racket[prop:chaperone-contract], or @racket[prop:flat-contract]. For example, lets say we wanted to make a simple form of the @racket[->] contract that accepts one contract for the range and one for the domain. We should define a struct with two fields and use @racket[build-chaperone-contract-property] to construct the chaperone contract property we need. @interaction/no-prompt[#:eval ex-eval (struct simple-arrow (dom rng) #:property prop:chaperone-contract (build-chaperone-contract-property #:name (λ (arr) (simple-arrow-name arr)) #:val-first-projection (λ (arr) (simple-arrow-val-first-proj arr))))] To do the automatic coercion of values like @racket[integer?] and @racket[#f] into contracts, we need to call @racket[coerce-chaperone-contract] (note that this rejects impersonator contracts and does not insist on flat contracts; to do either of those things, call @racket[coerce-contract] or @racket[coerce-flat-contract] instead). @interaction/no-prompt[#:eval ex-eval (define (simple-arrow-contract dom rng) (simple-arrow (coerce-contract 'simple-arrow-contract dom) (coerce-contract 'simple-arrow-contract rng)))] To define @racket[_simple-arrow-name] is straight-forward; it needs to return an s-expression representing the contract: @interaction/no-prompt[#:eval ex-eval (define (simple-arrow-name arr) `(-> ,(contract-name (simple-arrow-dom arr)) ,(contract-name (simple-arrow-rng arr))))] And we can define the projection using a generalization of the projection we defined earlier, this time using @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{chaperones}: @interaction/no-prompt[#:eval ex-eval (define (simple-arrow-val-first-proj arr) (define dom-ctc (get/build-val-first-projection (simple-arrow-dom arr))) (define rng-ctc (get/build-val-first-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) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (neg-party) (chaperone-procedure f (λ (arg) (values (λ (result) ((rng+blame result) neg-party)) ((dom+blame arg) neg-party))))) (λ (neg-party) (raise-blame-error blame #:missing-party neg-party f '(expected "a procedure of one argument" given: "~e") f))))))] @def+int[#:eval ex-eval (define/contract (f x) (simple-arrow-contract integer? boolean?) "not a boolean") (f #f) (f 1)] @section{With all the Bells and Whistles} There are a number of optional pieces to a contract that @racket[simple-arrow-contract] did not add. In this section, we walk through all of them to show examples of how they can be implemented. The first is a first-order check. This is used by @racket[or/c] in order to determine which of the higher-order argument contracts to use when it sees a value. Here's the function for our simple arrow contract. @interaction/no-prompt[#:eval ex-eval (define (simple-arrow-first-order ctc) (λ (v) (and (procedure? v) (procedure-arity-includes? v 1))))] It accepts a value and returns @racket[#f] if the value is guaranteed not to satisfy the contract, and @racket[#t] if, as far as we can tell, the value satisfies the contract, just be inspecting first-order properties of the value. 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). To exercise contracts, we need to implement a function that is given a @racket[arrow-contract] struct and some fuel. It should return two values: a function that accepts values of the contract and exercises them, plus a list of values that the exercising process will always produce. In the case of our simple contract, we know that we can always produce values of the range, as long as we can generate values of the domain (since we can just call the function). So, here's a function that matches the @racket[_exercise] argument of @racket[build-chaperone-contract-property]'s contract: @interaction/no-prompt[#:eval ex-eval (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 the domain contract can be generated, then we know we can do some good via exercising. In that case, we return a procedure that calls @racket[_f] (the function matching the contract) with something that we generated from the domain, and we stash the result value in the environment too. We also return @racket[(simple-arrow-rng arr)] to indicate that exercising will always produce something of that contract. If we cannot, then we simply return a function that does no exercising (@racket[void]) and the empty list (indicating that we won't generate any values). Then, to generate values matching the contract, we define a function that when given the contract and some fuel, makes up a random function. To help make it a more effective testing function, we can exercise any arguments it receives, and also stash them into the generation environment, but only if we can generate values of the range contract. @interaction/no-prompt[#:eval ex-eval (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 @racket[contract-random-generate-stash] is a candidate for the contract it is trying to generate. Of course, it the contract passed to @racket[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). To provide that functionality, we implement this function: @interaction/no-prompt[#:eval ex-eval (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))))] This function accepts @racket[_this] and @racket[_that], two contracts. It is guaranteed that @racket[_this] will be one of our simple arrow contracts, since we're supplying this function together with the simple arrow implementation. But the @racket[_that] argument might be any contract. This function checks to see if @racket[_that] is also a simple arrow contract and, if so compares the domain and range. Of course, there are other contracts that we could also check for (e.g., contracts built using @racket[->] or @racket[->*]), but we do not need to. The stronger function is allowed to return @racket[#f] if it doesn't know the answer but if it returns @racket[#t], then the contract really must be stronger. Now that we have all of the pieces implemented, we need to pass them to @racket[build-chaperone-contract-property] so the contract system starts using them: @interaction/no-prompt[#:eval ex-eval (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)) #:val-first-projection (λ (arr) (simple-arrow-val-first-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)))] We also add a @racket[prop:custom-write] property so that the contracts print properly, e.g.: @interaction[#:eval ex-eval (simple-arrow-contract integer? integer?)] (We use @racket[prop:custom-write] because the contract library can not depend on @racketmod[racket/generic] but yet still wants to provide some help to make it easy to use the right printer.) Now that that's done, we can use the new functionality. Here's a random function, generated by the contract library, using our @racket[simple-arrow-contract-generate] function: @def+int[#:eval ex-eval (define a-random-function (contract-random-generate (simple-arrow-contract integer? integer?))) (a-random-function 0) (a-random-function 1)] Here's how the contract system can now automatically find bugs in functions that consume simple arrow contracts: @def+int[#:eval ex-eval (define/contract (misbehaved-f f) (-> (simple-arrow-contract integer? boolean?) any) (f "not an integer")) (contract-exercise misbehaved-f)] And if we hadn't implemented @racket[simple-arrow-first-order], then @racket[or/c] would not be able to tell which branch of the @racket[or/c] to use in this program: @def+int[#:eval ex-eval (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 123)] @(close-eval ex-eval)