#### 8.7Building New Contract Combinators

 (require racket/contract/combinator) package: base

procedure

 (make-contract [ #:name name #:first-order test #:val-first-projection val-first-proj #:projection proj #:stronger stronger #:list-contract? is-list-contract?])
contract?
name : any/c = 'anonymous-contract
test : (-> any/c any/c) = (λ (x) #t)
 val-first-proj : (or/c #f (-> blame? (-> any/c (-> any/c any/c)))) = #f
proj : (-> blame? (-> any/c any/c))
=
 (λ (b) (λ (x) (if (test x) x (raise-blame-error b x '(expected: "~a" given: "~e") name x))))
stronger : (or/c #f (-> contract? contract? boolean?)) = #f
is-list-contract? : boolean? = #f

procedure

 (make-chaperone-contract [ #:name name #:first-order test #:val-first-projection val-first-proj #:projection proj #:stronger stronger #:list-contract? is-list-contract?])
chaperone-contract?
name : any/c = 'anonymous-chaperone-contract
test : (-> any/c any/c) = (λ (x) #t)
 val-first-proj : (or/c #f (-> blame? (-> any/c (-> any/c any/c)))) = #f
proj : (-> blame? (-> any/c any/c))
=
 (λ (b) (λ (x) (if (test x) x (raise-blame-error b x '(expected: "~a" given: "~e") name x))))
stronger : (or/c #f (-> contract? contract? boolean?)) = #f
is-list-contract? : boolean? = #f

procedure

 (make-flat-contract [ #:name name #:first-order test #:val-first-projection val-first-proj #:projection proj #:stronger stronger #:list-contract? is-list-contract?])
flat-contract?
name : any/c = 'anonymous-flat-contract
test : (-> any/c any/c) = (λ (x) #t)
 val-first-proj : (or/c #f (-> blame? (-> any/c (-> any/c any/c)))) = #f
proj : (-> blame? (-> any/c any/c))
=
 (λ (b) (λ (x) (if (test x) x (raise-blame-error b x '(expected: "~a" given: "~e") name x))))
stronger : (or/c #f (-> contract? contract? boolean?)) = #f
is-list-contract? : boolean? = #f
The precise details of the val-first-projection argument are subject to change. (Probably also the default values of the project arguments will change.

These functions build simple higher-order contracts, chaperone contracts, and flat contracts, respectively. They both take the same set of three optional arguments: a name, a first-order predicate, and a blame-tracking projection.

The name argument is any value to be rendered using display to describe the contract when a violation occurs. The default name for simple higher-order contracts is anonymous-contract, for chaperone contracts is anonymous-chaperone-contract, and for flat contracts is anonymous-flat-contract.

The first-order predicate test can be used to determine which values the contract applies to; usually, this is the set of values for which the contract fails immediately without any higher-order wrapping. This test is used by contract-first-order-passes?, and indirectly by or/c to determine which of multiple higher-order contracts to wrap a value with. The default test accepts any value.

The projection proj defines the behavior of applying the contract. It is a curried function of two arguments: the first application accepts a blame object, and the second accepts a value to protect with the contract. The projection must either produce the value, suitably wrapped to enforce any higher-order aspects of the contract, or signal a contract violation using raise-blame-error. The default projection produces an error when the first-order test fails, and produces the value unchanged otherwise.

Projections for chaperone contracts must produce a value that passes chaperone-of? when compared with the original, uncontracted value. Projections for flat contracts must fail precisely when the first-order test does, and must produce the input value unchanged otherwise. Applying a flat contract may result in either an application of the predicate, or the projection, or both; therefore, the two must be consistent. The existence of a separate projection only serves to provide more specific error messages. Most flat contracts do not need to supply an explicit projection.

The stronger argument is used to implement contract-stronger?. The first argument is always the contract itself and the second argument is whatever was passed as the second argument to contract-stronger?.

The is-list-contract? argument is used by the list-contract? predicate to determine if this is a contract that accepts only list? values.

Examples:

 (define int/c (make-flat-contract #:name 'int/c #:first-order integer?))
> (contract int/c 1 'positive 'negative)

1

> (contract int/c "not one" 'positive 'negative)

eval:4:0: broke its contract

promised: int/c

produced: "not one"

in: int/c

contract from: positive

blaming: positive

(assuming the contract is correct)

> (int/c 1)

#t

> (int/c "not one")

#f

 (define int->int/c (make-contract #:name 'int->int/c #:first-order (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) #:projection (λ (b) (let ([domain ((contract-projection int/c) (blame-swap b))] [range ((contract-projection int/c) b)]) (λ (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (x) (range (f (domain x)))) (raise-blame-error b f '(expected "a function of one argument" 'given: "~e") f)))))))
> (contract int->int/c "not fun" 'positive 'negative)

regexp-match: contract violation

expected: (or/c string? bytes? path? input-port?)

given: ''given:

argument position: 2nd

other arguments...:

#rx"^[\n ]"

 (define halve (contract int->int/c (λ (x) (/ x 2)) 'positive 'negative))
> (halve 2)

1

> (halve 1/2)

halve: contract violation

expected: int/c

given: 1/2

in: ...

int->int/c

contract from: positive

blaming: negative

(assuming the contract is correct)

> (halve 1)

halve: broke its contract

promised: int/c

produced: 1/2

in: ...

int->int/c

contract from: positive

blaming: positive

(assuming the contract is correct)

Changed in version 6.0.1.13 of package base: Added the #:list-contract? argument.

 procedure(build-compound-type-name c/s ...) → any c/s : any/c
Produces an S-expression to be used as a name for a contract. The arguments should be either contracts or symbols. It wraps parentheses around its arguments and extracts the names from any contracts it is supplied with.

 procedure(coerce-contract id x) → contract? id : symbol? x : any/c
Converts a regular Racket value into an instance of a contract struct, converting it according to the description of contracts.

If x is not one of the coercible values, coerce-contract signals an error, using the first argument in the error message.

 procedure(coerce-contracts id xs) → (listof contract?) id : symbol? xs : (listof any/c)
Coerces all of the arguments in ’xs’ into contracts (via coerce-contract/f) and signals an error if any of them are not contracts. The error messages assume that the function named by id got xs as its entire argument list.

 procedure id : symbol? x : any/c
Like coerce-contract, but requires the result to be a chaperone contract, not an arbitrary contract.

 procedure id : symbol? x : (listof any/c)
Like coerce-contracts, but requires the results to be chaperone contracts, not arbitrary contracts.

 procedure id : symbol? x : any/c
Like coerce-contract, but requires the result to be a flat contract, not an arbitrary contract.

 procedure id : symbol? x : (listof any/c)
Like coerce-contracts, but requires the results to be flat contracts, not arbitrary contracts.

 procedure(coerce-contract/f x) → (or/c contract? #f) x : any/c
Like coerce-contract, but returns #f if the value cannot be coerced to a contract.

 procedure → (-> contract? blame? (-> any/c (-> any/c any/c))) c : contract?
Returns the val-first projection for c.

See make-contract for more details.

Added in version 6.1.1.5 of package base.

##### 8.7.1Blame Objects

 procedure(blame? x) → boolean? x : any/c
This predicate recognizes blame objects.

procedure

 (blame-add-context blame context [ #:important important #:swap? swap?]) → blame?
blame : blame?
context : (or/c string? #f)
important : (or/c string? #f) = #f
swap? : boolean? = #f
Adds some context information to blame error messages that explicates which portion of the contract failed (and that gets rendered by raise-blame-error).

The context argument describes one layer of the portion of the contract, typically of the form "the 1st argument of" (in the case of a function contract) or "a conjunct of" (in the case of an and/c contract).

For example, consider this contract violation:
 > (define/contract f (list/c (-> integer? integer?)) (list (λ (x) x)))
> ((car f) #f)

f: contract violation

expected: integer?

given: #f

in: the 1st argument of

the 1st element of

(list/c (-> integer? integer?))

contract from: (definition f)

blaming: top-level

(assuming the contract is correct)

at: eval:2.0

It shows that the portion of the contract being violated is the first occurrence of integer?, because the -> and the list/c combinators each internally called blame-add-context to add the two lines following “in” in the error message.

The important argument is used to build the beginning part of the contract violation. The last important argument that gets added to a blame object is used. The class/c contract adds an important argument, as does the -> contract (when -> knows the name of the function getting the contract).

The swap? argument has the effect of calling blame-swap while adding the layer of context, but without creating an extra blame object.

The context information recorded in blame structs keeps track of combinators that do not add information, and add the string "..." for them, so programmers at least see that there was some context they are missing in the error messages. Accordingly, since there are combinators that should not add any context (e.g., recursive-contract), passing #f as the context string argument avoids adding the "..." string.

 procedure b : blame?
 procedure b : blame?
These functions produce printable descriptions of the current positive and negative parties of a blame object.

 procedure b : blame?
This function produces a description of the contract associated with a blame object (the result of contract-name).

 procedure(blame-value b) → any/c b : blame?
This function produces the name of the value to which the contract was applied, or #f if no name was provided.

 procedure b : blame?
This function produces the source location associated with a contract. If no source location was provided, all fields of the structure will contain #f.

 procedure(blame-swap b) → blame? b : blame?

 procedure b : blame?
 procedure b : blame?
These functions report whether the current blame of a given blame object is the same as in the original contract invocation (possibly of a compound contract containing the current one), or swapped, respectively. Each is the negation of the other; both are provided for convenience and clarity.

 procedure(blame-replace-negative b neg) → blame? b : blame? neg : any/c
Produces a blame? object just like b except that it uses neg instead of the negative position b has.

 procedure(blame-update b pos neg) → blame? b : blame? pos : any/c neg : any/c
Produces a blame? object just like b except that it adds pos and neg to the positive and negative parties of b respectively.

procedure

(raise-blame-error b x fmt v ...)  none/c

b : blame?
x : any/c
fmt :
 (or/c string? (listof (or/c string? 'given 'given: 'expected 'expected:)))
v : any/c
Signals a contract violation. The first argument, b, records the current blame information, including positive and negative parties, the name of the contract, the name of the value, and the source location of the contract application. The second argument, x, is the value that failed to satisfy the contract.

The remaining arguments are a format string, fmt, and its arguments, v ..., specifying an error message specific to the precise violation.

If fmt is a list, then the elements are concatenated together (with spaces added, unless there are already spaces at the ends of the strings), after first replacing symbols with either their string counterparts, or replacing 'given with "produced" and 'expected with "promised", depending on whether or not the b argument has been swapped or not (see blame-swap).

If fmt contains the symbols 'given: or 'expected:, they are replaced like 'given: and 'expected: are, but the replacements are prefixed with the string "\n  " to conform to the error message guidelines in Error Message Conventions.

struct

 (struct exn:fail:contract:blame exn:fail:contract (object)
#:extra-constructor-name make-exn:fail:contract:blame)
object : blame?
This exception is raised to signal a contract error. The object field contains a blame object associated with a contract violation.

 parameter (current-blame-format proc) → void? proc : (-> blame? any/c string? string?)
A parameter that is used when constructing a contract violation error. Its value is procedure that accepts three arguments:
• the blame object for the violation,

• the value that the contract applies to, and

• a message indicating the kind of violation.

The procedure then returns a string that is put into the contract error message. Note that the value is often already included in the message that indicates the violation.

Examples:

 (define (show-blame-error blame value message) (string-append "Contract Violation!\n" (format "Guilty Party: ~a\n" (blame-positive blame)) (format "Innocent Party: ~a\n" (blame-negative blame)) (format "Contracted Value Name: ~a\n" (blame-value blame)) (format "Contract Location: ~s\n" (blame-source blame)) (format "Contract Name: ~a\n" (blame-contract blame)) (format "Offending Value: ~s\n" value) (format "Offense: ~a\n" message)))
> (current-blame-format show-blame-error)
 > (define/contract (f x) (-> integer? integer?) (/ x 2))
> (f 2)

1

> (f 1)

Contract Violation!

Guilty Party: (function f)

Innocent Party: top-level

Contracted Value Name: f

Contract Location: #(struct:srcloc eval 4 0 4 1)

Contract Name: (-> integer? integer?)

Offending Value: 1/2

Offense: promised: integer?

produced: 1/2

> (f 1/2)

Contract Violation!

Guilty Party: top-level

Innocent Party: (function f)

Contracted Value Name: f

Contract Location: #(struct:srcloc eval 4 0 4 1)

Contract Name: (-> integer? integer?)

Offending Value: 1/2

Offense: expected: integer?

given: 1/2

##### 8.7.2Contracts as structs

The property prop:contract allows arbitrary structures to act as contracts. The property prop:chaperone-contract allows arbitrary structures to act as chaperone contracts; prop:chaperone-contract inherits prop:contract, so chaperone contract structures may also act as general contracts. The property prop:flat-contract allows arbitrary structures to act as flat contracts; prop:flat-contract inherits both prop:chaperone-contract and prop:procedure, so flat contract structures may also act as chaperone contracts, as general contracts, and as predicate procedures.

 value
 value
 value
These properties declare structures to be contracts or flat contracts, respectively. The value for prop:contract must be a contract property constructed by build-contract-property; likewise, the value for prop:chaperone-contract must be a chaperone contract property constructed by build-chaperone-contract-property and the value for prop:flat-contract must be a flat contract property constructed by build-flat-contract-property.

 value
 value
These properties attach a contract value to the protected structure, chaperone, or impersonator value. The function has-contract? returns #t for values that have one of these properties, and value-contract extracts the value from the property (which is expected to be the contract on the value).

 value
 value
These properties attach a blame information to the protected structure, chaperone, or impersonator value. The function blame-contract? returns #t for values that have one of these properties, and blame-contract extracts the value from the property (which is expected to be the blame record for the contract on the value).

procedure

 (build-flat-contract-property [ #:name get-name #:first-order get-first-order #:val-first-projection val-first-proj #:projection get-projection #:stronger stronger #:generate generate #:exercise exercise #:list-contract? is-list-contract?])
flat-contract-property?
 get-name : (-> contract? any/c) = (λ (c) 'anonymous-flat-contract)
 get-first-order : (-> contract? (-> any/c boolean?)) = (λ (c) (λ (x) #t))
 val-first-proj : (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c)))) = #f
get-projection : (-> contract? (-> blame? (-> any/c any/c)))
=
 (λ (c) (λ (b) (λ (x) (if ((get-first-order c) x) x (raise-blame-error b x '(expected: "~a" given: "~e") (get-name c) x)))))
stronger : (or/c (-> contract? contract? boolean?) #f) = #f
generate :
 (->i ([c contract?]) ([generator (c) (-> (and/c positive? real?) (or/c (-> (or/c contract-random-generate-fail? c)) #f))]))
= (λ (c) (λ (fuel) #f))
exercise :
 (->i ([c contract?]) ([result (c) (-> (and/c positive? real?) (values (-> c void?) (listof contract?)))]))
= (λ (c) (λ (fuel) (values void '())))
is-list-contract? : (-> contract? boolean?) = (λ (c) #f)

procedure

 (build-chaperone-contract-property [ #:name get-name #:first-order get-first-order #:val-first-projection val-first-proj #:projection get-projection #:stronger stronger #:generate generate #:exercise exercise #:list-contract? is-list-contract?])
chaperone-contract-property?
 get-name : (-> contract? any/c) = (λ (c) 'anonymous-chaperone-contract)
 get-first-order : (-> contract? (-> any/c boolean?)) = (λ (c) (λ (x) #t))
 val-first-proj : (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c)))) = #f
get-projection : (-> contract? (-> blame? (-> any/c any/c)))
=
 (λ (c) (λ (b) (λ (x) (if ((get-first-order c) x) x (raise-blame-error b x '(expected: "~a" given: "~e") (get-name c) x)))))
stronger : (or/c (-> contract? contract? boolean?) #f) = #f
generate :
 (->i ([c contract?]) ([generator (c) (-> (and/c positive? real?) (or/c (-> (or/c contract-random-generate-fail? c)) #f))]))
= (λ (c) (λ (fuel) #f))
exercise :
 (->i ([c contract?]) ([result (c) (-> (and/c positive? real?) (values (-> c void?) (listof contract?)))]))
= (λ (c) (λ (fuel) (values void '())))
is-list-contract? : (-> contract? boolean?) = (λ (c) #f)

procedure

 (build-contract-property [ #:name get-name #:first-order get-first-order #:val-first-projection val-first-proj #:projection get-projection #:stronger stronger #:generate generate #:exercise exercise #:list-contract? is-list-contract?])
contract-property?
get-name : (-> contract? any/c) = (λ (c) 'anonymous-contract)
 get-first-order : (-> contract? (-> any/c boolean?)) = (λ (c) (λ (x) #t))
 val-first-proj : (or/c #f (-> contract? blame? (-> any/c (-> any/c any/c)))) = #f
get-projection : (-> contract? (-> blame? (-> any/c any/c)))
=
 (λ (c) (λ (b) (λ (x) (if ((get-first-order c) x) x (raise-blame-error b x '(expected: "~a" given: "~e") (get-name c) x)))))
stronger : (or/c (-> contract? contract? boolean?) #f) = #f
generate :
 (->i ([c contract?]) ([generator (c) (-> (and/c positive? real?) (or/c (-> (or/c contract-random-generate-fail? c)) #f))]))
= (λ (c) (λ (fuel) #f))
exercise :
 (->i ([c contract?]) ([result (c) (-> (and/c positive? real?) (values (-> c void?) (listof contract?)))]))
= (λ (c) (λ (fuel) (values void '())))
is-list-contract? : (-> contract? boolean?) = (λ (c) #f)
The precise details of the val-first-projection argument are subject to change. (Probably also the default values of the project arguments will change.)

These functions build the arguments for prop:contract, prop:chaperone-contract, and prop:flat-contract, respectively.

A contract property specifies the behavior of a structure when used as a contract. It is specified in terms of five accessors: get-name, which produces a description to write as part of a contract violation; get-first-order, which produces a first-order predicate to be used by contract-first-order-passes?; get-projection, which produces a blame-tracking projection defining the behavior of the contract; stronger, which is a predicate that determines whether this contract (passed in the first argument) is stronger than some other contract (passed in the second argument); generate, which returns a thunk that generates random values matching the contract (using contract-random-generate-fail) to indicate failure) or #f to indicate that random generation for this contract isn’t supported; exercise, which returns a function that exercises values matching the contract (e.g., if it is a function contract, it may call the function) and a list of contracts whose values will be generated by this process; and is-flat-contract?, which is used by flat-contract? to determine if this contract accepts only list?s.

These accessors are passed as (optional) keyword arguments to build-contract-property, and are applied to instances of the appropriate structure type by the contract system. Their results are used analogously to the arguments of make-contract.

A chaperone contract property specifies the behavior of a structure when used as a chaperone contract. It is specified using build-chaperone-contract-property, and accepts exactly the same set of arguments as build-contract-property. The only difference is that the projection accessor must return a value that passes chaperone-of? when compared with the original, uncontracted value.

A flat contract property specifies the behavior of a structure when used as a flat contract. It is specified using build-flat-contract-property, and accepts exactly the same set of arguments as build-contract-property. The only difference is that the projection accessor is expected not to wrap its argument in a higher-order fashion, analogous to the constraint on projections in make-flat-contract.

Changed in version 6.0.1.13 of package base: Added the #:list-contract? argument. Changed in version 6.1.1.4: Allow generate to return contract-random-generate-fail

 procedure x : any/c
 procedure x : any/c
 procedure x : any/c
These predicates detect whether a value is a contract property, chaperone contract property, or a flat contract property, respectively.

##### 8.7.3Obligation Information in Check Syntax

Check Syntax in DrRacket shows obligation information for contracts according to syntax-propertys that the contract combinators leave in the expanded form of the program. These properties indicate where contracts appear in the source and where the positive and negative positions of the contracts appear.

To make Check Syntax show obligation information for your new contract combinators, use the following properties (some helper macros and functions are below):

•  'racket/contract:contract : (vector/c symbol? (listof syntax?) (listof syntax?))
This property should be attached to the result of a transformer that implements a contract combinator. It signals to Check Syntax that this is where a contract begins.

The first element in the vector should be a unique (in the sense of eq?) value that Check Syntax can use a tag to match up this contract with its subpieces (specified by the two following syntax properties).

The second and third elements of the vector are syntax objects from pieces of the contract, and Check Syntax will color them. The first list should contain subparts that are the responsibility of parties (typically modules) that provide implementations of the contract. The second list should contain subparts that are the responsibility of clients.

For example, in (->* () #:pre #t any/c #:post #t), the ->* and the #:post should be in the first list and #:pre in the second list.

• 'racket/contract:negative-position : symbol?
This property should be attached to sub-expressions of a contract combinator that are expected to be other contracts. The value of the property should be the key (the first element from the vector for the 'racket/contract:contract property) indicating which contract this is.

This property should be used when the expression’s value is a contract that clients are responsible for.

• 'racket/contract:positive-position : symbol?
This form is just like 'racket/contract:negative-position, except that it should be used when the expression’s value is a contract that the original party should be responsible for.

• 'racket/contract:contract-on-boundary : symbol?
The presence of this property tells Check Syntax that it should start coloring from this point. It expects the expression to be a contract (and, thus, to have the 'racket/contract:contract property); this property indicates that this contract is on a (module) boundary.

(The value of the property is not used.)

• 'racket/contract:internal-contract : symbol?

Like 'racket/contract:contract-on-boundary, the presence of this property triggers coloring, but this is meant for use when the party (module) containing the contract (regardless of whether or not this module exports anything matching the contract) can be blamed for violating the contract. This comes into play for ->i contracts, since the contract itself has access to values under contract via the dependency.

syntax

 header = main-id | (main-id id ...) | (main-id id ... . id)
The same as (define header body ...), except that uses of main-id in the header are annotated with the 'racket/contract:contract property (as above).

syntax

 header = main-id | (main-id id ...) | (main-id id ... . id)
The same as (define header body ...), except that uses of main-id in the header are annotated with the 'racket/contract:contract property (as above) and arguments are annotated with the 'racket/contract:positive-position property.

##### 8.7.4Utilities for Building New Combinators

 procedure x : contract? y : contract?
Returns #t if the contract x accepts either fewer or the same number of values as y does.

This function is conservative, so it may return #f when x does, in fact, accept fewer values.

Examples:

> (contract-stronger? integer? integer?)

#t

> (contract-stronger? (between/c 25 75) (between/c 0 100))

#t

> (contract-stronger? (between/c 0 100) (between/c 25 75))

#f

> (contract-stronger? (between/c -10 0) (between/c 0 10))

#f

 > (contract-stronger? (λ (x) (and (real? x) (<= x (random 10)))) (λ (x) (and (real? x) (<= x (+ 100 (random 10))))))

#f

 procedure(contract-first-order-passes? contract v) → boolean? contract : contract? v : any/c
Returns a boolean indicating whether the first-order tests of contract pass for v.

If it returns #f, the contract is guaranteed not to hold for that value; if it returns #t, the contract may or may not hold. If the contract is a first-order contract, a result of #t guarantees that the contract holds.

 procedure c : contract?
Produces the first-order test used by or/c to match values to higher-order contracts.