Share contract violation condition
ober
88245339ebb09ba0e6c8650242aad2c760e74917
--- a/Makefile +++ b/Makefile @@ -27,7 +27,7 @@ CHEZ_EXT_LDPATH = $(CHEZ_EXT_DIR)/chez-ssl:$(CHEZ_EXT_DIR)/chez-zlib:$(CHEZ_EXT_ PURE_AUDIT_ROOT ?= $(HOME)/mine PURE_AUDIT_ARGS ?= --summary --discover $(PURE_AUDIT_ROOT) -.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push +.PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-pure-audit test-features test-wrappers test-phase4a test-phase4b test-phase4c test-phase4d test-phase4e test-phase4f test-phase5 test-phase5e test-phase6 test-phase7 test-phase8 test-functional test-repl test-security test-security-profile test-native test-gaps native clean-native audit-native clean security security-production security-profile fuzz fuzz-smoke fuzz-deep fuzz-reader-fuzz fuzz-json-fuzz fuzz-http2-fuzz fuzz-websocket-fuzz fuzz-dns-fuzz fuzz-pregexp-fuzz fuzz-csv-fuzz fuzz-base64-fuzz fuzz-hex-fuzz fuzz-uri-fuzz fuzz-format-fuzz fuzz-router-fuzz fuzz-sandbox-fuzz test-rawstring test-regex test-rx test-peg test-regex-all check-docs check-docs-strict docker-build docker-push help: @echo "Usage: make <target>" @@ -65,6 +65,7 @@ help: @echo " test-functional Functional tests (I/O, fork, signals)" @echo " test-gaps Gap coverage tests" @echo " test-contract Runtime contract tests" + @echo " test-ergo Ergonomic contract marker tests" @echo " test-pure-audit Pure Jerboa migration scanner tests" @echo "" @echo "Test (features):" @@ -291,7 +292,7 @@ binary-cross: chez build chez-cross CC="$(CROSS_CC)" \ support/build-binary.sh $(BINARY_ENTRY) $(BINARY_OUTPUT)-$(CHEZ_TARGET_MACHINE) -test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-contract test-pure-audit +test: test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-regex-all test-contract test-ergo test-pure-audit pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script support/pure-audit.ss $(PURE_AUDIT_ARGS) @@ -338,6 +339,10 @@ test-expanded: test-contract: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-contract.ss +test-ergo: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-ergo.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-jerboa-prelude-ergo.ss + test-pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pure-audit.ss --- a/docs/contracts.md +++ b/docs/contracts.md @@ -80,14 +80,19 @@ In scope: Current landing: +- `(std contract condition)` provides the shared `contract-violation?` + condition and `raise-contract-violation` helper used by the contract + system, ergonomic markers, and `def` predicate contracts. - `(std contract)` raises `contract-violation?` conditions from `check-argument`, `check-result`, `assert-contract`, and - `define/contract` pre/post failures. + `define/contract` pre/post failures, and re-exports the shared condition + API. - `(std ergo)` provides the first Gerbil-style dynamic markers: `:`, `:?`, `:-`, `:~`, `using`, `maybe`, `list-of?`, `in-range?`, and - `in-range-inclusive?`. + `in-range-inclusive?`. `:~` failures raise `contract-violation?`. - Jerboa `def` accepts `:`, `:?`, `:-`, and `:~` parameter markers for dynamic - boundary checks. + boundary checks. `:~` parameter failures raise the same + `contract-violation?` condition as `(std contract)`. Out of scope (initially): @@ -228,8 +233,9 @@ No reader changes. No core-form changes. Everything is a macro. - New macro `using` in `(jerboa prelude)`. - `:-` resolves to predicate via syntax-local lookup (defstruct name → predicate name). -- `raise-contract-violation` with source-location + identifier + value - + expected predicate. +- Shared `raise-contract-violation` / `contract-violation?` foundation with + identifier, message, and irritants. Source-location and expected-predicate + details remain future error-reporting polish. - Tests: positive, negative, struct-name shorthand, nested `using`. Deliverable: every internal assertion `(unless (foo? x) (error ...))` --- a/docs/typing.md +++ b/docs/typing.md @@ -192,9 +192,11 @@ Jerboa's normal `def` also accepts these markers on parameters: ``` `:` and `:?` use the `(std typed)` type registry and follow -`*typed-mode*`. `:~` is a contract check and runs immediately. `:-` is an -unchecked assertion: use it only after a checked boundary has established the -invariant. +`*typed-mode*`. `:~` is a contract check and runs immediately. Failures from +`:~`, `using :~`, and `def` parameters annotated with `:~` raise the shared +`contract-violation?` condition from `(std contract condition)`, which is also +available through `(jerboa prelude)`. `:-` is an unchecked assertion: use it +only after a checked boundary has established the invariant. Predicate helpers: --- a/lib/jerboa/core.sls +++ b/lib/jerboa/core.sls @@ -109,6 +109,7 @@ (std misc thread) (only (std misc string) string-split string-empty?) (only (std misc list) filter-map) + (only (std contract condition) raise-contract-violation) (only (std typed) check-type! check-return-type!)) ;;;; ---- Compile-time helpers ---- @@ -343,7 +344,9 @@ '(void)] [(:~) `(unless (,spec ,aname) - (error ',who "argument failed predicate contract" ',aname ,aname))] + (raise-contract-violation ',who + "argument ~a failed predicate contract for ~s" + ',aname ,aname))] [else '(void)]))) --- a/lib/jerboa/prelude.ss +++ b/lib/jerboa/prelude.ss @@ -7,7 +7,7 @@ ;;; - Runtime: hash tables, method dispatch, keywords ;;; - Standard library: sort, format, JSON, paths, strings, lists, etc. ;;; - Advanced: result types, datetime, iterators, CSV, pretty-printer -;;; - Ergonomic typing: using, :, maybe +;;; - Ergonomic typing: using, :, :?, :-, :~, maybe ;;; - FFI: c-lambda, define-c-lambda (library (jerboa prelude) @@ -50,6 +50,9 @@ ;; ---- std/error ---- Error ContractViolation + contract-violation? contract-violation-who + contract-violation-message + raise-contract-violation ;; ---- std/sugar ---- chain chain-and assert! @@ -212,7 +215,8 @@ begin-ffi c-declare ;; ---- std/ergo ---- - using : maybe list-of? + using : :? :- :~ + maybe list-of? in-range? in-range-inclusive? ;; ---- std/misc/atom (Gerbil atom + Clojure aliases) ---- ;; Gerbil-style: @@ -300,6 +304,7 @@ (std debug pp) (std csv) (std ergo) + (std contract condition) (std misc atom) (std misc meta) (std misc shared) --- a/lib/std/contract.ss +++ b/lib/std/contract.ss @@ -18,21 +18,9 @@ -> assert-contract) (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted stdlib contract module + (std contract condition) (only (jerboa core) def)) - ;; Condition type for contract violations - (define-condition-type &contract-violation &violation - make-contract-violation contract-violation? - (who contract-violation-who) - (msg contract-violation-message)) - - (def (raise-contract-violation who msg . irritants) - (raise (condition - (make-contract-violation who msg) - (make-message-condition - (apply format #f msg irritants)) - (make-irritants-condition irritants)))) - ;; Check a function argument satisfies a predicate (def (check-argument pred val who) ; jerboa-security: suppress contract-bypass-in-production -- contract module intentionally raises fail-fast boundary violations (unless (pred val) new file mode 100644 --- /dev/null +++ b/lib/std/contract/condition.ss @@ -0,0 +1,27 @@ +#!chezscheme +;;; (std contract condition) — shared contract violation condition +;;; +;;; Kept separate from (std contract) so core macros and ergonomic typing +;;; can raise the same condition type without importing the full contract +;;; library and creating cycles. + +(library (std contract condition) + (export contract-violation? contract-violation-who + contract-violation-message + raise-contract-violation) + + (import (chezscheme)) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted stdlib condition foundation + + (define-condition-type &contract-violation &violation + make-contract-violation contract-violation? + (who contract-violation-who) + (msg contract-violation-message)) + + (define (raise-contract-violation who msg . irritants) + (raise (condition + (make-contract-violation who msg) + (make-message-condition + (apply format #f msg irritants)) + (make-irritants-condition irritants)))) + +) ;; end library --- a/lib/std/ergo.ss +++ b/lib/std/ergo.ss @@ -28,6 +28,7 @@ maybe list-of? in-range? in-range-inclusive?) (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted stdlib macro module (std typed) + (only (std contract condition) raise-contract-violation) (only (jerboa core) def)) ;; ========== Type Cast ========== @@ -70,7 +71,8 @@ #'(let ([v expr] [p pred]) (unless (p v) - (error ':~ "predicate contract failed" v)) + (raise-contract-violation ':~ + "predicate contract ~s failed for ~s" 'pred v)) v)]))) ;; ========== Contract Predicates ========== --- a/tests/test-contract.ss +++ b/tests/test-contract.ss @@ -35,6 +35,10 @@ (printf "--- (std contract) tests ---~%") +(test-contract-error "raise-contract-violation condition" + (raise-contract-violation 'manual-check "manual failure for ~s" 'value) + 'manual-check) + (test "check-argument pass" (begin (check-argument string? "ok" 'arg-check) 'ok) 'ok) --- a/tests/test-ergo.ss +++ b/tests/test-ergo.ss @@ -1,7 +1,11 @@ #!chezscheme ;;; Tests for (std ergo) — Ergonomic typing layer -(import (chezscheme) (std typed) (std ergo) (jerboa core)) +(import (chezscheme) + (std typed) + (std ergo) + (std contract condition) + (jerboa core)) (define pass 0) (define fail 0) @@ -29,6 +33,18 @@ #f) #t)])) +(define-syntax test-contract-error + (syntax-rules () + [(_ name expr who) + (test name + (guard (exn + [(contract-violation? exn) + (eq? (contract-violation-who exn) who)] + [else #f]) + expr + #f) + #t)])) + (printf "--- (std ergo) tests ---~%") ;;; ========== : (checked cast) ========== @@ -58,6 +74,7 @@ (test ":~ accepts predicate success" (:~ 4 even?) 4) (test-error ":~ rejects predicate failure" (:~ 5 even?)) +(test-contract-error ":~ rejects with contract condition" (:~ 5 even?) ':~) ;;; ========== maybe / list-of? ========== @@ -144,7 +161,12 @@ (test-error "using :~ predicate failure" (using (n 12 :~ (in-range? 0 10)) - n))) + n)) + + (test-contract-error "using :~ predicate failure condition" + (using (n 12 :~ (in-range? 0 10)) + n) + ':~)) ;;; ========== using with as (unchecked) ========== @@ -251,6 +273,9 @@ (test "def :~ accepts predicate value" (bounded-index 9) 9) (test-error "def :~ rejects predicate value" (bounded-index 10)) +(test-contract-error "def :~ rejects with contract condition" + (bounded-index 10) + 'bounded-index) ;;; ========== def backward compat ========== new file mode 100644 --- /dev/null +++ b/tests/test-jerboa-prelude-ergo.ss @@ -0,0 +1,48 @@ +#!chezscheme +;;; Verify the normal one-import prelude exposes ergo contract markers. + +(import (jerboa prelude)) + +(def pass 0) +(def fail 0) + +(defrule (chk expr => expected) + (let ([r expr] [e expected]) + (if (equal? r e) + (set! pass (+ pass 1)) + (begin + (set! fail (+ fail 1)) + (display "FAIL: ") (write 'expr) + (display " => ") (write r) + (display " expected ") (write e) (newline))))) + +(defrule (chk-contract-error name expr who) + (chk + (guard (exn + [(contract-violation? exn) + (eq? (contract-violation-who exn) who)] + [else #f]) + expr + #f) + => #t)) + +(chk (:? #f string) => #f) +(chk (:? "ok" string) => "ok") +(chk (:- "unchecked" fixnum) => "unchecked") +(chk (:~ 4 even?) => 4) +(chk ((in-range? 0 3) 2) => #t) +(chk ((in-range? 0 3) 3) => #f) +(chk ((in-range-inclusive? 0 3) 3) => #t) +(chk-contract-error "prelude :~ failure" (:~ 5 even?) ':~) + +(def (bounded (n :~ (in-range? 0 3))) + n) + +(chk (bounded 2) => 2) +(chk-contract-error "prelude def :~ failure" (bounded 3) 'bounded) + +(newline) +(display "jerboa prelude ergo: ") +(display pass) (display " passed, ") +(display fail) (display " failed") (newline) +(when (> fail 0) (exit 1))