Extend typed Kotlin JVM collections and JSON
ober
46dfd30d2ab66b59ef02336f5a0c7981b838bf84
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -46,14 +46,16 @@ (def *elaboration-scope* (make-parameter #f)) (def builtin-type-names - '(Unit Bool Char Int Nat Fixnum Float String Bytes Symbol Keyword)) + '(Unit Bool Char Int Nat Fixnum Float String Bytes Symbol Keyword Any)) (def compound-type-arities '((List . 1) (Array . 1) (Vector . 1) + (Iterator . 1) (MutableList . 1) (Map . 2) + (MutableMap . 2) (Set . 1) (MutableSet . 1) (Out . 1) @@ -373,6 +375,12 @@ (eq? (car actual) 'MutableList) (eq? (car expected) 'List) (type-assignable? (cadr actual) (cadr expected))) + (and (pair? actual) + (pair? expected) + (eq? (car actual) 'MutableMap) + (eq? (car expected) 'Map) + (type-assignable? (cadr actual) (cadr expected)) + (type-assignable? (caddr actual) (caddr expected))) (owned-to-borrow-assignable? actual expected))) (def (owned-type? type) @@ -594,6 +602,12 @@ (cons 'json-array-opt-string (make-typed-call-sig (list 'JSONArray 'Int32) 'String '() 'jvm-json-array-opt-string '())) + (cons 'json-array-opt-int32 + (make-typed-call-sig (list 'JSONArray 'Int32 'Int32) 'Int32 '() + 'jvm-json-array-opt-int32 '())) + (cons 'json-array-opt-any + (make-typed-call-sig (list 'JSONArray 'Int32) (list 'Nullable 'Any) '() + 'jvm-json-array-opt-any '())) (cons 'json-array-length (make-typed-call-sig (list 'JSONArray) 'Int32 '() 'jvm-json-array-length '())) @@ -636,6 +650,9 @@ (cons 'json-object-opt-string-default (make-typed-call-sig (list 'JSONObject 'String 'String) 'String '() 'jvm-json-object-opt-string-default '())) + (cons 'json-object-opt-any + (make-typed-call-sig (list 'JSONObject 'String) (list 'Nullable 'Any) '() + 'jvm-json-object-opt-any '())) (cons 'json-object-opt-bool-default (make-typed-call-sig (list 'JSONObject 'String 'Bool) 'Bool '() 'jvm-json-object-opt-bool-default '())) @@ -2606,7 +2623,12 @@ (def (map-key-value-types type) (and (pair? type) - (eq? (car type) 'Map) + (memq (car type) '(Map MutableMap)) + (cons (cadr type) (caddr type)))) + + (def (mutable-map-key-value-types type) + (and (pair? type) + (eq? (car type) 'MutableMap) (cons (cadr type) (caddr type)))) (def (set-inner-type type) @@ -2641,7 +2663,7 @@ (list (make-check-error 'argument-type-mismatch - "map-ref-or-null expects a Map value" + "map-ref-or-null expects a Map or MutableMap value" expr (and (pair? args) (expr-source (car args)))))) (if (and expected-key-type key-type @@ -2666,6 +2688,48 @@ (cons 'value-type value-type)))) (append errors type-errors)))))) + (def (infer-map-contains-key args env type-names expr) + (if (not (= (length args) 2)) + (values #f (bad-constructor-arity expr 'map-contains-key? 2 args)) + (let-values ([(arg-irs errors) (infer-args args env type-names)]) + (let* ([types (ir-list-types arg-irs)] + [map-type (car types)] + [key-type (cadr types)] + [kv-types (map-key-value-types map-type)] + [expected-key-type (and kv-types (car kv-types))] + [value-type (and kv-types (cdr kv-types))] + [type-errors + (append + (if kv-types + '() + (list + (make-check-error + 'argument-type-mismatch + "map-contains-key? expects a Map or MutableMap value" + expr + (and (pair? args) (expr-source (car args)))))) + (if (and expected-key-type key-type + (type-assignable? key-type expected-key-type)) + '() + (list + (make-check-error + 'argument-type-mismatch + "map-contains-key? key must match the map key type" + expr + (and (pair? (cdr args)) + (expr-source (cadr args)))))))] + [ok? (and (all-irs-valid? arg-irs) + (null? errors) + (null? type-errors))]) + (values + (and ok? + (make-typed-ir-call 'Bool + (expr-source expr) 'jvm-map-contains-key 'map-contains-key? + arg-irs + (list (cons 'key-type expected-key-type) + (cons 'value-type value-type)))) + (append errors type-errors)))))) + (def (infer-set-contains args env type-names expr) (if (not (= (length args) 2)) (values #f (bad-constructor-arity expr 'set-contains? 2 args)) @@ -2815,6 +2879,75 @@ (list (cons 'inner-type type-arg)))) errors)))) + (def (infer-mutable-map-empty args env type-names expr) + (if (not (= (length args) 2)) + (values #f (bad-constructor-arity expr 'mutable-map-empty 2 args)) + (let* ([key-type (strip-source-annotations (car args))] + [value-type (strip-source-annotations (cadr args))] + [errors (append (check-type key-type type-names) + (check-type value-type type-names))]) + (values + (and (null? errors) + (make-typed-ir-call (list 'MutableMap key-type value-type) + (expr-source expr) 'jvm-mutable-map-empty 'mutable-map-empty + '() + (list (cons 'key-type key-type) + (cons 'value-type value-type)))) + errors)))) + + (def (infer-mutable-map-put args env type-names expr) + (if (not (= (length args) 3)) + (values #f (bad-constructor-arity expr 'mutable-map-put! 3 args)) + (let-values ([(arg-irs errors) (infer-args args env type-names)]) + (let* ([types (ir-list-types arg-irs)] + [map-type (car types)] + [key-type (cadr types)] + [value-type (caddr types)] + [kv-types (mutable-map-key-value-types map-type)] + [expected-key-type (and kv-types (car kv-types))] + [expected-value-type (and kv-types (cdr kv-types))] + [type-errors + (append + (if kv-types + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-map-put! expects a MutableMap value" + expr + (and (pair? args) (expr-source (car args)))))) + (if (and expected-key-type key-type + (type-assignable? key-type expected-key-type)) + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-map-put! key must match the map key type" + expr + (and (pair? (cdr args)) + (expr-source (cadr args)))))) + (if (and expected-value-type value-type + (type-assignable? value-type expected-value-type)) + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-map-put! value must match the map value type" + expr + (and (pair? (cddr args)) + (expr-source (caddr args)))))))] + [ok? (and (all-irs-valid? arg-irs) + (null? errors) + (null? type-errors))]) + (values + (and ok? + (make-typed-ir-call 'Unit + (expr-source expr) 'jvm-mutable-map-put 'mutable-map-put! + arg-irs + (list (cons 'key-type expected-key-type) + (cons 'value-type expected-value-type)))) + (append errors type-errors)))))) + (def (infer-mutable-list-add args env type-names expr) (if (not (= (length args) 2)) (values #f (bad-constructor-arity expr 'mutable-list-add! 2 args)) @@ -3922,6 +4055,8 @@ (infer-list-ref args env type-names expr)] [(map-ref-or-null) (infer-map-ref-or-null args env type-names expr)] + [(map-contains-key?) + (infer-map-contains-key args env type-names expr)] [(set-contains?) (infer-set-contains args env type-names expr)] [(pair) @@ -3938,8 +4073,12 @@ (infer-mutable-list-empty args env type-names expr)] [(mutable-set-empty) (infer-mutable-set-empty args env type-names expr)] + [(mutable-map-empty) + (infer-mutable-map-empty args env type-names expr)] [(mutable-list-add!) (infer-mutable-list-add args env type-names expr)] + [(mutable-map-put!) + (infer-mutable-map-put args env type-names expr)] [(mutable-set-add!) (infer-mutable-set-add args env type-names expr)] [(mutable-list-remove!) --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -114,12 +114,18 @@ (make-kt-type-projection 'in (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) 'Iterator)) + (make-kt-type 'Iterator #f (list (typed-type->kotlin-type (cadr type))))] [(and (pair? type) (eq? (car type) 'MutableList)) (make-kt-type 'MutableList #f (list (typed-type->kotlin-type (cadr type))))] [(and (pair? type) (eq? (car type) 'Map)) (make-kt-type 'Map #f (list (typed-type->kotlin-type (cadr type)) (typed-type->kotlin-type (caddr type))))] + [(and (pair? type) (eq? (car type) 'MutableMap)) + (make-kt-type 'MutableMap #f + (list (typed-type->kotlin-type (cadr type)) + (typed-type->kotlin-type (caddr type))))] [(and (pair? type) (eq? (car type) 'Set)) (make-kt-type 'Set #f (list (typed-type->kotlin-type (cadr type))))] [(and (pair? type) (eq? (car type) 'MutableSet)) @@ -405,6 +411,22 @@ (make-kt-call (kt-name1 'listOf) args)] [(jvm-map-ref-or-null) (make-kt-index-get (car args) (cadr args))] + [(jvm-map-contains-key) + (make-kt-member-call (car args) 'containsKey (list (cadr args)))] + [(jvm-mutable-map-empty) + (make-kt-new + (make-kt-type 'LinkedHashMap #f + (list (typed-type->kotlin-type + (info-ref info 'key-type 'Any)) + (typed-type->kotlin-type + (info-ref info 'value-type 'Any)))) + '())] + [(jvm-mutable-map-put) + (make-kt-block + (list + (make-kt-assign (make-kt-index-get (car args) (cadr args)) + (caddr args))) + (make-kt-lit 'Unit '()))] [(jvm-set-contains) (make-kt-member-call (car args) 'contains (cdr args))] [(jvm-mutable-set-empty) @@ -500,6 +522,10 @@ (make-kt-member-call (car args) 'optJSONObject (cdr args))] [(jvm-json-array-opt-string) (make-kt-member-call (car args) 'optString (cdr args))] + [(jvm-json-array-opt-int32) + (make-kt-member-call (car args) 'optInt (cdr args))] + [(jvm-json-array-opt-any) + (make-kt-member-call (car args) 'opt (cdr args))] [(jvm-json-array-length) (make-kt-member-call (car args) 'length '())] [(jvm-json-array-opt-float32) @@ -589,6 +615,8 @@ (make-kt-member-call (car args) 'optString (cdr args))] [(jvm-json-object-opt-string-default) (make-kt-member-call (car args) 'optString (cdr args))] + [(jvm-json-object-opt-any) + (make-kt-member-call (car args) 'opt (cdr args))] [(jvm-json-object-opt-bool-default) (make-kt-member-call (car args) 'optBoolean (cdr args))] [(jvm-json-object-opt-float32) --- a/lib/jerboa/typed/kotlin/print.ss +++ b/lib/jerboa/typed/kotlin/print.ss @@ -162,6 +162,7 @@ (cond [(char=? ch #\\) (display "\\\\" port)] [(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)] --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -64,8 +64,8 @@ (list (make-kt-lit 'String "box_types.csv")))) "assets.`open`(\"box_types.csv\")") (test "string literal escapes" - (kotlin-string-literal "a\n\"b\"\\c") - "\"a\\n\\\"b\\\"\\\\c\"") + (kotlin-string-literal "a\n\"b\"\\c$d") + "\"a\\n\\\"b\\\"\\\\c\\$d\"") (test "lambda expression printer" (kotlin-expr->string (make-kt-lambda @@ -1094,10 +1094,20 @@ (define map-form '(typed-library (sample typed maps) - (export findCell) + (export findCell makeCells putCell hasCell nextName) (record Cell ((name : String))) + (extern (iteratorNext (items : (Iterator String))) : String + (kotlin-member-call next)) (def (findCell (cells : (Map String Cell)) (name : String)) : (Nullable Cell) - (map-ref-or-null cells name)))) + (map-ref-or-null cells name)) + (def (makeCells) : (MutableMap String Cell) + (mutable-map-empty String Cell)) + (def (putCell (cells : (MutableMap String Cell)) (cell : Cell)) : Unit + (mutable-map-put! cells (Cell-name cell) cell)) + (def (hasCell (cells : (MutableMap String Cell)) (name : String)) : Bool + (map-contains-key? cells name)) + (def (nextName (items : (Iterator String))) : String + (iteratorNext items)))) (define map-kotlin (typed-library-form->kotlin-string map-form)) @@ -1107,6 +1117,21 @@ (test-contains "Map lookup lowers to Kotlin index get" map-kotlin "return cells[name]") +(test-contains "MutableMap type lowers to Kotlin generics" + map-kotlin + "fun makeCells(): MutableMap<String, Cell>") +(test-contains "MutableMap empty lowers to linked hash map" + map-kotlin + "return LinkedHashMap<String, Cell>()") +(test-contains "MutableMap put lowers to indexed assignment" + map-kotlin + "cells[cell.name] = cell") +(test-contains "Map contains-key lowers to Kotlin containsKey" + map-kotlin + "return cells.containsKey(name)") +(test-contains "Iterator type lowers to Kotlin generic" + map-kotlin + "fun nextName(items: Iterator<String>): String") (define set-form '(typed-library (sample typed set) @@ -1161,7 +1186,7 @@ (define json-array-form '(typed-library (sample typed json-array) - (export makeNumbers firstNumber) + (export makeNumbers firstNumber firstInt rawItem) (type JSONArray) (type Int32) (type Float32) @@ -1174,7 +1199,11 @@ (def (firstNumber (items : JSONArray)) : Float32 (if (< (json-array-length items) (int32 1)) (float32 0.0) - (json-array-opt-float32 items (int32 0) (float32 0.0)))))) + (json-array-opt-float32 items (int32 0) (float32 0.0)))) + (def (firstInt (items : JSONArray)) : Int32 + (json-array-opt-int32 items (int32 0) (int32 -1))) + (def (rawItem (items : JSONArray) (index : Int32)) : (Nullable Any) + (json-array-opt-any items index)))) (define json-array-kotlin (typed-library-form->kotlin-string json-array-form)) @@ -1239,6 +1268,12 @@ (def (optName (items : JSONArray) (index : Int32)) : String (json-array-opt-string items index)))) "items.optString(index)") +(test-contains "JSONArray opt Int32 lowers to optInt" + json-array-kotlin + "return items.optInt(0, -1)") +(test-contains "JSONArray opt Any lowers to opt" + json-array-kotlin + "return items.opt(index)") (test-contains "JSONArray length lowers to method call" json-array-kotlin "items.length()") @@ -1248,7 +1283,7 @@ (define json-object-form '(typed-library (sample typed json-object) - (export makeCell parseCell copyCell readX readXDefault readCount readActive readItems readMeta readName readNameDefault) + (export makeCell parseCell copyCell readX readXDefault readCount readActive readItems readMeta readName readNameDefault rawField) (type JSONObject) (type JSONArray) (type Float32) @@ -1288,7 +1323,9 @@ (def (readName (json : JSONObject)) : String (json-object-opt-string json "name")) (def (readNameDefault (json : JSONObject)) : String - (json-object-opt-string-default json "name" "truth")))) + (json-object-opt-string-default json "name" "truth")) + (def (rawField (json : JSONObject) (key : String)) : (Nullable Any) + (json-object-opt-any json key)))) (define json-object-kotlin (typed-library-form->kotlin-string json-object-form)) @@ -1349,6 +1386,9 @@ (test-contains "JSONObject opt String default lowers to optString default" json-object-kotlin "json.optString(\"name\", \"truth\")") +(test-contains "JSONObject opt Any lowers to opt" + json-object-kotlin + "return json.opt(key)") (define fold-form '(typed-library (sample typed fold) @@ -1435,7 +1475,7 @@ (test-contains "String endsWith lowers to Kotlin endsWith" ocr-string-kotlin "text.endsWith(\"?\")") (test-contains "String regex matches lowers to Kotlin Regex matches" ocr-string-kotlin - "Regex(\"^\\\\d+\\\\s+boxes$\").matches(text)") + "Regex(\"^\\\\d+\\\\s+boxes\\$\").matches(text)") (test-contains "String startsWith lowers to Kotlin startsWith" ocr-string-kotlin "notes.startsWith(\"Guess:\")") (test-contains "String compare-to lowers to Kotlin compareTo" ocr-string-kotlin