Add Typed Jerboa property/fuzz test suite
ober
e387c751fcedf439ae79c9acfe6c6a74f83ed19c
--- a/Makefile +++ b/Makefile @@ -342,7 +342,7 @@ typed-split-tree-smoke: build/typed/split-tree-smoke/sample_typed_split_tree.ss \ tests/test-typed-split-tree-caller.ss -typed-test: test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-wrappers typecheck +typed-test: test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-wrappers test-typed-fuzz typecheck typed-clean: @rm -rf build/typed @@ -411,6 +411,9 @@ test-typed-rust: test-typed-wrappers: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-wrappers.ss +test-typed-fuzz: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-fuzz.ss + test-pure-audit: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-pure-audit.ss --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -343,7 +343,16 @@ Highest-value next steps: compiler errors can map back to typed source line and column. 7. Add fuzz/property tests for parser/checker and broader differential tests against dynamic Jerboa implementations before moving to LLVM or static - integration. + integration (Done — initial property suite). `tests/test-typed-fuzz.ss` + generates a batch of typed-library forms from a seeded LCG and asserts the + pipeline-level invariants: every generated module parses, type-checks + without errors, and emits a Rust string carrying the expected file header; + Rust emission is deterministic on identical input; ill-typed modules + surface structured `typed-check-error` records (not internal Scheme + exceptions); syntactically invalid modules raise a parse error rather than + blow up downstream. The seed is overrideable via `JERBOA_TYPED_FUZZ_SEED` + so failing seeds can be replayed. Differential testing against dynamic + Jerboa execution remains future work. Expression-level source spans have landed: the parser preserves annotated datums inside function bodies, the checker captures each diagnostic's source new file mode 100644 --- /dev/null +++ b/tests/test-typed-fuzz.ss @@ -0,0 +1,232 @@ +#!chezscheme +;;; Property/fuzz tests for the Typed Jerboa pipeline. +;;; +;;; These tests do not try to exhaustively cover semantics. Instead they +;;; check robustness invariants: +;;; +;;; - parser/checker/emitter never raise raw internal Scheme errors on +;;; well-formed input, even with diverse legal shapes. +;;; - emission is deterministic (same input -> same output). +;;; - error reporting is structured: ill-typed input surfaces typed-check +;;; errors rather than internal exceptions. + +(import (chezscheme) + (jerboa typed parser) + (jerboa typed checker) + (jerboa typed rust)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ label actual expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: exception ~s~%" label exn)]) + (let ([a actual] [e expected]) + (if (equal? a e) + (begin (set! pass (+ pass 1)) + (printf " ok ~a~%" label)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a~% expected: ~s~% actual: ~s~%" + label e a)))))])) + +(define-syntax test-true + (syntax-rules () + [(_ label actual) + (test label (if actual #t #f) #t)])) + +;; --------------------------------------------------------------------------- +;; Tiny pseudo-random generator. We do not need cryptographic quality; we want +;; reproducible variety, so we use a linear congruential generator seeded from +;; an environment variable when provided. +;; --------------------------------------------------------------------------- + +(define seed-state + (let ([env (getenv "JERBOA_TYPED_FUZZ_SEED")]) + (if (and env (> (string-length env) 0)) + (string->number env) + 20260520))) + +(define (rand-next!) + (set! seed-state (modulo (+ (* seed-state 1103515245) 12345) (expt 2 31))) + seed-state) + +(define (rand-int n) + (modulo (rand-next!) n)) + +(define (rand-elt lst) + (list-ref lst (rand-int (length lst)))) + +(define (rand-bool) + (= 0 (rand-int 2))) + +;; --------------------------------------------------------------------------- +;; Generators +;; --------------------------------------------------------------------------- + +(define scalar-types '(Nat Int Bool String)) + +(define (gen-type) + (let ([choice (rand-int 6)]) + (cond + [(< choice 4) (rand-elt scalar-types)] + [(= choice 4) `(Option ,(rand-elt scalar-types))] + [else `(Result ,(rand-elt scalar-types) String)]))) + +(define (gen-name prefix n) + (string->symbol (string-append prefix "-" (number->string n)))) + +(define (gen-param i) + `(,(gen-name "arg" i) : ,(gen-type))) + +(define (gen-id-def i) + ;; Generate a degenerate identity function on a scalar type to keep checker + ;; happy. Even simple bodies exercise the pipeline. + (let* ([type (rand-elt scalar-types)] + [name (gen-name "id" i)] + [arg (gen-name "x" i)]) + `(def (,name (,arg : ,type)) : ,type ,arg))) + +(define (def-name def) + ;; def = (def (name (arg : T) ...) : Return body ...) + (car (cadr def))) + +(define (gen-module-form n) + (let* ([def-count (+ 1 (rand-int 4))] + [defs (let loop ([i 0] [out '()]) + (if (= i def-count) + (reverse out) + (loop (+ i 1) (cons (gen-id-def i) out))))] + [exports (map def-name defs)]) + `(typed-library (fuzz module ,(string->symbol (number->string n))) + (export . ,exports) + . ,defs))) + +(define (gen-ill-typed-form) + ;; Mismatched return type: claim Nat, return a String literal. + '(typed-library (fuzz ill typed) + (export f) + (def (f (x : Nat)) : Nat + "not a nat"))) + +(define (gen-syntactically-invalid-form) + '(typed-library (fuzz invalid syntax) + (export f) + ;; missing return type colon + (def (f (x : Nat)) Nat + x))) + +;; --------------------------------------------------------------------------- +;; Pipeline helpers +;; --------------------------------------------------------------------------- + +(define (safe-parse form) + (guard (exn [#t (cons 'parse-error exn)]) + (cons 'ok (parse-typed-library form)))) + +(define (safe-check module) + (guard (exn [#t (cons 'check-error exn)]) + (cons 'ok (check-typed-module module)))) + +(define (safe-emit form) + (guard (exn [#t (cons 'emit-error exn)]) + (cons 'ok (typed-library-form->rust-string form)))) + +(define (errors-for form) + (let ([parsed (safe-parse form)]) + (cond + [(eq? (car parsed) 'parse-error) (list 'parse)] + [else + (let ([checked (safe-check (cdr parsed))]) + (cond + [(eq? (car checked) 'check-error) (list 'check-exn)] + [else + (map typed-check-error-kind (cdr checked))]))]))) + +;; --------------------------------------------------------------------------- +;; Tests +;; --------------------------------------------------------------------------- + +(printf "--- Typed Jerboa fuzz/property tests ---~%") +(printf " seed: ~a~%" seed-state) + +(define sample-count 16) + +(define generated-modules + (let loop ([i 0] [out '()]) + (if (= i sample-count) + (reverse out) + (loop (+ i 1) (cons (gen-module-form i) out))))) + +(test-true "all generated id-modules parse" + (let loop ([rest generated-modules]) + (cond + [(null? rest) #t] + [(eq? (car (safe-parse (car rest))) 'ok) (loop (cdr rest))] + [else #f]))) + +(test-true "all generated id-modules pass the checker without errors" + (let loop ([rest generated-modules]) + (cond + [(null? rest) #t] + [else + (let ([errs (errors-for (car rest))]) + (if (null? errs) (loop (cdr rest)) #f))]))) + +(test-true "all generated id-modules emit Rust without raising" + (let loop ([rest generated-modules]) + (cond + [(null? rest) #t] + [else + (let ([emitted (safe-emit (car rest))]) + (if (eq? (car emitted) 'ok) (loop (cdr rest)) #f))]))) + +(test-true "Rust emission is deterministic for the same input" + (let loop ([rest generated-modules]) + (cond + [(null? rest) #t] + [else + (let ([a (safe-emit (car rest))] + [b (safe-emit (car rest))]) + (cond + [(and (eq? (car a) 'ok) (eq? (car b) 'ok) + (string=? (cdr a) (cdr b))) + (loop (cdr rest))] + [else #f]))]))) + +(test-true "every emitted Rust string carries the file header" + (let loop ([rest generated-modules]) + (cond + [(null? rest) #t] + [else + (let ([emitted (safe-emit (car rest))]) + (cond + [(and (eq? (car emitted) 'ok) + (let ([s (cdr emitted)]) + (and (> (string-length s) 0) + (let ([head "// Generated by Jerboa's typed Rust backend."]) + (and (>= (string-length s) (string-length head)) + (string=? (substring s 0 (string-length head)) head)))))) + (loop (cdr rest))] + [else #f]))]))) + +(test "ill-typed module surfaces a return-type-mismatch" + (errors-for (gen-ill-typed-form)) + '(return-type-mismatch)) + +(test-true "syntactically invalid form raises a parse error (not internal)" + (let ([result (safe-parse (gen-syntactically-invalid-form))]) + (eq? (car result) 'parse-error))) + +;; Boundary case: empty exports / no defs should still produce a valid (empty) +;; Rust output without crashing. +(test-true "empty module parses, checks, and emits" + (let ([form '(typed-library (fuzz empty) (export))]) + (and (eq? (car (safe-parse form)) 'ok) + (null? (errors-for form)) + (eq? (car (safe-emit form)) 'ok)))) + +(printf "~%Typed fuzz: ~a passed, ~a failed~%" pass fail) +(when (> fail 0) + (exit 1))