(.require [library [lux (.except is as type) [abstract ["[0]" monad (.only Monad do)] ["[0]" enum]] [control ["<>" parser] ["[0]" function] ["[0]" io] ["[0]" maybe] ["[0]" try (.only Try)]] [data ["[0]" product] ["[0]" bit (.use "[1]#[0]" codec)] ["[0]" text (.use "[1]#[0]" equivalence monoid) ["%" \\format (.only format)]] [collection ["[0]" array (.only Array)] ["[0]" list (.use "[1]#[0]" monad mix monoid)]]] ["[0]" macro (.only with_symbols) [syntax (.only syntax)] ["^" pattern] ["[0]" template]] ["[0]" meta (.only) ["[0]" type (.use "[1]#[0]" equivalence)] ["[0]" code (.only) ["<[1]>" \\parser (.only Parser)]]]]]) (with_template [ ] [(def .public ( value) (-> (Primitive ) (Primitive )) ( value))] [byte_to_long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] [short_to_long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"] [double_to_int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"] [double_to_long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"] [double_to_float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"] [float_to_int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"] [float_to_long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"] [float_to_double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"] [int_to_byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"] [int_to_short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"] [int_to_long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"] [int_to_float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"] [int_to_double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"] [int_to_char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"] [long_to_byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"] [long_to_short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"] [long_to_int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"] [long_to_float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"] [long_to_double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"] [char_to_byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"] [char_to_short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"] [char_to_int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"] [char_to_long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"] ) (with_template [ ] [(def .public (template ( it) [(|> it (.is ) (.as (Primitive )))])) (def .public (template ( it) [(|> it (.is (Primitive )) (.as ))]))] [as_boolean .Bit "java.lang.Boolean" of_boolean] [as_long .Int "java.lang.Long" of_long] [as_double .Frac "java.lang.Double" of_double] [as_string .Text "java.lang.String" of_string] ) (with_template [ <$> <$'> ] [(def .public (template ( it) [(|> it (.is ) (.as (Primitive )) <$> (.is (Primitive )))])) (def .public (template ( it) [(|> it (.is (Primitive )) <$'> (.is (Primitive )) (.as ))]))] [as_byte .Int ..long_to_byte "java.lang.Long" ..byte_to_long "java.lang.Byte" of_byte] [as_short .Int ..long_to_short "java.lang.Long" ..short_to_long "java.lang.Short" of_short] [as_int .Int ..long_to_int "java.lang.Long" ..int_to_long "java.lang.Integer" of_int] [as_float .Frac ..double_to_float "java.lang.Double" ..float_to_double "java.lang.Float" of_float] ) ... [Utils] (def constructor_method_name "") (def member_separator "::") ... Types (.type JVM_Code Text) (.type BoundKind (Variant {#UpperBound} {#LowerBound})) (.type GenericType (Rec GenericType (Variant {#GenericTypeVar Text} {#GenericClass [Text (List GenericType)]} {#GenericArray GenericType} {#GenericWildcard (Maybe [BoundKind GenericType])}))) (.type Type_Parameter [Text (List GenericType)]) (.type Primitive_Mode (Variant {#ManualPrM} {#AutoPrM})) (.type .public Privacy (Variant {#PublicP} {#PrivateP} {#ProtectedP} {#DefaultP})) (.type .public State (Variant {#VolatileS} {#FinalS} {#DefaultS})) (.type .public Inheritance (Variant {#FinalI} {#AbstractI} {#DefaultI})) (.type Class_Kind (Variant {#Class} {#Interface})) (.type Class_Declaration (Record [#class_name Text #class_params (List Type_Parameter)])) (.type StackFrame (Primitive "java/lang/StackTraceElement")) (.type StackTrace (Array StackFrame)) (.type Super_Class_Decl (Record [#super_class_name Text #super_class_params (List GenericType)])) (.type AnnotationParam [Text Code]) (.type Annotation (Record [#ann_name Text #ann_params (List AnnotationParam)])) (.type Member_Declaration (Record [#member_name Text #member_privacy Privacy #member_anns (List Annotation)])) (.type FieldDecl (Variant {#ConstantField GenericType Code} {#VariableField State GenericType})) (.type MethodDecl (Record [#method_tvars (List Type_Parameter) #method_inputs (List GenericType) #method_output GenericType #method_exs (List GenericType)])) (.type ArgDecl (Record [#arg_name Text #arg_type GenericType])) (.type ConstructorArg [GenericType Code]) (.type Method_Definition (Variant {#ConstructorMethod [Bit (List Type_Parameter) (List ArgDecl) (List ConstructorArg) Code (List GenericType)]} {#VirtualMethod [Bit Bit (List Type_Parameter) Text (List ArgDecl) GenericType Code (List GenericType)]} {#OverridenMethod [Bit Class_Declaration (List Type_Parameter) Text (List ArgDecl) GenericType Code (List GenericType)]} {#StaticMethod [Bit (List Type_Parameter) (List ArgDecl) GenericType Code (List GenericType)]} {#AbstractMethod [(List Type_Parameter) (List ArgDecl) GenericType (List GenericType)]} {#NativeMethod [(List Type_Parameter) (List ArgDecl) GenericType (List GenericType)]})) (.type Partial_Call (Record [#pc_method Symbol #pc_args (List Code)])) (.type ImportMethodKind (Variant {#StaticIMK} {#VirtualIMK})) (.type ImportMethodCommons (Record [#import_member_mode Primitive_Mode #import_member_alias Text #import_member_kind ImportMethodKind #import_member_tvars (List Type_Parameter) #import_member_args (List [Bit GenericType]) #import_member_maybe? Bit #import_member_try? Bit #import_member_io? Bit])) (.type ImportConstructorDecl (Record [])) (.type ImportMethodDecl (Record [#import_method_name Text #import_method_return GenericType])) (.type ImportFieldDecl (Record [#import_field_mode Primitive_Mode #import_field_name Text #import_field_static? Bit #import_field_maybe? Bit #import_field_setter? Bit #import_field_type GenericType])) (.type Import_Member_Declaration (Variant {#EnumDecl (List Text)} {#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]} {#MethodDecl [ImportMethodCommons ImportMethodDecl]} {#FieldAccessDecl ImportFieldDecl})) ... Utils (def (manual_primitive_type class) (-> Text (Maybe Code)) (case class (^.with_template [ ] [ {.#Some (' )}]) (["boolean" (Primitive "java.lang.Boolean")] ["byte" (Primitive "java.lang.Byte")] ["short" (Primitive "java.lang.Short")] ["int" (Primitive "java.lang.Integer")] ["long" (Primitive "java.lang.Long")] ["float" (Primitive "java.lang.Float")] ["double" (Primitive "java.lang.Double")] ["char" (Primitive "java.lang.Character")] ["void" .Any]) _ {.#None})) (def (auto_primitive_type class) (-> Text (Maybe Code)) (case class (^.with_template [ ] [ {.#Some (' )}]) (["boolean" .Bit] ["byte" .Int] ["short" .Int] ["int" .Int] ["long" .Int] ["float" .Frac] ["double" .Frac] ["void" .Any]) _ {.#None})) (def safe (-> Text Text) (text.replaced "/" ".")) (def (generic_class_type' mode type_params in_array? name+params class_type') (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)] (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) Code) (case [name+params mode in_array?] (^.multi [[prim {.#End}] {#ManualPrM} #0] [(manual_primitive_type prim) {.#Some output}]) output (^.multi [[prim {.#End}] {#AutoPrM} #0] [(auto_primitive_type prim) {.#Some output}]) output [[name params] _ _] (let [name (safe name) =params (list#each (class_type' mode type_params in_array?) params)] (` (Primitive (, (code.text name)) [(,* =params)]))))) (def (class_type' mode type_params in_array? class) (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) (case class {#GenericTypeVar name} (case (list.example (function (_ [pname pbounds]) (and (text#= name pname) (not (list.empty? pbounds)))) type_params) {.#None} (code.symbol ["" name]) {.#Some [pname pbounds]} (class_type' mode type_params in_array? (maybe.trusted (list.head pbounds)))) {#GenericClass name+params} (generic_class_type' mode type_params in_array? name+params class_type') {#GenericArray param} (let [=param (class_type' mode type_params #1 param)] (` ((,! array.Array) (, =param)))) (^.or {#GenericWildcard {.#None}} {#GenericWildcard {.#Some [{#LowerBound} _]}}) (` .Any) {#GenericWildcard {.#Some [{#UpperBound} upper_bound]}} (class_type' mode type_params in_array? upper_bound) )) (def (class_type mode type_params class) (-> Primitive_Mode (List Type_Parameter) GenericType Code) (class_type' mode type_params #0 class)) (def (type_param_type$ [name bounds]) (-> Type_Parameter Code) (code.symbol ["" name])) (def (class_decl_type$ (open "[0]")) (-> Class_Declaration Code) (let [=params (list#each (.is (-> Type_Parameter Code) (function (_ [pname pbounds]) (case pbounds {.#End} (code.symbol ["" pname]) {.#Item bound1 _} (class_type {#ManualPrM} #class_params bound1)))) #class_params)] (` (Primitive (, (code.text (safe #class_name))) [(,* =params)])))) (def type_var_class Text "java.lang.Object") (def (simple_class$ env class) (-> (List Type_Parameter) GenericType Text) (case class {#GenericTypeVar name} (case (list.example (function (_ [pname pbounds]) (and (text#= name pname) (not (list.empty? pbounds)))) env) {.#None} type_var_class {.#Some [pname pbounds]} (simple_class$ env (maybe.trusted (list.head pbounds)))) (^.or {#GenericWildcard {.#None}} {#GenericWildcard {.#Some [{#LowerBound} _]}}) type_var_class {#GenericWildcard {.#Some [{#UpperBound} upper_bound]}} (simple_class$ env upper_bound) {#GenericClass name env} (safe name) {#GenericArray param'} (case param' {#GenericArray param} (format "[" (simple_class$ env param)) (^.with_template [ ] [{#GenericClass {.#End}} ]) (["boolean" "[Z"] ["byte" "[B"] ["short" "[S"] ["int" "[I"] ["long" "[J"] ["float" "[F"] ["double" "[D"] ["char" "[C"]) param (format "[L" (simple_class$ env param) ";")) )) (def (get_const_parser class_name field_name) (-> Text Text (Parser Code)) (do <>.monad [.let [dotted_name (format "::" field_name)] _ (.this (code.symbol ["" dotted_name]))] (in (`' ((, (code.text (format "jvm getstatic" ":" class_name ":" field_name)))))))) (def (get_var_parser class_name field_name) (-> Text Text (Parser Code)) (do <>.monad [.let [dotted_name (format "::" field_name)] _ (.this (code.symbol ["" dotted_name]))] (in (`' ((, (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this))))) (def (put_var_parser class_name field_name) (-> Text Text (Parser Code)) (do <>.monad [.let [dotted_name (format "::" field_name)] [_ _ value] (.is (Parser [Any Any Code]) (.form (all <>.and (.this (' :=)) (.this (code.symbol ["" dotted_name])) .any)))] (in (`' ((, (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (, value)))))) (def (pre_walk_replace f input) (-> (-> Code Code) Code Code) (case (f input) (^.with_template [] [[meta { parts}] [meta { (list#each (pre_walk_replace f) parts)}]]) ([.#Form] [.#Variant] [.#Tuple]) ast' ast')) (def (parser_replacer p ast) (-> (Parser Code) (-> Code Code)) (case (<>.result p (list ast)) {.#Right [{.#End} ast']} ast' _ ast )) (def (field_parser class_name [[field_name _ _] field]) (-> Text [Member_Declaration FieldDecl] (Parser Code)) (case field {#ConstantField _} (get_const_parser class_name field_name) {#VariableField _} (<>.either (get_var_parser class_name field_name) (put_var_parser class_name field_name)))) (def (constructor_parser params class_name arg_decls) (-> (List Type_Parameter) Text (List ArgDecl) (Parser Code)) (do <>.monad [args (.is (Parser (List Code)) (.form (<>.after (.this (' ::new!)) (.tuple (<>.exactly (list.size arg_decls) .any))))) .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]] (in (` ((, (code.text (format "jvm new" ":" class_name ":" (text.interposed "," arg_decls')))) (,* args)))))) (def (static_method_parser params class_name method_name arg_decls) (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) (do <>.monad [.let [dotted_name (format "::" method_name "!")] args (.is (Parser (List Code)) (.form (<>.after (.this (code.symbol ["" dotted_name])) (.tuple (<>.exactly (list.size arg_decls) .any))))) .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]] (in (`' ((, (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.interposed "," arg_decls')))) (,* args)))))) (with_template [ ] [(def ( params class_name method_name arg_decls) (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) (do <>.monad [.let [dotted_name (format "::" method_name "!")] args (.is (Parser (List Code)) (.form (<>.after (.this (code.symbol ["" dotted_name])) (.tuple (<>.exactly (list.size arg_decls) .any))))) .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]] (in (`' ((, (code.text (format ":" class_name ":" method_name ":" (text.interposed "," arg_decls')))) (,' _jvm_this) (,* args))))))] [special_method_parser "jvm invokespecial"] [virtual_method_parser "jvm invokevirtual"] ) (def (method_parser params class_name [[method_name _ _] meth_def]) (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Parser Code)) (case meth_def {#ConstructorMethod strict? type_vars args constructor_args return_expr exs} (constructor_parser params class_name args) {#StaticMethod strict? type_vars args return_type return_expr exs} (static_method_parser params class_name method_name args) (^.or {#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs} {#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs}) (special_method_parser params class_name method_name args) {#AbstractMethod type_vars args return_type exs} (virtual_method_parser params class_name method_name args) {#NativeMethod type_vars args return_type exs} (virtual_method_parser params class_name method_name args))) ... Parsers (def privacy_modifier^ (Parser Privacy) (let [(open "[0]") <>.monad] (all <>.or (.this (' "public")) (.this (' "private")) (.this (' "protected")) (in [])))) (def inheritance_modifier^ (Parser Inheritance) (let [(open "[0]") <>.monad] (all <>.or (.this (' "final")) (.this (' "abstract")) (in [])))) (def bound_kind^ (Parser BoundKind) (<>.or (.this (' <)) (.this (' >)))) (def (no_periods_assertion name) (-> Text (Parser Any)) (<>.assertion "Names in class declarations cannot contain periods." (not (text.contains? "." name)))) (def (generic_type^ type_vars) (-> (List Type_Parameter) (Parser GenericType)) (<>.rec (function (_ again^) (all <>.either (do <>.monad [_ (.this (' ?))] (in {#GenericWildcard {.#None}})) (.tuple (do <>.monad [_ (.this (' ?)) bound_kind bound_kind^ bound again^] (in {#GenericWildcard {.#Some [bound_kind bound]}}))) (do <>.monad [name .local _ (no_periods_assertion name)] (if (list.member? text.equivalence (list#each product.left type_vars) name) (in {#GenericTypeVar name}) (in {#GenericClass name (list)}))) (.tuple (do <>.monad [component again^] (case component (^.with_template [ ] [{#GenericClass {.#End}} (in {#GenericClass (list)})]) (["[Z" "boolean"] ["[B" "byte"] ["[S" "short"] ["[I" "int"] ["[J" "long"] ["[F" "float"] ["[D" "double"] ["[C" "char"]) _ (in {#GenericArray component})))) (.form (do <>.monad [name .local _ (no_periods_assertion name) params (<>.some again^) _ (<>.assertion (format name " cannot be a type-parameter!") (not (list.member? text.equivalence (list#each product.left type_vars) name)))] (in {#GenericClass name params}))) )))) (def type_param^ (Parser Type_Parameter) (<>.either (do <>.monad [param_name .local] (in [param_name (list)])) (.tuple (do <>.monad [param_name .local _ (.this (' <)) bounds (<>.many (..generic_type^ (list)))] (in [param_name bounds]))))) (def type_params^ (Parser (List Type_Parameter)) (|> ..type_param^ <>.some .tuple (<>.else (list)))) (def class_decl^ (Parser Class_Declaration) (<>.either (do <>.monad [name .local _ (no_periods_assertion name)] (in [name (list)])) (.form (do <>.monad [name .local _ (no_periods_assertion name) params (<>.some ..type_param^)] (in [name params]))) )) (def (super_class_decl^ type_vars) (-> (List Type_Parameter) (Parser Super_Class_Decl)) (<>.either (do <>.monad [name .local _ (no_periods_assertion name)] (in [name (list)])) (.form (do <>.monad [name .local _ (no_periods_assertion name) params (<>.some (..generic_type^ type_vars))] (in [name params]))))) (def annotation_params^ (Parser (List AnnotationParam)) (.tuple (<>.some (<>.and .text .any)))) (def annotation^ (Parser Annotation) (<>.either (do <>.monad [ann_name .local] (in [ann_name (list)])) (.form (<>.and .local annotation_params^)))) (def annotations^' (Parser (List Annotation)) (do <>.monad [_ (.this (' "ann"))] (.tuple (<>.some ..annotation^)))) (def annotations^ (Parser (List Annotation)) (do <>.monad [anns?? (<>.maybe ..annotations^')] (in (maybe.else (list) anns??)))) (def (throws_decl'^ type_vars) (-> (List Type_Parameter) (Parser (List GenericType))) (do <>.monad [_ (.this (' "throws"))] (.tuple (<>.some (..generic_type^ type_vars))))) (def (throws_decl^ type_vars) (-> (List Type_Parameter) (Parser (List GenericType))) (do <>.monad [exs? (<>.maybe (throws_decl'^ type_vars))] (in (maybe.else (list) exs?)))) (def (method_decl^ type_vars) (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl])) (.form (do <>.monad [tvars ..type_params^ name .local anns ..annotations^ inputs (.tuple (<>.some (..generic_type^ type_vars))) output (..generic_type^ type_vars) exs (..throws_decl^ type_vars)] (in [[name {#PublicP} anns] [#method_tvars tvars #method_inputs inputs #method_output output #method_exs exs]])))) (def state_modifier^ (Parser State) (all <>.or (.this (' "volatile")) (.this (' "final")) (at <>.monad in []))) (def (field_decl^ type_vars) (-> (List Type_Parameter) (Parser [Member_Declaration FieldDecl])) (<>.either (.form (do <>.monad [_ (.this (' "const")) name .local anns ..annotations^ type (..generic_type^ type_vars) body .any] (in [[name {#PublicP} anns] {#ConstantField [type body]}]))) (.form (do <>.monad [pm privacy_modifier^ sm state_modifier^ name .local anns ..annotations^ type (..generic_type^ type_vars)] (in [[name pm anns] {#VariableField [sm type]}]))))) (def (arg_decl^ type_vars) (-> (List Type_Parameter) (Parser ArgDecl)) (<>.and .local (..generic_type^ type_vars))) (def (arg_decls^ type_vars) (-> (List Type_Parameter) (Parser (List ArgDecl))) (.tuple (<>.some (arg_decl^ type_vars)))) (def (constructor_arg^ type_vars) (-> (List Type_Parameter) (Parser ConstructorArg)) (<>.and (..generic_type^ type_vars) .any)) (def (constructor_args^ type_vars) (-> (List Type_Parameter) (Parser (List ConstructorArg))) (.tuple (<>.some (constructor_arg^ type_vars)))) (def (constructor_method^ class_vars) (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) (.form (do <>.monad [pm privacy_modifier^ strict_fp? (<>.parses? (.this (' "strict"))) method_vars ..type_params^ .let [total_vars (list#composite class_vars method_vars)] [_ arg_decls] (.form (<>.and (.this (' new)) (..arg_decls^ total_vars))) constructor_args (..constructor_args^ total_vars) exs (..throws_decl^ total_vars) annotations ..annotations^ body .any] (in [[#member_name constructor_method_name #member_privacy pm #member_anns annotations] {#ConstructorMethod strict_fp? method_vars arg_decls constructor_args body exs}])))) (def (virtual_method_def^ class_vars) (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) (.form (do <>.monad [pm privacy_modifier^ strict_fp? (<>.parses? (.this (' "strict"))) final? (<>.parses? (.this (' "final"))) method_vars ..type_params^ .let [total_vars (list#composite class_vars method_vars)] [name this_name arg_decls] (.form (all <>.and .local .local (..arg_decls^ total_vars))) return_type (..generic_type^ total_vars) exs (..throws_decl^ total_vars) annotations ..annotations^ body .any] (in [[#member_name name #member_privacy pm #member_anns annotations] {#VirtualMethod final? strict_fp? method_vars this_name arg_decls return_type body exs}])))) (def overriden_method_def^ (Parser [Member_Declaration Method_Definition]) (.form (do <>.monad [strict_fp? (<>.parses? (.this (' "strict"))) owner_class ..class_decl^ method_vars ..type_params^ .let [total_vars (list#composite (product.right owner_class) method_vars)] [name this_name arg_decls] (.form (all <>.and .local .local (..arg_decls^ total_vars))) return_type (..generic_type^ total_vars) exs (..throws_decl^ total_vars) annotations ..annotations^ body .any] (in [[#member_name name #member_privacy {#PublicP} #member_anns annotations] {#OverridenMethod strict_fp? owner_class method_vars this_name arg_decls return_type body exs}])))) (def static_method_def^ (Parser [Member_Declaration Method_Definition]) (.form (do <>.monad [pm privacy_modifier^ strict_fp? (<>.parses? (.this (' "strict"))) _ (.this (' "static")) method_vars ..type_params^ .let [total_vars method_vars] [name arg_decls] (.form (<>.and .local (..arg_decls^ total_vars))) return_type (..generic_type^ total_vars) exs (..throws_decl^ total_vars) annotations ..annotations^ body .any] (in [[#member_name name #member_privacy pm #member_anns annotations] {#StaticMethod strict_fp? method_vars arg_decls return_type body exs}])))) (def abstract_method_def^ (Parser [Member_Declaration Method_Definition]) (.form (do <>.monad [pm privacy_modifier^ _ (.this (' "abstract")) method_vars ..type_params^ .let [total_vars method_vars] [name arg_decls] (.form (<>.and .local (..arg_decls^ total_vars))) return_type (..generic_type^ total_vars) exs (..throws_decl^ total_vars) annotations ..annotations^] (in [[#member_name name #member_privacy pm #member_anns annotations] {#AbstractMethod method_vars arg_decls return_type exs}])))) (def native_method_def^ (Parser [Member_Declaration Method_Definition]) (.form (do <>.monad [pm privacy_modifier^ _ (.this (' "native")) method_vars ..type_params^ .let [total_vars method_vars] [name arg_decls] (.form (<>.and .local (..arg_decls^ total_vars))) return_type (..generic_type^ total_vars) exs (..throws_decl^ total_vars) annotations ..annotations^] (in [[#member_name name #member_privacy pm #member_anns annotations] {#NativeMethod method_vars arg_decls return_type exs}])))) (def (method_def^ class_vars) (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) (all <>.either (..constructor_method^ class_vars) (..virtual_method_def^ class_vars) ..overriden_method_def^ ..static_method_def^ ..abstract_method_def^ ..native_method_def^)) (def partial_call^ (Parser Partial_Call) (.form (<>.and .symbol (<>.some .any)))) (def import_member_alias^ (Parser (Maybe Text)) (<>.maybe (do <>.monad [_ (.this (' "as"))] .local))) (def (import_member_args^ type_vars) (-> (List Type_Parameter) (Parser (List [Bit GenericType]))) (.tuple (<>.some (<>.and (<>.parses? (.this (' "?"))) (..generic_type^ type_vars))))) (def import_member_return_flags^ (Parser [Bit Bit Bit]) (all <>.and (<>.parses? (.this (' "io"))) (<>.parses? (.this (' "try"))) (<>.parses? (.this (' "?"))))) (def primitive_mode^ (Parser Primitive_Mode) (<>.or (.this (' "manual")) (.this (' "auto")))) (def (import_member_decl^ owner_vars) (-> (List Type_Parameter) (Parser Import_Member_Declaration)) (all <>.either (.form (do <>.monad [_ (.this (' "enum")) enum_members (<>.some .local)] (in {#EnumDecl enum_members}))) (.form (do <>.monad [tvars ..type_params^ _ (.this (' new)) ?alias import_member_alias^ .let [total_vars (list#composite owner_vars tvars)] ?prim_mode (<>.maybe primitive_mode^) args (..import_member_args^ total_vars) [io? try? maybe?] import_member_return_flags^] (in {#ConstructorDecl [[#import_member_mode (maybe.else {#AutoPrM} ?prim_mode) #import_member_alias (maybe.else "new" ?alias) #import_member_kind {#VirtualIMK} #import_member_tvars tvars #import_member_args args #import_member_maybe? maybe? #import_member_try? try? #import_member_io? io?] []]}))) (.form (do <>.monad [kind (.is (Parser ImportMethodKind) (<>.or (.this (' "static")) (in []))) tvars ..type_params^ name .local ?alias import_member_alias^ .let [total_vars (list#composite owner_vars tvars)] ?prim_mode (<>.maybe primitive_mode^) args (..import_member_args^ total_vars) [io? try? maybe?] import_member_return_flags^ return (..generic_type^ total_vars)] (in {#MethodDecl [[#import_member_mode (maybe.else {#AutoPrM} ?prim_mode) #import_member_alias (maybe.else name ?alias) #import_member_kind kind #import_member_tvars tvars #import_member_args args #import_member_maybe? maybe? #import_member_try? try? #import_member_io? io?] [#import_method_name name #import_method_return return]]}))) (.form (do <>.monad [read_only? (<>.parses? (.this (' "read_only"))) static? (<>.parses? (.this (' "static"))) name .local ?prim_mode (<>.maybe primitive_mode^) gtype (..generic_type^ owner_vars) maybe? (<>.parses? (.this (' "?")))] (in {#FieldAccessDecl [#import_field_mode (maybe.else {#AutoPrM} ?prim_mode) #import_field_name name #import_field_static? static? #import_field_maybe? maybe? #import_field_setter? (not read_only?) #import_field_type gtype]}))) )) ... Generators (def with_parens (-> JVM_Code JVM_Code) (text.enclosed ["(" ")"])) (def with_brackets (-> JVM_Code JVM_Code) (text.enclosed ["[" "]"])) (def spaced (-> (List JVM_Code) JVM_Code) (text.interposed " ")) (def (privacy_modifier$ pm) (-> Privacy JVM_Code) (case pm {#PublicP} "public" {#PrivateP} "private" {#ProtectedP} "protected" {#DefaultP} "default")) (def (inheritance_modifier$ im) (-> Inheritance JVM_Code) (case im {#FinalI} "final" {#AbstractI} "abstract" {#DefaultI} "default")) (def (annotation_param$ [name value]) (-> AnnotationParam JVM_Code) (format name "=" (code.format value))) (def (annotation$ [name params]) (-> Annotation JVM_Code) (format "(" name " " "{" (text.interposed text.tab (list#each annotation_param$ params)) "}" ")")) (def (bound_kind$ kind) (-> BoundKind JVM_Code) (case kind {#UpperBound} "<" {#LowerBound} ">")) (def (generic_type$ gtype) (-> GenericType JVM_Code) (case gtype {#GenericTypeVar name} name {#GenericClass name params} (format "(" (safe name) " " (spaced (list#each generic_type$ params)) ")") {#GenericArray param} (format "(" array.type_name " " (generic_type$ param) ")") {#GenericWildcard {.#None}} "?" {#GenericWildcard {.#Some [bound_kind bound]}} (format (bound_kind$ bound_kind) (generic_type$ bound)))) (def (type_param$ [name bounds]) (-> Type_Parameter JVM_Code) (format "(" name " " (spaced (list#each generic_type$ bounds)) ")")) (def (class_decl$ (open "[0]")) (-> Class_Declaration JVM_Code) (format "(" (safe #class_name) " " (spaced (list#each type_param$ #class_params)) ")")) (def (super_class_decl$ (open "[0]")) (-> Super_Class_Decl JVM_Code) (format "(" (safe #super_class_name) " " (spaced (list#each generic_type$ #super_class_params)) ")")) (def (method_decl$ [[name pm anns] method_decl]) (-> [Member_Declaration MethodDecl] JVM_Code) (let [(open "[0]") method_decl] (with_parens (spaced (list name (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ #method_tvars))) (with_brackets (spaced (list#each generic_type$ #method_exs))) (with_brackets (spaced (list#each generic_type$ #method_inputs))) (generic_type$ #method_output)) )))) (def (state_modifier$ sm) (-> State JVM_Code) (case sm {#VolatileS} "volatile" {#FinalS} "final" {#DefaultS} "default")) (def (field_decl$ [[name pm anns] field]) (-> [Member_Declaration FieldDecl] JVM_Code) (case field {#ConstantField class value} (with_parens (spaced (list "constant" name (with_brackets (spaced (list#each annotation$ anns))) (generic_type$ class) (code.format value)) )) {#VariableField sm class} (with_parens (spaced (list "variable" name (privacy_modifier$ pm) (state_modifier$ sm) (with_brackets (spaced (list#each annotation$ anns))) (generic_type$ class)) )) )) (def (arg_decl$ [name type]) (-> ArgDecl JVM_Code) (with_parens (spaced (list name (generic_type$ type))))) (def (constructor_arg$ [class term]) (-> ConstructorArg JVM_Code) (with_brackets (spaced (list (generic_type$ class) (code.format term))))) (def (method_def$ replacer super_class [[name pm anns] method_def]) (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code) (case method_def {#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs} (with_parens (spaced (list "init" (privacy_modifier$ pm) (bit#encoded strict_fp?) (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ type_vars))) (with_brackets (spaced (list#each generic_type$ exs))) (with_brackets (spaced (list#each arg_decl$ arg_decls))) (with_brackets (spaced (list#each constructor_arg$ constructor_args))) (code.format (pre_walk_replace replacer body)) ))) {#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs} (with_parens (spaced (list "virtual" name (privacy_modifier$ pm) (bit#encoded final?) (bit#encoded strict_fp?) (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ type_vars))) (with_brackets (spaced (list#each generic_type$ exs))) (with_brackets (spaced (list#each arg_decl$ arg_decls))) (generic_type$ return_type) (code.format (pre_walk_replace replacer (` (let [(, (code.local this_name)) (,' _jvm_this)] (, body)))))))) {#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs} (let [super_replacer (parser_replacer (.form (do <>.monad [_ (.this (' ::super!)) args (.tuple (<>.exactly (list.size arg_decls) .any)) .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ (list))) arg_decls))]] (in (`' ((, (code.text (format "jvm invokespecial" ":" (the #super_class_name super_class) ":" name ":" (text.interposed "," arg_decls')))) (,' _jvm_this) (,* args)))))))] (with_parens (spaced (list "override" (class_decl$ class_decl) name (bit#encoded strict_fp?) (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ type_vars))) (with_brackets (spaced (list#each generic_type$ exs))) (with_brackets (spaced (list#each arg_decl$ arg_decls))) (generic_type$ return_type) (|> (` (let [(, (code.local this_name)) (,' _jvm_this)] (, body))) (pre_walk_replace replacer) (pre_walk_replace super_replacer) (code.format)) )))) {#StaticMethod strict_fp? type_vars arg_decls return_type body exs} (with_parens (spaced (list "static" name (privacy_modifier$ pm) (bit#encoded strict_fp?) (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ type_vars))) (with_brackets (spaced (list#each generic_type$ exs))) (with_brackets (spaced (list#each arg_decl$ arg_decls))) (generic_type$ return_type) (code.format (pre_walk_replace replacer body))))) {#AbstractMethod type_vars arg_decls return_type exs} (with_parens (spaced (list "abstract" name (privacy_modifier$ pm) (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ type_vars))) (with_brackets (spaced (list#each generic_type$ exs))) (with_brackets (spaced (list#each arg_decl$ arg_decls))) (generic_type$ return_type)))) {#NativeMethod type_vars arg_decls return_type exs} (with_parens (spaced (list "native" name (privacy_modifier$ pm) (with_brackets (spaced (list#each annotation$ anns))) (with_brackets (spaced (list#each type_param$ type_vars))) (with_brackets (spaced (list#each generic_type$ exs))) (with_brackets (spaced (list#each arg_decl$ arg_decls))) (generic_type$ return_type)))) )) (def (complete_call$ g!obj [method args]) (-> Code Partial_Call Code) (` ((, (code.symbol method)) (,* args) (, g!obj)))) ... [Syntax] (def object_super_class Super_Class_Decl [#super_class_name "java/lang/Object" #super_class_params (list)]) (def .public class (syntax (_ [im inheritance_modifier^ class_decl ..class_decl^ .let [full_class_name (product.left class_decl)] .let [class_vars (product.right class_decl)] super (<>.else object_super_class (..super_class_decl^ class_vars)) interfaces (<>.else (list) (.tuple (<>.some (..super_class_decl^ class_vars)))) annotations ..annotations^ fields (<>.some (..field_decl^ class_vars)) methods (<>.some (..method_def^ class_vars))]) (do meta.monad [current_module meta.current_module_name .let [fully_qualified_class_name (format (safe current_module) "." full_class_name) field_parsers (list#each (field_parser fully_qualified_class_name) fields) method_parsers (list#each (method_parser (product.right class_decl) fully_qualified_class_name) methods) replacer (parser_replacer (list#mix <>.either (<>.failure "") (list#composite field_parsers method_parsers))) def_code (format "jvm class:" (spaced (list (class_decl$ class_decl) (super_class_decl$ super) (with_brackets (spaced (list#each super_class_decl$ interfaces))) (inheritance_modifier$ im) (with_brackets (spaced (list#each annotation$ annotations))) (with_brackets (spaced (list#each field_decl$ fields))) (with_brackets (spaced (list#each (method_def$ replacer super) methods))))))]] (in (list (` ((, (code.text def_code))))))))) (def .public interface (syntax (_ [class_decl ..class_decl^ .let [class_vars (product.right class_decl)] supers (<>.else (list) (.tuple (<>.some (..super_class_decl^ class_vars)))) annotations ..annotations^ members (<>.some (..method_decl^ class_vars))]) (let [def_code (format "jvm interface:" (spaced (list (class_decl$ class_decl) (with_brackets (spaced (list#each super_class_decl$ supers))) (with_brackets (spaced (list#each annotation$ annotations))) (spaced (list#each method_decl$ members)))))] (in (list (` ((, (code.text def_code))))))))) (def .public object (syntax (_ [class_vars (.tuple (<>.some ..type_param^)) super (<>.else object_super_class (..super_class_decl^ class_vars)) interfaces (<>.else (list) (.tuple (<>.some (..super_class_decl^ class_vars)))) constructor_args (..constructor_args^ class_vars) methods (<>.some ..overriden_method_def^)]) (let [def_code (format "jvm anon-class:" (spaced (list (super_class_decl$ super) (with_brackets (spaced (list#each super_class_decl$ interfaces))) (with_brackets (spaced (list#each constructor_arg$ constructor_args))) (with_brackets (spaced (list#each (method_def$ function.identity super) methods))))))] (in (list (` ((, (code.text def_code))))))))) (def .public null (syntax (_ []) (in (list (` ("jvm object null")))))) (def .public (null? obj) (-> (Primitive "java.lang.Object") Bit) ("jvm object null?" obj)) (def .public ??? (syntax (_ [expr .any]) (with_symbols [g!temp] (in (list (` (let [(, g!temp) (, expr)] (if ("jvm object null?" (, g!temp)) {.#None} {.#Some (, g!temp)})))))))) (def .public !!! (syntax (_ [expr .any]) (with_symbols [g!value] (in (list (` (.case (, expr) {.#Some (, g!value)} (, g!value) {.#None} ("jvm object null")))))))) (def .public as (syntax (_ [class (..generic_type^ (list)) unchecked (<>.maybe .any)]) (with_symbols [g!_ g!unchecked] (let [class_name (simple_class$ (list) class) class_type (` (.Primitive (, (code.text class_name)))) check_type (` (.Maybe (, class_type))) check_code (` (if ((, (code.text (format "jvm instanceof" ":" class_name))) (, g!unchecked)) {.#Some (.as (, class_type) (, g!unchecked))} {.#None}))] (case unchecked {.#Some unchecked} (in (list (` (.is (, check_type) (let [(, g!unchecked) (, unchecked)] (, check_code)))))) {.#None} (in (list (` (.is (-> (Primitive "java.lang.Object") (, check_type)) (function ((, g!_) (, g!unchecked)) (, check_code)))))) ))))) (def .public synchronized (syntax (_ [lock .any body .any]) (in (list (` ("jvm object synchronized" (, lock) (, body))))))) (def .public do_to (syntax (_ [obj .any methods (<>.some partial_call^)]) (with_symbols [g!obj] (in (list (` (let [(, g!obj) (, obj)] (exec (,* (list#each (complete_call$ g!obj) methods)) (, g!obj))))))))) (def (class_import$ [full_name params]) (-> Class_Declaration Code) (let [params' (list#each (|>> product.left code.local) params)] (template.with_locals [g!_] (` (def (, (code.symbol ["" full_name])) Type (All ((, (' g!_)) (,* params')) (Primitive (, (code.text (safe full_name))) [(,* params')]))))))) (def (member_type_vars class_tvars member) (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter)) (case member {#ConstructorDecl [commons _]} (list#composite class_tvars (the #import_member_tvars commons)) {#MethodDecl [commons _]} (case (the #import_member_kind commons) {#StaticIMK} (the #import_member_tvars commons) _ (list#composite class_tvars (the #import_member_tvars commons))) _ class_tvars)) (def (member_def_arg_bindings type_params class member) (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)])) (case member (^.or {#ConstructorDecl [commons _]} {#MethodDecl [commons _]}) (let [(open "[0]") commons] (do [! meta.monad] [arg_inputs (monad.each ! (.is (-> [Bit GenericType] (Meta [Bit Code])) (function (_ [maybe? _]) (with_symbols [arg_name] (in [maybe? arg_name])))) #import_member_args) .let [arg_classes (.is (List Text) (list#each (|>> product.right (simple_class$ (list#composite type_params #import_member_tvars))) #import_member_args)) arg_types (list#each (.is (-> [Bit GenericType] Code) (function (_ [maybe? arg]) (let [arg_type (class_type (the #import_member_mode commons) type_params arg)] (if maybe? (` (Maybe (, arg_type))) arg_type)))) #import_member_args)]] (in [arg_inputs arg_classes arg_types]))) _ (at meta.monad in [(list) (list) (list)]))) (def (decorate_return_maybe class member return_term) (-> Class_Declaration Import_Member_Declaration Code Code) (case member (^.or {#ConstructorDecl [commons _]} {#MethodDecl [commons _]}) (if (the #import_member_maybe? commons) (` (??? (, return_term))) (let [g!temp (` ((,' ,') (, (code.symbol ["" " Ω "]))))] (` (let [(, g!temp) (, return_term)] (if (not (..null? (.as (Primitive "java.lang.Object") (, g!temp)))) (, g!temp) (panic! (, (code.text (format "Cannot produce null references from method calls @ " (the #class_name class) "." (the #import_member_alias commons)))))))))) _ return_term)) (with_template [ ] [(def ( member return_term) (-> Import_Member_Declaration Code Code) (case member (^.or {#ConstructorDecl [commons _]} {#MethodDecl [commons _]}) (if (the commons) return_term) _ return_term))] [decorate_return_try #import_member_try? (` (.try (, return_term)))] [decorate_return_io #import_member_io? (` ((,! io.io) (, return_term)))] ) (def (free_type_param? [name bounds]) (-> Type_Parameter Bit) (case bounds {.#End} #1 _ #0)) (def (lux_type_parameter [name _]) (-> Type_Parameter Code) (code.symbol ["" name])) (with_template [ ] [(def ( mode [class expression]) (-> Primitive_Mode [Text Code] Code) (case mode {#ManualPrM} expression {#AutoPrM} expression))] [auto_convert_input long_to_byte long_to_short long_to_int double_to_float] [auto_convert_output byte_to_long short_to_long int_to_long float_to_double] ) (def (un_quote quoted) (-> Code Code) (` ((,' ,) (, quoted)))) (def (jvm_extension_inputs mode classes inputs) (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code)) (|> inputs (list#each (function (_ [maybe? input]) (if maybe? (` ((,! !!!) (, (un_quote input)))) (un_quote input)))) (list.zipped_2 classes) (list#each (auto_convert_input mode)))) (def (import_name format class member) (-> Text Text Text Text) (|> format (text.replaced "[1]" class) (text.replaced "[0]" member))) (def syntax_inputs (-> (List Code) (List Code)) (|>> (list#each (function (_ name) (list name (` (,! .any))))) list#conjoint)) (def (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format) (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code))) (let [[full_name class_tvars] class full_name (safe full_name) all_params (|> (member_type_vars class_tvars member) (list.only free_type_param?) (list#each lux_type_parameter))] (case member {#EnumDecl enum_members} (macro.with_symbols [g!_] (do [! meta.monad] [.let [enum_type (.is Code (case class_tvars {.#End} (` (Primitive (, (code.text full_name)))) _ (let [=class_tvars (|> class_tvars (list.only free_type_param?) (list#each lux_type_parameter))] (` (All ((, g!_) (,* =class_tvars)) (Primitive (, (code.text full_name)) [(,* =class_tvars)])))))) getter_interop (.is (-> Text Code) (function (_ name) (let [getter_name (code.symbol ["" (..import_name import_format method_prefix name)])] (` (def (, getter_name) (, enum_type) ((, (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]] (in (list#each getter_interop enum_members)))) {#ConstructorDecl [commons _]} (do meta.monad [.let [def_name (code.symbol ["" (..import_name import_format method_prefix (the #import_member_alias commons))]) jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.interposed "," arg_classes))) jvm_interop (|> (` ((, jvm_extension) (,* (jvm_extension_inputs (the #import_member_mode commons) arg_classes arg_function_inputs)))) (decorate_return_maybe class member) (decorate_return_try member) (decorate_return_io member))]] (in (list (` (def (, def_name) ((,! syntax) ((, def_name) [(,* (syntax_inputs (list#each product.right arg_function_inputs)))]) ((,' in) (.list (.` (, jvm_interop)))))))))) {#MethodDecl [commons method]} (with_symbols [g!obj] (do meta.monad [.let [def_name (code.symbol ["" (..import_name import_format method_prefix (the #import_member_alias commons))]) (open "[0]") commons (open "[0]") method [jvm_op object_ast] (.is [Text (List Code)] (case #import_member_kind {#StaticIMK} ["invokestatic" (list)] {#VirtualIMK} (case kind {#Class} ["invokevirtual" (list g!obj)] {#Interface} ["invokeinterface" (list g!obj)] ))) jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" #import_method_name ":" (text.interposed "," arg_classes))) jvm_interop (|> [(simple_class$ (list) (the #import_method_return method)) (` ((, jvm_extension) (,* (list#each un_quote object_ast)) (,* (jvm_extension_inputs (the #import_member_mode commons) arg_classes arg_function_inputs))))] (auto_convert_output (the #import_member_mode commons)) (decorate_return_maybe class member) (decorate_return_try member) (decorate_return_io member))]] (in (list (` (def (, def_name) ((,! syntax) ((, def_name) [(,* (syntax_inputs (list#each product.right arg_function_inputs))) (,* (syntax_inputs object_ast))]) ((,' in) (.list (.` (, jvm_interop))))))))))) {#FieldAccessDecl fad} (do meta.monad [.let [(open "[0]") fad base_gtype (class_type #import_field_mode type_params #import_field_type) classC (class_decl_type$ class) typeC (if #import_field_maybe? (` (Maybe (, base_gtype))) base_gtype) tvar_asts (.is (List Code) (|> class_tvars (list.only free_type_param?) (list#each lux_type_parameter))) getter_name (code.symbol ["" (..import_name import_format method_prefix #import_field_name)]) setter_name (code.symbol ["" (..import_name import_format method_prefix (format #import_field_name "!"))])] getter_interop (with_symbols [g!obj] (let [getter_call (if #import_field_static? (` ((, getter_name) [])) (` ((, getter_name) [(, g!obj) (,! .any)]))) getter_body (<| (auto_convert_output #import_field_mode) [(simple_class$ (list) #import_field_type) (if #import_field_static? (let [jvm_extension (code.text (format "jvm getstatic" ":" full_name ":" #import_field_name))] (` ((, jvm_extension)))) (let [jvm_extension (code.text (format "jvm getfield" ":" full_name ":" #import_field_name))] (` ((, jvm_extension) (, (un_quote g!obj))))))]) getter_body (if #import_field_maybe? (` ((,! ???) (, getter_body))) getter_body) getter_body (if #import_field_setter? (` ((,! io.io) (, getter_body))) getter_body)] (in (` (def (, getter_name) ((,! syntax) (, getter_call) ((,' in) (.list (.` (, getter_body)))))))))) setter_interop (.is (Meta (List Code)) (if #import_field_setter? (with_symbols [g!obj g!value] (let [setter_call (if #import_field_static? (` ((, setter_name) [(, g!value) (,! .any)])) (` ((, setter_name) [(, g!value) (,! .any) (, g!obj) (,! .any)]))) setter_value (auto_convert_input #import_field_mode [(simple_class$ (list) #import_field_type) (un_quote g!value)]) setter_value (if #import_field_maybe? (` ((,! !!!) (, setter_value))) setter_value) setter_command (format (if #import_field_static? "jvm putstatic" "jvm putfield") ":" full_name ":" #import_field_name) g!obj+ (.is (List Code) (if #import_field_static? (list) (list (un_quote g!obj))))] (in (list (` (def (, setter_name) ((,! syntax) (, setter_call) ((,' in) (.list (.` ((,! io.io) ((, (code.text setter_command)) (,* g!obj+) (, setter_value))))))))))))) (in (list))))] (in (list.partial getter_interop setter_interop))) ))) (def (member_import$ type_params kind class [import_format member]) (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code))) (let [[method_prefix _] class] (do meta.monad [=args (member_def_arg_bindings type_params class member)] (member_def_interop type_params kind class =args member method_prefix import_format)))) (.type (java/lang/Class a) (Primitive "java.lang.Class" [a])) (def interface? (All (_ a) (-> (java/lang/Class a) Bit)) (|>> "jvm invokevirtual:java.lang.Class:isInterface:")) (def (load_class class_name) (-> Text (Try (java/lang/Class Any))) (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name))) (def (class_kind [class_name _]) (-> Class_Declaration (Meta Class_Kind)) (let [class_name (..safe class_name)] (case (..load_class class_name) {try.#Success class} (at meta.monad in (if (interface? class) {#Interface} {#Class})) {try.#Failure error} (meta.failure (format "Cannot load class: " class_name text.new_line error))))) (def .public import (syntax (_ [class_decl ..class_decl^ import_format .text members (<>.some (..import_member_decl^ (product.right class_decl)))]) (do [! meta.monad] [kind (class_kind class_decl) =members (|> members (list#each (|>> [import_format])) (monad.each ! (member_import$ (product.right class_decl) kind class_decl)))] (in (list.partial (class_import$ class_decl) (list#conjoint =members)))))) (def .public array (syntax (_ [type (..generic_type^ (list)) size .any]) (case type (^.with_template [ ] [(pattern {#GenericClass (list)}) (in (list (` ( (, size)))))]) (["boolean" "jvm znewarray"] ["byte" "jvm bnewarray"] ["short" "jvm snewarray"] ["int" "jvm inewarray"] ["long" "jvm lnewarray"] ["float" "jvm fnewarray"] ["double" "jvm dnewarray"] ["char" "jvm cnewarray"]) _ (in (list (` ("jvm anewarray" (, (code.text (generic_type$ type))) (, size)))))))) (def .public length (syntax (_ [array .any]) (in (list (` ("jvm arraylength" (, array))))))) (def (type_class_name type) (-> Type (Meta Text)) (if (type#= Any type) (at meta.monad in "java.lang.Object") (case type {.#Primitive name params} (at meta.monad in name) {.#Apply A F} (case (type.applied (list A) F) {.#None} (meta.failure (format "Cannot apply type: " (type.format F) " to " (type.format A))) {.#Some type'} (type_class_name type')) {.#Named _ type'} (type_class_name type') _ (meta.failure (format "Cannot convert to JvmType: " (type.format type)))))) (def .public read! (syntax (_ [idx .any array .any]) (case array [_ {.#Symbol array_name}] (do meta.monad [array_type (meta.type array_name) array_jvm_type (type_class_name array_type)] (case array_jvm_type (^.with_template [ ] [ (in (list (` ( (, array) (, idx)))))]) (["[Z" "jvm zaload"] ["[B" "jvm baload"] ["[S" "jvm saload"] ["[I" "jvm iaload"] ["[J" "jvm jaload"] ["[F" "jvm faload"] ["[D" "jvm daload"] ["[C" "jvm caload"]) _ (in (list (` ("jvm aaload" (, array) (, idx))))))) _ (with_symbols [g!array] (in (list (` (let [(, g!array) (, array)] (..read! (, idx) (, g!array)))))))))) (def .public write! (syntax (_ [idx .any value .any array .any]) (case array [_ {.#Symbol array_name}] (do meta.monad [array_type (meta.type array_name) array_jvm_type (type_class_name array_type)] (case array_jvm_type (^.with_template [ ] [ (in (list (` ( (, array) (, idx) (, value)))))]) (["[Z" "jvm zastore"] ["[B" "jvm bastore"] ["[S" "jvm sastore"] ["[I" "jvm iastore"] ["[J" "jvm jastore"] ["[F" "jvm fastore"] ["[D" "jvm dastore"] ["[C" "jvm castore"]) _ (in (list (` ("jvm aastore" (, array) (, idx) (, value))))))) _ (with_symbols [g!array] (in (list (` (let [(, g!array) (, array)] (..write! (, idx) (, value) (, g!array)))))))))) (def .public class_for (syntax (_ [type (..generic_type^ (list))]) (in (list (` ("jvm object class" (, (code.text (simple_class$ (list) type))))))))) (def .public type (syntax (_ [type (..generic_type^ (list))]) (in (list (..class_type {#ManualPrM} (list) type))))) (def .public is (template (is type term) [(.as type term)]))