Add typed Kotlin map lookup helpers
ober
7ab18a16f499067f36d57ea79cb138fe0f807e1c
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -50,6 +50,7 @@ '((List . 1) (Vector . 1) (MutableList . 1) + (Map . 2) (Nullable . 1) (Option . 1) (Result . 2) @@ -92,7 +93,7 @@ [(unknown-type) "Define the type in this typed-library, import it later when imports exist, or use a builtin type name."] [(unknown-type-constructor) - "Use a supported compound type constructor: List, Vector, Option, Result, Pair, Owned, Borrow, MutBorrow, or ->."] + "Use a supported compound type constructor: List, Vector, MutableList, Map, Nullable, Option, Result, Pair, Owned, Borrow, MutBorrow, or ->."] [(bad-type-arity) "Check the number of type arguments for the compound type."] [(duplicate-type duplicate-value duplicate-field duplicate-param @@ -487,6 +488,12 @@ (cons 'json-array-put-int32! (make-typed-call-sig (list 'JSONArray 'Int32) 'Unit '() 'jvm-json-array-put-int32 '())) + (cons 'json-array-put-string! + (make-typed-call-sig (list 'JSONArray 'String) 'Unit '() + 'jvm-json-array-put-string '())) + (cons 'json-array-put-json-object! + (make-typed-call-sig (list 'JSONArray 'JSONObject) 'Unit '() + 'jvm-json-array-put-json-object '())) (cons 'json-array-length (make-typed-call-sig (list 'JSONArray) 'Int32 '() 'jvm-json-array-length '())) @@ -1713,6 +1720,53 @@ (eq? (car type) 'MutableList) (cadr type))) + (def (map-key-value-types type) + (and (pair? type) + (eq? (car type) 'Map) + (cons (cadr type) (caddr type)))) + + (def (infer-map-ref-or-null args env type-names expr) + (if (not (= (length args) 2)) + (values #f (bad-constructor-arity expr 'map-ref-or-null 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-ref-or-null expects a Map 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-ref-or-null 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 (list 'Nullable value-type) + (expr-source expr) 'jvm-map-ref-or-null 'map-ref-or-null + arg-irs + (list (cons 'key-type expected-key-type) + (cons 'value-type value-type)))) + (append errors type-errors)))))) + (def (infer-mutable-list-empty args env type-names expr) (if (not (= (length args) 1)) (values #f (bad-constructor-arity expr 'mutable-list-empty 1 args)) @@ -2351,6 +2405,8 @@ (infer-list-size args env type-names expr)] [(list-ref) (infer-list-ref args env type-names expr)] + [(map-ref-or-null) + (infer-map-ref-or-null args env type-names expr)] [(mutable-list-empty) (infer-mutable-list-empty args env type-names expr)] [(mutable-list-add!) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -133,6 +133,7 @@ debug-string jvm-list-size jvm-list-ref + jvm-map-ref-or-null jvm-mutable-list-empty jvm-mutable-list-add jvm-mutable-list-remove @@ -140,6 +141,8 @@ jvm-json-array-empty jvm-json-array-put-float32 jvm-json-array-put-int32 + jvm-json-array-put-string + jvm-json-array-put-json-object jvm-json-array-length jvm-json-array-opt-float32 jvm-json-object-empty --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -101,6 +101,10 @@ (make-kt-type 'List #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) 'Nullable)) (let ([inner (typed-type->kotlin-type (cadr type))]) (make-kt-type (kt-type-name inner) #t (kt-type-args inner)))] @@ -326,6 +330,8 @@ (make-kt-member-get (car args) 'size)] [(jvm-list-ref) (make-kt-index-get (car args) (cadr args))] + [(jvm-map-ref-or-null) + (make-kt-index-get (car args) (cadr args))] [(jvm-mutable-list-empty) (make-kt-new (make-kt-type 'ArrayList #f @@ -371,6 +377,24 @@ 'put (list (cadr args))))) (make-kt-lit 'Unit '()))] + [(jvm-json-array-put-string) + (make-kt-block + (list + (make-kt-expr-stmt + (make-kt-member-call + (car args) + 'put + (list (cadr args))))) + (make-kt-lit 'Unit '()))] + [(jvm-json-array-put-json-object) + (make-kt-block + (list + (make-kt-expr-stmt + (make-kt-member-call + (car args) + 'put + (list (cadr args))))) + (make-kt-lit 'Unit '()))] [(jvm-json-array-length) (make-kt-member-call (car args) 'length '())] [(jvm-json-array-opt-float32) --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -78,7 +78,7 @@ (error-kinds '(typed-library (bad compound) (export f) - (def (f (x : (Map String Nat))) : Nat + (def (f (x : (Dict String Nat))) : Nat 0))) '(unknown-type-constructor)) @@ -965,6 +965,37 @@ (json-object-opt-string json "id")))) '(argument-type-mismatch)) +(test "map-ref-or-null returns nullable map value" + (error-kinds + '(typed-library (body map-ok) + (export find) + (record Cell ((id : String))) + (def (find (cells : (Map String Cell)) (id : String)) : (Nullable Cell) + (map-ref-or-null cells id)))) + '()) + +(test "map-ref-or-null rejects wrong key type" + (error-kinds + '(typed-library (body map-key) + (export find) + (record Cell ((id : String))) + (type Int32) + (def (find (cells : (Map String Cell)) (id : Int32)) : (Nullable Cell) + (map-ref-or-null cells id)))) + '(argument-type-mismatch)) + +(test "json-array accepts string and object puts" + (error-kinds + '(typed-library (body json-array-more) + (export put-values) + (type JSONArray) + (type JSONObject) + (def (put-values (items : JSONArray) (name : String) (json : JSONObject)) : Unit + (begin + (json-array-put-string! items name) + (json-array-put-json-object! items json))))) + '()) + (test "variant constructor and predicate calls" (error-kinds '(typed-library (body variant-ok) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -596,6 +596,22 @@ list-kotlin "cells[0] = cell") +(define map-form + '(typed-library (sample typed maps) + (export findCell) + (record Cell ((name : String))) + (def (findCell (cells : (Map String Cell)) (name : String)) : (Nullable Cell) + (map-ref-or-null cells name)))) + +(define map-kotlin (typed-library-form->kotlin-string map-form)) + +(test-contains "Map type lowers to Kotlin generics" + map-kotlin + "fun findCell(cells: Map<String, Cell>, name: String): Cell?") +(test-contains "Map lookup lowers to Kotlin index get" + map-kotlin + "return cells[name]") + (define json-array-form '(typed-library (sample typed json-array) (export makeNumbers firstNumber) @@ -630,6 +646,23 @@ (def (putCount (items : JSONArray) (count : Int32)) : Unit (json-array-put-int32! items count)))) "items.put(count)") +(test-contains "JSONArray put String lowers directly" + (typed-library-form->kotlin-string + '(typed-library (sample typed json-array-string) + (export putName) + (type JSONArray) + (def (putName (items : JSONArray) (name : String)) : Unit + (json-array-put-string! items name)))) + "items.put(name)") +(test-contains "JSONArray put JSONObject lowers directly" + (typed-library-form->kotlin-string + '(typed-library (sample typed json-array-object) + (export putObject) + (type JSONArray) + (type JSONObject) + (def (putObject (items : JSONArray) (json : JSONObject)) : Unit + (json-array-put-json-object! items json)))) + "items.put(json)") (test-contains "JSONArray length lowers to method call" json-array-kotlin "items.length()")