Add typed Kotlin Pair accessors
ober
95eb94930e82dc21c387b51cd97081a239c98931
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -1810,6 +1810,11 @@ (memq (car type) '(Set MutableSet)) (cadr type))) + (def (pair-component-types type) + (and (pair? type) + (eq? (car type) 'Pair) + (cons (cadr type) (caddr type)))) + (def (mutable-set-inner-type type) (and (pair? type) (eq? (car type) 'MutableSet) @@ -1896,6 +1901,33 @@ (list (cons 'inner-type inner-type)))) (append errors type-errors)))))) + (def (infer-pair-access args env type-names expr op kind selector) + (if (not (= (length args) 1)) + (values #f (bad-constructor-arity expr op 1 args)) + (let-values ([(arg-irs errors) (infer-args args env type-names)]) + (let* ([pair-type (car (ir-list-types arg-irs))] + [components (pair-component-types pair-type)] + [return-type (and components (selector components))] + [type-errors + (if return-type + '() + (list + (make-check-error + 'argument-type-mismatch + "pair access expects a Pair value" + expr + (and (pair? args) (expr-source (car args))))))] + [ok? (and (all-irs-valid? arg-irs) + (null? errors) + (null? type-errors))]) + (values + (and ok? + (make-typed-ir-call return-type (expr-source expr) + kind op arg-irs + (list (cons 'left-type (and components (car components))) + (cons 'right-type (and components (cdr components)))))) + (append errors type-errors)))))) + (def (infer-pair args env type-names expr) (if (not (= (length args) 2)) (values #f (bad-constructor-arity expr 'pair 2 args)) @@ -2682,6 +2714,12 @@ (infer-set-contains args env type-names expr)] [(pair) (infer-pair args env type-names expr)] + [(pair-first) + (infer-pair-access args env type-names expr + 'pair-first 'jvm-pair-first car)] + [(pair-second) + (infer-pair-access args env type-names expr + 'pair-second 'jvm-pair-second cdr)] [(mutable-list-empty) (infer-mutable-list-empty args env type-names expr)] [(mutable-set-empty) --- a/lib/jerboa/typed/core.ss +++ b/lib/jerboa/typed/core.ss @@ -135,6 +135,8 @@ debug-string kotlin-call jvm-pair + jvm-pair-first + jvm-pair-second jvm-list-size jvm-list-ref jvm-map-ref-or-null --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -249,6 +249,10 @@ (make-kt-member-call (car args) 'toString '())] [(jvm-pair) (make-kt-call (kt-name1 'Pair) args)] + [(jvm-pair-first) + (make-kt-member-get (car args) 'first)] + [(jvm-pair-second) + (make-kt-member-get (car args) 'second)] [(jvm-float32-abs) (make-kt-call (make-kt-name '(kotlin math abs)) args)] [(jvm-float32-max) --- a/tests/test-typed-kotlin.ss +++ b/tests/test-typed-kotlin.ss @@ -699,16 +699,26 @@ (define pair-form '(typed-library (sample typed pairs) - (export makeNameCount) + (export makeNameCount nameOf countOf) (type Int32) (def (makeNameCount (name : String) (count : Int32)) : (Pair String Int32) - (pair name count)))) + (pair name count)) + (def (nameOf (item : (Pair String Int32))) : String + (pair-first item)) + (def (countOf (item : (Pair String Int32))) : Int32 + (pair-second item)))) (define pair-kotlin (typed-library-form->kotlin-string pair-form)) (test-contains "Pair constructor lowers to Kotlin Pair call" pair-kotlin "return Pair(name, count)") +(test-contains "Pair first lowers to Kotlin first property" + pair-kotlin + "return item.first") +(test-contains "Pair second lowers to Kotlin second property" + pair-kotlin + "return item.second") (define json-array-form '(typed-library (sample typed json-array)