Racket编程指南——7 合约

7 合约

本章对Racket的合约系统提供了一个详细的介绍。

在《Racket参考》中的“合约（Contracts）”部分提供有对合约更详细的信息。

7.1 合约和边界

7.1.1 合约的违反

7.1.2 合约与模块的测试

7.1.3 嵌套合约边界测试

7.2 函数的简单合约

7.2.1 ->类型

7.2.2 使用define/contract和 ->

7.2.3 any和any/c

7.2.4 运转你自己的合约

7.2.5 高阶函数的合约

7.2.6 带”???“的合约信息

7.2.7 解析一个合约错误信息

7.3 一般功能合约

7.3.1 可选参数

7.3.2 剩余参数

7.3.3 关键字参数

7.3.4 可选关键字参数

7.3.5 case-lambda的合约

7.3.6 参数和结果依赖

7.3.7 检查状态变化

7.3.8 多个结果值

7.3.9 固定但静态未知数量

7.4 合约：一个完整的例子

7.5 结构上的合约

7.5.1 确保一个特定值

7.5.2 确保所有值

7.5.3 检查数据结构的特性

7.6 用#:exists和#:∃抽象合约

7.7 附加实例

7.7.1 一个客户管理器组建

7.7.2 一个参数化（简单）栈

7.7.3 一个字典

7.7.4 一个队列

7.8 建立新合约

7.8.1 合约结构属性

7.8.2 使所有警告和报警一致

7.9 问题

7.9.1 合约和eq?

7.9.2 合约边界和define/contract

7.9.3 存在的合约和判断

7.9.4 定义递归合约

7.9.5 混合set!和contract-out

7.1 合约和边界

如同两个商业伙伴之间的一个合约，一个软件合约是双方之间的一个协议。这个协议规定了从一方传给另一方的每一”产品“（或值）的义务和保证。

因此，一个合约确定了双方之间的一个边界。每当一个值跨越这个边界，这个合约监督系统执行合约检查，确保合作伙伴遵守既定合约。

在这种精神下，Racket主要在模块边界支持合约。具体来说，程序员可以附加合约到provide从句从而对输出值的使用施加约束和承诺。例如，输出描述

#lang racket

(provide (contract-out [amount positive?]))

(define amount ...)

对上述amount值的模块的所有客户端的承诺将始终是一个正数。合约系统仔细地监测了该模块的义务。每次一个客户端引用amount时，监视器检查amount值是否确实是一个正数。

合约库是建立在Racket语言中内部的，但是如果你希望使用racket/base，你可以像这样明确地输入合约库：

#lang racket/base

(require racket/contract) ; 现在我们可以写合约了。

(provide (contract-out [amount positive?]))

(define amount ...)

7.1.1 合约的违反

如果我们把amount绑定到一个非正的数字上，

#lang racket

(provide (contract-out [amount positive?]))

(define amount 0)

那么，当模块被需要时，监控系统发出一个合同违反的信号并将违背承诺归咎于这个模块。

一个更大的错误将是绑定amount到一个非数字值上：

#lang racket

(provide (contract-out [amount positive?]))

