Lower Typed Jerboa records and variants to Rust
ober
a936fe928d32de9444d0a905dc3e918465b7fe4a
--- 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) TYPED_SOURCES ?= tests/fixtures/typed/valid-split-tree.ss -TYPED_RUST_SOURCES ?= tests/fixtures/typed/rust-basic.ss +TYPED_RUST_SOURCES ?= $(TYPED_SOURCES) TYPED_RUST_DIR ?= build/typed/rust .PHONY: help chez chez-cross build binary binary-cross native-cross pure-audit typecheck typed-rust typed-build typed-test typed-clean test test-reader test-core test-runtime test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-typed-parser test-typed-checker test-typed-rust 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-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 --- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -539,13 +539,15 @@ Second module: typed `rope`. - Generate deterministic Rust text. Initial `(jerboa typed rust)` emitter landed with safe Rust headers, identifier sanitization, primitive type - mapping, records, variants, and primitive function bodies. + mapping, records, variants, primitive function bodies, record/variant + operation lowering, and exhaustive variant `match` lowering. - Generate crate directory. Initial `build/typed/rust` generation landed. - Generate `Cargo.toml`. Initial disposable crate manifest landed. - Generate `lib.rs`. Initial single-file crate output landed. - Generate one function returning an integer. Initial text emission for `Nat` functions landed. -- Build with Cargo. Initial `make typed-build` target runs `cargo check`. +- Build with Cargo. Initial `make typed-build` target runs `cargo check` on + the main typed split-tree fixture. - Call from Jerboa through FFI. ### Milestone 2: Primitive Types --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -148,8 +148,9 @@ Current landing: and a short hint for common errors. - `(jerboa typed rust)` emits deterministic safe Rust text for checked typed modules. The first emitter covers Rust identifiers, primitive types, - records, variants, and primitive function bodies; native artifact builds and - FFI wrappers are still future work. + records, variants, primitive function bodies, record accessors/constructors, + variant constructors, variant predicates, and exhaustive variant `match`; + native artifact builds and FFI wrappers are still future work. - `support/typed-rust.ss`, `make typed-rust`, and `make typed-build` generate a disposable Cargo crate under `build/typed/rust`; `typed-build` runs `cargo check` against the generated crate. @@ -633,7 +634,8 @@ Initial meanings: - `typecheck`: parse and type check typed modules. Initial target landed for parser/checker validation over `TYPED_SOURCES`. - `typed-rust`: generate Rust for typed modules. Initial target writes - `build/typed/rust/Cargo.toml` and `build/typed/rust/src/lib.rs`. + `build/typed/rust/Cargo.toml` and `build/typed/rust/src/lib.rs` from + `TYPED_RUST_SOURCES`, which defaults to `TYPED_SOURCES`. - `typed-build`: generate Rust and run `cargo check`. Native artifact builds and wrappers are still pending. - `typed-test`: run typed compiler tests and runtime boundary tests. Initial @@ -781,7 +783,8 @@ Minimum excluded features: - Generate Rust structs and enums. Initial safe Rust text emission landed. - Generate Rust functions. Initial primitive expression function emission - landed. + landed, along with lowering for same-module record/variant operations and + exhaustive variant `match`. - Generate a Cargo crate. Initial `make typed-rust` / `make typed-build` targets landed for a primitive typed fixture. - Generate conversion functions. --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -18,6 +18,10 @@ (jerboa typed parser) (jerboa typed checker)) + (def *rust-record-env* (make-parameter '())) + (def *rust-variant-env* (make-parameter '())) + (def *rust-variant-case-env* (make-parameter '())) + (def (emit-to-string thunk) (let ([port (open-output-string)]) (thunk port) @@ -36,6 +40,16 @@ (loop (cdr rest)))) (get-output-string port))])) + (def (symbol-append . parts) + (string->symbol + (apply string-append + (map (lambda (p) + (cond + [(symbol? p) (symbol->string p)] + [(string? p) p] + [else (error 'symbol-append "expected symbol or string" p)])) + parts)))) + (def (write-indent port level) (let loop ([n level]) (when (> n 0) @@ -148,6 +162,94 @@ [else (error 'typed-rust "unsupported compound type" type)])] [else (error 'typed-rust "unsupported type" type)])) + (def (append-map f xs) + (let loop ([rest xs] [out '()]) + (if (null? rest) + (reverse out) + (loop (cdr rest) (append (reverse (f (car rest))) out))))) + + (def (typed-module-records module) + (let loop ([rest (typed-module-declarations module)] [out '()]) + (cond + [(null? rest) (reverse out)] + [(typed-record? (car rest)) (loop (cdr rest) (cons (car rest) out))] + [else (loop (cdr rest) out)]))) + + (def (typed-module-variants module) + (let loop ([rest (typed-module-declarations module)] [out '()]) + (cond + [(null? rest) (reverse out)] + [(typed-variant? (car rest)) (loop (cdr rest) (cons (car rest) out))] + [else (loop (cdr rest) out)]))) + + (def (record-env modules) + (map (lambda (record) + (cons (typed-record-name record) record)) + (append-map typed-module-records modules))) + + (def (variant-env modules) + (map (lambda (variant) + (cons (typed-variant-name variant) variant)) + (append-map typed-module-variants modules))) + + (def (variant-case-env modules) + (append-map + (lambda (variant) + (map (lambda (case) + (cons (typed-variant-case-name case) + (cons variant case))) + (typed-variant-cases variant))) + (append-map typed-module-variants modules))) + + (def (lookup-name name env) + (let ([entry (assq name env)]) + (and entry (cdr entry)))) + + (def (lookup-record-constructor name) + (let loop ([rest (*rust-record-env*)]) + (cond + [(null? rest) #f] + [(eq? name (symbol-append "make-" (caar rest))) (cdar rest)] + [else (loop (cdr rest))]))) + + (def (lookup-record-predicate name) + (let loop ([rest (*rust-record-env*)]) + (cond + [(null? rest) #f] + [(eq? name (symbol-append (caar rest) "?")) (cdar rest)] + [else (loop (cdr rest))]))) + + (def (lookup-record-accessor name) + (let record-loop ([records (*rust-record-env*)]) + (cond + [(null? records) #f] + [else + (let* ([record (cdar records)] + [record-name (typed-record-name record)] + [prefix (symbol->string record-name)]) + (let field-loop ([fields (typed-record-fields record)]) + (cond + [(null? fields) (record-loop (cdr records))] + [(eq? name (symbol-append prefix "-" (typed-field-name (car fields)))) + (cons record (car fields))] + [else (field-loop (cdr fields))])))]))) + + (def (lookup-variant-constructor name) + (lookup-name name (*rust-variant-case-env*))) + + (def (lookup-variant-predicate name) + (let loop ([rest (*rust-variant-env*)]) + (cond + [(null? rest) #f] + [(eq? name (symbol-append (caar rest) "?")) (cdar rest)] + [else (loop (cdr rest))]))) + + (def (with-rust-env modules thunk) + (parameterize ([*rust-record-env* (record-env modules)] + [*rust-variant-env* (variant-env modules)] + [*rust-variant-case-env* (variant-case-env modules)]) + (thunk))) + (def (emit-record record port) (write-line port 0 "#[derive(Clone, Debug, PartialEq)]") (write-line port 0 @@ -268,12 +370,132 @@ (emit-expression (caddr args)) " }")) - (def (emit-call name args) + (def (emit-record-constructor-call record args) + (let ([fields (typed-record-fields record)]) + (string-append + (rust-symbol-name (typed-record-name record)) + " { " + (join-strings + (map (lambda (field arg) + (string-append + (rust-symbol-name (typed-field-name field)) + ": " + (emit-expression arg))) + fields + args) + ", ") + " }"))) + + (def (emit-record-accessor-call field-entry args) + (unless (= (length args) 1) + (error 'typed-rust "record accessor expects one argument" args)) + (let ([field (cdr field-entry)]) + (string-append + "(" + (emit-expression (car args)) + ")." + (rust-symbol-name (typed-field-name field))))) + + (def (emit-variant-constructor-call case-entry args) + (let* ([variant (car case-entry)] + [case (cdr case-entry)] + [fields (typed-variant-case-fields case)]) + (if (null? fields) + (string-append + (rust-symbol-name (typed-variant-name variant)) + "::" + (rust-symbol-name (typed-variant-case-name case))) + (string-append + (rust-symbol-name (typed-variant-name variant)) + "::" + (rust-symbol-name (typed-variant-case-name case)) + " { " + (join-strings + (map (lambda (field arg) + (string-append + (rust-symbol-name (typed-field-name field)) + ": " + (emit-expression arg))) + fields + args) + ", ") + " }")))) + + (def (emit-match-field-pattern field var) + (let ([field-name (rust-symbol-name (typed-field-name field))]) + (cond + [(eq? var '_) (string-append field-name ": _")] + [else + (let ([var-name (rust-symbol-name var)]) + (if (string=? field-name var-name) + field-name + (string-append field-name ": " var-name)))]))) + + (def (emit-match-case-pattern case-entry vars) + (let* ([variant (car case-entry)] + [case (cdr case-entry)] + [fields (typed-variant-case-fields case)] + [prefix + (string-append + (rust-symbol-name (typed-variant-name variant)) + "::" + (rust-symbol-name (typed-variant-case-name case)))]) + (if (null? fields) + prefix + (string-append + prefix + " { " + (join-strings (map emit-match-field-pattern fields vars) ", ") + " }")))) + + (def (emit-match-clause clause) + (let ([pattern (car clause)] + [body (cdr clause)]) + (cond + [(and (symbol? pattern) (memq pattern '(else _))) + (string-append "_ => " (emit-begin body) ",")] + [(and (pair? pattern) (symbol? (car pattern))) + (let ([case-entry (lookup-variant-constructor (car pattern))]) + (unless case-entry + (error 'typed-rust "unknown variant case in match" (car pattern))) + (string-append + (emit-match-case-pattern case-entry (cdr pattern)) + " => " + (emit-begin body) + ","))] + [else (error 'typed-rust "unsupported match pattern" pattern)]))) + + (def (emit-match args) + (unless (>= (length args) 2) + (error 'typed-rust "match expects target and clauses" args)) (string-append - (rust-symbol-name name) - "(" - (join-strings (map emit-expression args) ", ") - ")")) + "match " + (emit-expression (car args)) + " { " + (join-strings (map emit-match-clause (cdr args)) " ") + " }")) + + (def (emit-call name args) + (let ([record-constructor (lookup-record-constructor name)] + [record-accessor (lookup-record-accessor name)] + [record-predicate (lookup-record-predicate name)] + [variant-constructor (lookup-variant-constructor name)] + [variant-predicate (lookup-variant-predicate name)]) + (cond + [record-constructor + (emit-record-constructor-call record-constructor args)] + [record-accessor + (emit-record-accessor-call record-accessor args)] + [record-predicate "true"] + [variant-constructor + (emit-variant-constructor-call variant-constructor args)] + [variant-predicate "true"] + [else + (string-append + (rust-symbol-name name) + "(" + (join-strings (map emit-expression args) ", ") + ")")]))) (def (emit-expression expr) (cond @@ -306,7 +528,7 @@ (string-append "(!" (emit-expression (cadr expr)) ")")] [(and) (emit-bool-chain "&&" (cdr expr))] [(or) (emit-bool-chain "||" (cdr expr))] - [(match) (error 'typed-rust "match lowering is not implemented yet" expr)] + [(match) (emit-match (cdr expr))] [else (if (symbol? (car expr)) (emit-call (car expr) (cdr expr)) @@ -339,6 +561,7 @@ (write-line port 0 "// Generated by Jerboa's typed Rust backend. Do not edit.") (write-line port 0 "#![forbid(unsafe_code)]") (write-line port 0 "#![allow(unused_parens)]") + (write-line port 0 "#![allow(unused_variables)]") (newline port)) (def (emit-module-declarations module port) @@ -357,9 +580,11 @@ (error 'typed-module->rust-string "typed module has check errors" (map typed-check-error-kind errors))) - (emit-to-string - (lambda (port) - (emit-module module port))))) + (with-rust-env (list module) + (lambda () + (emit-to-string + (lambda (port) + (emit-module module port))))))) (def (typed-library-form->rust-string form) (typed-module->rust-string (parse-typed-library form))) @@ -373,13 +598,15 @@ "typed module has check errors" (map typed-check-error-kind errors))))) modules) - (emit-to-string - (lambda (port) - (emit-rust-header port) - (for-each - (lambda (module) - (emit-module-declarations module port)) - modules)))) + (with-rust-env modules + (lambda () + (emit-to-string + (lambda (port) + (emit-rust-header port) + (for-each + (lambda (module) + (emit-module-declarations module port)) + modules)))))) (def (typed-library-forms->rust-crate-string forms) (typed-modules->rust-crate-string (map parse-typed-library forms))) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -29,7 +29,7 @@ (+ x 1)))) (define calc-rust - "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![forbid(unsafe_code)]\n#![allow(unused_parens)]\n\npub fn zero() -> u64 {\n 0u64\n}\n\npub fn add_one(x: u64) -> u64 {\n (x + 1u64)\n}\n\n") + "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![forbid(unsafe_code)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\npub fn zero() -> u64 {\n 0u64\n}\n\npub fn add_one(x: u64) -> u64 {\n (x + 1u64)\n}\n\n") (define data-form '(typed-library (sample typed data) @@ -43,7 +43,30 @@ (Noop)))) (define data-rust - "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![forbid(unsafe_code)]\n#![allow(unused_parens)]\n\n#[derive(Clone, Debug, PartialEq)]\npub struct Pane {\n pub id: u64,\n pub focused_p: bool,\n}\n\n#[derive(Clone, Debug, PartialEq)]\npub enum EditOp {\n Insert {\n at: u64,\n text: String,\n },\n Noop,\n}\n\n") + "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![forbid(unsafe_code)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\n#[derive(Clone, Debug, PartialEq)]\npub struct Pane {\n pub id: u64,\n pub focused_p: bool,\n}\n\n#[derive(Clone, Debug, PartialEq)]\npub enum EditOp {\n Insert {\n at: u64,\n text: String,\n },\n Noop,\n}\n\n") + +(define ops-form + '(typed-library (sample typed ops) + (export pane-id make-insert make-noop edit-size) + (record Pane + ((id : Nat) + (mut focused? : Bool))) + (variant EditOp + (Insert (at : Nat) (text : String)) + (Noop)) + (def (pane-id (pane : Pane)) : Nat + (Pane-id pane)) + (def (make-insert (at : Nat) (text : String)) : EditOp + (Insert at text)) + (def (make-noop) : EditOp + (Noop)) + (def (edit-size (op : EditOp)) : Nat + (match op + ((Insert at text) at) + ((Noop) 0))))) + +(define ops-rust + "// Generated by Jerboa's typed Rust backend. Do not edit.\n#![forbid(unsafe_code)]\n#![allow(unused_parens)]\n#![allow(unused_variables)]\n\n#[derive(Clone, Debug, PartialEq)]\npub struct Pane {\n pub id: u64,\n pub focused_p: bool,\n}\n\n#[derive(Clone, Debug, PartialEq)]\npub enum EditOp {\n Insert {\n at: u64,\n text: String,\n },\n Noop,\n}\n\npub fn pane_id(pane: Pane) -> u64 {\n (pane).id\n}\n\npub fn make_insert(at: u64, text: String) -> EditOp {\n EditOp::Insert { at: at, text: text }\n}\n\npub fn make_noop() -> EditOp {\n EditOp::Noop\n}\n\npub fn edit_size(op: EditOp) -> u64 {\n match op { EditOp::Insert { at, text } => at, EditOp::Noop => 0u64, }\n}\n\n") (printf "--- Typed Jerboa Rust emitter tests ---~%") @@ -59,6 +82,10 @@ (typed-library-form->rust-string data-form) data-rust) +(test "rust lowers record and variant operations" + (typed-library-form->rust-string ops-form) + ops-rust) + (printf "~%Typed Rust emitter: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))