►The Racket Guide
▼7 Contracts
►7.8 Building New Contracts
On this page:
7.8.1 Contract Struct Properties
7.8.2 With all the Bells and Whistles
  top  contents    up   

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.

Here is the first of those two projections, rewritten for use in the contract system:
(define (int-proj blame)
  (λ (x)
    (if (integer? x)
        x
        (raise-blame-error
         blame
         x
         '(expected: "<integer>" 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 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)))))

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 late neg projection accepts a blame object without the negative blame information and then returns a function that accepts both the value to be contracted and the name of the negative party, in that order. The returned function then in turn returns the value with the contract. Rewriting int->int-proj to use this API looks like this:
(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))))
The advantage of this style of contract is that the blame argument can be supplied on the server side of the contract boundary and the result can be used for each different client. With the simpler situation, a new blame object has to be created for each client.

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))))

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 make-chaperone-contract to build it:
(define int->int-contract
  (make-contract
   #:name 'int->int
   #:late-neg-projection int->int-proj))
and then combine it with a value and get some contract checking.
(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.

For example, lets say we wanted to make a simple form of the -> contract that accepts one contract for the range and one for the domain. We should define a struct with two fields and use build-chaperone-contract-property to construct the chaperone contract property we need.
(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))))

To do the automatic coercion of values like integer? and #f into contracts, we need to call coerce-chaperone-contract (note that this rejects impersonator contracts and does not insist on flat contracts; to do either of those things, call coerce-contract or coerce-flat-contract instead).
(define (simple-arrow-contract dom rng)
  (simple-arrow (coerce-contract 'simple-arrow-contract dom)
                (coerce-contract 'simple-arrow-contract rng)))

To define simple-arrow-name is straight-forward; it needs to return an s-expression representing the contract:
(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 chaperones:
(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.

The first is a first-order check. This is used by 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.
(define (simple-arrow-first-order ctc)
  (λ (v) (and (procedure? v)
              (procedure-arity-includes? v 1))))
It accepts a value and returns #f if the value is guaranteed not to satisfy the contract, and #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 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 exercise argument of build-chaperone-contract-property’s contract:
(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 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 (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 (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.
(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).

To provide that functionality, we implement this function:
(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 this and that, two contracts. It is guaranteed that this will be one of our simple arrow contracts, since we’re supplying this function together with the simple arrow implementation. But the that argument might be any contract. This function checks to see if 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 -> or ->*), but we do not need to. The stronger function is allowed to return #f if it doesn’t know the answer but if it returns #t, then the contract really must be stronger.

Now that we have all of the pieces implemented, we need to pass them to build-chaperone-contract-property so the contract system starts using them:
(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)))
We also add a prop:custom-write property so that the contracts print properly, e.g.:
> (simple-arrow-contract integer? integer?)

(-> integer? integer?)

(We use prop:custom-write because the contract library can not depend on

#lang 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 simple-arrow-contract-generate function:
(define a-random-function
  (contract-random-generate
   (simple-arrow-contract integer? integer?)))

 

> (a-random-function 0)

0

> (a-random-function 1)

-1

Here’s how the contract system can now automatically find bugs in functions that consume simple arrow contracts:
(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

And if we hadn’t implemented simple-arrow-first-order, then or/c would not be able to tell which branch of the or/c to use in this program:
(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

  top  contents    up