(define amount 'amount)

在这种情况下，监控系统将应用positive?到一个符号，但是positive?报告一个错误，因为它的定义域仅是数字。为了使合约能取得我们对所有Racket值的意图，我们可以确保这个数值既是一个数值同时也是正的，用and/c结合两个合约：

(provide (contract-out [amount (and/c number? positive?)]))

7.1.2 合约与模块的测试

在这一章中的所有合约和模块（不包括那些只是跟随的是使用描述模块的标准#lang语法编写。由于模块充当一个合约中各方之间的边界，因此示例涉及多个模块。

为了在一个单一的模块内或者在DrRacket的定义范围（definitions area）内用多个模块进行测试，使用Racket的子模块。例如，尝试如下所示本节中早先的示例：

#lang racket

(module+ server

(provide (contract-out [amount (and/c number? positive?)]))

(define amount 150))

(module+ main

(require (submod ".." server))

(+ amount 10))

每个模块及其合约都用前面的module+关键字包裹在圆括号中。module后面的第一个表是该模块的名称，它被用在一个随后的require语句中（其中通过一个require每个引用用".."对名称进行前缀）。

7.1.3 嵌套合约边界测试

在许多情况下，在模块边界上附加合约是有意义的。然而，能够以一个比模块更细致的方式使用合约通常是方便的。这个define/contract表提供这种使用的权利：

#lang racket

(define/contract amount

(and/c number? positive?)

150)

(+ amount 10)

在这个例子中，define/contract表确定在amount的定义与其周边上下文之间的一个合约边界。换言之，这里的双方是这个定义及包含它的这个模块。

创造这些嵌套合约边界（nested contract boundaries）的表有时对使用来说是微妙的，因为它们也许有意想不到的性能影响或归咎于似乎不直观的一方。这些微妙之处在《使用define/contract和 ->》和《合约边界和define/contract》中被讲解。

7.2 函数的简单合约

一个数学函数有一个定义域(domain)和一个值域(range)。定义域表示这个函数可以作为参数接受的值的类型，值域表示它生成的值的类型。用其定义域和值域描述一个函数的常规符号是

f : A -> B

这里A是这个函数的定义域，B是值域。

一个编程语言中的函数也有定义域和值域，而一个合约可以确保一个函数在其定义域中只接收值并且在其值域中只产生值。一个->为一个函数创建这样的一个合约。一个->之后的表为定义域指定定义域并且最后为值域指定一个合约。

这里有一个可以代表一个银行帐户的模块：

#lang racket

(provide (contract-out

[deposit (-> number? any)]

[balance (-> number?)]))

(define amount 0)

(define (deposit a) (set! amount (+ amount a)))

(define (balance) amount)

这个模块输出两个函数：

• deposit，它接受一个数字并返回某个未在合约中指定的值，

• balance，它返回指示账户当前余额的一个数值。

当一个模块输出一个函数时，它在自己作为“服务器（server）”与“客户端（client）”的输入这个函数的模块之间建立两个通信通道。如果客户端模块调用该函数，它发送一个值进入服务器模块。相反，如果这样一个函数调用结束并且这个函数返回一个值，这个服务器模块发送一个值回到客户端模块。这种客户端-服务器区别是很重要的，因为当出现问题时，一方或另一方将被归咎。

如果一个客户端模块准备应用deposit到'millions，这将违反其合约。合约监视系统会获得这个违规并因为与上述模块违背合约而归咎于这个客户端。相比之下，如果balance函数准备返回'broke，合同监视系统将归咎于服务器模块。

一个->本身不是一个合约；它是一种合约组合（contract combinator），它结合其它合约以构成一个合约。

7.2.1 ->类型

如果你已经习惯了数学函数，你可以选择一个合约箭头出现在函数的定义域和值域之间而不是在开头。如果你已经阅读过《How to Design Programs》，那你已经见过这个很多次了。事实上，你也许已经在其他人的代码中看到比如这些合约：

(provide (contract-out

[deposit (number? . -> . any)]))

如果一个Racket的S表达式包含在中间带一个符号的两个点，读取器重新安排这个S表达式并放置符号到前面，就如《列表和Racket语法》里描述的那样。因此，

(number? . -> . any)

只是编写的另一种方式

(-> number? any)

7.2.2 使用define/contract和 ->

在《嵌套合约边界测试》中引入的define/contract表也可以用来定义合约中的函数。例如,

(define/contract (deposit amount)

(-> number? any)

; 实现在这里进行

....)

它用合约更早定义deposit函数。请注意，这对deposit的使用有两个潜在的重要影响：

1. 由于合约总是在调用deposit时进行检查，即使在定义它的模块内，这也可能增加合约被检查的次数。这可能导致一个性能下降。如果函数在循环中反复调用或使用递归时尤其如此。

2. 在某些情况下，当在同一模块中被其它代码调用时，一个函数可以编写来接受一组更宽松的输入。对于此类用例，通过define/contract建立的合约边界过于严格。

7.2.3 any和any/c

用于deposit的any合约匹配任何结果，并且它只能用于一个函数合约的值域位置。代替上面的any，我们可以使用更具体的合约void?，它表示函数总会返回(void)值。然而，void?合约会要求合约监视系统每次在函数被调用时去检查这个返回值，即使“客户端”模块不能很好用这个值工作。相反，any告诉监视系统不检查这个返回值，它告诉一个潜在客户端这个“服务器”模块对这个函数的返回值不作任何承诺，甚至不管它是一个单独的值或多个值。

any/c合约类似于any，在那里它对一个值不做要求。不像any，any/c表示一个单个值，并且它适合用作一个参数合约。使用any/c作为一个值域合约强迫一个对这个函数产生一个单个值的检查。就像这样，

(-> integer? any)

描述一个接受一个整数并返回任意数值的函数，然而

(-> integer? any/c)

描述接受一个整数并生成一个单个结果（但对结果没有更多说明）的一个函数。以下函数

(define (f x) (values (+ x 1) (- x 1)))

匹配(-> integer? any)，但不匹配(-> integer? any/c)。

当对承诺来自一个函数的一个单个结果特别重要时，使用any/c作为一个结果合约。当你希望对一个函数的结果尽可能少地承诺（并尽可能少地检查）时，使用any/c。

7.2.4 运转你自己的合约

deposit函数将给定的数值添加到amount中。当该函数的合约阻止客户端将它应用到非数值时，这个合约仍然允许它们把这个函数应用到复数、负数或不精确的数字中，但没有一个能合理地表示钱的金额。

合约系统允许程序员定义他们自己的合约作为函数：

#lang racket

(define (amount? a)

(and (number? a) (integer? a) (exact? a) (>= a 0)))

(provide (contract-out

; 一个金额是一个美分的自然数

; 是给定的数字的一个amount?

[deposit (-> amount? any)]

[amount? (-> any/c boolean?)]

[balance (-> amount?)]))

(define amount 0)

(define (deposit a) (set! amount (+ amount a)))

(define (balance) amount)

这个模块定义了一个amount?函数并在->合约内使用它作为一个合约。当一个客户端用(-> amount? any)调用deposit函数作为输出时，它必须提供一个精确的、非负的整数，否则amount?函数应用到参数将返回#f，这将导致合约监视系统归咎于客户端。类似地，服务器模块必须提供一个精确的、非负的整数作为balance的结果以保持无可归咎。

当然，将一个通信通道限制为客户端不明白的值是没有意义的。因此，这个模块也输出amount?判断本身，用一个合约表示它接受一个任意值并返回一个布尔值。

在这种情况下，我们也可以使用natural-number/c代替amount?，因为它恰恰意味着相同的检查：

(provide (contract-out

[deposit (-> natural-number/c any)]

[balance (-> natural-number/c)]))

接受一个参数的每一个函数可以当作一个判断从而被用作一个合约。然而，为了结合现有的对一个新参数的检查，合约连接符像and/c或or/c往往是有用的。例如，这里还有另一种途径去编写上述合约：

(define amount/c

(and/c number? integer? exact? (or/c positive? zero?)))

(provide (contract-out

[deposit (-> amount/c any)]

[balance (-> amount/c)]))

其它值也作为合约提供双重任务。例如，如果一个函数接受一个数值或#f，(or/cnumber? #f)就够了。同样，amount/c合约也许已经用一个0代替zero?来编写。如果你使用一个正则表达式作为一个合约，该合约接受与正则表达式匹配的字符串和字节字符串。

当然，你可以用连接符像and/c混合你自己的合约执行函数。这里有一个用于创建来自于银行记录的字符串的模块：

#lang racket

(define (has-decimal? str)

(define L (string-length str))

(and (>= L 3)

(char=? #\. (string-ref str (- L 3)))))

(provide (contract-out

; 转换一个随机数为一个字符串

[format-number (-> number? string?)]

; 用一个十进制点转换一个金额为一个字符串，

; 就像在美国货币的一个金额那样。

[format-nat (-> natural-number/c

(and/c string? has-decimal?))]))

输出函数format-number的合约指定该函数接受一个数值并生成一个字符串。这个输出函数format-nat的合约比format-number的其中之一更有趣。它只接受自然数。它的值域合约承诺在右边的第三个位置带有一个.的字符串。

如果我们希望加强format-nat的值域合约的承诺，以便它只接受带数字和一个点的字符串，我们可以这样编写：

#lang racket

(define (digit-char? x)

(member x '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)))

(define (has-decimal? str)

(define L (string-length str))

(and (>= L 3)

(char=? #\. (string-ref str (- L 3)))))

(define (is-decimal-string? str)

(define L (string-length str))

(and (has-decimal? str)

(andmap digit-char?

(string->list (substring str 0 (- L 3))))

(andmap digit-char?

(string->list (substring str (- L 2) L)))))

....

(provide (contract-out

....

; 转换美分的一个金额（自然数）

; 成为一个基于美元的字符串

[format-nat (-> natural-number/c

(and/c string?

is-decimal-string?))]))

另外，在这种情况下，我们可以使用一个正则表达式作为一个合约：

#lang racket

(provide

(contract-out

....

; 转换美分的一个数量（自然数）

; 成为一个基于美元的字符串

[format-nat (-> natural-number/c

(and/c string? #rx"[0-9]*\\.[0-9][0-9]"))]))

7.2.5 高阶函数的合约

函数合约不仅仅局限于在其定义域或值域上的简单判断。还包括它们自己的函数合约，能够被用作参数及一个函数结果。

例如：

(-> integer? (-> integer? integer?))

是描述一个柯里函数的一个合约。它匹配接受一个参数的函数并接着在返回另一个接受一个前面的第二个参数，最后返回一个整数。如果一个服务器用这个合约输出一个函数make-adder，并且如果make-adder返回一个函数外还返回一个值，那么这个服务器应被归咎。如果make-adder确实返回一个函数，但这个返回函数被应用于一个整数外还有一个值，则客户端应被归咎。

同样，合约

(-> (-> integer? integer?) integer?)

描述接受其它函数作为其输入的函数。如果一个服务器用这个合约输出一个函数twice并且twice被应用给一个带一个参数的函数外还给一个值，那么客户端应被归咎。如果twice被应用给一个带一个参数的函数并且twice对一个整数调用这个给定的函数外还对一个值，那么服务器应被归咎。

7.2.6 带”???“的合约信息

你编写了你的模块。你添加了合约。你将它们放入接口以便客户端程序员拥有来自接口的所有信息。这是一门艺术：

> (module bank-server racket     (provide      (contract-out       [deposit (-> (λ (x)                      (and (number? x) (integer? x) (>= x 0)))                    any)]))        (define total 0)     (define (deposit a) (set! total (+ a total))))

几个客户端使用了你的模块。其他人转而使用了他们的模块。突然他们中的一个看到了这个错误消息：

> (require 'bank-server)

> (deposit -10)

deposit: contract violation

expected: ???

given: -10

in: the 1st argument of

(-> ??? any)

contract from: bank-server

blaming: top-level

(assuming the contract is correct)

at: eval:2.0

???在那里代表什么？如果我们有这样一个数据类型的名字，就像我们有字符串、数字等等，那不是很好吗？

针对这种情况，Racket提供了扁平命名合约（flat named contract）。在这一术语中使用“合约”表明合约是第一类值。这个“扁平（flat）”意味着数据的集合是内建的数据原子类的一个子集；它们由一个接受所有Racket值并产生一个布尔值的判断来描述。这个“命名（named）”部分表示我们想要做的事情，它将去命名这个合约以便错误消息变得明白易懂：

> (module improved-bank-server racket     (provide      (contract-out       [deposit (-> (flat-named-contract                     'amount                     (λ (x)                       (and (number? x) (integer? x) (>= x 0))))                    any)]))        (define total 0)     (define (deposit a) (set! total (+ a total))))

用这个小小的更改，这个错误消息就变得相当易读：

> (require 'improved-bank-server)

> (deposit -10)

deposit: contract violation

expected: amount

given: -10

in: the 1st argument of

(-> amount any)

contract from: improved-bank-server

blaming: top-level

(assuming the contract is correct)

at: eval:5.0

7.2.7 解析一个合约错误信息

一般来说，每个合约错误信息由六部分组成：

• 一个用合约关联的函数或方法的名称。而且这个短语“合约违反”或“违反合约”取决于是否这个合约被客户端或服务器违反；例如在前面的示例中：

  deposit: contract violation

  ；

   

• 一个被违反的合约的准确方面的描述，

  expected: amount

  given: -10

  ；

   

• 这个完整的合约加上一个路径显示哪个方面被违反，

  in: the 1st argument of

  (-> amount any)

  ；

   

• 合约被放置的这个模块（或者更广泛地说，合同所规定的边界），

  contract from: improved-bank-server

  ；

   

• 哪个应被归咎，

  blaming: top-level

  (assuming the contract is correct)

  ；

   

• 以及这个合约出现的源程序位置。

  at: eval:5.0

  。

7.3 一般功能合约

->合约构造器为带有一个固定数量参数的函数工作，并且这里这个结果合约不依赖于这个输入参数。为了支持其它类型的函数，Racket提供额外的合约构造器，尤其是 ->*和->i。

7.3.1 可选参数

请看一个字符串处理模块的摘录，该灵感来自于《Scheme cookbook》：

#lang racket

(provide

(contract-out

; 用（可选的）char填充给定的左右两个str以使其左右居中

;

[string-pad-center (->* (string? natural-number/c)

(char?)

string?)]))

(define (string-pad-center str width [pad #\space])

(define field-width (min width (string-length str)))

(define rmargin (ceiling (/ (- width field-width) 2)))

(define lmargin (floor (/ (- width field-width) 2)))

(string-append (build-string lmargin (λ (x) pad))

str

(build-string rmargin (λ (x) pad))))

这个模块输出string-pad-center，一个函数，它在中心用给定字符串创建一个给定的width的一个字符串。这个默认的填充字符是#\space；如果这个客户端模块希望使用一个不同的字符，它可以用第三个参数——一个重写默认值的char——调用string-pad-center。

这个函数定义使用可选参数，它对于这种功能是合适的。这里有趣的一点是string-pad-center的合约的表达方式。

合约组合器->*，要求几组合约：

• 第一个是对所有必需参数的合约的一个括号组。在这个例子中，我们看到两个：string?和natural-number/c。

• 第二个是对所有可选参数的合约的一个括号组：char?。

• 最后一个是一个单一的合约：函数的结果。

请注意，如果默认值不满足合约，则不会获得此接口的合约错误。如果不能信任你自己去正确获得初始值，则需要在边界上传递初始值。

7.3.2 剩余参数

max操作符至少接受一个实数，但它接受任意数量的附加参数。你可以使用一个剩余参数（rest argument）编写其它此类函数，例如在max-abs中：

参见《申明一个剩余（rest）参数》以获取剩余参数的介绍。

(define (max-abs n . rst)

(foldr (lambda (n m) (max (abs n) m)) (abs n) rst))

通过一个合约描述这个函数需要一个对->*进一步的扩展：一个#:rest关键字在必需参数和可选参数之后指定在一个参数列表上的一个合约：

(provide

(contract-out

[max-abs (->* (real?) () #:rest (listof real?) real?)]))

正如对->*的通常情况，必需参数合约被封闭在第一对括号中，在这种情况下是一个单一的实数。空括号表示没有可选参数（不包含剩余参数）。剩余参数合约跟着#:rest；因为所有的额外的参数必须是实数，剩余参数的列表必须满足合约(listof real?)。

7.3.3 关键字参数

其实->合约构造器也包含对关键字参数的支持。例如，考虑这个函数，它创建一个简单的GUI并向用户询问一个yes-or-no的问题：

参见《声明关键字（keyword）参数》以获取关键字参数的介绍。

#lang racket/gui

(define (ask-yes-or-no-question question

#:default answer

#:title title

#:width w

#:height h)

(define d (new dialog% [label title] [width w] [height h]))

(define msg (new message% [label question] [parent d]))

(define (yes) (set! answer #t) (send d show #f))

(define (no) (set! answer #f) (send d show #f))

(define yes-b (new button%

[label "Yes"] [parent d]

[callback (λ (x y) (yes))]

[style (if answer '(border) '())]))

(define no-b (new button%

[label "No"] [parent d]

[callback (λ (x y) (no))]

[style (if answer '() '(border))]))

(send d show #t)

answer)

(provide (contract-out

[ask-yes-or-no-question

(-> string?

#:default boolean?

#:title string?

#:width exact-integer?

#:height exact-integer?

boolean?)]))

如果你真的想通过一个GUI问一个yes或no的问题，你应该使用message-box/custom。对此事而论，通常会比用较“yes”或“no”更确切的回答来提供按钮更好。

ask-yes-or-no-question的合约使用->，同样的方式lambda（或基于define的函数）允许一个关键字先于一个函数正式的参数，->允许一个关键字先于一个函数合约的参数合约。在这种情况下，这个合约表明ask-yes-or-no-question必须接收四个关键字参数，每一个关键字为：#:default、#:title、#:width和#:height。如同在一个函数定义中，在->中关键字的顺序相对于其它的每个来说对函数的客户端无关紧要；只有参数合约的相对顺序没有关键字问题。

7.3.4 可选关键字参数

当然，ask-yes-or-no-question（从上一个问题中引来）中有许多参数有合理的默认值并且应该被设为可选的：

(define (ask-yes-or-no-question question

#:default answer

#:title [title "Yes or No?"]

#:width [w 400]

#:height [h 200])

...)

要指定这个函数的合约，我们需要再次使用->*。它支持关键字，正如你在可选参数和强制参数部分中所期望的一样。在这种情况下，我们有强制关键字#:default和可选关键字#:title、#:width和#:height。所以，我们像这样编写合约：

(provide (contract-out

[ask-yes-or-no-question

(->* (string?

#:default boolean?)

(#:title string?

#:width exact-integer?

#:height exact-integer?)

boolean?)]))

也就是说，我们把强制关键字方在第一部分中，同时我们把可选关键字放在在第二部分中。

7.3.5 case-lambda的合约

用case-lambda定义的一个函数可以对其参数施加不同的约束取决于多少参数被提供。例如，report-cost函数可以既可以转换一对数值也可以转换一个字符串为一个新字符串：

参见《实参数量感知函数：case-lambda》以获得case-lambda的介绍。

(define report-cost   (case-lambda     [(lo hi) (format "between $~a and $~a" lo hi)]     [(desc) (format "~a of dollars" desc)]))

> (report-cost 5 8) "between $5 and $8" > (report-cost "millions") "millions of dollars"

对这样的一个函数的合约用case->组合器构成，它根据需要组合多个功能合约：

(provide (contract-out

[report-cost

(case->

(integer? integer? . -> . string?)

(string? . -> . string?))]))

如你所见，report-cost的合约组合了两个函数合约，它与其功能所需的解释一样多的从句。

7.3.6 参数和结果依赖

以下是来自一个虚构的数值模块的一个摘录：

(provide

(contract-out

[real-sqrt (->i ([argument (>=/c 1)])

[result (argument) (<=/c argument)])]))

这个词“indy”意味着暗示归咎会被分配到合约本身，因为这个合约必须被认为是一个独立的组件。响应两个现有标签选择名称——“lax”和“picky”——为在研究文献中的函数合约的不同语义。

这个输出函数real-sqrt的合约使用->i比使用->*更好。这个“i”代表是一个印地依赖（indy dependent）合约，意味函数值域的合约依赖于该参数的值。在result的合约这一行里argument的出现意味着那个结果依赖于这个参数。在特别情况下，real-sqrt的参数大于或等于1，所以一个很基本的正确性检查是结果小于参数。

一般来说，一个依赖函数合约看起来更像一般的->*合约，但是在合约的其它地方可以使用名字。

回到银行帐户示例，假设我们一般化这个模块以支持多个帐户并且我们也包括一个取款操作。 改进后的银行帐户模块包括一个account结构类型和以下函数：

(provide (contract-out

[balance (-> account? amount/c)]

[withdraw (-> account? amount/c account?)]

[deposit (-> account? amount/c account?)]))

但是，除了要求一个客户端为一个取款提供一个有效金额外，金额应小于或等于指定账户的余额，并且结果账户会比它开始时的钱少。同样，该模块可能承诺一个存款通过为账户增加钱来产生一个帐户。以下实现通过合约强制执行这些约束和保证：

#lang racket

; 第1部分：合约定义

(struct account (balance))

(define amount/c natural-number/c)

; 第2部分：输出

(provide

(contract-out

[create   (amount/c . -> . account?)]

[balance  (account? . -> . amount/c)]

[withdraw (->i ([acc account?]

[amt (acc) (and/c amount/c (<=/c (balance acc)))])

[result (acc amt)

(and/c account?

(lambda (res)

(>= (balance res)

(- (balance acc) amt))))])]

[deposit  (->i ([acc account?]

[amt amount/c])

[result (acc amt)

(and/c account?

(lambda (res)

(>= (balance res)

(+ (balance acc) amt))))])]))

; 第3部分：函数定义

(define balance account-balance)

(define (create amt) (account amt))

(define (withdraw a amt)

(account (- (account-balance a) amt)))

(define (deposit a amt)

(account (+ (account-balance a) amt)))

在第2部分中这个合约为create和balance提供了典型的类型保证。然而，对于withdraw和deposit，该合约检查并保证对balance和deposit的更为复杂的约束。在对withdraw的合约上的第二个参数使用(balance acc)来检查所提供的取款金额是否足够小，其中acc是在->i之中给定的函数第一个参数的名称。在withdraw结果上的合约使用acc和amt来保证不超过所要求的金额被提取。在deposit上的合约同样在结果合约中使用acc和amount来保证至少和提供的一样多的钱被存入账户。

正如上面所编写的，当一个合约检查失败时，该错误消息不是很显著。下面的修订在一个助手函数mk-account-contract中使用flat-named-contract以提供更好的错误消息。

#lang racket

; 第1部分：合约定义

(struct account (balance))

(define amount/c natural-number/c)

(define msg> "account a with balance larger than ~a expected")

(define msg< "account a with balance less than ~a expected")

(define (mk-account-contract acc amt op msg)

(define balance0 (balance acc))

(define (ctr a)

(and (account? a) (op balance0 (balance a))))

(flat-named-contract (format msg balance0) ctr))

; 第2部分：导出

(provide

(contract-out

[create   (amount/c . -> . account?)]

[balance  (account? . -> . amount/c)]

[withdraw (->i ([acc account?]

[amt (acc) (and/c amount/c (<=/c (balance acc)))])

[result (acc amt) (mk-account-contract acc amt >= msg>)])]

[deposit  (->i ([acc account?]

[amt amount/c])

[result (acc amt)

(mk-account-contract acc amt <= msg<)])]))

; 第3部分：函数定义

(define balance account-balance)

(define (create amt) (account amt))

(define (withdraw a amt)

(account (- (account-balance a) amt)))

(define (deposit a amt)

(account (+ (account-balance a) amt)))

7.3.7 检查状态变化

->i合约组合器也可以确保一个函数仅按照一定的约束修改状态。例如，考虑这个合约（它是来自框架中的函数preferences:add-panel的一个略微简化的版本）：

(->i ([parent (is-a?/c area-container-window<%>)])

[_ (parent)

(let ([old-children (send parent get-children)])

(λ (child)

(andmap eq?

(append old-children (list child))

(send parent get-children))))])

它表示该函数接受一个被命名为parent的单一参数，并且parent必须是一个匹配这个接口area-container-window<%>的对象。

这个值域合约确保该函数通过添加一个新的child到列表的前面来仅仅修改parent的children。它通过使用_代替一个正常的标识符来完成这个，它告诉这个合约库该值域合约并不依赖于任何结果的值，因此当这个函数被调用时，而不是返回时，该合约库求值这个跟着_的表达式。因此对get-children方法的调用发生在合约被调用下的函数之前。当合约下的函数返回时，它的结果作为child被传递进去，并且合约确保该函数返回后的child与该函数调用之前的child相同，但是有许许多多的child，在列表前面。

要去明白在一个集中在这点上的玩具例子中的不同，考虑这个程序：

#lang racket

(define x '())

(define (get-x) x)

(define (f) (set! x (cons 'f x)))

(provide

(contract-out

[f (->i () [_ (begin (set! x (cons 'ctc x)) any/c)])]

[get-x (-> (listof symbol?))]))

如果你将需要这个模块，调用f，那么get-x的结果会是'(f ctc)。相反，如果f的合约是

(->i () [res (begin (set! x (cons 'ctc x)) any/c)])

（只改变res的下划线），那么get-x的结果会是'(ctc f)。

7.3.8 多个结果值

函数split接受char的一个列表并且传递在#\newline（如果有）的第一次出现之前的字符串以及这个列表的剩余部分：

(define (split l)

(define (split l w)

(cond

[(null? l) (values (list->string (reverse w)) '())]

[(char=? #\newline (car l))

(values (list->string (reverse w)) (cdr l))]

[else (split (cdr l) (cons (car l) w))]))

(split l '()))

它是一个典型的多值函数，通过遍历一个单个列表返回两个值。

这样一个函数的合约可以使用普通函数箭头->，此后当它作为最后结果出现时，->特别地处理values：

(provide (contract-out

[split (-> (listof char?)

(values string? (listof char?)))]))

这样一个函数的合约也可以使用->*编写：

(provide (contract-out

[split (->* ((listof char?))

()

(values string? (listof char?)))]))

和前面一样，带->*的参数的合约被包裹在一对额外的圆括号中对（并且必须总是这样被包裹）中，并且这个空括号对表示这里没有可选参数。这个结果的合约是在values内部：一个字符串和字符的一个列表。

现在，假设我们还希望确保split的第一个结果是在列表格式中的这个给定单词的一个前缀。在这种情况下，我们需要使用这个->i合约组合器：

(define (substring-of? s)

(flat-named-contract

(format "substring of ~s" s)

(lambda (s2)

(and (string? s2)

(<= (string-length s2) (string-length s))

(equal? (substring s 0 (string-length s2)) s2)))))

(provide

(contract-out

[split (->i ([fl (listof char?)])

(values [s (fl) (substring-of? (list->string fl))]

[c (listof char?)]))]))

像->*、->i组合使用函数中的参数来创建范围的合约。是的，它不只是返回一个合约，而是函数产生值的数量：每个值的一个合约。在这种情况下，第二个合约和以前一样，确保第二个结果是char列表。与此相反，第一个合约增强旧的，因此结果是给定单词的前缀。

当然，这个合约对于检查来说是值得的。这里有一个稍微廉价的版本：

(provide

(contract-out

[split (->i ([fl (listof char?)])

(values [s (fl) (string-len/c (length fl))]

[c (listof char?)]))]))

7.3.9 固定但静态未知数量

想象一下你自己为一个函数编写了一个合约，这个函数接受其它一些函数并且一个最终前者应用于后者的数值的列表。除非这个给定的函数的数量匹配给定列表的长度，否则你的过程就会陷入困难。

考虑这个n-step函数：

; (number ... -> (union #f number?)) (listof number) -> void

(define (n-step proc inits)

(let ([inc (apply proc inits)])

(when inc

(n-step proc (map (λ (x) (+ x inc)) inits)))))

n-step的参数是proc，一个函数proc的结果要么是数值要么是假(false)，以及一个列表。它接着应用proc到这个列表inits中。只要proc返回一个数值，n-step把那个数值处理为一个在inits和递归里的每个数值的增量值。当proc返回false时，这个循环停止。

这里有两个应用：

; nat -> nat

(define (f x)

(printf "~s\n" x)

(if (= x 0) #f -1))

(n-step f '(2))

; nat nat -> nat

(define (g x y)

(define z (+ x y))

(printf "~s\n" (list x y z))

(if (= z 0) #f -1))

(n-step g '(1 1))

一个n-step的合约必须指定proc的行为的两方面：其数量必须在inits里包括元素的数量，同时它必须返回一个数值或#f。后者是容易的，前者是困难的。乍一看，这似乎暗示一个合约分配了一个可变数量（variable-arity）给了proc：

(->* ()

#:rest (listof any/c)

(or/c number? false/c))

然而，这个合约表明这个函数必须接受任意（any）数量的参数，而不是一个特定（specific）的但不确定（undetermined）的数值。因此，应用n-step到(lambda (x) x)和(list 1)违反合约，因为这个给定的函数只接受一个参数。

正确的合约使用unconstrained-domain->组合器，它仅指定一个函数的值域，而不是它的定义域。它接下来可能连接这个合约到一个数量测试以指定n-step的正确合约：

(provide

(contract-out

[n-step

(->i ([proc (inits)

(and/c (unconstrained-domain->

(or/c false/c number?))

(λ (f) (procedure-arity-includes?

f

(length inits))))]

[inits (listof number?)])

()

any)]))

7.4 合约：一个完整的例子

 

本节开发对于同一个例子的合约的几种不同特点：Racket的argmax函数。根据它的Racket文档，这个函数接受一个过程proc和一个非空的值列表，lst。它

返回在最大化proc的结果的列表lst中的first元素。对first的强调是我们的。

 

 

例子：

> (argmax add1 (list 1 2 3))

3

> (argmax sqrt (list 0.4 0.9 0.16))

0.9

> (argmax second '((a 2) (b 3) (c 4) (d 1) (e 4)))

'(c 4)

 

这里是这个函数的可能最简单的合约：

version 1

#lang racket

(define (argmax f lov) ...)

(provide

(contract-out

[argmax (-> (-> any/c real?) (and/c pair? list?) any/c)]))

这个合约捕捉argmax的非正式描述的两个必备条件：

• 这个给定的函数必须产生按<进行比较的数值。特别是，这个合约(-> any/c number?)不可行，因为number?也承认Racket中的复数有效。

• 给定列表必须至少包含一项。

当组合名称时，合约解释在同级的argmax的行为作为在一个模块签名（除空表方面外）中的一个ML（机器语言）函数类型。

然而，合约可能比一个类型签名更值得关注。看一看argmax的第二个合约：

version 2

#lang racket

(define (argmax f lov) ...)

(provide

(contract-out

[argmax

(->i ([f (-> any/c real?)] [lov (and/c pair? list?)]) ()

(r (f lov)

(lambda (r)

(define f@r (f r))

(for/and ([v lov]) (>= f@r (f v))))))]))

它是一个依赖合约，它命名两个参数并使用这个名称在结果上添加一个判断。这个判断计算 (f r)——这里r是argmax的结果——并接着验证这个值大于或等于在lov的项目上的所有f值。

这是可能的吗？——argmax会通过返回一个随机值作弊，这个随机值意外地最大化f超过lov的所有元素。用一个合约，就有可能排除这种可能性：

version 2 rev. a

#lang racket

(define (argmax f lov) ...)

(provide

(contract-out

[argmax

(->i ([f (-> any/c real?)] [lov (and/c pair? list?)]) ()

(r (f lov)

(lambda (r)

(define f@r (f r))

(and (memq r lov)

(for/and ([v lov]) (>= f@r (f v)))))))]))

memq函数确保r是相等（intensionally equal）也就是说，那些喜欢在硬件层面思考的人的“指针相等（pointer equality）”。于lov的其中一个成员。当然，片刻的反思显露出要构成这样一个值是不可能的。函数是Racket中的不透明值，并且没有应用一个函数，无法确定某个随机输入值是否产生一个输出值或触发某些异常。因此我们从这里开始忽略这种可能性。

版本2确切地阐述了argmax文档的整体观点，但它没能传达出这个结果是这个给定的最大化给定的函数f的列表的第一个元素。这是一个传达这个非正式文档的第二个方面的版本：

version 3

#lang racket

(define (argmax f lov) ...)

(provide

(contract-out

[argmax

(->i ([f (-> any/c real?)] [lov (and/c pair? list?)]) ()

(r (f lov)

(lambda (r)

(define f@r (f r))

(and (for/and ([v lov]) (>= f@r (f v)))

(eq? (first (memf (lambda (v) (= (f v) f@r)) lov))

r)))))]))

那就是，memf函数确定lov的第一个元素，f下的lov的值等于f下的r的值。如果此元素是有意等于r，argmax的结果就是正确的。

第二个细化步骤介绍了两个问题。首先，条件都重新计算lov的所有元素的f的值。第二，这个合约现在很难阅读。合约应该有一个简洁的表达方式，它可以让一个客户端可以用一个简单的扫描进行理解。让我们用具有合理意义的名称的两个辅助函来数消除可读性问题：

version 3 rev. a

#lang racket

(define (argmax f lov) ...)

(provide

(contract-out

[argmax

(->i ([f (-> any/c real?)] [lov (and/c pair? list?)]) ()

(r (f lov)

(lambda (r)

(define f@r (f r))

(and (is-first-max? r f@r f lov)

(dominates-all f@r f lov)))))]))

; 这里

;  f@r大于或等于在lov中v的所有(f v)

(define (dominates-all f@r f lov)

(for/and ([v lov]) (>= f@r (f v))))

;  r是eq?于lov的第一个元素v，因为它的(pred? v)

(define (is-first-max? r f@r f lov)

(eq? (first (memf (lambda (v) (= (f v) f@r)) lov)) r))

原则上，这两个判断的名称表示它们的功能和表达不需要读取它们的定义。

这一步给我们带来了新引进的低效率问题。为了避免因lov上的所有 v引起的(f v)的重复计算，我们改变合约以致其计算这些值和重用它们是必要的：

version 3 rev. b

#lang racket

(define (argmax f lov) ...)

(provide

(contract-out

[argmax

(->i ([f (-> any/c real?)] [lov (and/c pair? list?)]) ()

(r (f lov)

(lambda (r)

(define f@r (f r))

(define flov (map f lov))

(and (is-first-max? r f@r (map list lov flov))

(dominates-all f@r flov)))))]))

; 这里

;  f@r大于或等于flov中所有的f@v

(define (dominates-all f@r flov)

(for/and ([f@v flov]) (>= f@r f@v)))

;  r是lov+flov里第一个x的(first x)，整理为(= (second x) f@r)

(define (is-first-max? r f@r lov+flov)

(define fst (first lov+flov))

(if (= (second fst) f@r)

(eq? (first fst) r)

(is-first-max? r f@r (rest lov+flov))))

现在对结果的判断为lov的元素再次计算了f的所有值一次。

单词“eager（热切，急切）”来自于合约语言学文献。

当版本3去调用f时也许还太急切。然而无论lov包含有多少成员，Racket的argmax总是调用f，让我们想象一下，为了说明目的，我们自己的实现首先检查列表是否是单体。如果是这样，第一个元素将是lov的唯一元素，在这种情况下就不需要计算(f r)。Racket的argmax隐含论证它不仅承诺第一个值，它最大化f超过lov但同样f产生一个结果的值。 事实上，由于f可能发散或增加一些例外输入，argmax应该尽可能避免调用f。

下面的合约演示了如何调整高阶依赖合约，以避免过度依赖：

version 4

#lang racket

(define (argmax f lov)

(if (empty? (rest lov))

(first lov)

...))

(provide

(contract-out

[argmax

(->i ([f (-> any/c real?)] [lov (and/c pair? list?)]) ()

(r (f lov)

(lambda (r)

(cond

[(empty? (rest lov)) (eq? (first lov) r)]

[else

(define f@r (f r))

(define flov (map f lov))

(and (is-first-max? r f@r (map list lov flov))

(dominates-all f@r flov))]))))]))

; where

;  f@r大于或等于flov中所有的f@v

(define (dominates-all f@r lov) ...)

;  r是lov+flov里第一个x的(first x)，整理为(= (second x) f@r)

(define (is-first-max? r f@r lov+flov) ...)

注意，这种考虑不适用于一阶合同的世界。只有一个高阶（或惰性）语言迫使程序员去以如此精确度去表达合约。

发散或异常提升函数的问题应该让读者对带副作用的函数的一般性问题保持警惕。如果这个给定的函数f有明显的影响——表明它把它的调用记录到了一个文件——那么argmax的客户端将能够观察每次调用argmax的两套日志。确切地讲，如果值列表包含多个元素，这个日志将包含lov上的每一个值的两个f调用。如果f对于计算来说太昂贵，则加倍调用承受一个高成本。

用过度热切的合约来避免这种成本以及来标志问题，一个合约系统可以记录已约定的函数参数的i/o并使用这些散列表的相关规范。这是PLT研究中的一个课题。敬请关注。

7.5 结构上的合约

模块以两种方式处理结构。首先它们输出struct的定义，即某种创造结构的资格、存取它们的字段的资格、修改它们的资格以及区别这种结构于世界上所有其它值的资格。其次，有时一个模块输出一个特定的结构并希望它的字段包含某种值。本节讲解如何使用合约保护结构的两种使用。

7.5.1 确保一个特定值

如果你的模块定义了一个变量做为一个结构，那么你可以使用struct/c指定结构的形态：

#lang racket

(require lang/posn)

(define origin (make-posn 0 0))

(provide (contract-out

[origin (struct/c posn zero? zero?)]))

在这个例子中，该模块输入一个代表位置的库，它输出一个posn结构。posn中的一个创建并输出所代表的网格原点，即(0,0)。

又见vector/c及类似的对（扁平）复合数据的合约组合器。

7.5.2 确保所有值

《How to Design Programs》这本书教授了posn应该只包含在它们两个字段里的数值。用合约我们可以执行以下这种非正式数据定义：

#lang racket

(struct posn (x y))

(provide (contract-out

[struct posn ((x number?) (y number?))]

[p-okay posn?]

[p-sick posn?]))

(define p-okay (posn 10 20))

(define p-sick (posn 'a 'b))

这个模块输出整个结构定义：posn、posn?、posn-x、posn-y、set-posn-x!和set-posn-y!。每个函数执行或承诺一个posn结构的这两个字段是数值——当这些值穿过模块边界传递时。因此，如果一个客户端在10和'a上调用posn，这个合约系统就发出一个合约违反信号。

然而，posn模块内的p-sick的创建，并没有违反该合约。这个函数posn在内部使用，所以'a和'b不穿过模块边界。同样，当p-sick穿过posn的边界时，该合约承诺一个posn?并且别的什么也没有。特别是，这个检查并没有需要p-sick的字段是数值。

用模块边界的合约检查的联系意味着p-okay和p-sick从一个客户端的角度看起来相似，直到客户端选取了以下片断：

#lang racket

(require lang/posn)

... (posn-x p-sick) ...

使用posn-x是这个客户端能够找到一个posn在x字段里包含的内容的唯一途径。posn-x的应用程序发送回p-sick进入posn模块以及发送回这个结果值——这里的'a——给客户端，再跨越模块边界。在这一点上，这个合约系统发现一个承诺被违反了。具体来说，posn-x没有返回一个数值但却返回了一个符号，因此应该被归咎。

这个具体的例子表明，对一个违反合约的解释并不总是指明错误的来源。好消息是，这个错误被定位在posn模块内。坏消息是，这种解释是误导性的。虽然posn-x产生了一个符号而不是一个数值是真的，它是从符号创建了posn的这个程序员的责任，亦即这个程序员添加了

(define p-sick (posn 'a 'b))

到这个模块中。所以，当你在寻找基于违反合约的bug时，把这个例子记在心里。

如果我们想修复p-sick的合约以便在sick被输出时这个错误被捕获，一个单一的改变就足够了：

(provide

(contract-out

...

[p-sick (struct/c posn number? number?)]))

更确切地说，代替作为一个直白的posn?的输出p-sick，我们使用一个struct/c合约来执行对其组件的约束。

7.5.3 检查数据结构的特性

用struct/c编写的合约立即检查数据结构的字段，但是有时这能够对一个程序的性能具有灾难性的影响，这个程序本身并不检查整个数据结构。

作为一个例子，考虑二叉搜索树搜索算法。一个二叉搜索树就像一个二叉树，除了这些数值被组织在树中以便快速搜索这个树。特别是，对于树中的每个内部节点，左边子树中的所有数值都小于节点中的数值，同时右子树中的所有数值都大于节点中的数值。

我们可以实现一个搜索函数in?，它利用二叉搜索树结构的优势。

#lang racket

(struct node (val left right))

; 利用二叉搜索树不变量，

; 确定二叉搜索树“b”中是否存在“n”。

(define (in? n b)

(cond

[(null? b) #f]

[else (cond

[(= n (node-val b))

#t]

[(< n (node-val b))

(in? n (node-left b))]

[(> n (node-val b))

(in? n (node-right b))])]))

; 一个识别二叉搜索树的判断。

(define (bst-between? b low high)

(or (null? b)

(and (<= low (node-val b) high)

(bst-between? (node-left b) low (node-val b))

(bst-between? (node-right b) (node-val b) high))))

(define (bst? b) (bst-between? b -inf.0 +inf.0))

(provide (struct-out node))

(provide (contract-out

[bst? (any/c . -> . boolean?)]

[in? (number? bst? . -> . boolean?)]))

在一个完整的二叉搜索树中，这意味着in?函数只需探索一个对数节点。

对in?的合约保证其输入是一个二叉搜索树。但仔细的思考表明，该合约违背了二叉搜索树算法的目的。特别是，考虑到in?函数里内部的cond。这是in?函数获取其速度的地方：它避免在每次递归调用时搜索整个子树。现在把它与bst-between?函数比较。在这种情况下它返回#t，它遍历整个树，意味in?的加速没有实现。

为了解决这个问题，我们可以利用一种新的策略来检查这个二叉搜索树合约。特别是，如果我们只检查了in?看着的节点上的合约，我们仍然可以保证这个树至少部分形成良好，但是没有改变复杂性。

要做到这一点，我们需要使用struct/dc来定义bst-between?。像struct/c一样，struct/dc为一个结构定义一个合约。与struct/c不同，它允许字段被标记为惰性，这样当匹配选择器被调用时，这些合约才被检查。同样，它不允许将可变字段被标记为惰性。

struct/dc表接受这个结构的每个字段的一个合约并返回结构上的一个合约。更有趣的是，struct/dc允许我们编写依赖合约，也就是说，合约中的某些合约取决于其它字段。我们可以用这个去定义二叉搜索树合约：

#lang racket

(struct node (val left right))

; 确定“n”是否在二进制搜索树“b”中

(define (in? n b) ... as before ...)

; bst-between : number number -> contract

; 构建了一个二叉搜索树合约

; whose values are between low and high

(define (bst-between/c low high)

(or/c null?

(struct/dc node [val (between/c low high)]

[left (val) #:lazy (bst-between/c low val)]

[right (val) #:lazy (bst-between/c val high)])))

(define bst/c (bst-between/c -inf.0 +inf.0))

(provide (struct-out node))

(provide (contract-out

[bst/c contract?]

[in? (number? bst/c . -> . boolean?)]))

一般来说，struct/dc的每个使用都必须命名字段并且接着为每个字段指定合约。在上面，val字段是一个接受low与high之间的值的合约。left和right字段依赖于val的值，被它们的第二个子表达式所表示。他们也用#:lazy关键字标记以表明它们只有当合适的存取器被结构实例被调用时应该被检查。它们的合约是通过递归调用bst-between/c函数来构建的。综合起来，这个合约确保了在原始示例中被检查的bst-between?函数的同样的事情，但这里这个检查只发生在in?探索这个树时。

虽然这个合约提高了in?的性能，把它恢复到无合约版本的对数行为上，但它仍然施加相当大的恒定开销。因此，这个合约库也提供define-opt/c，它通过优化其主体来降低常数因子。它的形态和上面的define一样。它希望它的主体是一个合约并且接着优化该合约。

(define-opt/c (bst-between/c low high)

(or/c null?

(struct/dc node [val (between/c low high)]

[left (val) #:lazy (bst-between/c low val)]

[right (val) #:lazy (bst-between/c val high)])))

7.6 用#:exists和#:∃抽象合约

合约系统提供可以保护抽象化的存在性合约，确保你的模块的客户端不能依赖于为你的数据结构所做的精确表示选择。

如果你不能容易地键入Unicode字符，你可以键入#:exists来代替#:∃；在DrRacket里，键入\exists后跟着alt-\或control-（取决于你的平台）会生成∃。

 

contract-out表允许你编写

#:∃ name-of-a-new-contract

作为其从句之一。这个声明引进这个变量name-of-a-new-contract，将它绑定到一个新的隐藏关于它保护的值的信息的合约。

 

作为一个例子，考虑这（简单的）一列数据结构的实现：

#lang racket

(define empty '())

(define (enq top queue) (append queue (list top)))

(define (next queue) (car queue))

(define (deq queue) (cdr queue))

(define (empty? queue) (null? queue))

(provide

(contract-out

[empty (listof integer?)]

[enq (-> integer? (listof integer?) (listof integer?))]

[next (-> (listof integer?) integer?)]

[deq (-> (listof integer?) (listof integer?))]

[empty? (-> (listof integer?) boolean?)]))

此代码纯粹按照列表实现一个队列，这意味着数据结构的客户端可以对数据结构直接使用car和cdr（也许偶然地），从而在描述里的任何改变（例如，对于一个更有效表示，它支持摊销的固定时间队列和队列操作）可能会破坏客户机代码。

为确保这个队列描述是抽象的，我们可以在contract-out表达式里使用#:∃，就像这样：

(provide

(contract-out

#:∃ queue

[empty queue]

[enq (-> integer? queue queue)]

[next (-> queue integer?)]

[deq (-> queue queue)]

[empty? (-> queue boolean?)]))

现在，如果数据结构的客户端尝试使用car和cdr，它们会收到一个错误，而不是用队列内部的东西来搞砸。

也参见《存在的合约和判断》。

7.7 附加实例

本节说明Racket合约实施的当前状态，用一系列来自于《Design by Contract, by Example》[Mitchell02]的例子。

米切尔（Mitchell）和麦金（McKim）的合约设计准则DbC源于1970年代风格的代数规范。DbC的总体目标是依据它的观察指定一个代数的构造器。当我们换种方式表达米切尔和麦金的术语同时我们用最适合的途径，我们保留他们的术语“类”（classes）和“对象”（objects）：

• 从命令中分离查询。

  一个查询（query）返回一个结果但不会改变一个对象的可观察性。一个命令（command）改变一个对象的可见性但不返回结果。在应用程序实现中一个命令通常返回同一个类的一个新对象。

• 从派生查询中分离基本查询。

  一个派生查询（derived query）返回一个根据基本查询可计算的结果。

• 对于每个派生查询，编写一个根据基本查询指定结果的岗位条件合约。

• 对于每个命令，编写一个根据基本查询指定对可观测性更改的岗位条件合约。

• 对于每个查询和命令，决定一个合适的前置条件合约。

以下各节对应于在米切尔和麦金的书中的一章（但不是所有的章都显示在这里）。我们建议你先阅读合约（在第一模块的末尾附近），然后是实现（在第一个模块中），然后是测试模块（在每一节的结尾）。

米切尔和麦金使用Eiffel语言作为底层编程语言同时采用一个传统的命令式编程风格。我们的长期目标是翻译他们的例子为有应用价值的Racket、面向结构的命令式Racket以及Racket的类系统。

注：模仿米切尔和McKim的参数性非正式概念（参数多态性），我们用一类合约。在几个地方，一类合约的使用改进了米切尔和麦金的设计（参见接口中的注释）。

7.7.1 一个客户管理器组建

为了更好地跟踪漏洞（bug），这第一个模块包含一个独立模块里的一些结构定义。

#lang racket

; data definitions

(define id? symbol?)

(define id-equal? eq?)

(define-struct basic-customer (id name address) #:mutable)

; interface

(provide

(contract-out

[id?                   (-> any/c boolean?)]

[id-equal?             (-> id? id? boolean?)]

[struct basic-customer ((id id?)

(name string?)

(address string?))]))

; end of interface

该模块包含使用上述内容的程序。

#lang racket

(require "1.rkt") ; the module just above

; implementation

; [listof (list basic-customer? secret-info)]

(define all '())

(define (find c)

(define (has-c-as-key p)

(id-equal? (basic-customer-id (car p)) c))

(define x (filter has-c-as-key all))

(if (pair? x) (car x) x))

(define (active? c)

(pair? (find c)))

(define not-active? (compose not active? basic-customer-id))

(define count 0)

(define (get-count) count)

(define (add c)

(set! all (cons (list c 'secret) all))

(set! count (+ count 1)))

(define (name id)

(define bc-with-id (find id))

(basic-customer-name (car bc-with-id)))

(define (set-name id name)

(define bc-with-id (find id))

(set-basic-customer-name! (car bc-with-id) name))

(define c0 0)

; end of implementation

(provide

(contract-out

; how many customers are in the db?

[get-count (-> natural-number/c)]

; is the customer with this id active?

[active?   (-> id? boolean?)]

; what is the name of the customer with this id?

[name      (-> (and/c id? active?) string?)]

; change the name of the customer with this id

[set-name  (->i ([id id?] [nn string?])

[result any/c] ; result contract

#:post (id nn) (string=? (name id) nn))]

[add       (->i ([bc (and/c basic-customer? not-active?)])

; A pre-post condition contract must use

; a side-effect to express this contract

; via post-conditions

#:pre () (set! c0 count)

[result any/c] ; result contract

#:post () (> count c0))]))

测试：

#lang racket

(require rackunit rackunit/text-ui "1.rkt" "1b.rkt")

(add (make-basic-customer 'mf "matthias" "brookstone"))

(add (make-basic-customer 'rf "robby" "beverly hills park"))

(add (make-basic-customer 'fl "matthew" "pepper clouds town"))

(add (make-basic-customer 'sk "shriram" "i city"))

(run-tests

(test-suite

"manager"

(test-equal? "id lookup" "matthias" (name 'mf))

(test-equal? "count" 4 (get-count))

(test-true "active?" (active? 'mf))

(test-false "active? 2" (active? 'kk))

(test-true "set name" (void? (set-name 'mf "matt")))))

7.7.2 一个参数化（简单）栈

#lang racket

; a contract utility

(define (eq/c x) (lambda (y) (eq? x y)))

(define-struct stack (list p? eq))

(define (initialize p? eq) (make-stack '() p? eq))

(define (push s x)

(make-stack (cons x (stack-list s)) (stack-p? s) (stack-eq s)))

(define (item-at s i) (list-ref (reverse (stack-list s)) (- i 1)))

(define (count s) (length  (stack-list s)))

(define (is-empty? s) (null? (stack-list s)))

(define not-empty? (compose not is-empty?))

(define (pop s) (make-stack (cdr (stack-list s))

(stack-p? s)

(stack-eq s)))

(define (top s) (car (stack-list s)))

(provide

(contract-out

; predicate

[stack?     (-> any/c boolean?)]

; primitive queries

; how many items are on the stack?

[count      (-> stack? natural-number/c)]

; which item is at the given position?

[item-at

(->d ([s stack?] [i (and/c positive? (<=/c (count s)))])

()

[result (stack-p? s)])]

; derived queries

; is the stack empty?

[is-empty?

(->d ([s stack?])

()

[result (eq/c (= (count s) 0))])]

; which item is at the top of the stack

[top

(->d ([s (and/c stack? not-empty?)])

()

[t (stack-p? s)] ; a stack item, t is its name

#:post-cond

([stack-eq s] t (item-at s (count s))))]

; creation

[initialize

(->d ([p contract?] [s (p p . -> . boolean?)])

()

; Mitchell and McKim use (= (count s) 0) here to express

; the post-condition in terms of a primitive query

[result (and/c stack? is-empty?)])]

; commands

; add an item to the top of the stack

[push

(->d ([s stack?] [x (stack-p? s)])

()

[sn stack?] ; result kind

#:post-cond

(and (= (+ (count s) 1) (count sn))

([stack-eq s] x (top sn))))]

; remove the item at the top of the stack

[pop

(->d ([s (and/c stack? not-empty?)])

()

[sn stack?] ; result kind

#:post-cond

(= (- (count s) 1) (count sn)))]))

测试：

#lang racket

(require rackunit rackunit/text-ui "2.rkt")

(define s0 (initialize (flat-contract integer?) =))

(define s2 (push (push s0 2) 1))

(run-tests

(test-suite

"stack"

(test-true

"empty"

(is-empty? (initialize (flat-contract integer?) =)))

(test-true "push" (stack? s2))

(test-true

"push exn"

(with-handlers ([exn:fail:contract? (lambda _ #t)])

(push (initialize (flat-contract integer?)) 'a)

#f))

(test-true "pop" (stack? (pop s2)))

(test-equal? "top" (top s2) 1)

(test-equal? "toppop" (top (pop s2)) 2)))

7.7.3 一个字典

#lang racket

; a shorthand for use below

(define-syntax ⇒

(syntax-rules ()

[(⇒ antecedent consequent) (if antecedent consequent #t)]))

; implementation

(define-struct dictionary (l value? eq?))

; the keys should probably be another parameter (exercise)

(define (initialize p eq) (make-dictionary '() p eq))

(define (put d k v)

(make-dictionary (cons (cons k v) (dictionary-l d))

(dictionary-value? d)

(dictionary-eq? d)))

(define (rem d k)

(make-dictionary

(let loop ([l (dictionary-l d)])

(cond

[(null? l) l]

[(eq? (caar l) k) (loop (cdr l))]

[else (cons (car l) (loop (cdr l)))]))

(dictionary-value? d)

(dictionary-eq? d)))

(define (count d) (length (dictionary-l d)))

(define (value-for d k) (cdr (assq k (dictionary-l d))))

(define (has? d k) (pair? (assq k (dictionary-l d))))

(define (not-has? d) (lambda (k) (not (has? d k))))

; end of implementation

; interface

(provide

(contract-out

; predicates

[dictionary? (-> any/c boolean?)]

; basic queries

; how many items are in the dictionary?

[count       (-> dictionary? natural-number/c)]

; does the dictionary define key k?

[has?        (->d ([d dictionary?] [k symbol?])

()

[result boolean?]

#:post-cond

((zero? (count d)) . ⇒ . (not result)))]

; what is the value of key k in this dictionary?

[value-for   (->d ([d dictionary?]

[k (and/c symbol? (lambda (k) (has? d k)))])

()

[result (dictionary-value? d)])]

; initialization

; post condition: for all k in symbol, (has? d k) is false.

[initialize  (->d ([p contract?] [eq (p p . -> . boolean?)])

()

[result (and/c dictionary? (compose zero? count))])]

; commands

; Mitchell and McKim say that put shouldn't consume Void (null ptr)

; for v. We allow the client to specify a contract for all values

; via initialize. We could do the same via a key? parameter

; (exercise). add key k with value v to this dictionary

[put         (->d ([d dictionary?]

[k (and/c symbol? (not-has? d))]

[v (dictionary-value? d)])

()

[result dictionary?]

#:post-cond

(and (has? result k)

(= (count d) (- (count result) 1))

([dictionary-eq? d] (value-for result k) v)))]

; remove key k from this dictionary

[rem         (->d ([d dictionary?]

[k (and/c symbol? (lambda (k) (has? d k)))])

()

[result (and/c dictionary? not-has?)]

#:post-cond

(= (count d) (+ (count result) 1)))]))

; end of interface

测试：

#lang racket

(require rackunit rackunit/text-ui "3.rkt")

(define d0 (initialize (flat-contract integer?) =))

(define d (put (put (put d0 'a 2) 'b 2) 'c 1))

(run-tests

(test-suite

"dictionaries"

(test-equal? "value for" 2 (value-for d 'b))

(test-false "has?" (has? (rem d 'b) 'b))

(test-equal? "count" 3 (count d))

(test-case "contract check for put: symbol?"

(define d0 (initialize (flat-contract integer?) =))

(check-exn exn:fail:contract? (lambda () (put d0 "a" 2))))))

7.7.4 一个队列

#lang racket

; Note: this queue doesn't implement the capacity restriction

; of Mitchell and McKim's queue but this is easy to add.

; a contract utility

(define (all-but-last l) (reverse (cdr (reverse l))))

(define (eq/c x) (lambda (y) (eq? x y)))

; implementation

(define-struct queue (list p? eq))

(define (initialize p? eq) (make-queue '() p? eq))

(define items queue-list)

(define (put q x)

(make-queue (append (queue-list q) (list x))

(queue-p? q)

(queue-eq q)))

(define (count s) (length  (queue-list s)))

(define (is-empty? s) (null? (queue-list s)))

(define not-empty? (compose not is-empty?))

(define (rem s)

(make-queue (cdr (queue-list s))

(queue-p? s)

(queue-eq s)))

(define (head s) (car (queue-list s)))

; interface

(provide

(contract-out

; predicate

[queue?     (-> any/c boolean?)]

; primitive queries

; Imagine providing this 'query' for the interface of the module

; only. Then in Racket there is no reason to have count or is-empty?

; around (other than providing it to clients). After all items is

; exactly as cheap as count.

[items      (->d ([q queue?]) () [result (listof (queue-p? q))])]

; derived queries

[count      (->d ([q queue?])

; We could express this second part of the post

; condition even if count were a module "attribute"

; in the language of Eiffel; indeed it would use the

; exact same syntax (minus the arrow and domain).

()

[result (and/c natural-number/c

(=/c (length (items q))))])]

[is-empty?  (->d ([q queue?])

()

[result (and/c boolean?

(eq/c (null? (items q))))])]

[head       (->d ([q (and/c queue? (compose not is-empty?))])

()

[result (and/c (queue-p? q)

(eq/c (car (items q))))])]

; creation

[initialize (-> contract?

(contract? contract? . -> . boolean?)

(and/c queue? (compose null? items)))]

; commands

[put        (->d ([oldq queue?] [i (queue-p? oldq)])

()

[result

(and/c

queue?

(lambda (q)

(define old-items (items oldq))

(equal? (items q) (append old-items (list i)))))])]

[rem        (->d ([oldq (and/c queue? (compose not is-empty?))])

()

[result

(and/c queue?

(lambda (q)

(equal? (cdr (items oldq)) (items q))))])]))

; end of interface

测试：

#lang racket

(require rackunit rackunit/text-ui "5.rkt")

(define s (put (put (initialize (flat-contract integer?) =) 2) 1))

(run-tests

(test-suite

"queue"

(test-true

"empty"

(is-empty? (initialize (flat-contract integer?) =)))

(test-true "put" (queue? s))

(test-equal? "count" 2 (count s))

(test-true "put exn"

(with-handlers ([exn:fail:contract? (lambda _ #t)])

(put (initialize (flat-contract integer?)) 'a)

#f))

(test-true "remove" (queue? (rem s)))

(test-equal? "head" 2 (head s))))

7.8 建立新合约

合约在内部作为函数来表示，这个函数接受关于合约的信息（归咎于谁、源程序位置等等）并产生执行合约的推断（本着Dana Scott的精神）。

一般意义上，一个推断是接受一个任意值的一个函数，并返回满足相应合约的一个值。例如，只接受整数的一个推断对应于合约(flat-contract integer?)，同时可以这样编写：

(define int-proj

(λ (x)

(if (integer? x)

x

(signal-contract-violation))))

作为第二个例子，接受整数上的一元函数的一个推断看起来像这样：

(define int->int-proj

(λ (f)

(if (and (procedure? f)

(procedure-arity-includes? f 1))

(λ (x) (int-proj (f (int-proj x))))

(signal-contract-violation))))

虽然这些推断具有恰当的错误行为，但它们还不太适合作为合约使用，因为它们不容纳归咎也不提供良好的错误消息。为了适应这些，合约不只使用简单的推断，而是使用接受一个归咎对象（blame object）的函数将被归咎双方的名字封装起来，以及合约建立的源代码位置和合约名称的记录。然后，它们可以依次传递这些信息给raise-blame-error来发出一个良好的错误信息。

这里是这两个推断中的第一个，被重写以在合约系统中使用：

(define (int-proj blame)

(λ (x)

(if (integer? x)

x

(raise-blame-error

blame

x

'(expected: "" given: "~e")

x))))

新的论据指明了谁将因为正数和负数的合约违约被归咎。

在这个系统中，合约总是建立在双方之间。一方称为服务器，根据这个合约提供一些值；另一方称为客户端，也根据这个合约接受这些值。服务器称为主动位置，客户端称为被动位置。因此，对于仅在整数合约的情况下，唯一可能出错的是所提供的值不是一个整数。因此，永远只有主动的一方（服务器）才能获得归咎。raise-blame-error函数总是归咎主动的一方。

与我们的函数合约的推断的比较：

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

在这种情况下，唯一明确的归咎涵盖了一个提供给合约的非过程或一个这个不接受一个参数的过程的情况。与整数推断一样，这里的归咎也在于这个值的生成器，这就是为什么raise-blame-error传递没有改变的blame。

对于定义域和值域的检查被委托给了int-proj函数，它在int->int-proj函数的前面两行提供其参数。这里的诀窍是，即使int->int-proj函数总是归咎于它所认为的主动方，我们可以通过在给定的归咎对象（blame object）上调用blame-swap来互换归咎方，用被动方更换主动方，反之亦然。

然而，这种技术并不仅仅是一个让这个例子工作的廉价技巧。主动方和被动方的反转是一个函数行为方式的自然结果。也就是说，想象在两个模块之间的一个程序里的值流。首先，一个模块（服务器）定义了一个函数，然后那个模块被另一个模块（客户端）所依赖。到目前为止，这个函数本身必须从原始出发，提供模块给这个需求模块。现在，假设需求模块调用这个函数，为它提供一个参数。此时，值流逆转。这个参数正在从需求模块回流到提供的模块！这个客户端正在“提供”参数给服务器，并且这个服务器正在作为客户端接收那个值。最后，当这个函数产生一个结果时，那个结果在原始方向上从服务器回流到客户端。因此，定义域上的合约倒转了主动的和被动的归咎方，就像值流逆转一样。

我们可以利用这个领悟来概括函数合约并构建一个函数，它接受任意两个合约并为它们之间的函数返回一个合约。

这一推断也走的更远而且在一个合约违反被检测到时使用blame-add-context来改进错误信息。

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

虽然这些推断得到了合约库的支持并且可以用来构建新合约，但是这个合约库也为了更有效的推断支持一个不同的API。具体来说，一个后负推断（late neg projection）接受一个不带反面归咎的信息的归咎对象，然后按照这个顺序返回一个函数，它既接受合约约定的值也接受该被动方的名称。这个返回函数接着依次根据合约返回值。看起来像这样重写int->int-proj以使用这个API：

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

这种类型的合约的优点是，blame参数能够在合同边界的服务器一边被提供，而且这个结果可以被用于每个不同的客户端。在较简单的情况下，一个新的归咎对象必须为每个客户端被创建。

最后一个问题在这个合约能够与剩余的合约系统一起使用之前任然存在。在上面的函数中，这个合约通过为f创建一个包装函数来实现，但是这个包装器函数与equal?不协作，它也不让运行时系统知道这里有一个结果函数与输入函数f之间的联系。

为了解决这两个问题，我们应该使用监护（chaperones）而不是仅仅使用λ来创建包装器函数。这里是这个被重写以使用监护的int->int-proj函数：

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

如上所述的推断，但适合于其它，你可能制造的新类型的值，可以与合约库原语一起使用。具体来说，我们能够使用make-chaperone-contract来构建它：

(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 合约结构属性

对于一次性合约来说make-chaperone-contract函数是可以的，但通常你想制定许多不同的合约，仅在某些方面不同。做到这一点的最好方法是使用一个struct，带有prop:contract、prop:chaperone-contract或prop:flat-contract。

例如，假设我们想制定接受一个值域合约和一个定义域合约的->合约的一个简单表。我们应该定义一个带有两个字段的结构并使用build-chaperone-contract-property来构建我们需要的监护合约属性。

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

要像integer?和#f那样对值进行自动强制，我们需要调用coerce-chaperone-contract（注意这个拒绝模拟合约并对扁平合约不予坚持；要去做那些事情中的任何一件，而不是调用coerce-contract或coerce-flat-contract）。

(define (simple-arrow-contract dom rng)   (simple-arrow (coerce-contract 'simple-arrow-contract dom)                 (coerce-contract 'simple-arrow-contract rng)))

去定义simple-arrow-name是直截了当的；它需要返回一个表示合约的S表达式：

(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 使所有警告和报警一致

这里有一些对一个simple-arrow-contract没有添加的合约的可选部分。在这一节中，我们通过所有的例子来展示它们是如何实现的。

首先是一个一阶检查。这是被or/c使用来确定那一个高阶参数合约在它看到一个值时去使用。下面是我们简单箭头合约的函数。

(define (simple-arrow-first-order ctc)   (λ (v) (and (procedure? v)               (procedure-arity-includes? v 1))))

如果这个值确实不满足合约，它接受一个值并返回#f，并且如返回#t，只要我们能够辨别，这个值满足合约，只是检查值的一阶属性。

其次是随机生成。合约库中的随机生成分为两部分：随机生成满足合约的值的能力以及运用匹配这个给定合约的值的能力，希望发现其中的错误（并也试图使它们产生令人感兴趣的值以在生成期间被用于其它地方）。

为了运用合约，我们需要实现一个被给定一个arrow-contract结构的函数和一些辅助函数。它应该返回两个值：一个接受合约值并运用它们的函数；外加运用进程总会产生的一个值列表。在我们简单合约的情况，我们知道我们总能产生值域的值，只要我们能够生成定义域的值（因为我们能够仅调用这个函数）。因此，这里有一个匹配build-chaperone-contract-property的合约的exercise参数的函数：

(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 '())])))

如果定义域合约可以被生成，那么我们知道我们能够通过运用做一些好的事情。在这种情况下，我们返回一个过程，它用我们从定义域生成的东西调用f（匹配这个合约函数），并且我们也在环境中隐藏这个结果值。我们也返回(simple-arrow-rng arr)来表明运用总会产生那个合约的某些东西。

如果我们不能做到，那么我们只简单地返回一个函数，它不运用(void)和空列表（表示我们不会生成任何值）。

然后，为了生成与这个合约相匹配的值，我们定义一个在给定合约和某些辅助函数时成为一个随机函数的函数。为了帮助它成为一个更有效的测试函数，我们可以运用它接受的任何参数，同时也将它们保存到生成环境中，但前提是我们可以生成值域合约的值。

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

当这个随机生成将某个东西拉出环境时，它需要能够判断一个被传递给contract-random-generate-stash的值是否是一个试图生成的合约的候选对象。当然，合约传递给contract-random-generate-stash的是一个精确的匹配，那么它就能够使用它。但是，如果这个合约更强（意思是它接受更少的值），它也能够使用这个价值。

为了提供这个功能，我们实现这个函数：

(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和that，两个合约。它保证this将是我们的简单箭头合约之一，因为我们正在用简单箭头合约实现供应这个函数。但这个that参数也许是任何合约。如果同样比较定义域和值域，这个函数检查以弄明白是否that也是一个简单箭头合约。当然，那里还有其它的合约，我们也可以检查（例如，使用->或->*的合约构建），但我们并不需要。如果这个更强的函数不知道答案但如果它返回#t，它被允许返回#f，那么这个合约必须真正变得更强。

既然我们有实现了的所有部分，我们需要传递它们给build-chaperone-contract-property，这样合约系统就开始使用它们了：

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

我们还添加了一个prop:custom-write属性以便这个合约正确打印，例如：

> (simple-arrow-contract integer? integer?)

(-> integer? integer?)

 

（因为合约库不能依赖于

#lang racket/generic

但仍然希望提供一些帮助以便于使用正确的打印机，我们使用prop:custom-write。）

 

既然那些已经完成，我们就能够使用新功能。这里有一个随机函数，它由合约库生成，使用我们的simple-arrow-contract-generate函数：

(define a-random-function   (contract-random-generate    (simple-arrow-contract integer? integer?)))

> (a-random-function 0) 0 > (a-random-function 1) -1730424298

这里是是合约系统怎么能在使用简单箭头合约的函数中立刻自动发现缺陷（bug）：

(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

并且如果我们没有实现simple-arrow-first-order，那么or/c就不能够辨别这个程序中使用哪一个or/c分支：

(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: #   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

7.9 问题

7.9.1 合约和eq?

作为一般规则，向程序中添加一个合约既应该使程序的行为保持不变，也应该标志出一个合约违反。并且这对于Racket合约几乎是真实的，只有一个例外：eq?。

eq?过程被设计为快速且不提供太多的确保方式，除非它返回true，这意味着这两个值在所有方面都是相同的。在内部，这被实现为在一个底层的指针相等，因此它揭示了有关Racket如何被实现的信息（以及合约如何被实现的信息）。

用eq?进行合约交互是糟糕的，因为函数合约检查被内部实现为包装器函数。例如，考虑这个模块：

#lang racket

(define (make-adder x)

(if (= 1 x)

add1

(lambda (y) (+ x y))))

(provide (contract-out

[make-adder (-> number? (-> number? number?))]))

除当它的输入是1时它返回Racket的add1外，它输出通常被柯里化为附加函数的make-adder函数。

你可能希望这样：

(eq? (make-adder 1)

(make-adder 1))

应该返回#t，但它却没有。如果该合约被改为any/c（或者甚至是(-> number?any/c)），那eq?调用将返回#t。

教训：不要对有合约的值使用eq?。

7.9.2 合约边界和define/contract

被define/contract建立的合约边界，它创建了一个嵌套的合约边界，有时是不直观的。当多个函数或其它带有合约的值相互作用时尤其如此。例如，考虑这两个相互作用的函数：

> (define/contract (f x)     (-> integer? integer?)     x)

> (define/contract (g)     (-> string?)     (f "not an integer"))

> (g)

f: contract violation

expected: integer?

given: "not an integer"

in: the 1st argument of

(-> integer? integer?)

contract from: (function f)

blaming: top-level

(assuming the contract is correct)

at: eval:2.0

人们可能期望这个函数g将因为违反其带f的合约条件而被归咎。如果f和g是直接建立合约的对方，归咎于g就是对的。然而，它们不是。相反，f和g之间的访问是通过封闭模块的顶层被协调的。

更确切地说，f和模块的顶层有(-> integer? integer?)合约协调它们的相互作用，g和顶层有(-> string?)协调它们的相互作用，但是f和g之间没有直接的合约，这意味着在g的主体内对f的引用实际上是模块职责的顶层，而不是g的。换句话说，函数f已经被用在g与顶层之间没有合约的方式赋予g，因此顶层被归咎。

如果我们想在g和顶层之间增加一个合约，我们可以使用define/contract的#:freevar申明并看到预期的归咎：

> (define/contract (f x)     (-> integer? integer?)     x)

> (define/contract (g)     (-> string?)     #:freevar f (-> integer? integer?)     (f "not an integer"))

> (g)

f: contract violation

expected: integer?

given: "not an integer"

in: the 1st argument of

(-> integer? integer?)

contract from: top-level

blaming: (function g)

(assuming the contract is correct)

at: eval:6.0

教训：如果带合约的两个值应相互作用，在模块边界上将它们放置在具有合约的分开的模块中或使用#:freevar。

7.9.3 存在的合约和判断

很像上面的这个eq?例子，#:∃合约能够改变一个程序的行为。

具体来说，null?判断（和许多其它判断）为#:∃合约返回#f，同时那些合同中的一个改变为any/c意味着null?现在可能反而返回#t，任何不同行为的结果依赖于这个布尔值可以怎样在程序中流动。

 

#lang racket/exists

package: base

 

要解决上述问题，racket/exists库行为就像racket，但当给定#:∃合约时判断会发出错误信号。

教训：不要使用基于#:∃合约的判断，但是如果你并不确定，用racket/exists在是安全的。

7.9.4 定义递归合约

当定义一个自参考合约时，很自然地去使用define。例如，人们可能试图在像这样的流上编写一个合约：

> (define stream/c     (promise/c      (or/c null?            (cons/c number? stream/c))))

stream/c: undefined;

cannot reference undefined identifier

不幸的是，这不会工作，因为stream/c的值在被定义之前就被需要。换句话说，所有的组合器都渴望对它们的参数求值，即使它们不接受这些值。

相反，使用

(define stream/c

(promise/c

(or/c

null?

(cons/c number? (recursive-contract stream/c)))))

recursive-contract的使用延迟对标识符stream/c的求值，直到合约被首先检查之后，足够长以确保stream/c被定义。

也参见《检查数据结构的特性》。

7.9.5 混合set!和contract-out

假定变量通过contract-out输出的合约库没有被分配，但没有执行它。因此，如果你试图set!这些变量，你可能会感到惊讶。考虑下面的例子：

> (module server racket     (define (inc-x!) (set! x (+ x 1)))     (define x 0)     (provide (contract-out [inc-x! (-> void?)]                            [x integer?])))

> (module client racket     (require 'server)        (define (print-latest) (printf "x is ~s\n" x))        (print-latest)     (inc-x!)     (print-latest))

> (require 'client)

x is 0 x is 0

尽管x的值已经被增加（并且在模块x内可见），两个对print-latest的调用打印0。

为了解决这个问题，输出访问器函数，而不是直接输出变量，像这样：

#lang racket

(define (get-x) x)

(define (inc-x!) (set! x (+ x 1)))

(define x 0)

(provide (contract-out [inc-x! (-> void?)]

[get-x (-> integer?)]))

教训：这是一个我们将在一个以后版本中讨论的缺陷。