Add typed Kotlin enum declarations
ober
f8fcc73d550c08d46f88df2e6cfcfdf8cc125299
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -271,6 +271,7 @@ [(typed-variant? decl) (typed-variant-name decl)] [(typed-object-decl? decl) (typed-object-decl-name decl)] [(typed-class-decl? decl) (typed-class-decl-name decl)] + [(typed-enum-decl? decl) (typed-enum-decl-name decl)] [else #f])) (def (declared-type-names declarations) @@ -309,6 +310,7 @@ [(typed-property? decl) (list (typed-property-name decl))] [(typed-object-decl? decl) (list (typed-object-decl-name decl))] [(typed-class-decl? decl) (list (typed-class-decl-name decl))] + [(typed-enum-decl? decl) (list (typed-enum-decl-name decl))] [(typed-extern? decl) (list (typed-extern-name decl))] [(typed-record? decl) (record-value-names decl)] [(typed-variant? decl) (variant-value-names decl)] @@ -1083,6 +1085,86 @@ (check-declaration decl visible-type-names)) declarations))))) + (def (check-enum-entry enum-name params entry env type-names) + (let-values ([(arg-irs arg-errors) + (infer-args + (typed-enum-entry-args entry) + env + type-names)]) + (let* ([param-types (map typed-param-type params)] + [arg-types (ir-list-types arg-irs)] + [arity-errors + (if (= (length params) (length arg-irs)) + '() + (list + (make-check-error + 'bad-call-arity + "enum entry argument count must match enum constructor parameters" + (list (typed-enum-entry-name entry) + (length params) + (length (typed-enum-entry-args entry))) + (typed-enum-entry-source entry))))] + [type-errors + (if (null? arity-errors) + (let loop ([actuals arg-types] + [expecteds param-types] + [forms (typed-enum-entry-args entry)] + [out '()]) + (cond + [(null? actuals) (reverse out)] + [else + (let ([actual (car actuals)] + [expected (car expecteds)]) + (loop + (cdr actuals) + (cdr expecteds) + (cdr forms) + (if (and actual + (type-assignable? actual expected)) + out + (cons + (make-check-error + 'argument-type-mismatch + "enum entry argument does not match constructor parameter type" + (list (typed-enum-entry-name entry) + expected + actual) + (and (pair? forms) + (expr-source (car forms)))) + out))))])) + '())] + [errors (append arg-errors arity-errors type-errors)]) + (when (and (null? errors) (all-irs-valid? arg-irs)) + (record-elaboration-by-name! + (list enum-name (typed-enum-entry-name entry) '*args*) + arg-irs)) + errors))) + + (def (check-enum-decl enum type-names) + (let* ([params (typed-enum-decl-params enum)] + [entries (typed-enum-decl-entries enum)] + [visible-type-names (cons (typed-enum-decl-name enum) type-names)]) + (append + (duplicate-errors 'duplicate-param + "duplicate enum constructor parameter" + (map typed-param-name params)) + (append-map + (lambda (param) + (check-type (typed-param-type param) visible-type-names)) + params) + (duplicate-errors 'duplicate-value + "duplicate enum entry" + (map typed-enum-entry-name entries)) + (append-map + (lambda (entry) + (check-enum-entry + (typed-enum-decl-name enum) + params + entry + (*global-value-env*) + visible-type-names)) + entries)))) + (def (infer-body exprs env type-names . src*) (let ([src (if (pair? src*) (car src*) #f)]) (cond @@ -3862,6 +3944,7 @@ [(typed-property? decl) (check-property decl type-names)] [(typed-object-decl? decl) (check-object-decl decl type-names)] [(typed-class-decl? decl) (check-class-decl decl type-names)] + [(typed-enum-decl? decl) (check-enum-decl decl type-names)] [(typed-extern? decl) (check-extern decl type-names)] [(typed-def? decl) (check-def decl type-names)] [else '()])) @@ -3900,6 +3983,8 @@ (memq (typed-object-decl-name decl) exports)] [(typed-class-decl? decl) (memq (typed-class-decl-name decl) exports)] + [(typed-enum-decl? decl) + (memq (typed-enum-decl-name decl) exports)] [(typed-record? decl) (or (memq (typed-record-name decl) exports) (let any-loop ([rs values]) --- a/lib/jerboa/typed/kotlin/ast.ss +++ b/lib/jerboa/typed/kotlin/ast.ss @@ -40,6 +40,9 @@ kt-property-setter? make-kt-property-setter kt-property-setter-param-name kt-property-setter-body + kt-enum-entry? make-kt-enum-entry + kt-enum-entry-name kt-enum-entry-args + kt-return? make-kt-return kt-return-expr @@ -143,6 +146,7 @@ (defstruct kt-property (visibility modifiers mutable? name type init annotations setter)) (defstruct kt-property-setter (param-name body)) + (defstruct kt-enum-entry (name args)) ;; Statements. (defstruct kt-return (expr)) --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -1003,6 +1003,15 @@ #f #f)) + (def (lower-enum-param param) + (make-kt-param + (typed-param-name param) + (typed-type->kotlin-type (typed-param-type param)) + #f + 'val + #f + #f)) + (def (lower-def def) (let ([ir (lookup-kotlin-ir (typed-def-name def))]) (unless ir @@ -1107,6 +1116,31 @@ (typed-class-decl-declarations decl)) '()))) + (def (lower-enum-entry enum entry) + (let ([arg-irs + (lookup-kotlin-ir + (list (typed-enum-decl-name enum) + (typed-enum-entry-name entry) + '*args*))]) + (unless arg-irs + (error 'lower-enum-entry + "missing elaborated IR for enum entry" + (typed-enum-entry-name entry))) + (make-kt-enum-entry + (typed-enum-entry-name entry) + (map lower-expr arg-irs)))) + + (def (lower-enum-declaration decl) + (make-kt-class + 'enum + #f + (typed-enum-decl-name decl) + (map lower-enum-param (typed-enum-decl-params decl)) + '() + (map (lambda (entry) (lower-enum-entry decl entry)) + (typed-enum-decl-entries decl)) + '())) + (def (lower-declaration decl) (cond [(typed-record? decl) (lower-record decl)] @@ -1114,6 +1148,7 @@ [(typed-property? decl) (lower-property decl)] [(typed-object-decl? decl) (lower-object-declaration decl)] [(typed-class-decl? decl) (lower-class-declaration decl)] + [(typed-enum-decl? decl) (lower-enum-declaration decl)] [(typed-extern? decl) (lower-extern decl)] [(typed-def? decl) (lower-def decl)] [else #f])) --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -562,6 +562,51 @@ (kt-property-setter-body setter)) (write-line port (+ indent 1) "}")))) + (def (write-enum-entry port indent entry suffix) + (write-line port indent + (string-append + (kotlin-symbol-name (kt-enum-entry-name entry)) + (let ([args (kt-enum-entry-args entry)]) + (if (null? args) + "" + (string-append + "(" + (join-strings (map kotlin-expr->string args) ", ") + ")"))) + suffix))) + + (def (write-enum-class-body port indent body) + (let loop ([rest body] [entries '()] [decls '()]) + (cond + [(null? rest) + (let ([entries (reverse entries)] + [decls (reverse decls)]) + (unless (null? entries) + (let enum-loop ([xs entries]) + (let ([last? (null? (cdr xs))]) + (write-enum-entry + port + (+ indent 1) + (car xs) + (cond + [(not last?) ","] + [(null? decls) ""] + [else ";"])) + (unless last? (enum-loop (cdr xs)))))) + (when (and (not (null? entries)) + (not (null? decls))) + (newline port)) + (unless (null? decls) + (for-each + (lambda (decl) + (write-declaration port (+ indent 1) decl) + (newline port)) + decls)))] + [(kt-enum-entry? (car rest)) + (loop (cdr rest) (cons (car rest) entries) decls)] + [else + (loop (cdr rest) entries (cons (car rest) decls))]))) + (def (write-class port indent class) (for-each (lambda (line) (write-line port indent line)) (annotation-lines (kt-class-annotations class))) @@ -577,11 +622,13 @@ " {"))) (let ([body (kt-class-body class)]) (unless (null? body) - (for-each - (lambda (decl) - (write-declaration port (+ indent 1) decl) - (newline port)) - body))) + (if (eq? (kt-class-kind class) 'enum) + (write-enum-class-body port indent body) + (for-each + (lambda (decl) + (write-declaration port (+ indent 1) decl) + (newline port)) + body)))) (write-line port indent "}")) (def (write-declaration port indent decl) @@ -589,6 +636,7 @@ [(kt-class? decl) (write-class port indent decl)] [(kt-function? decl) (write-function port indent decl)] [(kt-property? decl) (write-property port indent decl)] + [(kt-enum-entry? decl) (write-enum-entry port indent decl "")] [else (error 'write-declaration "unsupported Kotlin declaration" decl)])) (def (write-import port import) --- a/lib/jerboa/typed/parser.ss +++ b/lib/jerboa/typed/parser.ss @@ -57,6 +57,14 @@ typed-class-super-name typed-class-super-args typed-class-super-source + typed-enum-decl? make-typed-enum-decl + typed-enum-decl-name typed-enum-decl-params + typed-enum-decl-entries typed-enum-decl-source + + typed-enum-entry? make-typed-enum-entry + typed-enum-entry-name typed-enum-entry-args + typed-enum-entry-source + typed-extern? make-typed-extern typed-extern-name typed-extern-params typed-extern-return-type typed-extern-kotlin-path typed-extern-source @@ -90,6 +98,8 @@ (defstruct typed-object-decl (name declarations source)) (defstruct typed-class-decl (name params super declarations source)) (defstruct typed-class-super (name args source)) + (defstruct typed-enum-decl (name params entries source)) + (defstruct typed-enum-entry (name args source)) (defstruct typed-extern (name params return-type kotlin-path source)) (defstruct typed-variant (name cases source)) (defstruct typed-variant-case (name fields source)) @@ -741,6 +751,43 @@ (map parse-typed-declaration decls) source))))) + (def (parse-enum-entry form) + (let* ([source (datum-source form)] + [raw-form (datum-value form)] + [form (strip-source-annotations form)]) + (expect-proper-list 'parse-typed-enum-entry form) + (unless (and (pair? form) (symbol? (car form))) + (error 'parse-typed-enum-entry + "expected (ENTRY arg ...)" + form)) + (make-typed-enum-entry + (car form) + (cdr raw-form) + source))) + + (def (parse-enum-decl form) + (let* ([source (datum-source form)] + [raw-form (datum-value form)] + [form (strip-source-annotations form)]) + (expect-proper-list 'parse-typed-enum form) + (unless (>= (length form) 4) + (error 'parse-typed-enum + "expected (enum Name ((param : Type) ...) entry ...)" + form)) + (let ([name (expect-symbol 'parse-typed-enum (cadr form) form)] + [params-form (caddr form)] + [raw-params (caddr raw-form)]) + (unless (and (list? params-form) + (proper-list? params-form)) + (error 'parse-typed-enum + "enum constructor params must be a list" + params-form)) + (make-typed-enum-decl + name + (map parse-param raw-params) + (map parse-enum-entry (cdddr raw-form)) + source)))) + (def (parse-typed-declaration form) (let ([stripped-form (strip-source-annotations form)]) (expect-proper-list 'parse-typed-declaration stripped-form) @@ -753,6 +800,7 @@ [(val var) (parse-property form)] [(object) (parse-object-decl form)] [(class) (parse-class-decl form)] + [(enum) (parse-enum-decl form)] [(variant) (parse-variant form)] [(extern) (parse-extern form)] [(def) (parse-def form)] --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -1555,6 +1555,19 @@ (kotlin-name read) length)))) +(define enum-form + '(typed-library (sample typed enumdecl) + (export ButtonKind) + (type Int32) + (type Float32) + (enum ButtonKind + ((backgroundColor : Int32) + (foregroundColor : Int32) + (textSp : Float32) + (heightDp : Int32)) + (PRIMARY (int32 1) (int32 2) (float32 18.0) (int32 56)) + (NEUTRAL (int32 3) (int32 4) (float32 15.0) (int32 48))))) + (define return-form '(typed-library (sample typed returns) (export guarded) @@ -1585,6 +1598,9 @@ (define kotlin-name-kotlin (typed-library-form->kotlin-string kotlin-name-form)) +(define enum-kotlin + (typed-library-form->kotlin-string enum-form)) + (test-contains "typed class declaration lowers constructor and superclass" class-declaration-kotlin "class ReviewView(context: Context) : View(context) {") @@ -1609,6 +1625,12 @@ (test-contains "typed class declaration lowers method modifiers" class-declaration-kotlin "override fun performClick(): Boolean {\n return run {\n bindSelf(this)\n super.performClick()\n true\n}") +(test-contains "typed enum declaration lowers enum class constructor properties" + enum-kotlin + "enum class ButtonKind(val backgroundColor: Int, val foregroundColor: Int, val textSp: Float, val heightDp: Int) {") +(test-contains "typed enum declaration lowers enum entries" + enum-kotlin + "PRIMARY(1, 2, 18.0f, 56),\n NEUTRAL(3, 4, 15.0f, 48)") (test-contains "typed def kotlin-name lowers emitted method name" kotlin-name-kotlin "override fun read(): Int")