Add typed Kotlin object expressions
ober
3192be39569ab234ee7ffd3e2a7cf766ac1ae7ab
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -1062,6 +1062,114 @@ (if param (cons param params) params) (append (reverse param-errors) errors))))))])) + (def (object-method-name method) + (let ([v (strip-source-annotations method)]) + (and (pair? v) + (pair? (cdr v)) + (let ([head (cadr v)]) + (and (pair? head) (car head)))))) + + (def (parse-object-method method env type-names) + (let* ([source (expr-source method)] + [raw (expr-value method)] + [v (strip-source-annotations method)]) + (cond + [(and (list? v) + (>= (length v) 5) + (eq? (car v) 'override) + (pair? (cadr v)) + (symbol? (car (cadr v))) + (memq (caddr v) '(: ->))) + (let* ([raw-head (cadr raw)] + [head (cadr v)] + [method-name (car head)] + [param-exprs (cdr raw-head)] + [return-type (parse-typed-type (cadddr v))] + [body (cddddr raw)] + [return-type-errors (check-type return-type type-names)] + [duplicate-param-errors + (duplicate-errors 'duplicate-param + "duplicate object method parameter" + (map lambda-param-name param-exprs))]) + (let loop ([rest param-exprs] + [params '()] + [errors (append return-type-errors duplicate-param-errors)]) + (if (null? rest) + (let ([ok-params (reverse params)]) + (if (not (null? errors)) + (values #f (reverse errors)) + (let ([local-env (append (param-env ok-params) env)]) + (let-values ([(body-ir body-errors) + (infer-body body local-env type-names source)]) + (let* ([body-type (ir-type body-ir)] + [method-return-errors + (if (and body-type + (valid-type? return-type type-names) + (not (type-assignable? body-type return-type))) + (list (make-check-error 'return-type-mismatch + "object method body type does not match declared return type" + (list method-name return-type body-type) + source)) + '())] + [ok? (and body-ir body-type + (null? body-errors) + (null? method-return-errors))]) + (values + (and ok? + (make-typed-ir-object-method + '(override) + method-name + ok-params + return-type + body-ir + source)) + (append body-errors method-return-errors))))))) + (let-values ([(param param-errors) + (parse-lambda-param (car rest) type-names)]) + (loop (cdr rest) + (if param (cons param params) params) + (append (reverse param-errors) errors))))))] + [else + (values #f + (list (make-check-error 'bad-object-method + "object methods must be shaped (override (name (arg : Type) ...) : Return body ...)" + v + source)))]))) + + (def (infer-object args env type-names expr) + (cond + [(< (length args) 2) + (values #f + (list (error-at expr 'bad-object + "object expects a super type and one or more method definitions" + expr)))] + [else + (let* ([super-type (parse-typed-type (car args))] + [type-errors (check-type super-type type-names)] + [method-exprs (cdr args)] + [duplicate-method-errors + (duplicate-errors 'duplicate-object-method + "duplicate object method" + (map object-method-name method-exprs))]) + (let loop ([rest method-exprs] + [methods '()] + [errors (append type-errors duplicate-method-errors)]) + (if (null? rest) + (if (not (null? errors)) + (values #f (reverse errors)) + (values + (make-typed-ir-object + super-type + (expr-source expr) + super-type + (reverse methods)) + '())) + (let-values ([(method-ir method-errors) + (parse-object-method (car rest) env type-names)]) + (loop (cdr rest) + (if method-ir (cons method-ir methods) methods) + (append (reverse method-errors) errors))))))])) + (def (lookup-variant name) (lookup-name name (*variant-env*))) @@ -2671,6 +2779,20 @@ (if (< (length args) 2) (values moved '()) (check-ownership-body (cdr args) env moved))] + [(object) + (let loop ([rest (cdr args)] [errors '()]) + (if (null? rest) + (values moved (reverse errors)) + (let ([v (strip-source-annotations (car rest))]) + (if (and (list? v) (>= (length v) 5)) + (let-values ([(_after body-errors) + (check-ownership-body + (cddddr (expr-value (car rest))) + env + moved)]) + (loop (cdr rest) + (append (reverse body-errors) errors))) + (loop (cdr rest) errors)))))] [(match) (if (< (length args) 1) (values moved '()) @@ -2844,6 +2966,8 @@ (infer-if args env type-names expr)] [(lambda) (infer-lambda args env type-names expr)] + [(object) + (infer-object args env type-names expr)] [(invoke) (infer-function-value-invoke args env type-names expr)] [(match) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -44,6 +44,20 @@ typed-ir-lambda-type typed-ir-lambda-source typed-ir-lambda-params typed-ir-lambda-body + typed-ir-object? + make-typed-ir-object + typed-ir-object-type typed-ir-object-source + typed-ir-object-super-type typed-ir-object-methods + + typed-ir-object-method? + make-typed-ir-object-method + typed-ir-object-method-modifiers + typed-ir-object-method-name + typed-ir-object-method-params + typed-ir-object-method-return-type + typed-ir-object-method-body + typed-ir-object-method-source + typed-ir-for-fold? make-typed-ir-for-fold typed-ir-for-fold-type typed-ir-for-fold-source @@ -94,6 +108,9 @@ (defstruct typed-ir-binding (name expr)) (defstruct typed-ir-if (type source test then else)) (defstruct typed-ir-lambda (type source params body)) + (defstruct typed-ir-object (type source super-type methods)) + (defstruct typed-ir-object-method + (modifiers name params return-type body source)) ;; single-accumulator fold over an in-range index: the loop variable runs ;; [range-start, range-end); body (of acc's type) becomes acc's next value. (defstruct typed-ir-for-fold @@ -213,6 +230,7 @@ (typed-ir-let? x) (typed-ir-if? x) (typed-ir-lambda? x) + (typed-ir-object? x) (typed-ir-for-fold? x) (typed-ir-bytes-build? x) (typed-ir-match? x) @@ -226,6 +244,7 @@ [(typed-ir-let? node) (typed-ir-let-type node)] [(typed-ir-if? node) (typed-ir-if-type node)] [(typed-ir-lambda? node) (typed-ir-lambda-type node)] + [(typed-ir-object? node) (typed-ir-object-type node)] [(typed-ir-for-fold? node) (typed-ir-for-fold-type node)] [(typed-ir-bytes-build? node) (typed-ir-bytes-build-type node)] [(typed-ir-match? node) (typed-ir-match-type node)] @@ -240,6 +259,7 @@ [(typed-ir-let? node) (typed-ir-let-source node)] [(typed-ir-if? node) (typed-ir-if-source node)] [(typed-ir-lambda? node) (typed-ir-lambda-source node)] + [(typed-ir-object? node) (typed-ir-object-source node)] [(typed-ir-for-fold? node) (typed-ir-for-fold-source node)] [(typed-ir-bytes-build? node) (typed-ir-bytes-build-source node)] [(typed-ir-match? node) (typed-ir-match-source node)] --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -757,6 +757,24 @@ (map typed-param-name (typed-ir-lambda-params ir)) (lower-expr (typed-ir-lambda-body ir)))) + (def (lower-object-method method) + (make-kt-function + #f + (typed-ir-object-method-modifiers method) + (typed-ir-object-method-name method) + (map lower-param (typed-ir-object-method-params method)) + (typed-type->kotlin-type (typed-ir-object-method-return-type method)) + (if (eq? (typed-ir-object-method-return-type method) 'Unit) + (lower-unit-statements (typed-ir-object-method-body method)) + (list (make-kt-return + (lower-expr (typed-ir-object-method-body method))))) + '())) + + (def (lower-object ir) + (make-kt-object-expr + (list (typed-type->kotlin-type (typed-ir-object-super-type ir))) + (map lower-object-method (typed-ir-object-methods ir)))) + (def (lower-expr ir) (cond [(typed-ir-lit? ir) @@ -774,6 +792,8 @@ (lower-expr (typed-ir-if-else ir)))] [(typed-ir-lambda? ir) (lower-lambda ir)] + [(typed-ir-object? ir) + (lower-object ir)] [(typed-ir-for-fold? ir) (lower-for-fold ir)] [(typed-ir-bytes-build? ir) --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -542,6 +542,45 @@ (invoke x)))) '(not-callable)) +(test "typed object expression" + (error-kinds + '(typed-library (body object-ok) + (export make-watcher) + (type TextWatcher) + (type CharSequence) + (type Editable) + (type Int32) + (def (make-watcher (action : (-> Unit))) : TextWatcher + (object TextWatcher + (override (beforeTextChanged + (s : (Nullable CharSequence)) + (start : Int32) + (count : Int32) + (after : Int32)) : Unit + (begin)) + (override (onTextChanged + (s : (Nullable CharSequence)) + (start : Int32) + (before : Int32) + (count : Int32)) : Unit + (invoke action)) + (override (afterTextChanged + (s : (Nullable Editable))) : Unit + (begin)))))) + '()) + +(test "typed object expression method return mismatch" + (error-kinds + '(typed-library (body object-return-mismatch) + (export make-bad) + (type TextWatcher) + (type Int32) + (def (make-bad) : TextWatcher + (object TextWatcher + (override (answer) : Int32 + "wrong"))))) + '(return-type-mismatch)) + (test "extern kotlin call can be used from typed code" (error-kinds '(typed-library (body extern-ok) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -400,6 +400,45 @@ lambda-kotlin "action()") +(define object-form + '(typed-library (sample typed objectexpr) + (export makeWatcher) + (type TextWatcher) + (type CharSequence) + (type Editable) + (type Int32) + (def (makeWatcher (action : (-> Unit))) : TextWatcher + (object TextWatcher + (override (beforeTextChanged + (s : (Nullable CharSequence)) + (start : Int32) + (count : Int32) + (after : Int32)) : Unit + (begin)) + (override (onTextChanged + (s : (Nullable CharSequence)) + (start : Int32) + (before : Int32) + (count : Int32)) : Unit + (invoke action)) + (override (afterTextChanged + (s : (Nullable Editable))) : Unit + (begin)))))) + +(define object-kotlin (typed-library-form->kotlin-string object-form)) + +(test-contains "typed object expression lowers to anonymous Kotlin object" + object-kotlin + "return object : TextWatcher {") + +(test-contains "typed object method lowers override modifier" + object-kotlin + "override fun onTextChanged(s: CharSequence?, start: Int, before: Int, count: Int): Unit") + +(test-contains "typed object method can invoke function value" + object-kotlin + "action()") + (define geometry-form '(typed-library (sample typed geometry) (export make-SsdCell SsdCell? SsdCell-x SsdCell-y SsdCell-w SsdCell-h