contract-utils.rkt
```;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  Contract-Utils: general-purpose PLT contract utilities.
;;  Copyright (C) 2005-2010  Richard Cobbe
;;  Version 4.0
;;
;;  For licensing information, see the Scribble manual.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

#lang racket

(require (prefix-in srfi-67: srfi/67))

;; abstract types provided by Racket:
;;   Contract
;;   Flat-Contract

;; Pred-Contract ::= (Union (a -> Bool) Contract)
;; Pred-Flat-Contract ::= (Union (a -> Bool) Flat-Contract)

;; listof-unique/c :: (a a -> Bool) -> Flat-Contract
;; produces a flat contract that recognizes lists whose elements are unique
;; with respect to equ?
;; FIXME: take a contract that also applies to each element, like listof?
(define listof-unique/c
(lambda (equ?)
(flat-named-contract
"list of unique elements"
(lambda (elems)
(let scan ([elems elems])
(if (null? elems)
#t
(let* ([elem (car elems)]
[rest (cdr elems)])
(and (andmap (lambda (other) (not (equ? elem other))) rest)
(scan rest)))))))))

;; listof-unique-compare/c :: (a a -> (Union -1 0 1)) -> Flat-Contract
;; produces a flat contract that recognizes lists whose elements are unique
;; with respect to cmp.
(define listof-unique-compare/c
(lambda (cmp)
(flat-named-contract
"list of unique elements"
(lambda (elems)
(apply srfi-67:chain<? cmp (sort elems (srfi-67:<? cmp)))))))

;; nelistof/c :: Pred-Flat-Contract -> Flat-Contract
;; produces a contract that recognizes a non-empty list of elements
;; which satisfy the contract c.
(define nelistof/c
(lambda (c)
(and/c (listof c) (not/c null?))))

;; sexp/c :: Flat-Contract
;; recognizes arbitrary s-expressions.
(define sexp/c
(flat-rec-contract sexp
(cons/c sexp sexp)
null?
number?
symbol?
string?
boolean?
char?))

;; predicate/c :: Contract
;; recognizes unary predicates
(define predicate/c (any/c . -> . boolean?))

;; binary-predicate/c :: Contract -> Contract
;; recognizes binary predicates that accept elements that satisfy arg/c
(define binary-predicate/c
(lambda (arg/c)
(arg/c arg/c . -> . boolean?)))

;; equality/c :: Contract -> Contract
;; recognizes equality predicates that work on values that satisfy arg/c
(define equality/c
(lambda (arg/c)
(arg/c arg/c . -> . boolean?)))

;; comparison/c :: Contract -> Contract
;; recognizes comparison functions as defined by SRFI 67 that work on values
;; that satisfy arg/c
(define comparison/c
(lambda (arg/c)
(arg/c arg/c . -> . (integer-in -1 1))))

;; optional/c :: Pred-Contract -> Contract
;; produces a contract that recognizes both #f and all values recognized
;; by the argument
(define optional/c (lambda (contract) (or/c contract false/c)))

;; positive-int/c :: Flat-Contract
;; recognizes all positive integers
(define positive-int/c
(flat-named-contract "positive integer"
(and/c natural-number/c (lambda (x) (> x 0)))))

;; contract/c :: Contract
;; recognizes contracts and predicates
(define contract/c (or/c contract? predicate/c))

;; flat-contract/c :: Contract
;; recognizes flat contracts and predicates
(define flat-contract/c (or/c flat-contract? predicate/c))

;; immutable-string/c :: Flat-Contract
;; recognizes immutable strings.
(define immutable-string/c (and/c string? immutable?))

;; contract-of :: Pred-Contract -> Contract
;; wraps a predicate in a flat contract; idempotent
(define contract-of
(lambda (c/p)
(if (contract? c/p) c/p (flat-contract c/p))))

;; predicate-of :: Pred-Flat-Contract -> Predicate
;; extracts a flat contract's predicate if necessary.  Idempotent.
(define predicate-of
(lambda (c/p)
(if (flat-contract? c/p) (flat-contract-predicate c/p) c/p)))

(define-syntax eta
(syntax-rules ()
[(_ f) (lambda args (apply f args))]))

(provide/contract [sexp/c flat-contract?]
[predicate/c contract?]
[binary-predicate/c (contract/c . -> . contract/c)]
[equality/c (contract/c . -> . contract/c)]
[comparison/c (contract/c . -> . contract/c)]
[optional/c (contract/c . -> . contract?)]
[positive-int/c flat-contract?]
[listof-unique/c (equality/c . -> . flat-contract/c)]
[listof-unique-compare/c (comparison/c . -> .
flat-contract/c)]
[nelistof/c (contract/c . -> . flat-contract?)]
[contract/c contract?]
[flat-contract/c contract?]
[immutable-string/c flat-contract?]
[contract-of (contract/c . -> . contract?)]
[predicate-of (flat-contract/c . -> . predicate/c)])

(provide eta)
```