Support recursive Typed Jerboa matches
ober
e55ad6822d152fbdf076a5e2ae4e7fec0f753209
--- a/docs/jerboa-to-rust.md +++ b/docs/jerboa-to-rust.md @@ -246,7 +246,10 @@ structured error returns are still future work. The first recursive data lowering has also landed: variant fields that refer to their own variant type are emitted as `std::boxed::Box<T>` fields, and -constructors wrap those children when building Rust enum values. +constructors wrap those children when building Rust enum values. Match clauses +that bind recursive child fields clone the boxed child back into an owned typed +value before evaluating the branch body, which is enough for the first +recursive split-tree traversals. ## Generics @@ -551,7 +554,8 @@ Recommended first module: typed `split-tree`. Exports: - Initial landed slice: `make-leaf`, `make-split`, `split-tree?`, - `split-tree-size`, `leaf-id`, and `leaf-text` + `split-tree-size`, `split-tree-total-size`, `split-tree-valid?`, `leaf-id`, + and `leaf-text` - Next split-tree work: `split-tree-flatten`, `split-tree-find-parent`, `split-tree-remove`, and `split-tree-valid?` @@ -605,7 +609,8 @@ Second module: typed `rope`. - Support pattern matching. - Pass same-module records and variants through exported typed function boundaries as opaque handles. -- Box self-recursive variant fields in generated Rust. +- Box self-recursive variant fields in generated Rust and rebind recursive + match children as owned typed values for branch bodies. - Support equality and debug output. ### Milestone 4: First Real Module --- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -181,8 +181,9 @@ Current landing: dynamic calls are rejected by generated wrapper predicates before crossing the FFI boundary. - `make typed-split-tree-smoke` builds the first recursive split-tree slice: - typed leaf/split constructors, size and leaf accessors, dynamic wrapper - checks, string returns, opaque handles, and explicit handle drops. + typed leaf/split constructors, recursive total-size and validity traversals, + leaf accessors, dynamic wrapper checks, string returns, opaque handles, and + explicit handle drops. - `support/typed-rust.ss`, `make typed-rust`, and `make typed-build` generate a disposable Cargo crate under `build/typed/rust`; `typed-build` also writes wrappers under `build/typed/jerboa` and runs `cargo build` against the @@ -844,8 +845,10 @@ Minimum excluded features: ### Milestone 4: First Real Module - Implement typed `split-tree` or `rope`. An initial recursive split-tree slice - now lands in `tests/fixtures/typed/valid-split-tree.ss`. -- Add unit tests. Recursive variant lowering is covered by Rust emitter tests. + now lands in `tests/fixtures/typed/valid-split-tree.ss`, including recursive + child traversal through boxed Rust variant fields. +- Add unit tests. Recursive variant lowering and recursive match child + rebinding are covered by Rust emitter tests. - Add dynamic boundary tests. `make typed-split-tree-smoke` builds and calls the generated split-tree wrapper through Chez FFI. - Use it from a small part of Jerboa. --- a/lib/jerboa/typed/rust.ss +++ b/lib/jerboa/typed/rust.ss @@ -773,16 +773,50 @@ ", ") " }")))) - (def (emit-match-field-pattern field var) + (def (recursive-variant-field? variant field) + (equal? (typed-field-type field) + (typed-variant-name variant))) + + (def (match-box-binding-name var) + (string-append (rust-symbol-name var) "_box")) + + (def (emit-match-field-pattern variant field var) (let ([field-name (rust-symbol-name (typed-field-name field))]) (cond [(eq? var '_) (string-append field-name ": _")] + [(recursive-variant-field? variant field) + (string-append field-name ": " (match-box-binding-name var))] [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-recursive-binding variant field var) + (and (not (eq? var '_)) + (recursive-variant-field? variant field) + (string-append + "let " + (rust-symbol-name var) + " = (*" + (match-box-binding-name var) + ").clone();"))) + + (def (emit-match-recursive-bindings variant fields vars) + (let loop ([rest-fields fields] [rest-vars vars] [out '()]) + (cond + [(or (null? rest-fields) (null? rest-vars)) (reverse out)] + [else + (let ([binding + (emit-match-recursive-binding + variant + (car rest-fields) + (car rest-vars))]) + (loop + (cdr rest-fields) + (cdr rest-vars) + (if binding (cons binding out) out)))]))) + (def (emit-match-case-pattern case-entry vars) (let* ([variant (car case-entry)] [case (cdr case-entry)] @@ -797,7 +831,23 @@ (string-append prefix " { " - (join-strings (map emit-match-field-pattern fields vars) ", ") + (join-strings + (map (lambda (field var) + (emit-match-field-pattern variant field var)) + fields + vars) + ", ") + " }")))) + + (def (emit-match-branch-body prelude body) + (let ([body-expr (emit-begin body)]) + (if (null? prelude) + body-expr + (string-append + "{ " + (join-strings prelude " ") + " " + body-expr " }")))) (def (emit-match-clause clause) @@ -813,7 +863,12 @@ (string-append (emit-match-case-pattern case-entry (cdr pattern)) " => " - (emit-begin body) + (emit-match-branch-body + (emit-match-recursive-bindings + (car case-entry) + (typed-variant-case-fields (cdr case-entry)) + (cdr pattern)) + body) ","))] [else (error 'typed-rust "unsupported match pattern" pattern)]))) --- a/tests/fixtures/typed/valid-split-tree.ss +++ b/tests/fixtures/typed/valid-split-tree.ss @@ -1,5 +1,6 @@ (typed-library (sample typed split-tree) - (export make-leaf make-split split-tree? split-tree-size leaf-id leaf-text) + (export make-leaf make-split split-tree? split-tree-size split-tree-total-size + split-tree-valid? leaf-id leaf-text) (variant SplitTree (Leaf (id : Nat) (text : String)) @@ -19,6 +20,18 @@ ((Leaf _ text) (string-length text)) ((Split _ _ size) size))) + (def (split-tree-total-size (tree : SplitTree)) : Nat + (match tree + ((Leaf _ text) (string-length text)) + ((Split left right _) (+ (split-tree-total-size left) + (split-tree-total-size right))))) + + (def (split-tree-valid? (tree : SplitTree)) : Bool + (match tree + ((Leaf _ _) #t) + ((Split left right _) (and (split-tree-valid? left) + (split-tree-valid? right))))) + (def (leaf-id (tree : SplitTree)) : Nat (match tree ((Leaf id _) id) --- a/tests/test-typed-rust.ss +++ b/tests/test-typed-rust.ss @@ -98,7 +98,7 @@ (define recursive-form '(typed-library (sample typed recursive) - (export make-leaf make-split split-tree-size) + (export make-leaf make-split split-tree-size split-tree-total-size) (variant SplitTree (Leaf (id : Nat) (text : String)) (Split (left : SplitTree) (right : SplitTree) (size : Nat))) @@ -109,7 +109,12 @@ (def (split-tree-size (tree : SplitTree)) : Nat (match tree ((Leaf _ text) (string-length text)) - ((Split _ _ size) size))))) + ((Split _ _ size) size))) + (def (split-tree-total-size (tree : SplitTree)) : Nat + (match tree + ((Leaf _ text) (string-length text)) + ((Split left right _) (+ (split-tree-total-size left) + (split-tree-total-size right))))))) (define recursive-rust (typed-library-form->rust-string recursive-form)) @@ -221,6 +226,11 @@ "SplitTree::Split { left: std::boxed::Box::new(left), right: std::boxed::Box::new(right), size: size }")) #t) +(test "rust unboxes recursive match bindings" + (and (substring? recursive-rust + "SplitTree::Split { left: left_box, right: right_box, size: _ } => { let left = (*left_box).clone(); let right = (*right_box).clone(); (split_tree_total_size(left) + split_tree_total_size(right)) },")) + #t) + (test "rust lowers record and variant operations" (typed-library-form->rust-string ops-form) ops-rust) --- a/tests/test-typed-split-tree-e2e.ss +++ b/tests/test-typed-split-tree-e2e.ss @@ -40,6 +40,10 @@ (string=? (leaf-text left) "abc")) (check "split size" (= (split-tree-size root) 5)) +(check "split total size" + (= (split-tree-total-size root) 5)) +(check "split valid" + (split-tree-valid? root)) (check "split leaf fallback id" (= (leaf-id root) 0)) (check "split leaf fallback text"