Emit typed Kotlin property setters
ober
5ff5cf043de505db7403d7c3068508404ee34603
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -894,11 +894,62 @@ (typed-property-init prop) (*global-value-env*) type-names)]) - (let* ([actual-type (ir-type init-ir)] + (let* ([setter (typed-property-setter prop)] + [setter-param (and setter (typed-property-setter-param setter))] + [setter-env + (and setter-param + (extend-env/mutable + 'field + (typed-property-type prop) + (extend-env + (typed-param-name setter-param) + (typed-param-type setter-param) + (*global-value-env*))))] + [setter-result + (and setter + (call-with-values + (lambda () + (infer-body + (typed-property-setter-body setter) + setter-env + type-names + (typed-property-setter-source setter))) + list))] + [setter-ir (and setter-result (car setter-result))] + [setter-errors (if setter-result (cadr setter-result) '())] + [setter-type (ir-type setter-ir)] + [setter-shape-errors + (cond + [(not setter) '()] + [(not (typed-property-mutable? prop)) + (list (make-check-error 'bad-property-setter + "only var properties can have setters" + (typed-property-name prop) + (typed-property-source prop)))] + [(not (type-assignable? + (typed-param-type setter-param) + (typed-property-type prop))) + (list (make-check-error 'property-setter-type-mismatch + "setter parameter type must match property type" + (list (typed-property-name prop) + (typed-property-type prop) + (typed-param-type setter-param)) + (typed-property-setter-source setter)))] + [(and setter-type + (not (eq? setter-type 'Unit))) + (list (make-check-error 'property-setter-type-mismatch + "setter body must return Unit" + (list (typed-property-name prop) setter-type) + (typed-property-setter-source setter)))] + [else '()])] + [actual-type (ir-type init-ir)] [declared-type (typed-property-type prop)] [type-errors (append (check-type declared-type type-names) + (if setter-param + (check-type (typed-param-type setter-param) type-names) + '()) (if (and actual-type (valid-type? declared-type type-names) (not (type-assignable? actual-type declared-type))) @@ -909,9 +960,14 @@ actual-type) (typed-property-source prop))) '()))] - [all-errors (append init-errors type-errors)]) + [all-errors + (append init-errors type-errors setter-errors setter-shape-errors)]) (when (null? all-errors) - (record-elaboration-by-name! (typed-property-name prop) init-ir)) + (record-elaboration-by-name! (typed-property-name prop) init-ir) + (when setter + (record-elaboration-by-name! + (list (typed-property-name prop) '*setter*) + setter-ir))) all-errors))) (def (check-object-decl object type-names) --- a/lib/jerboa/typed/kotlin/ast.ss +++ b/lib/jerboa/typed/kotlin/ast.ss @@ -34,7 +34,10 @@ kt-property? make-kt-property kt-property-visibility kt-property-mutable? kt-property-name kt-property-type kt-property-init - kt-property-annotations + kt-property-annotations kt-property-setter + + kt-property-setter? make-kt-property-setter + kt-property-setter-param-name kt-property-setter-body kt-return? make-kt-return kt-return-expr @@ -134,7 +137,8 @@ (defstruct kt-function (visibility modifiers name params return-type body annotations)) (defstruct kt-property - (visibility mutable? name type init annotations)) + (visibility mutable? name type init annotations setter)) + (defstruct kt-property-setter (param-name body)) ;; Statements. (defstruct kt-return (expr)) --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -1003,7 +1003,8 @@ '()))) (def (lower-property prop) - (let ([ir (lookup-kotlin-ir (typed-property-name prop))]) + (let ([ir (lookup-kotlin-ir (typed-property-name prop))] + [setter (typed-property-setter prop)]) (unless ir (error 'lower-property "missing elaborated IR for typed property" @@ -1014,7 +1015,18 @@ (typed-property-name prop) (typed-type->kotlin-type (typed-property-type prop)) (lower-expr ir) - '()))) + '() + (and setter + (let ([setter-ir + (lookup-kotlin-ir + (list (typed-property-name prop) '*setter*))]) + (unless setter-ir + (error 'lower-property + "missing elaborated IR for typed property setter" + (typed-property-name prop))) + (make-kt-property-setter + (typed-param-name (typed-property-setter-param setter)) + (lower-unit-statements setter-ir))))))) (def (lower-extern decl) (let* ([target (typed-extern-kotlin-path decl)] --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -38,7 +38,7 @@ "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" + "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" @@ -538,7 +538,19 @@ "") (if (kt-property-init prop) (string-append " = " (kotlin-expr->string (kt-property-init prop))) - "")))) + ""))) + (when (kt-property-setter prop) + (let ([setter (kt-property-setter prop)]) + (write-line port (+ indent 1) + (string-append + "set(" + (kotlin-symbol-name (kt-property-setter-param-name setter)) + ") {")) + (for-each + (lambda (stmt) + (write-statement port (+ indent 2) stmt)) + (kt-property-setter-body setter)) + (write-line port (+ indent 1) "}")))) (def (write-class port indent class) (for-each (lambda (line) (write-line port indent line)) --- a/lib/jerboa/typed/parser.ss +++ b/lib/jerboa/typed/parser.ss @@ -36,7 +36,12 @@ typed-property? make-typed-property typed-property-mutable? typed-property-name - typed-property-type typed-property-init typed-property-source + typed-property-type typed-property-init + typed-property-setter typed-property-source + + typed-property-setter? make-typed-property-setter + typed-property-setter-param typed-property-setter-body + typed-property-setter-source typed-object-decl? make-typed-object-decl typed-object-decl-name typed-object-decl-declarations @@ -78,7 +83,8 @@ (defstruct typed-field (name type mutable? source)) (defstruct typed-record (name fields source)) (defstruct typed-resource (name close source)) - (defstruct typed-property (mutable? name type init source)) + (defstruct typed-property (mutable? name type init setter source)) + (defstruct typed-property-setter (param body source)) (defstruct typed-object-decl (name declarations source)) (defstruct typed-class-decl (name params super declarations source)) (defstruct typed-class-super (name args source)) @@ -503,16 +509,42 @@ (parse-kotlin-call-target target) source))))) + (def (setter-form? value) + (let ([value (strip-source-annotations value)]) + (and (pair? value) + (eq? (car value) 'setter)))) + + (def (parse-property-setter form) + (let* ([source (datum-source form)] + [raw-form (datum-value form)] + [form (strip-source-annotations form)]) + (expect-proper-list 'parse-typed-property form) + (unless (and (>= (length form) 3) + (eq? (car form) 'setter)) + (error 'parse-typed-property + "expected (setter (value : Type) body ...)" + form)) + (make-typed-property-setter + (parse-param (cadr raw-form)) + (cddr raw-form) + source))) + (def (parse-property form) (let* ([source (datum-source form)] [raw-form (datum-value form)] [form (strip-source-annotations form)]) - (expect-length 'parse-typed-property form 5) + (expect-proper-list 'parse-typed-property form) + (unless (or (= (length form) 5) (= (length form) 6)) + (error 'parse-typed-property + "expected (val name : Type init), (var name : Type init), or property with setter" + form)) (let ([kind (car form)] [name (cadr form)] [type-marker (caddr form)] [type (cadddr form)] - [init (list-ref raw-form 4)]) + [init (list-ref raw-form 4)] + [setter (and (= (length form) 6) + (list-ref raw-form 5))]) (unless (memq kind '(val var)) (error 'parse-typed-property "expected val or var declaration" @@ -526,6 +558,13 @@ (expect-symbol 'parse-typed-property name form) (parse-typed-type type) init + (and setter + (begin + (unless (setter-form? setter) + (error 'parse-typed-property + "property extension must be a setter form" + setter)) + (parse-property-setter setter))) source)))) (def (parse-type-decl form) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -1477,10 +1477,18 @@ (kotlin-call contextDensity)) (extern (densityReady (density : Float32)) : Bool (kotlin-call densityReady)) + (extern (markDirty) : Unit + (kotlin-call markDirty)) (class ReviewView ((context : Context)) (extends View context) (val density : Float32 (contextDensity context)) + (var selected : String + "" + (setter (value : String) + (begin + (set! field value) + (markDirty)))) (def (ready) : Bool (densityReady density))))) @@ -1493,6 +1501,9 @@ (test-contains "typed class declaration lowers member property" class-declaration-kotlin "val density: Float = contextDensity(context)") +(test-contains "typed class declaration lowers custom property setter" + class-declaration-kotlin + "var selected: String = \"\"\n set(value) {\n field = value\n markDirty()\n }") (test-contains "typed class declaration lowers member function" class-declaration-kotlin "fun ready(): Boolean {\n return densityReady(density)")