Add typed Kotlin backend foundation
ober
e666dfb8a217784b1672cd7f9cbf826d2bf08cbf
--- a/Makefile +++ b/Makefile @@ -72,7 +72,7 @@ TYPED_LLVMIR_PARITY_FN ?= sample_typed_llvmir_smoke::main LLVM_BIN ?= $(shell if command -v llvm-as >/dev/null 2>&1; then dirname "$$(command -v llvm-as)"; elif [ -x /opt/homebrew/opt/llvm/bin/llvm-as ]; then echo /opt/homebrew/opt/llvm/bin; elif [ -x /usr/local/opt/llvm/bin/llvm-as ]; then echo /usr/local/opt/llvm/bin; fi) TYPED_WRAPPER_DIR ?= build/typed/jerboa -.PHONY: help chez static-supported-check chez-cross build binary binary-typed binary-typed-smoke binary-cross native-cross pure-audit typecheck typed-rust typed-llvmir typed-llvmir-check typed-llvmir-smoke typed-llvmir-parity typed-wrappers typed-build typed-wrapper-smoke typed-split-tree-smoke typed-test typed-clean test test-known-flaky test-reader test-core test-runtime test-try-debug test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-sqlite-robustness test-limits-primitives test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-llvmir test-typed-wrappers 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 audit-native security-audit clean security security-production security-profile security-hardware-smoke sbom reproducibility-report reproducibility-compare verify release-evidence 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 data-check docker-build docker-push +.PHONY: help chez static-supported-check chez-cross build binary binary-typed binary-typed-smoke binary-cross native-cross pure-audit typecheck typed-rust typed-llvmir typed-llvmir-check typed-llvmir-smoke typed-llvmir-parity typed-wrappers typed-build typed-wrapper-smoke typed-split-tree-smoke typed-test typed-clean test test-known-flaky test-reader test-core test-runtime test-try-debug test-stdlib test-ffi test-modules test-expanded test-contract test-ergo test-sqlite-robustness test-limits-primitives test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-kotlin test-typed-llvmir test-typed-wrappers 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 audit-native security-audit clean security security-production security-profile security-hardware-smoke sbom reproducibility-report reproducibility-compare verify release-evidence 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 data-check docker-build docker-push .PHONY: check-cross-tools docker fuzz-websocket-fuzz jlsp jlsp-freebsd-amd64 \ jlsp-install jlsp-linux-amd64 jlsp-portable jmcp-freebsd-amd64 \ jmcp-freebsd-arm64 jmcp-linux-amd64 jmcp-linux-arm64 \ @@ -195,6 +195,7 @@ help: @echo " test-typed-parser Typed Jerboa parser tests" @echo " test-typed-checker Typed Jerboa checker tests" @echo " test-typed-rust Typed Jerboa Rust emitter tests" + @echo " test-typed-kotlin Typed Jerboa Kotlin emitter tests" @echo " test-typed-llvmir Typed Jerboa LLVM IR emitter tests" @echo " test-typed-wrappers Typed Jerboa wrapper generator tests" @echo " test-pure-audit Pure Jerboa migration scanner tests" @@ -1227,7 +1228,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-llvmir test-typed-wrappers test-typed-fuzz typecheck +typed-test: test-typed-core test-typed-parser test-typed-checker test-typed-rust test-typed-kotlin test-typed-llvmir test-typed-wrappers test-typed-fuzz typecheck # Build a jerboa-bin that bakes in a Typed Jerboa Rust .a archive. The # generated wrapper resolves its `jt_*` symbols via dlsym(RTLD_DEFAULT) — no @@ -1330,6 +1331,9 @@ test-typed-checker: test-typed-rust: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-rust.ss +test-typed-kotlin: + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-kotlin.ss + test-typed-llvmir: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-typed-llvmir.ss --- a/data/changelog.sexp +++ b/data/changelog.sexp @@ -2,7 +2,24 @@ . "Machine-readable changelog of Jerboa API drift. Consumers (LLM tooling, lints, jerboa_verify) use this to invalidate stale recommendations and to suggest migrations when a symbol is renamed or relocated.") ("entries" - (("added" ("*sandbox-max-children*")) + (("added" "typed-library-form->kotlin-string" + "typed-module->kotlin-string" "typed-module->kotlin-file" + "typed-type->kotlin-type" "kotlin-file->string" + "kotlin-expr->string") + ("date" . "2026-07-15") + ("modules_added" "(jerboa typed kotlin)" + "(jerboa typed kotlin ast)" "(jerboa typed kotlin lower)" + "(jerboa typed kotlin print)") + ("moved") + ("notes" + . + "Typed Jerboa now has an initial structured Kotlin backend. The backend lowers checked typed-library modules to a Kotlin AST and deterministic printer, supports the current portable typed subset for top-level functions, records, variants, basic expressions, and simple for/fold, and intentionally exposes no raw Kotlin/Java source node.") + ("removed") + ("renamed") + ("tier_changes") + ("tools_added" "test-typed-kotlin") + ("version" . "v0.2.4")) + (("added" ("*sandbox-max-children*")) ("date" . "2026-06-25") ("modules_added") ("moved") new file mode 100644 --- /dev/null +++ b/docs/typed-kotlin.md @@ -0,0 +1,44 @@ +# Typed Jerboa Kotlin Backend + +The `(jerboa typed kotlin)` backend lowers checked `typed-library` forms to a +structured Kotlin AST and then prints deterministic Kotlin source. Kotlin text +is always output, not input: the AST has no raw-source node. + +The first implementation slice supports the portable typed subset already used +by the Rust and LLVM work: + +- top-level typed functions; +- records as Kotlin `data class` declarations; +- variants as Kotlin `sealed class` declarations with `data class` and + `data object` cases; +- literals, variables, `begin`, `let`, `if`, same-module calls, arithmetic, + comparison, boolean operations, record construction/access, variant + construction, and simple `for/fold`. + +Public entry points: + +```scheme +(import (jerboa typed kotlin)) + +(typed-library-form->kotlin-string + '(typed-library (sample typed calc) + (export add-one) + (def (add-one (x : Nat)) : Nat + (+ x 1)))) +``` + +The generated file starts with a stable header and package: + +```kotlin +// Generated by Jerboa's typed Kotlin backend. Do not edit. + +package sample.typed.calc + +fun add_one(x: ULong): ULong { + return (x + 1uL) +} +``` + +Unsupported typed IR fails closed with a backend error. Add a structured KAST +node and printer support for any new Kotlin feature before adding a lowerer +case; do not add raw Kotlin, raw Java, or target-language string escape hatches. new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/kotlin.ss @@ -0,0 +1,21 @@ +#!chezscheme +;;; (jerboa typed kotlin) -- public Typed Jerboa Kotlin backend API + +(library (jerboa typed kotlin) + (export + kotlin-symbol-name + kotlin-package-name + kotlin-string-literal + kotlin-char-literal + kotlin-type->string + kotlin-expr->string + kotlin-file->string + + typed-type->kotlin-type + typed-module->kotlin-file + typed-module->kotlin-string + typed-library-form->kotlin-string) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed Kotlin backend facade + (jerboa typed kotlin print) + (jerboa typed kotlin lower))) new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/kotlin/ast.ss @@ -0,0 +1,132 @@ +#!chezscheme +;;; (jerboa typed kotlin ast) -- structured Kotlin output model +;;; +;;; This module defines the backend-owned Kotlin AST used by the typed Kotlin +;;; printer and lowerer. It deliberately has no "raw source" node: all output +;;; must be represented as declarations, statements, expressions, types, names, +;;; imports, and literals that the printer owns. + +(library (jerboa typed kotlin ast) + (export + kt-file? make-kt-file + kt-file-package kt-file-imports kt-file-declarations + + kt-import? make-kt-import + kt-import-path kt-import-alias + + kt-type? make-kt-type + kt-type-name kt-type-nullable? kt-type-args + + kt-param? make-kt-param + kt-param-name kt-param-type kt-param-default + kt-param-property kt-param-mutable? kt-param-visibility + + kt-class? make-kt-class + kt-class-kind kt-class-visibility kt-class-name + kt-class-params kt-class-super-types kt-class-body + kt-class-annotations + + kt-function? make-kt-function + kt-function-visibility kt-function-name kt-function-params + kt-function-return-type kt-function-body kt-function-annotations + + kt-property? make-kt-property + kt-property-visibility kt-property-mutable? + kt-property-name kt-property-type kt-property-init + kt-property-annotations + + kt-return? make-kt-return + kt-return-expr + + kt-val? make-kt-val + kt-val-mutable? kt-val-name kt-val-type kt-val-init + + kt-assign? make-kt-assign + kt-assign-target kt-assign-expr + + kt-for-range? make-kt-for-range + kt-for-range-var kt-for-range-start kt-for-range-end + kt-for-range-body + + kt-expr-stmt? make-kt-expr-stmt + kt-expr-stmt-expr + + kt-lit? make-kt-lit + kt-lit-type kt-lit-value + + kt-name? make-kt-name + kt-name-parts + + kt-call? make-kt-call + kt-call-callee kt-call-args + + kt-member-call? make-kt-member-call + kt-member-call-target kt-member-call-name kt-member-call-args + + kt-member-get? make-kt-member-get + kt-member-get-target kt-member-get-name + + kt-binary? make-kt-binary + kt-binary-op kt-binary-left kt-binary-right + + kt-unary? make-kt-unary + kt-unary-op kt-unary-expr + + kt-if? make-kt-if + kt-if-test kt-if-then kt-if-else + + kt-block? make-kt-block + kt-block-statements kt-block-result + + kt-new? make-kt-new + kt-new-type kt-new-args + + kt-when? make-kt-when + kt-when-subject kt-when-branches + + kt-when-branch? make-kt-when-branch + kt-when-branch-pattern kt-when-branch-body) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted Kotlin AST library + (only (jerboa core) defstruct)) + + ;; Files and imports. + (defstruct kt-file (package imports declarations)) + (defstruct kt-import (path alias)) + + ;; Types. `name` is a symbol, string, or list of package/name parts. + (defstruct kt-type (name nullable? args)) + + ;; Function/constructor parameters. When `property` is 'val or 'var, the + ;; printer emits the parameter as a Kotlin primary-constructor property. + (defstruct kt-param (name type default property mutable? visibility)) + + ;; Declarations. `kind` is one of: class, data-class, sealed-class, object, + ;; data-object, interface, enum. + (defstruct kt-class + (kind visibility name params super-types body annotations)) + (defstruct kt-function + (visibility name params return-type body annotations)) + (defstruct kt-property + (visibility mutable? name type init annotations)) + + ;; Statements. + (defstruct kt-return (expr)) + (defstruct kt-val (mutable? name type init)) + (defstruct kt-assign (target expr)) + (defstruct kt-for-range (var start end body)) + (defstruct kt-expr-stmt (expr)) + + ;; Expressions. + (defstruct kt-lit (type value)) + (defstruct kt-name (parts)) + (defstruct kt-call (callee args)) + (defstruct kt-member-call (target name args)) + (defstruct kt-member-get (target name)) + (defstruct kt-binary (op left right)) + (defstruct kt-unary (op expr)) + (defstruct kt-if (test then else)) + (defstruct kt-block (statements result)) + (defstruct kt-new (type args)) + (defstruct kt-when (subject branches)) + (defstruct kt-when-branch (pattern body))) new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -0,0 +1,405 @@ +#!chezscheme +;;; (jerboa typed kotlin lower) -- Typed Jerboa IR to structured Kotlin AST + +(library (jerboa typed kotlin lower) + (export + typed-type->kotlin-type + typed-module->kotlin-file + typed-module->kotlin-string + typed-library-form->kotlin-string) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted typed compiler Kotlin lowerer + (only (jerboa core) def) + (jerboa typed parser) + (jerboa typed checker) + (jerboa typed core) + (jerboa typed kotlin ast) + (jerboa typed kotlin print)) + + (def *kotlin-record-env* (make-parameter '())) + (def *kotlin-variant-env* (make-parameter '())) + (def *kotlin-variant-case-env* (make-parameter '())) + (def *kotlin-ir-env* (make-parameter '())) + + (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 (with-kotlin-env modules thunk) + (parameterize ([*kotlin-record-env* (record-env modules)] + [*kotlin-variant-env* (variant-env modules)] + [*kotlin-variant-case-env* (variant-case-env modules)]) + (thunk))) + + (def (lookup alist key) + (let ([entry (assq key alist)]) + (and entry (cdr entry)))) + + (def (info-ref info key default) + (let ([entry (assq key info)]) + (if entry (cdr entry) default))) + + (def (typed-type->kotlin-type type) + (cond + [(symbol? type) + (case type + [(Unit) (make-kt-type 'Unit #f '())] + [(Bool) (make-kt-type 'Boolean #f '())] + [(Char) (make-kt-type 'Char #f '())] + [(Int Fixnum) (make-kt-type 'Long #f '())] + [(Nat) (make-kt-type 'ULong #f '())] + [(Float) (make-kt-type 'Double #f '())] + [(String) (make-kt-type 'String #f '())] + [(Bytes) (make-kt-type 'ByteArray #f '())] + [(Symbol Keyword) (make-kt-type 'String #f '())] + [else (make-kt-type type #f '())])] + [(and (pair? type) (eq? (car type) 'List)) + (make-kt-type 'List #f (list (typed-type->kotlin-type (cadr type))))] + [(and (pair? type) (eq? (car type) 'Vector)) + (make-kt-type 'List #f (list (typed-type->kotlin-type (cadr type))))] + [(and (pair? type) (eq? (car type) 'Pair)) + (make-kt-type 'Pair #f + (list (typed-type->kotlin-type (cadr type)) + (typed-type->kotlin-type (caddr type))))] + [(and (pair? type) (eq? (car type) 'Option)) + (make-kt-type 'JbOption #f + (list (typed-type->kotlin-type (cadr type))))] + [(and (pair? type) (eq? (car type) 'Result)) + (make-kt-type 'JbResult #f + (list (typed-type->kotlin-type (cadr type)) + (typed-type->kotlin-type (caddr type))))] + [(and (pair? type) (memq (car type) '(Owned Borrow MutBorrow))) + (typed-type->kotlin-type (cadr type))] + [else (error 'typed-type->kotlin-type "unsupported typed Jerboa type" type)])) + + (def (kt-name1 sym) + (make-kt-name (list sym))) + + (def (lower-lit type value) + (cond + [(eq? type 'Unit) (make-kt-lit 'Unit '())] + [(eq? type 'Bool) (make-kt-lit 'Bool value)] + [(eq? type 'Char) (make-kt-lit 'Char value)] + [(eq? type 'String) (make-kt-lit 'String value)] + [(eq? type 'Symbol) (make-kt-lit 'Symbol (symbol->string value))] + [(eq? type 'Keyword) (make-kt-lit 'Keyword (symbol->string value))] + [(eq? type 'Nat) (make-kt-lit 'Nat value)] + [(or (eq? type 'Int) (eq? type 'Fixnum)) (make-kt-lit 'Int value)] + [(eq? type 'Float) (make-kt-lit 'Float value)] + [else (error 'lower-lit "unsupported literal type" type value)])) + + (def (chain-binary op args) + (cond + [(null? args) (error 'chain-binary "expected at least one arg" op)] + [(null? (cdr args)) (car args)] + [else + (let loop ([acc (make-kt-binary op (car args) (cadr args))] + [rest (cddr args)]) + (if (null? rest) + acc + (loop (make-kt-binary op acc (car rest)) (cdr rest))))])) + + (def (arith-op op) + (case op + [(+) "+"] + [(-) "-"] + [(*) "*"] + [(/) "/"] + [else (error 'arith-op "unsupported arithmetic op" op)])) + + (def (cmp-op op) + (case op + [(=) "=="] + [(<) "<"] + [(<=) "<="] + [(>) ">"] + [(>=) ">="] + [else (error 'cmp-op "unsupported comparison op" op)])) + + (def (bitwise-op op) + (case op + [(bitwise-and) "and"] + [(bitwise-ior) "or"] + [(bitwise-xor) "xor"] + [else #f])) + + (def (lower-call ir) + (let* ([kind (typed-ir-call-kind ir)] + [operator (typed-ir-call-operator ir)] + [args (map lower-expr (typed-ir-call-args ir))] + [info (typed-ir-call-info ir)]) + (case kind + [(function) + (make-kt-call (kt-name1 operator) args)] + [(prim-arith) + (chain-binary (arith-op operator) args)] + [(prim-cmp) + (chain-binary (cmp-op operator) args)] + [(prim-eq) + (chain-binary "==" args)] + [(prim-bool) + (case operator + [(not) (make-kt-unary "!" (car args))] + [(and) (chain-binary "&&" args)] + [(or) (chain-binary "||" args)] + [else (error 'lower-call "unsupported boolean primitive" operator)])] + [(prim-bitwise) + (cond + [(eq? operator 'bitwise-not) + (make-kt-member-call (car args) 'inv '())] + [(bitwise-op operator) + (chain-binary (bitwise-op operator) args)] + [else (error 'lower-call "unsupported bitwise primitive" operator)])] + [(prim-shift) + (case operator + [(bitwise-arithmetic-shift-left) + (make-kt-member-call (car args) 'shl (list (cadr args)))] + [(bitwise-arithmetic-shift-right) + (make-kt-member-call (car args) 'shr (list (cadr args)))] + [else (error 'lower-call "unsupported shift primitive" operator)])] + [(string-length) + (make-kt-member-call + (make-kt-member-get (car args) 'length) + 'toULong + '())] + [(string-append) + (chain-binary "+" args)] + [(bytevector-length) + (make-kt-member-call + (make-kt-member-get (car args) 'size) + 'toULong + '())] + [(record-ctor) + (make-kt-new + (make-kt-type (info-ref info 'record operator) #f '()) + args)] + [(record-accessor) + (make-kt-member-get (car args) (info-ref info 'field operator))] + [(variant-ctor) + (let ([variant-name (info-ref info 'variant #f)] + [case-name (info-ref info 'case operator)]) + (if variant-name + (make-kt-call (make-kt-name (list variant-name case-name)) args) + (make-kt-call (kt-name1 case-name) args)))] + [(option-some) + (make-kt-call (make-kt-name '(JbOption Some)) args)] + [(option-none) + (make-kt-call (make-kt-name '(JbOption None)) '())] + [(result-ok) + (make-kt-call (make-kt-name '(JbResult Ok)) args)] + [(result-err) + (make-kt-call (make-kt-name '(JbResult Err)) args)] + [else (error 'lower-call "unsupported typed IR call kind for Kotlin" kind)]))) + + (def (lower-begin exprs) + (cond + [(null? exprs) (make-kt-lit 'Unit '())] + [(null? (cdr exprs)) (lower-expr (car exprs))] + [else + (make-kt-block + (map (lambda (expr) (make-kt-expr-stmt (lower-expr expr))) + (let loop ([xs exprs]) + (if (or (null? xs) (null? (cdr xs))) '() + (cons (car xs) (loop (cdr xs)))))) + (lower-expr (let loop ([xs exprs]) + (if (null? (cdr xs)) (car xs) (loop (cdr xs))))))])) + + (def (lower-let ir) + (make-kt-block + (map (lambda (binding) + (make-kt-val + #f + (typed-ir-binding-name binding) + (typed-type->kotlin-type + (typed-ir-node-type (typed-ir-binding-expr binding))) + (lower-expr (typed-ir-binding-expr binding)))) + (typed-ir-let-bindings ir)) + (lower-begin (typed-ir-let-body ir)))) + + (def (lower-for-fold ir) + (let ([acc-name (typed-ir-for-fold-acc-name ir)]) + (make-kt-block + (list + (make-kt-val + #t + acc-name + (typed-type->kotlin-type (typed-ir-node-type (typed-ir-for-fold-acc-init ir))) + (lower-expr (typed-ir-for-fold-acc-init ir))) + (make-kt-for-range + (typed-ir-for-fold-var-name ir) + (lower-expr (typed-ir-for-fold-range-start ir)) + (lower-expr (typed-ir-for-fold-range-end ir)) + (list + (make-kt-assign + (kt-name1 acc-name) + (lower-expr (typed-ir-for-fold-body ir))))))) + (kt-name1 acc-name))) + + (def (lower-expr ir) + (cond + [(typed-ir-lit? ir) + (lower-lit (typed-ir-lit-type ir) (typed-ir-lit-value ir))] + [(typed-ir-var? ir) + (kt-name1 (typed-ir-var-name ir))] + [(typed-ir-begin? ir) + (lower-begin (typed-ir-begin-exprs ir))] + [(typed-ir-let? ir) + (lower-let ir)] + [(typed-ir-if? ir) + (make-kt-if + (lower-expr (typed-ir-if-test ir)) + (lower-expr (typed-ir-if-then ir)) + (lower-expr (typed-ir-if-else ir)))] + [(typed-ir-for-fold? ir) + (lower-for-fold ir)] + [(typed-ir-call? ir) + (lower-call ir)] + [else (error 'lower-expr "unsupported typed IR node for Kotlin" ir)])) + + (def (lower-field-param field) + (make-kt-param + (typed-field-name field) + (typed-type->kotlin-type (typed-field-type field)) + #f + 'val + (typed-field-mutable? field) + #f)) + + (def (lower-record record) + (make-kt-class + 'data-class + #f + (typed-record-name record) + (map lower-field-param (typed-record-fields record)) + '() + '() + '())) + + (def (lower-variant-case variant case) + (let ([fields (typed-variant-case-fields case)] + [variant-type (make-kt-type (typed-variant-name variant) #f '())]) + (if (null? fields) + (make-kt-class + 'data-object + #f + (typed-variant-case-name case) + '() + (list variant-type) + '() + '()) + (make-kt-class + 'data-class + #f + (typed-variant-case-name case) + (map lower-field-param fields) + (list variant-type) + '() + '())))) + + (def (lower-variant variant) + (make-kt-class + 'sealed-class + #f + (typed-variant-name variant) + '() + '() + (map (lambda (case) (lower-variant-case variant case)) + (typed-variant-cases variant)) + '())) + + (def (lower-param param) + (make-kt-param + (typed-param-name param) + (typed-type->kotlin-type (typed-param-type param)) + #f + #f + #f + #f)) + + (def (lower-def def) + (let ([ir-entry (assq (typed-def-name def) (*kotlin-ir-env*))]) + (unless ir-entry + (error 'lower-def "missing elaborated IR for typed definition" (typed-def-name def))) + (make-kt-function + #f + (typed-def-name def) + (map lower-param (typed-def-params def)) + (typed-type->kotlin-type (typed-def-return-type def)) + (list (make-kt-return (lower-expr (cdr ir-entry)))) + '()))) + + (def (lower-declaration decl) + (cond + [(typed-record? decl) (lower-record decl)] + [(typed-variant? decl) (lower-variant decl)] + [(typed-def? decl) (lower-def decl)] + [else #f])) + + (def (elaborate-module-or-error module who) + (let-values ([(errors defs) + (check-and-elaborate-typed-module module)]) + (unless (null? errors) + (error who + "typed module has check errors" + (map typed-check-error-kind errors))) + (map (lambda (ed) + (cons (elaborated-def-name ed) + (elaborated-def-body-ir ed))) + defs))) + + (def (typed-module->kotlin-file module) + (let ([ir-env (elaborate-module-or-error module 'typed-module->kotlin-file)]) + (with-kotlin-env (list module) + (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-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)))) new file mode 100644 --- /dev/null +++ b/lib/jerboa/typed/kotlin/print.ss @@ -0,0 +1,439 @@ +#!chezscheme +;;; (jerboa typed kotlin print) -- canonical Kotlin renderer + +(library (jerboa typed kotlin print) + (export + kotlin-symbol-name + kotlin-package-name + kotlin-string-literal + kotlin-char-literal + kotlin-type->string + kotlin-expr->string + kotlin-file->string) + + (import (chezscheme) ; jerboa-security: suppress direct-chezscheme-import-user-code -- trusted Kotlin printer + (only (jerboa core) def) + (jerboa typed kotlin ast)) + + (def (emit-to-string thunk) + (let ([port (open-output-string)]) + (thunk port) + (get-output-string port))) + + (def (join-strings strings separator) + (cond + [(null? strings) ""] + [else + (let ([port (open-output-string)]) + (display (car strings) port) + (let loop ([rest (cdr strings)]) + (unless (null? rest) + (display separator port) + (display (car rest) port) + (loop (cdr rest)))) + (get-output-string port))])) + + (def kotlin-keywords + '("as" "break" "class" "continue" "do" "else" "false" "for" "fun" + "if" "in" "interface" "is" "null" "object" "package" "return" + "super" "this" "throw" "true" "try" "typealias" "typeof" "val" + "var" "when" "while" "by" "catch" "constructor" "delegate" "dynamic" + "field" "file" "finally" "get" "import" "init" "param" "property" + "receiver" "set" "setparam" "where" "actual" "abstract" "annotation" + "companion" "const" "crossinline" "data" "enum" "expect" "external" + "final" "infix" "inline" "inner" "internal" "lateinit" "noinline" + "open" "operator" "out" "override" "private" "protected" "public" + "reified" "sealed" "suspend" "tailrec" "vararg")) + + (def (kotlin-keyword? name) + (let loop ([rest kotlin-keywords]) + (cond + [(null? rest) #f] + [(string=? name (car rest)) #t] + [else (loop (cdr rest))]))) + + (def (identifier-start? ch) + (or (char-alphabetic? ch) (char=? ch #\_))) + + (def (identifier-char? ch) + (or (identifier-start? ch) (char-numeric? ch))) + + (def (write-kotlin-ident-char ch port) + (cond + [(identifier-char? ch) (write-char ch port)] + [(char=? ch #\-) (write-char #\_ port)] + [(char=? ch #\?) (display "_p" port)] + [(char=? ch #\!) (display "_bang" port)] + [(char=? ch #\/) (write-char #\_ port)] + [else (write-char #\_ port)])) + + (def (sanitize-kotlin-ident raw) + (let ([port (open-output-string)]) + (let loop ([chars (string->list raw)]) + (unless (null? chars) + (write-kotlin-ident-char (car chars) port) + (loop (cdr chars)))) + (let ([name (get-output-string port)]) + (cond + [(string=? name "") "_"] + [(or (not (identifier-start? (string-ref name 0))) + (kotlin-keyword? name)) + (string-append "_" name)] + [else name])))) + + (def (part->string part) + (cond + [(symbol? part) (symbol->string part)] + [(string? part) part] + [else (error 'kotlin-symbol-name "expected symbol or string name part" part)])) + + (def (kotlin-symbol-name sym) + (sanitize-kotlin-ident (part->string sym))) + + (def (name-parts->strings parts) + (cond + [(null? parts) '()] + [(pair? parts) + (map kotlin-symbol-name parts)] + [else (list (kotlin-symbol-name parts))])) + + (def (kotlin-package-name parts) + (join-strings (name-parts->strings parts) ".")) + + (def (kotlin-string-literal text) + (emit-to-string + (lambda (port) + (write-char #\" port) + (let loop ([chars (string->list text)]) + (unless (null? chars) + (let ([ch (car chars)]) + (cond + [(char=? ch #\\) (display "\\\\" port)] + [(char=? ch #\") (display "\\\"" port)] + [(char=? ch #\newline) (display "\\n" port)] + [(char=? ch #\tab) (display "\\t" port)] + [(char=? ch #\return) (display "\\r" port)] + [else (write-char ch port)])) + (loop (cdr chars)))) + (write-char #\" port)))) + + (def (kotlin-char-literal ch) + (string-append + "'" + (cond + [(char=? ch #\\) "\\\\"] + [(char=? ch #\') "\\'"] + [(char=? ch #\newline) "\\n"] + [(char=? ch #\tab) "\\t"] + [(char=? ch #\return) "\\r"] + [else (string ch)]) + "'")) + + (def (write-indent port level) + (let loop ([n level]) + (when (> n 0) + (display " " port) + (loop (- n 1))))) + + (def (write-line port level text) + (write-indent port level) + (display text port) + (newline port)) + + (def (visibility-prefix visibility) + (if visibility + (string-append (kotlin-symbol-name visibility) " ") + "")) + + (def (annotation-lines annotations) + (map (lambda (ann) + (string-append "@" (kotlin-package-name ann))) + annotations)) + + (def (kotlin-type->string type) + (cond + [(kt-type? type) + (let ([base (kotlin-package-name (kt-type-name type))] + [args (kt-type-args type)]) + (string-append + base + (if (null? args) + "" + (string-append "<" + (join-strings (map kotlin-type->string args) ", ") + ">")) + (if (kt-type-nullable? type) "?" "")))] + [(symbol? type) (kotlin-symbol-name type)] + [(string? type) (sanitize-kotlin-ident type)] + [else (error 'kotlin-type->string "not a Kotlin type" type)])) + + (def (kotlin-param->string param) + (string-append + (visibility-prefix (kt-param-visibility param)) + (cond + [(kt-param-property param) + (string-append (if (kt-param-mutable? param) "var " "val "))] + [else ""]) + (kotlin-symbol-name (kt-param-name param)) + ": " + (kotlin-type->string (kt-param-type param)) + (if (kt-param-default param) + (string-append " = " (kotlin-expr->string (kt-param-default param))) + ""))) + + (def (kotlin-lit->string lit) + (let ([type (kt-lit-type lit)] + [value (kt-lit-value lit)]) + (case type + [(Unit) "Unit"] + [(Bool) (if value "true" "false")] + [(Char) (kotlin-char-literal value)] + [(String Symbol Keyword) (kotlin-string-literal value)] + [(Nat) (string-append (number->string value) "uL")] + [(Int Fixnum) (string-append (number->string value) "L")] + [(Float) (number->string value)] + [(Null) "null"] + [else (error 'kotlin-lit->string "unsupported literal type" type)]))) + + (def (kotlin-name->string name) + (kotlin-package-name (kt-name-parts name))) + + (def (parenthesize text) + (string-append "(" text ")")) + + (def (kotlin-expr->string expr) + (cond + [(kt-lit? expr) (kotlin-lit->string expr)] + [(kt-name? expr) (kotlin-name->string expr)] + [(kt-call? expr) + (string-append + (kotlin-expr->string (kt-call-callee expr)) + "(" + (join-strings (map kotlin-expr->string (kt-call-args expr)) ", ") + ")")] + [(kt-member-call? expr) + (string-append + (kotlin-expr->string (kt-member-call-target expr)) + "." + (kotlin-symbol-name (kt-member-call-name expr)) + "(" + (join-strings (map kotlin-expr->string (kt-member-call-args expr)) ", ") + ")")] + [(kt-member-get? expr) + (string-append + (kotlin-expr->string (kt-member-get-target expr)) + "." + (kotlin-symbol-name (kt-member-get-name expr)))] + [(kt-binary? expr) + (parenthesize + (string-append + (kotlin-expr->string (kt-binary-left expr)) + " " + (kt-binary-op expr) + " " + (kotlin-expr->string (kt-binary-right expr))))] + [(kt-unary? expr) + (parenthesize + (string-append (kt-unary-op expr) + (kotlin-expr->string (kt-unary-expr expr))))] + [(kt-if? expr) + (string-append + "if (" + (kotlin-expr->string (kt-if-test expr)) + ") " + (kotlin-expr->string (kt-if-then expr)) + " else " + (kotlin-expr->string (kt-if-else expr)))] + [(kt-block? expr) + (emit-to-string + (lambda (port) + (display "run {" port) + (newline port) + (for-each (lambda (stmt) (write-statement port 1 stmt)) + (kt-block-statements expr)) + (write-line port 1 (kotlin-expr->string (kt-block-result expr))) + (display "}" port)))] + [(kt-new? expr) + (string-append + (kotlin-type->string (kt-new-type expr)) + "(" + (join-strings (map kotlin-expr->string (kt-new-args expr)) ", ") + ")")] + [(kt-when? expr) + (emit-to-string + (lambda (port) + (display "when (" port) + (display (kotlin-expr->string (kt-when-subject expr)) port) + (display ") {" port) + (newline port) + (for-each + (lambda (branch) + (write-line port 1 + (string-append + (if (eq? (kt-when-branch-pattern branch) 'else) + "else" + (kotlin-expr->string (kt-when-branch-pattern branch))) + " -> " + (kotlin-expr->string (kt-when-branch-body branch))))) + (kt-when-branches expr)) + (display "}" port)))] + [else (error 'kotlin-expr->string "unsupported Kotlin expression" expr)])) + + (def (write-statement port indent stmt) + (cond + [(kt-return? stmt) + (write-line port indent + (string-append "return " (kotlin-expr->string (kt-return-expr stmt))))] + [(kt-val? stmt) + (write-line port indent + (string-append + (if (kt-val-mutable? stmt) "var " "val ") + (kotlin-symbol-name (kt-val-name stmt)) + (if (kt-val-type stmt) + (string-append ": " (kotlin-type->string (kt-val-type stmt))) + "") + " = " + (kotlin-expr->string (kt-val-init stmt))))] + [(kt-assign? stmt) + (write-line port indent + (string-append + (kotlin-expr->string (kt-assign-target stmt)) + " = " + (kotlin-expr->string (kt-assign-expr stmt))))] + [(kt-for-range? stmt) + (write-line port indent + (string-append + "for (" + (kotlin-symbol-name (kt-for-range-var stmt)) + " in " + (kotlin-expr->string (kt-for-range-start stmt)) + " until " + (kotlin-expr->string (kt-for-range-end stmt)) + ") {")) + (for-each (lambda (body-stmt) (write-statement port (+ indent 1) body-stmt)) + (kt-for-range-body stmt)) + (write-line port indent "}")] + [(kt-expr-stmt? stmt) + (write-line port indent (kotlin-expr->string (kt-expr-stmt-expr stmt)))] + [else (error 'write-statement "unsupported Kotlin statement" stmt)])) + + (def (class-prefix class) + (let ([kind (kt-class-kind class)]) + (string-append + (visibility-prefix (kt-class-visibility class))