Support Kotlin object superclass constructors
ober
f833c6c8887a23fedbd207d5d4e48df3ea2afc06
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -1136,6 +1136,34 @@ v source)))]))) + (def (parse-object-super spec env type-names) + (let* ([source (expr-source spec)] + [raw (expr-value spec)] + [v (strip-source-annotations spec)]) + (cond + [(and (list? v) (pair? v) (eq? (car v) 'new)) + (if (< (length v) 2) + (values #f #f + (list (make-check-error 'bad-object-super + "object superclass constructor must be shaped (new Type arg ...)" + v + source))) + (let* ([super-type (parse-typed-type (cadr v))] + [type-errors (check-type super-type type-names)] + [constructor-args (cddr raw)]) + (let-values ([(arg-irs arg-errors) + (infer-args constructor-args env type-names)]) + (if (or (not (valid-type? super-type type-names)) + (not (null? type-errors)) + (not (null? arg-errors)) + (not (all-irs-valid? arg-irs))) + (values super-type #f (append type-errors arg-errors)) + (values super-type arg-irs '())))))] + [else + (let* ([super-type (parse-typed-type spec)] + [type-errors (check-type super-type type-names)]) + (values super-type #f type-errors))]))) + (def (infer-object args env type-names expr) (cond [(< (length args) 2) @@ -1144,31 +1172,32 @@ "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))))))])) + (let-values ([(super-type super-args super-errors) + (parse-object-super (car args) env type-names)]) + (let* ([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 super-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 + super-args + (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*))) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -47,7 +47,8 @@ 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-super-type typed-ir-object-super-args + typed-ir-object-methods typed-ir-object-method? make-typed-ir-object-method @@ -108,7 +109,7 @@ (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 (type source super-type super-args 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 --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -771,9 +771,14 @@ '())) (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)))) + (let ([super-type (typed-type->kotlin-type (typed-ir-object-super-type ir))] + [super-args (typed-ir-object-super-args ir)]) + (make-kt-object-expr + (list + (if super-args + (make-kt-new super-type (map lower-expr super-args)) + super-type)) + (map lower-object-method (typed-ir-object-methods ir))))) (def (lower-expr ir) (cond --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -189,6 +189,16 @@ [(string? type) (sanitize-kotlin-ident type)] [else (error 'kotlin-type->string "not a Kotlin type" type)])) + (def (kotlin-super->string super) + (cond + [(kt-new? super) + (string-append + (kotlin-type->string (kt-new-type super)) + "(" + (join-strings (map kotlin-expr->string (kt-new-args super)) ", ") + ")")] + [else (kotlin-type->string super)])) + (def (kotlin-param->string param) (string-append (visibility-prefix (kt-param-visibility param)) @@ -288,7 +298,7 @@ (let ([supers (kt-object-expr-super-types expr)]) (unless (null? supers) (display " : " port) - (display (join-strings (map kotlin-type->string supers) ", ") port))) + (display (join-strings (map kotlin-super->string supers) ", ") port))) (display " {" port) (newline port) (for-each --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -112,6 +112,29 @@ "\n" "}")) +(test "anonymous object superclass constructor printer" + (kotlin-expr->string + (make-kt-object-expr + (list (make-kt-new + (make-kt-type '(android view ScaleGestureDetector SimpleOnScaleGestureListener) #f '()) + '())) + (list + (make-kt-function + #f + '(override) + 'onScale + '() + (make-kt-type 'Boolean #f '()) + (list (make-kt-return (make-kt-lit 'Bool #t))) + '())))) + (string-append + "object : android.view.ScaleGestureDetector.SimpleOnScaleGestureListener() {\n" + " override fun onScale(): Boolean {\n" + " return true\n" + " }\n" + "\n" + "}")) + (define ast-file-text (string-append "// Generated by Jerboa's typed Kotlin backend. Do not edit.\n\n" @@ -439,6 +462,26 @@ object-kotlin "action()") +(define object-constructor-form + '(typed-library (sample typed objectconstructor) + (export makeListener) + (type ScaleListener) + (type Detector) + (type Int32) + (extern (makeDetector (listener : ScaleListener)) : Detector + (kotlin-call Detector)) + (def (makeListener (step : Int32)) : ScaleListener + (object (new ScaleListener step) + (override (onScale) : Bool + #t))))) + +(define object-constructor-kotlin + (typed-library-form->kotlin-string object-constructor-form)) + +(test-contains "typed object expression lowers superclass constructor call" + object-constructor-kotlin + "return object : ScaleListener(step) {") + (define geometry-form '(typed-library (sample typed geometry) (export make-SsdCell SsdCell? SsdCell-x SsdCell-y SsdCell-w SsdCell-h