Add flat contract combinators
ober
bf248172a010acbf9a80f6ee3a7454902606b8f7
--- a/docs/contracts.md +++ b/docs/contracts.md @@ -40,7 +40,7 @@ stack-archaeology required. the docstring, and it cannot drift from the code because it *is* the code. 3. **Refactor safety.** Tighten a predicate from `number?` to - `exact-integer?` and every caller that was sloppy lights up. No + `(and/c integer? exact?)` and every caller that was sloppy lights up. No grep, no guessing. 4. **Tooling surface.** IDEs read the same predicates for completion and signature help. Property-based test generators reuse them as @@ -86,7 +86,8 @@ Current landing: - `(std contract)` raises `contract-violation?` conditions from `check-argument`, `check-result`, `assert-contract`, and `define/contract` pre/post failures, and re-exports the shared condition - API. + API. It also provides the first flat contract combinators: `any/c`, `or/c`, + `and/c`, `listof`, `vectorof`, and `maybe`. - `(std ergo)` provides the first Gerbil-style dynamic markers: `:`, `:?`, `:-`, `:~`, `using`, `maybe`, `list-of?`, `in-range?`, and `in-range-inclusive?`. `:~` failures raise `contract-violation?`. @@ -135,7 +136,7 @@ directly, matching Gerbil's idiom: ### 2.2 Module-export annotations ```scheme -(: parse-int (-> string? (or/c exact-integer? #f))) +(: parse-int (-> string? (or/c (and/c integer? exact?) #f))) (def (parse-int s) ...) ``` @@ -149,6 +150,7 @@ re-check. | Form | Meaning | |-----------------------------|------------------------------------------| +| `any/c` | accepts any value | | `(or/c p ...)` | satisfies any of the listed predicates | | `(and/c p ...)` | satisfies all | | `(listof p)` | a list whose elements all satisfy p | @@ -157,6 +159,10 @@ re-check. | `(-> arg ... result)` | function contract | | `(->* (req ...) (opt ...) result)` | optional/required arities | +For the flat combinators, a procedure is treated as a predicate. A +non-procedure value is treated as a literal contract matched with `equal?`, so +`(or/c (and/c integer? exact?) #f)` accepts exact integers or `#f`. + --- ## 3. Desugaring and Semantics @@ -179,7 +185,7 @@ context as we want. ### 3.2 `:` annotation expansion ```scheme -(: parse-int (-> string? (or/c exact-integer? #f))) +(: parse-int (-> string? (or/c (and/c integer? exact?) #f))) (def (parse-int s) body) ;; expands to (def parse-int @@ -187,7 +193,7 @@ context as we want. (lambda (s) (using (s :- string?) (let ([result (raw s)]) - (unless (or (exact-integer? result) (eq? result #f)) + (unless (or (and (integer? result) (exact? result)) (eq? result #f)) (raise-contract-violation/result 'parse-int ...)) result))))) ``` @@ -246,7 +252,7 @@ messages for free. - `(: name signature)` macro. Captures signature at module top level, associates with the next `def`. -- Combinators: `or/c`, `and/c`, `listof`, `vectorof`, `maybe`, `->`. +- Combinators: `any/c`, `or/c`, `and/c`, `listof`, `vectorof`, `maybe`, `->`. - Module-boundary wrapping: only exported bindings are wrapped. - Tests: signature mismatch reporting, recursive-call performance. --- a/lib/std/contract.ss +++ b/lib/std/contract.ss @@ -15,6 +15,7 @@ contract-violation-message raise-contract-violation define/contract pre: post: + any/c or/c and/c listof vectorof maybe -> assert-contract) (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted stdlib contract module @@ -34,11 +35,58 @@ "result failed predicate ~a: ~s" pred val)) val) + ;; Normalize simple contract expressions to predicates. Procedure values are + ;; predicates; non-procedures are literal values matched with equal?. + (def (contract->predicate c) + (if (procedure? c) + c + (lambda (v) (equal? v c)))) + + (def (any/c v) #t) + + (def (or/c . contracts) + (let ([preds (map contract->predicate contracts)]) + (lambda (v) + (let loop ([rest preds]) + (and (pair? rest) + (or ((car rest) v) + (loop (cdr rest)))))))) + + (def (and/c . contracts) + (let ([preds (map contract->predicate contracts)]) + (lambda (v) + (let loop ([rest preds]) + (or (null? rest) + (and ((car rest) v) + (loop (cdr rest)))))))) + + (def (listof contract) + (let ([pred (contract->predicate contract)]) + (lambda (v) + (and (list? v) + (for-all pred v))))) + + (def (vectorof contract) + (let ([pred (contract->predicate contract)]) + (lambda (v) + (and (vector? v) + (let loop ([i 0]) + (or (= i (vector-length v)) + (and (pred (vector-ref v i)) + (loop (+ i 1))))))))) + + (def (maybe contract) + (let ([pred (contract->predicate contract)]) + (lambda (v) + (or (not v) + (pred v))))) + ;; Function contract: (-> domain ... range) ;; Returns a wrapper that checks arguments and result (def (-> . preds) - (let ([arg-preds (reverse (cdr (reverse preds)))] - [result-pred (car (reverse preds))]) + (let ([arg-preds (map contract->predicate + (reverse (cdr (reverse preds))))] + [result-pred (contract->predicate (car (reverse preds)))]) (lambda (f) (lambda args (for-each (lambda (pred val) --- a/tests/test-contract.ss +++ b/tests/test-contract.ss @@ -55,6 +55,74 @@ (check-result string? 42 'result-check) 'result-check) +(test "any/c accepts any value" + (and (any/c 42) (any/c #f) (any/c '(a b))) + #t) + +(test "or/c accepts first predicate" + ((or/c string? number?) "ok") + #t) + +(test "or/c accepts later predicate" + ((or/c string? number?) 42) + #t) + +(test "or/c accepts literal contract" + ((or/c (and/c integer? exact?) #f) #f) + #t) + +(test "or/c rejects non-match" + ((or/c string? number?) 'nope) + #f) + +(test "and/c accepts all predicates" + ((and/c integer? positive?) 7) + #t) + +(test "and/c rejects failed predicate" + ((and/c integer? positive?) -1) + #f) + +(test "listof accepts element contract" + ((listof number?) '(1 2 3)) + #t) + +(test "listof rejects bad element" + ((listof number?) '(1 "bad" 3)) + #f) + +(test "listof rejects non-list" + ((listof number?) '#(1 2 3)) + #f) + +(test "vectorof accepts element contract" + ((vectorof string?) '#("a" "b")) + #t) + +(test "vectorof rejects bad element" + ((vectorof string?) '#("a" 2)) + #f) + +(test "vectorof rejects non-vector" + ((vectorof string?) '("a" "b")) + #f) + +(test "maybe accepts #f" + ((maybe string?) #f) + #t) + +(test "maybe accepts predicate match" + ((maybe string?) "ok") + #t) + +(test "maybe rejects predicate miss" + ((maybe string?) 42) + #f) + +(test-contract-error "check-argument combinator violation" + (check-argument (listof number?) '(1 "bad") 'list-check) + 'list-check) + (test "assert-contract pass" (assert-contract number? 10) 10) @@ -92,6 +160,15 @@ (safe-add "bad" 2) 'contract)) +(let ([parse-result ((-> string? (or/c (and/c integer? exact?) #f)) + (lambda (s) (string->number s)))]) + (test "function contract literal-result combinator pass" + (parse-result "42") + 42) + (test "function contract literal-result #f pass" + (parse-result "nope") + #f)) + (printf "~%Contract: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))