Emit typed Kotlin object declarations
ober
1a1b380b52cb6eeaf1397adfffd73e1c4c8d035c
--- a/lib/jerboa/typed/checker.ss +++ b/lib/jerboa/typed/checker.ss @@ -268,6 +268,7 @@ [(typed-record? decl) (typed-record-name decl)] [(typed-resource? decl) (typed-resource-name decl)] [(typed-variant? decl) (typed-variant-name decl)] + [(typed-object-decl? decl) (typed-object-decl-name decl)] [else #f])) (def (declared-type-names declarations) @@ -304,6 +305,7 @@ (cond [(typed-def? decl) (list (typed-def-name decl))] [(typed-property? decl) (list (typed-property-name decl))] + [(typed-object-decl? decl) (list (typed-object-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)] @@ -904,6 +906,31 @@ (record-elaboration-by-name! (typed-property-name prop) init-ir)) all-errors))) + (def (check-object-decl object type-names) + (let* ([declarations (typed-object-decl-declarations object)] + [local-type-names (declared-type-names declarations)] + [local-value-names (declared-value-names declarations)] + [local-calls (call-env declarations)] + [local-variants (declared-variant-env declarations)] + [local-global-values (global-property-env declarations)] + [visible-type-names (append type-names local-type-names)]) + (parameterize + ([*call-env* (append local-calls (*call-env*))] + [*variant-env* (append local-variants (*variant-env*))] + [*global-value-env* + (append local-global-values (*global-value-env*))]) + (append + (duplicate-errors 'duplicate-type + "duplicate object type declaration" + local-type-names) + (duplicate-errors 'duplicate-value + "duplicate object value declaration" + local-value-names) + (append-map + (lambda (decl) + (check-declaration decl visible-type-names)) + declarations))))) + (def (infer-body exprs env type-names . src*) (let ([src (if (pair? src*) (car src*) #f)]) (cond @@ -3519,6 +3546,7 @@ [(typed-record? decl) (check-record decl type-names)] [(typed-variant? decl) (check-variant decl type-names)] [(typed-property? decl) (check-property decl type-names)] + [(typed-object-decl? decl) (check-object-decl decl type-names)] [(typed-extern? decl) (check-extern decl type-names)] [(typed-def? decl) (check-def decl type-names)] [else '()])) @@ -3553,6 +3581,8 @@ [(typed-def? decl) (memq (typed-def-name decl) exports)] [(typed-property? decl) (memq (typed-property-name decl) exports)] + [(typed-object-decl? decl) + (memq (typed-object-decl-name decl) exports)] [(typed-record? decl) (or (memq (typed-record-name decl) exports) (let any-loop ([rs values]) @@ -3746,7 +3776,19 @@ out) out)))] [else (loop (cdr rest) out)]))]) - (values errors defs))))) + (let* ([returned-names (map elaborated-def-name defs)] + [extras + (let loop ([rest entries] [out '()]) + (cond + [(null? rest) (reverse out)] + [(memq (caar rest) returned-names) + (loop (cdr rest) out)] + [else + (loop (cdr rest) + (cons (make-elaborated-def + (caar rest) #f (cdar rest)) + out))]))]) + (values errors (append defs extras))))))) (def (check-and-elaborate-typed-modules modules) ;; Returns a list of (module-name errors elaborated-defs) triples in --- a/lib/jerboa/typed/kotlin/lower.ss +++ b/lib/jerboa/typed/kotlin/lower.ss @@ -1019,11 +1019,28 @@ #f '())))) + (def (lower-object-declaration decl) + (make-kt-class + 'object + #f + (typed-object-decl-name decl) + '() + '() + (let loop ([decls (typed-object-decl-declarations decl)] [out '()]) + (cond + [(null? decls) (reverse out)] + [else + (let ([lowered (lower-declaration (car decls))]) + (loop (cdr decls) + (if lowered (cons lowered out) out)))])) + '())) + (def (lower-declaration decl) (cond [(typed-record? decl) (lower-record decl)] [(typed-variant? decl) (lower-variant decl)] [(typed-property? decl) (lower-property decl)] + [(typed-object-decl? decl) (lower-object-declaration decl)] [(typed-extern? decl) (lower-extern decl)] [(typed-def? decl) (lower-def decl)] [else #f])) --- a/lib/jerboa/typed/parser.ss +++ b/lib/jerboa/typed/parser.ss @@ -38,6 +38,10 @@ typed-property-mutable? typed-property-name typed-property-type typed-property-init typed-property-source + typed-object-decl? make-typed-object-decl + typed-object-decl-name typed-object-decl-declarations + typed-object-decl-source + typed-extern? make-typed-extern typed-extern-name typed-extern-params typed-extern-return-type typed-extern-kotlin-path typed-extern-source @@ -66,6 +70,7 @@ (defstruct typed-record (name fields source)) (defstruct typed-resource (name close source)) (defstruct typed-property (mutable? name type init source)) + (defstruct typed-object-decl (name declarations source)) (defstruct typed-extern (name params return-type kotlin-path source)) (defstruct typed-variant (name cases source)) (defstruct typed-variant-case (name fields source)) @@ -515,6 +520,20 @@ (expect-symbol 'parse-typed-type-decl (cadr form) form) source))) + (def (parse-object-decl form) + (let* ([source (datum-source form)] + [raw-form (datum-value form)] + [form (strip-source-annotations form)]) + (expect-proper-list 'parse-typed-object form) + (unless (>= (length form) 2) + (error 'parse-typed-object + "expected (object Name declaration ...)" + form)) + (make-typed-object-decl + (expect-symbol 'parse-typed-object (cadr form) form) + (map parse-typed-declaration (cddr raw-form)) + source))) + (def (parse-typed-declaration form) (let ([stripped-form (strip-source-annotations form)]) (expect-proper-list 'parse-typed-declaration stripped-form) @@ -525,6 +544,7 @@ [(record) (parse-record form)] [(resource) (parse-resource form)] [(val var) (parse-property form)] + [(object) (parse-object-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 @@ -1423,5 +1423,40 @@ top-level-property-kotlin "external fun nativeThing(x: Int): String") +(define object-declaration-form + '(typed-library (sample typed objectdecl) + (export SsdVisionBridge) + (type Throwable) + (type Int32) + (object SsdVisionBridge + (extern (nativeDetectRgbaJson + (width : Int32) + (height : Int32) + (rgba : Bytes)) : String + (kotlin-external)) + (var loadError : (Nullable Throwable) + (nullable-none Throwable)) + (def (loadErrorMessage) : String + (throwableMessageOrEmpty loadError))) + (extern (throwableMessageOrEmpty + (error : (Nullable Throwable))) : String + (kotlin-call throwableMessageOrEmpty)))) + +(define object-declaration-kotlin + (typed-library-form->kotlin-string object-declaration-form)) + +(test-contains "typed object declaration lowers to Kotlin object" + object-declaration-kotlin + "object SsdVisionBridge {") +(test-contains "typed object declaration lowers external member" + object-declaration-kotlin + "external fun nativeDetectRgbaJson(width: Int, height: Int, rgba: ByteArray): String") +(test-contains "typed object declaration lowers property member" + object-declaration-kotlin + "var loadError: Throwable? = null") +(test-contains "typed object declaration lowers function member" + object-declaration-kotlin + "fun loadErrorMessage(): String {\n return throwableMessageOrEmpty(loadError)") + (printf "typed-kotlin tests: ~a passed, ~a failed~%" pass fail) (when (> fail 0) (exit 1))