Support split typed Kotlin modules
ober
7abb42877bde4c4027df22c8bd8ed7675a9c69e1
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -1676,6 +1676,56 @@ (list (cons 'inner-type type-arg)))) errors)))) + (def (infer-nullable-null? args env type-names expr) + (if (not (= (length args) 1)) + (values #f (bad-constructor-arity expr 'nullable-null? 1 args)) + (let-values ([(value-ir errors) + (infer-expression (car args) env type-names)]) + (let* ([value-type (ir-type value-ir)] + [inner-type (and (pair? value-type) + (eq? (car value-type) 'Nullable) + (cadr value-type))] + [type-errors + (if inner-type + '() + (list (make-check-error 'argument-type-mismatch + "nullable-null? expects a Nullable value" + expr + (expr-source (car args)))))] + [ok? (and value-ir (null? errors) (null? type-errors))]) + (values + (and ok? + (make-typed-ir-call 'Bool + (expr-source expr) 'jvm-nullable-null? 'nullable-null? + (list value-ir) + (list (cons 'inner-type inner-type)))) + (append errors type-errors)))))) + + (def (infer-nullable-get args env type-names expr) + (if (not (= (length args) 1)) + (values #f (bad-constructor-arity expr 'nullable-get 1 args)) + (let-values ([(value-ir errors) + (infer-expression (car args) env type-names)]) + (let* ([value-type (ir-type value-ir)] + [inner-type (and (pair? value-type) + (eq? (car value-type) 'Nullable) + (cadr value-type))] + [type-errors + (if inner-type + '() + (list (make-check-error 'argument-type-mismatch + "nullable-get expects a Nullable value" + expr + (expr-source (car args)))))] + [ok? (and value-ir (null? errors) (null? type-errors))]) + (values + (and ok? + (make-typed-ir-call inner-type + (expr-source expr) 'jvm-nullable-get 'nullable-get + (list value-ir) + (list (cons 'inner-type inner-type)))) + (append errors type-errors)))))) + (def (infer-result-ok args env type-names expr) (if (not (= (length args) 2)) (values #f (bad-constructor-arity expr 'result-ok 2 args)) @@ -2002,6 +2052,10 @@ (infer-nullable-some args env type-names expr)] [(nullable-none) (infer-nullable-none args env type-names expr)] + [(nullable-null?) + (infer-nullable-null? args env type-names expr)] + [(nullable-get) + (infer-nullable-get args env type-names expr)] [(result-ok) (infer-result-ok args env type-names expr)] [(result-err) @@ -2117,6 +2171,54 @@ [else #f])]) (loop (cdr rest) (if exported? (cons decl out) out)))])))) + (def (module-export-context imported-module) + (let* ([decls (exported-declarations imported-module)] + [type-names (declared-type-names decls)] + [call-sigs + (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)] + [variants + (append-map + (lambda (d) + (cond + [(typed-variant? d) + (list (cons (typed-variant-name d) d))] + [else '()])) + decls)]) + (values type-names call-sigs variants))) + + (def (same-module-context module module-registry) + ;; Kotlin package-level declarations in separate generated files share a + ;; package namespace. Model that by making earlier typed-library forms with + ;; the same module/package name visible to later forms. + (let loop ([rest module-registry] + [type-names '()] + [call-sigs '()] + [variants '()]) + (cond + [(null? rest) + (values (reverse type-names) + (reverse call-sigs) + (reverse variants))] + [(equal? (typed-module-name module) (caar rest)) + (let-values ([(types calls vars) + (module-export-context (cdar rest))]) + (loop (cdr rest) + (append (reverse types) type-names) + (append (reverse calls) call-sigs) + (append (reverse vars) variants)))] + [else + (loop (cdr rest) type-names call-sigs variants)]))) + (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. @@ -2142,35 +2244,13 @@ 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))]))]))) + (let-values ([(types calls vars) + (module-export-context (cdr entry))]) + (loop (cdr imports) + (append types type-names) + (append calls call-sigs) + (append vars variants) + errors))]))]))) (def (module-registry-from-list modules) (map (lambda (m) (cons (typed-module-name m) m)) modules)) @@ -2190,9 +2270,11 @@ [calls (call-env declarations)] [variants (declared-variant-env declarations)]) (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)]) + (build-import-context module registry)] + [(same-types same-calls same-variants) + (same-module-context module registry)]) + (parameterize ([*call-env* (append import-calls same-calls calls)] + [*variant-env* (append import-variants same-variants variants)]) (append import-errors (duplicate-errors 'duplicate-type @@ -2204,7 +2286,8 @@ (check-exports (typed-module-exports module) value-names) (append-map (lambda (decl) - (check-declaration decl (append import-types type-names))) + (check-declaration decl + (append import-types same-types type-names))) declarations)))))) (def (check-typed-modules modules) --- a/lib/jerboa/typed/kotlin.ss +++ b/lib/jerboa/typed/kotlin.ss @@ -13,7 +13,9 @@ typed-type->kotlin-type typed-module->kotlin-file + typed-modules->kotlin-files typed-module->kotlin-string + typed-library-forms->kotlin-files typed-library-form->kotlin-string) (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed Kotlin backend facade --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -5,7 +5,9 @@ (export typed-type->kotlin-type typed-module->kotlin-file + typed-modules->kotlin-files typed-module->kotlin-string + typed-library-forms->kotlin-files typed-library-form->kotlin-string) (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler Kotlin lowerer @@ -336,6 +338,10 @@ (car args)] [(jvm-nullable-none) (make-kt-lit 'Null '())] + [(jvm-nullable-null?) + (make-kt-binary "==" (car args) (make-kt-lit 'Null '()))] + [(jvm-nullable-get) + (make-kt-unary "!!" (car args))] [(result-ok) (make-kt-call (make-kt-name '(JbResult Ok)) args)] [(result-err) @@ -520,6 +526,27 @@ (elaborated-def-body-ir ed))) defs))) + (def (elaborated-defs->ir-env defs) + (map (lambda (ed) + (cons (elaborated-def-name ed) + (elaborated-def-body-ir ed))) + defs)) + + (def (lower-module->kotlin-file module modules ir-env) + (with-kotlin-env modules + (lambda () + (parameterize ([*kotlin-ir-env* ir-env]) + (make-kt-file + (typed-module-name module) + '() + (let loop ([decls (typed-module-declarations module)] [out '()]) + (cond + [(null? decls) (reverse out)] + [else + (let ([lowered (lower-declaration (car decls))]) + (loop (cdr decls) + (if lowered (cons lowered out) out)))]))))))) + (def (typed-module->kotlin-file module) (let ([ir-env (elaborate-module-or-error module 'typed-module->kotlin-file)]) (with-kotlin-env (list module) @@ -536,8 +563,39 @@ (loop (cdr decls) (if lowered (cons lowered out) out)))])))))))) + (def (module-ir-envs-or-error modules who) + (let* ([results (check-and-elaborate-typed-modules modules)] + [errors + (append-map + (lambda (result) + (let ([module-name (car result)] + [module-errors (cadr result)]) + (map (lambda (error) (cons module-name error)) + module-errors))) + results)]) + (unless (null? errors) + (error who + "typed modules have check errors" + (map (lambda (entry) + (list (car entry) (typed-check-error-kind (cdr entry)))) + errors))) + (map (lambda (result) + (elaborated-defs->ir-env (caddr result))) + results))) + + (def (typed-modules->kotlin-files modules) + (let ([ir-envs + (module-ir-envs-or-error modules 'typed-modules->kotlin-files)]) + (map lower-module->kotlin-file + modules + (map (lambda (_) modules) modules) + ir-envs))) + (def (typed-module->kotlin-string module) (kotlin-file->string (typed-module->kotlin-file module))) (def (typed-library-form->kotlin-string form) - (typed-module->kotlin-string (parse-typed-library form)))) + (typed-module->kotlin-string (parse-typed-library form))) + + (def (typed-library-forms->kotlin-files forms) + (typed-modules->kotlin-files (map parse-typed-library forms)))) --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -248,9 +248,14 @@ " " (kotlin-expr->string (kt-binary-right expr))))] [(kt-unary? expr) - (parenthesize - (string-append (kt-unary-op expr) - (kotlin-expr->string (kt-unary-expr expr))))] + (if (string=? (kt-unary-op expr) "!!") + (parenthesize + (string-append + (kotlin-expr->string (kt-unary-expr expr)) + "!!")) + (parenthesize + (string-append (kt-unary-op expr) + (kotlin-expr->string (kt-unary-expr expr)))))] [(kt-if? expr) (string-append "if (" --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -170,6 +170,53 @@ (test-contains "Nullable lowers to Kotlin nullable type" jvm-kotlin "data class SsdSession(val sessionId: String, val ssdArea: FloatArray?)") +(define cross-module-forms + (list + '(typed-library (sample typed base) + (export make-Thing Thing? Thing-name) + (record Thing + ((name : String)))) + '(typed-library (sample typed use) + (export describe) + (import (sample typed base)) + (def (describe (thing : Thing)) : String + (string-append "Thing: " (Thing-name thing)))))) + +(define cross-module-kotlin + (map kotlin-file->string + (typed-library-forms->kotlin-files cross-module-forms))) + +(test-contains "multi-module Kotlin emits imported record user" + (cadr cross-module-kotlin) + "fun describe(thing: Thing): String") +(test-contains "multi-module Kotlin lowers imported record accessor" + (cadr cross-module-kotlin) + "thing.name") + +(define same-package-forms + (list + '(typed-library (sample typed split) + (export make-Cell Cell? Cell-x) + (type Int32) + (record Cell + ((x : Int32)))) + '(typed-library (sample typed split) + (export cellX) + (type Int32) + (def (cellX (cell : Cell)) : Int32 + (Cell-x cell))))) + +(define same-package-kotlin + (map kotlin-file->string + (typed-library-forms->kotlin-files same-package-forms))) + +(test-contains "same-package Kotlin files share earlier records" + (cadr same-package-kotlin) + "fun cellX(cell: Cell): Int") +(test-contains "same-package Kotlin files share earlier accessors" + (cadr same-package-kotlin) + "return cell.x") + (define nullable-form '(typed-library (sample typed nullable) (export nonBlank) @@ -179,8 +226,18 @@ (nullable-none String) (nullable-some trimmed)))))) +(define nullable-access-form + '(typed-library (sample typed nullable-access) + (export orDefault) + (def (orDefault (value : (Nullable String))) : String + (if (nullable-null? value) + "fallback" + (nullable-get value))))) + (define nullable-kotlin (typed-library-form->kotlin-string nullable-form)) +(define nullable-access-kotlin + (typed-library-form->kotlin-string nullable-access-form)) (test-contains "nullable return lowers to Kotlin nullable return" nullable-kotlin @@ -191,6 +248,12 @@ (test-contains "nullable some lowers to wrapped value directly" nullable-kotlin "else trimmed") +(test-contains "nullable null test lowers to Kotlin null comparison" + nullable-access-kotlin + "(value == null)") +(test-contains "nullable get lowers to checked JVM non-null" + nullable-access-kotlin + "(value!!)") (define geometry-form '(typed-library (sample typed geometry)