Add typed Kotlin mutable collections
ober
59834d6e71b430a7280ce9ff2bd8e95558812877
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -52,6 +52,7 @@ (MutableList . 1) (Map . 2) (Set . 1) + (MutableSet . 1) (Nullable . 1) (Option . 1) (Result . 2) @@ -94,7 +95,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, MutableList, Map, Set, Nullable, Option, Result, Pair, Owned, Borrow, MutBorrow, or ->."] + "Use a supported compound type constructor: List, Vector, MutableList, Map, Set, MutableSet, 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 @@ -334,6 +335,11 @@ (or (equal? actual expected) (eq? expected any-value-type) (and (eq? actual 'Nat) (eq? expected 'Int)) + (and (pair? actual) + (pair? expected) + (eq? (car actual) 'MutableSet) + (eq? (car expected) 'Set) + (type-assignable? (cadr actual) (cadr expected))) (owned-to-borrow-assignable? actual expected))) (def (owned-type? type) @@ -1767,7 +1773,12 @@ (def (set-inner-type type) (and (pair? type) - (eq? (car type) 'Set) + (memq (car type) '(Set MutableSet)) + (cadr type))) + + (def (mutable-set-inner-type type) + (and (pair? type) + (eq? (car type) 'MutableSet) (cadr type))) (def (infer-map-ref-or-null args env type-names expr) @@ -1827,7 +1838,7 @@ (list (make-check-error 'argument-type-mismatch - "set-contains? expects a Set value" + "set-contains? expects a Set or MutableSet value" expr (and (pair? args) (expr-source (car args)))))) (if (and inner-type value-type @@ -1921,6 +1932,44 @@ (list (cons 'inner-type inner-type)))) (append errors type-errors)))))) + (def (infer-mutable-set-add args env type-names expr) + (if (not (= (length args) 2)) + (values #f (bad-constructor-arity expr 'mutable-set-add! 2 args)) + (let-values ([(arg-irs errors) (infer-args args env type-names)]) + (let* ([types (ir-list-types arg-irs)] + [set-type (car types)] + [value-type (cadr types)] + [inner-type (mutable-set-inner-type set-type)] + [type-errors + (append + (if inner-type + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-set-add! expects a MutableSet value" + expr + (and (pair? args) (expr-source (car args)))))) + (if (and inner-type value-type + (type-assignable? value-type inner-type)) + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-set-add! value must match the set element 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 'Unit (expr-source expr) + 'jvm-mutable-set-add 'mutable-set-add! arg-irs + (list (cons 'inner-type inner-type)))) + (append errors type-errors)))))) + (def (infer-mutable-list-remove args env type-names expr) (if (not (= (length args) 2)) (values #f (bad-constructor-arity expr 'mutable-list-remove! 2 args)) @@ -2008,6 +2057,78 @@ (list (cons 'inner-type inner-type)))) (append errors type-errors)))))) + (def (infer-mutable-list-clear args env type-names expr) + (if (not (= (length args) 1)) + (values #f (bad-constructor-arity expr 'mutable-list-clear! 1 args)) + (let-values ([(list-ir errors) + (infer-expression (car args) env type-names)]) + (let* ([list-type (ir-type list-ir)] + [inner-type (mutable-list-inner-type list-type)] + [type-errors + (if inner-type + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-list-clear! expects a MutableList value" + expr + (and (pair? args) (expr-source (car args))))))] + [ok? (and list-ir (null? errors) (null? type-errors))]) + (values + (and ok? + (make-typed-ir-call 'Unit (expr-source expr) + 'jvm-mutable-list-clear 'mutable-list-clear! (list list-ir) + (list (cons 'inner-type inner-type)))) + (append errors type-errors)))))) + + (def (infer-mutable-list-add-all args env type-names expr) + (if (not (= (length args) 2)) + (values #f (bad-constructor-arity expr 'mutable-list-add-all! 2 args)) + (let-values ([(arg-irs errors) (infer-args args env type-names)]) + (let* ([types (ir-list-types arg-irs)] + [target-type (car types)] + [source-type (cadr types)] + [target-inner-type (mutable-list-inner-type target-type)] + [source-inner-type (list-like-inner-type source-type)] + [type-errors + (append + (if target-inner-type + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-list-add-all! expects a MutableList target" + expr + (and (pair? args) (expr-source (car args)))))) + (if source-inner-type + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-list-add-all! expects a List, Vector, or MutableList source" + expr + (and (pair? (cdr args)) + (expr-source (cadr args)))))) + (if (and target-inner-type source-inner-type + (type-assignable? source-inner-type target-inner-type)) + '() + (list + (make-check-error + 'argument-type-mismatch + "mutable-list-add-all! source elements must match the target element 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 'Unit (expr-source expr) + 'jvm-mutable-list-add-all 'mutable-list-add-all! arg-irs + (list (cons 'inner-type target-inner-type)))) + (append errors type-errors)))))) + (def (infer-make-bytevector args env type-names expr) ;; (make-bytevector size) or (make-bytevector size fill). Size and fill are ;; numeric; the result is a fresh Bytes buffer. A missing fill defaults to a @@ -2518,10 +2639,16 @@ (infer-mutable-list-empty args env type-names expr)] [(mutable-list-add!) (infer-mutable-list-add args env type-names expr)] + [(mutable-set-add!) + (infer-mutable-set-add args env type-names expr)] [(mutable-list-remove!) (infer-mutable-list-remove args env type-names expr)] [(mutable-list-set!) (infer-mutable-list-set args env type-names expr)] + [(mutable-list-clear!) + (infer-mutable-list-clear args env type-names expr)] + [(mutable-list-add-all!) + (infer-mutable-list-add-all args env type-names expr)] [(bytes-build) (infer-bytes-build args env type-names expr)] [(option-some) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -136,10 +136,13 @@ jvm-list-ref jvm-map-ref-or-null jvm-set-contains + jvm-mutable-set-add jvm-mutable-list-empty jvm-mutable-list-add jvm-mutable-list-remove jvm-mutable-list-set + jvm-mutable-list-clear + jvm-mutable-list-add-all jvm-json-array-empty jvm-json-array-put-float32 jvm-json-array-put-int32 --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -107,6 +107,8 @@ (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)) + (make-kt-type 'MutableSet #f (list (typed-type->kotlin-type (cadr 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)))] @@ -354,6 +356,12 @@ (make-kt-index-get (car args) (cadr args))] [(jvm-set-contains) (make-kt-member-call (car args) 'contains (cdr args))] + [(jvm-mutable-set-add) + (make-kt-block + (list + (make-kt-expr-stmt + (make-kt-member-call (car args) 'add (list (cadr args))))) + (make-kt-lit 'Unit '()))] [(jvm-mutable-list-empty) (make-kt-new (make-kt-type 'ArrayList #f @@ -378,6 +386,18 @@ (make-kt-assign (make-kt-index-get (car args) (cadr args)) (caddr args))) (make-kt-lit 'Unit '()))] + [(jvm-mutable-list-clear) + (make-kt-block + (list + (make-kt-expr-stmt + (make-kt-member-call (car args) 'clear '()))) + (make-kt-lit 'Unit '()))] + [(jvm-mutable-list-add-all) + (make-kt-block + (list + (make-kt-expr-stmt + (make-kt-member-call (car args) 'addAll (list (cadr args))))) + (make-kt-lit 'Unit '()))] [(jvm-json-array-empty) (make-kt-new (make-kt-type 'JSONArray #f '()) '())] [(jvm-json-array-put-float32) --- a/tests/test-typed-checker.ss +++ b/tests/test-typed-checker.ss @@ -880,6 +880,27 @@ (mutable-list-remove! cells cell)))) '()) +(test "mutable-list clear and add-all accept compatible lists" + (error-kinds + '(typed-library (body mutable-list-bulk-ok) + (export replace-names!) + (def (replace-names! (target : (MutableList String)) + (source : (List String))) : Unit + (begin + (mutable-list-clear! target) + (mutable-list-add-all! target source))))) + '()) + +(test "mutable-list add-all rejects wrong element type" + (error-kinds + '(typed-library (body mutable-list-bulk-element) + (export replace-names!) + (type Int32) + (def (replace-names! (target : (MutableList String)) + (source : (List Int32))) : Unit + (mutable-list-add-all! target source)))) + '(argument-type-mismatch)) + (test "mutable-list remove rejects immutable list receiver" (error-kinds '(typed-library (body mutable-list-remove-receiver) @@ -1005,6 +1026,35 @@ (set-contains? ids id)))) '()) +(test "mutable-set accepts contains and add" + (error-kinds + '(typed-library (body mutable-set-ok) + (export remember?) + (def (remember? (ids : (MutableSet String)) (id : String)) : Bool + (begin + (mutable-set-add! ids id) + (set-contains? ids id))))) + '()) + +(test "mutable-set add rejects wrong element type" + (error-kinds + '(typed-library (body mutable-set-wrong-element) + (export add-id!) + (type Int32) + (def (add-id! (ids : (MutableSet String)) (id : Int32)) : Unit + (mutable-set-add! ids id)))) + '(argument-type-mismatch)) + +(test "mutable-set is assignable to set parameter" + (error-kinds + '(typed-library (body mutable-set-assignable) + (export seen-through-set?) + (def (seen? (ids : (Set String)) (id : String)) : Bool + (set-contains? ids id)) + (def (seen-through-set? (ids : (MutableSet String)) (id : String)) : Bool + (seen? ids id)))) + '()) + (test "set-contains rejects wrong element type" (error-kinds '(typed-library (body set-contains-wrong-element) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -568,7 +568,7 @@ (define list-form '(typed-library (sample typed lists) (export make-Cell Cell? Cell-x listCount firstX secondName - emptyCells appendCell removeCell replaceCell) + emptyCells appendCell removeCell replaceCell replaceNames) (type Int32) (type Float32) (record Cell @@ -587,7 +587,12 @@ (def (removeCell (cells : (MutableList Cell)) (cell : Cell)) : Unit (mutable-list-remove! cells cell)) (def (replaceCell (cells : (MutableList Cell)) (cell : Cell)) : Unit - (mutable-list-set! cells (int32 0) cell)))) + (mutable-list-set! cells (int32 0) cell)) + (def (replaceNames (target : (MutableList String)) + (source : (List String))) : Unit + (begin + (mutable-list-clear! target) + (mutable-list-add-all! target source))))) (define list-kotlin (typed-library-form->kotlin-string list-form)) @@ -615,6 +620,12 @@ (test-contains "MutableList set lowers to indexed assignment" list-kotlin "cells[0] = cell") +(test-contains "MutableList clear lowers to Kotlin clear" + list-kotlin + "target.clear()") +(test-contains "MutableList add-all lowers to Kotlin addAll" + list-kotlin + "target.addAll(source)") (define map-form '(typed-library (sample typed maps) @@ -634,9 +645,11 @@ (define set-form '(typed-library (sample typed set) - (export seen?) + (export seen? remember!) (def (seen? (ids : (Set String)) (id : String)) : Bool - (set-contains? ids id)))) + (set-contains? ids id)) + (def (remember! (ids : (MutableSet String)) (id : String)) : Unit + (mutable-set-add! ids id)))) (define set-kotlin (typed-library-form->kotlin-string set-form)) @@ -646,6 +659,12 @@ (test-contains "Set contains lowers to Kotlin contains" set-kotlin "return ids.contains(id)") +(test-contains "MutableSet type lowers to Kotlin generics" + set-kotlin + "fun remember_bang(ids: MutableSet<String>, id: String)") +(test-contains "MutableSet add lowers to Kotlin add" + set-kotlin + "ids.add(id)") (define pair-form '(typed-library (sample typed pairs)