Resolve Typed Jerboa imports in the checker
ober
65d4ac9034c49bdca93ebdd64101225935b6a88c
--- a/docs/typed-jerboa.md +++ b/docs/typed-jerboa.md @@ -286,8 +286,13 @@ Highest-value next steps: IR through `*rust-ir-env*` in `typed-module->rust-string` and `typed-modules->rust-crate-string`. The wrapper generator still walks surface AST, which is fine for ABI-level shape information. -2. Resolve imports between typed modules. The checker currently handles calls - within one typed module only; imported calls are intentionally unsupported. +2. Resolve imports between typed modules. The parser now accepts an optional + `(import (module name) ...)` clause and the checker offers + `check-typed-modules` / `check-and-elaborate-typed-modules`, which walk a + topologically ordered module list and extend each module's type/call/variant + envs with the previously listed modules' exported declarations. The Rust + emitter does not yet emit cross-module `use` declarations or split the + generated crate into per-module files. 3. Improve boundary semantics for Option/Result. They currently cross the FFI boundary as opaque handles; direct conversion to idiomatic Scheme result values is still open. --- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -12,7 +12,9 @@ typed-check-error-hint typed-check-error->string check-typed-module + check-typed-modules check-and-elaborate-typed-module + check-and-elaborate-typed-modules elaborate-typed-def-ir elaborated-def? make-elaborated-def @@ -1511,27 +1513,141 @@ (car rest)) out))])))) - (def (check-typed-module module) - (let* ([declarations (typed-module-declarations module)] + (def (exported-declarations module) + (let ([exports (typed-module-exports module)]) + (let loop ([rest (typed-module-declarations module)] [out '()]) + (cond + [(null? rest) (reverse out)] + [else + (let* ([decl (car rest)] + [values (declaration-value-names decl)] + [exported? + (cond + [(typed-def? decl) (memq (typed-def-name decl) exports)] + [(typed-record? decl) + (or (memq (typed-record-name decl) exports) + (let any-loop ([rs values]) + (cond + [(null? rs) #f] + [(memq (car rs) exports) #t] + [else (any-loop (cdr rs))])))] + [(typed-variant? decl) + (or (memq (typed-variant-name decl) exports) + (let any-loop ([rs values]) + (cond + [(null? rs) #f] + [(memq (car rs) exports) #t] + [else (any-loop (cdr rs))])))] + [else #f])]) + (loop (cdr rest) (if exported? (cons decl out) out)))])))) + + (def (build-import-context module module-registry) + ;; Returns (values type-names call-sigs variant-env errors). Each imported + ;; module contributes its exported records, variants, and defs. + (let loop ([imports (typed-module-imports module)] + [type-names '()] + [call-sigs '()] + [variants '()] + [errors '()]) + (cond + [(null? imports) + (values (reverse type-names) + (reverse call-sigs) + (reverse variants) + (reverse errors))] + [else + (let* ([modname (car imports)] + [entry (assoc modname module-registry)]) + (cond + [(not entry) + (loop (cdr imports) type-names call-sigs variants + (cons (make-check-error 'unknown-import + "imported module is not in the module registry" + modname) + errors))] + [else + (let* ([imported-module (cdr entry)] + [decls (exported-declarations imported-module)] + [type-names+ + (append (declared-type-names decls) type-names)] + [call-sigs+ + (append + (append-map + (lambda (d) + (cond + [(and (typed-def? d) + (memq (typed-def-name d) + (typed-module-exports imported-module))) + (list (function-signature d))] + [(typed-record? d) (record-call-signatures d)] + [(typed-variant? d) (variant-call-signatures d)] + [else '()])) + decls) + call-sigs)] + [variants+ + (append + (append-map + (lambda (d) + (cond + [(typed-variant? d) + (list (cons (typed-variant-name d) d))] + [else '()])) + decls) + variants)]) + (loop (cdr imports) type-names+ call-sigs+ variants+ errors))]))]))) + + (def (module-registry-from-list modules) + (map (lambda (m) (cons (typed-module-name m) m)) modules)) + + (def (check-typed-module module . opts) + ;; opts may include (registry <module-registry>) to enable import resolution. + (let* ([registry (cond + [(null? opts) '()] + [(and (pair? opts) (eq? (car opts) 'registry)) + (cadr opts)] + [else + (error 'check-typed-module + "unexpected option keyword" opts)])] + [declarations (typed-module-declarations module)] [type-names (declared-type-names declarations)] [value-names (declared-value-names declarations)] [calls (call-env declarations)] [variants (declared-variant-env declarations)]) - (parameterize ([*call-env* calls] - [*variant-env* variants]) - (append - (duplicate-errors 'duplicate-type - "duplicate type declaration" - type-names) - (duplicate-errors 'duplicate-value - "duplicate value declaration" - value-names) - (check-exports (typed-module-exports module) value-names) - (append-map - (lambda (decl) (check-declaration decl type-names)) - declarations))))) - - (def (check-and-elaborate-typed-module module) + (let-values ([(import-types import-calls import-variants import-errors) + (build-import-context module registry)]) + (parameterize ([*call-env* (append import-calls calls)] + [*variant-env* (append import-variants variants)]) + (append + import-errors + (duplicate-errors 'duplicate-type + "duplicate type declaration" + type-names) + (duplicate-errors 'duplicate-value + "duplicate value declaration" + value-names) + (check-exports (typed-module-exports module) value-names) + (append-map + (lambda (decl) + (check-declaration decl (append import-types type-names))) + declarations)))))) + + (def (check-typed-modules modules) + ;; Returns a list of (module-name . errors) entries in input order. Each + ;; module sees the *previously listed* modules as importable, so the + ;; caller is responsible for topological ordering. + (let loop ([rest modules] [registry '()] [out '()]) + (cond + [(null? rest) (reverse out)] + [else + (let* ([module (car rest)] + [errors (check-typed-module module 'registry registry)] + [next-registry + (cons (cons (typed-module-name module) module) registry)]) + (loop (cdr rest) + next-registry + (cons (cons (typed-module-name module) errors) out)))]))) + + (def (check-and-elaborate-typed-module module . opts) ;; Returns (values errors elaborated-defs), where elaborated-defs is a ;; list of elaborated-def records in declaration order. Only defs whose ;; bodies passed all checks appear in the list; their body-ir field is a @@ -1539,7 +1655,7 @@ (let ([acc (box '())]) (let ([errors (parameterize ([*elaboration-acc* acc]) - (check-typed-module module))]) + (apply check-typed-module module opts))]) (let* ([entries (reverse (unbox acc))] [defs (let loop ([rest (typed-module-declarations module)] [out '()]) @@ -1558,6 +1674,24 @@ [else (loop (cdr rest) out)]))]) (values errors defs))))) + (def (check-and-elaborate-typed-modules modules) + ;; Returns a list of (module-name errors elaborated-defs) triples in + ;; input order. Each module sees previously listed modules as importable. + (let loop ([rest modules] [registry '()] [out '()]) + (cond + [(null? rest) (reverse out)] + [else + (let ([module (car rest)]) + (let-values ([(errs defs) + (check-and-elaborate-typed-module + module 'registry registry)]) + (let ([next-registry + (cons (cons (typed-module-name module) module) registry)]) + (loop (cdr rest) + next-registry + (cons (list (typed-module-name module) errs defs) + out)))))]))) + (def (elaborate-typed-def-ir def module) ;; Convenience for callers that want a single def's body IR. (let-values ([(errors defs) --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -1166,6 +1166,82 @@ (typed-ir-call-kind inner))) 'prim-arith) +;; --- Module imports ------------------------------------------------------ + +(define provider-form + '(typed-library (provider one) + (export inc make-Pair-N Pair-N-a Pair-N-b TA TB Tag?) + + (record Pair-N + ((a : Nat) (b : Nat))) + + (variant Tag + (TA (n : Nat)) + (TB)) + + (def (inc (x : Nat)) : Nat (+ x 1)))) + +(define provider-module (parse-typed-library provider-form)) + +(define consumer-form + '(typed-library (consumer) + (export use-inc use-pair use-tag) + + (import (provider one)) + + (def (use-inc (n : Nat)) : Nat + (inc n)) + + (def (use-pair (a : Nat) (b : Nat)) : Pair-N + (make-Pair-N a b)) + + (def (use-tag (t : Tag)) : Nat + (match t + [(TA n) n] + [(TB) 0])))) + +(define consumer-module (parse-typed-library consumer-form)) + +(test "consumer alone has errors due to missing imports" + (let ([kinds (map typed-check-error-kind + (check-typed-module consumer-module))]) + (not (null? kinds))) + #t) + +(test "consumer with provider in registry has no errors" + (check-typed-modules (list provider-module consumer-module)) + '(((provider one)) ((consumer)))) + +(test "provider before consumer order matters" + (let* ([results (check-typed-modules + (list consumer-module provider-module))] + [consumer-errors (cdr (assoc '(consumer) results))]) + (not (null? consumer-errors))) + #t) + +(test "unknown import emits unknown-import error" + (let ([results + (check-typed-modules + (list + (parse-typed-library + '(typed-library (lonely) + (export f) + (import (no-such-module)) + (def (f (x : Nat)) : Nat x)))))]) + (map typed-check-error-kind (cdr (assoc '(lonely) results)))) + '(unknown-import)) + +(test "check-and-elaborate-typed-modules returns IR for resolved imports" + (let* ([results (check-and-elaborate-typed-modules + (list provider-module consumer-module))] + [consumer-entry (assoc '(consumer) results)] + [consumer-errs (cadr consumer-entry)] + [consumer-defs (caddr consumer-entry)]) + (and (null? consumer-errs) + (= (length consumer-defs) 3) + (map elaborated-def-name consumer-defs))) + '(use-inc use-pair use-tag)) + (printf "~%Typed checker: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))