diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/host.old.lux | 1666 |
1 files changed, 833 insertions, 833 deletions
diff --git a/stdlib/source/lux/host.old.lux b/stdlib/source/lux/host.old.lux index 8bc8cbea0..461a99a77 100644 --- a/stdlib/source/lux/host.old.lux +++ b/stdlib/source/lux/host.old.lux @@ -23,7 +23,7 @@ [macro ["." code] [syntax (#+ syntax:)]] - ["." meta (#+ with-gensyms) + ["." meta (#+ with_gensyms) ["." annotation]]]) (template [<name> <op> <from> <to>] @@ -34,43 +34,43 @@ (-> (primitive <from>) (primitive <to>)) (<op> value))] - [byte-to-long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] + [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"] + [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"] + [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"] + [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"] + [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"] ) ## [Utils] -(def: constructor-method-name "<init>") -(def: member-separator "::") +(def: constructor_method_name "<init>") +(def: member_separator "::") ## Types -(type: JVM-Code Text) +(type: JVM_Code Text) (type: BoundKind #UpperBound @@ -82,10 +82,10 @@ (#GenericArray GenericType) (#GenericWildcard (Maybe [BoundKind GenericType]))) -(type: Type-Parameter +(type: Type_Parameter [Text (List GenericType)]) -(type: Primitive-Mode +(type: Primitive_Mode #ManualPrM #AutoPrM) @@ -105,129 +105,129 @@ #AbstractIM #DefaultIM) -(type: Class-Kind +(type: Class_Kind #Class #Interface) -(type: Class-Declaration - {#class-name Text - #class-params (List Type-Parameter)}) +(type: Class_Declaration + {#class_name Text + #class_params (List Type_Parameter)}) (type: StackFrame (primitive "java/lang/StackTraceElement")) (type: StackTrace (Array StackFrame)) -(type: Super-Class-Decl - {#super-class-name Text - #super-class-params (List GenericType)}) +(type: Super_Class_Decl + {#super_class_name Text + #super_class_params (List GenericType)}) (type: AnnotationParam [Text Code]) (type: Annotation - {#ann-name Text - #ann-params (List AnnotationParam)}) + {#ann_name Text + #ann_params (List AnnotationParam)}) -(type: Member-Declaration - {#member-name Text - #member-privacy PrivacyModifier - #member-anns (List Annotation)}) +(type: Member_Declaration + {#member_name Text + #member_privacy PrivacyModifier + #member_anns (List Annotation)}) (type: FieldDecl (#ConstantField GenericType Code) (#VariableField StateModifier GenericType)) (type: MethodDecl - {#method-tvars (List Type-Parameter) - #method-inputs (List GenericType) - #method-output GenericType - #method-exs (List GenericType)}) + {#method_tvars (List Type_Parameter) + #method_inputs (List GenericType) + #method_output GenericType + #method_exs (List GenericType)}) (type: ArgDecl - {#arg-name Text - #arg-type GenericType}) + {#arg_name Text + #arg_type GenericType}) (type: ConstructorArg [GenericType Code]) -(type: Method-Definition +(type: Method_Definition (#ConstructorMethod [Bit - (List Type-Parameter) + (List Type_Parameter) (List ArgDecl) (List ConstructorArg) Code (List GenericType)]) (#VirtualMethod [Bit Bit - (List Type-Parameter) + (List Type_Parameter) Text (List ArgDecl) GenericType Code (List GenericType)]) (#OverridenMethod [Bit - Class-Declaration - (List Type-Parameter) + Class_Declaration + (List Type_Parameter) Text (List ArgDecl) GenericType Code (List GenericType)]) (#StaticMethod [Bit - (List Type-Parameter) + (List Type_Parameter) (List ArgDecl) GenericType Code (List GenericType)]) - (#AbstractMethod [(List Type-Parameter) + (#AbstractMethod [(List Type_Parameter) (List ArgDecl) GenericType (List GenericType)]) - (#NativeMethod [(List Type-Parameter) + (#NativeMethod [(List Type_Parameter) (List ArgDecl) GenericType (List GenericType)])) -(type: Partial-Call - {#pc-method Name - #pc-args (List Code)}) +(type: Partial_Call + {#pc_method Name + #pc_args (List Code)}) (type: ImportMethodKind #StaticIMK #VirtualIMK) (type: ImportMethodCommons - {#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}) + {#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 {}) (type: ImportMethodDecl - {#import-method-name Text - #import-method-return GenericType}) + {#import_method_name Text + #import_method_return GenericType}) (type: ImportFieldDecl - {#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 + {#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 (#EnumDecl (List Text)) (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) (#MethodDecl [ImportMethodCommons ImportMethodDecl]) (#FieldAccessDecl ImportFieldDecl)) ## Utils -(def: (manual-primitive-to-type class) +(def: (manual_primitive_to_type class) (-> Text (Maybe Code)) (case class (^template [<prim> <type>] @@ -246,7 +246,7 @@ _ #.None)) -(def: (auto-primitive-to-type class) +(def: (auto_primitive_to_type class) (-> Text (Maybe Code)) (case class (^template [<prim> <type>] @@ -266,82 +266,82 @@ (def: sanitize (-> Text Text) - (text.replace-all "/" ".")) + (text.replace_all "/" ".")) -(def: (generic-class->type' mode type-params in-array? name+params +(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) + (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)] + (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) Code) - (case [name+params mode in-array?] + (case [name+params mode in_array?] (^multi [[prim #.Nil] #ManualPrM #0] - [(manual-primitive-to-type prim) (#.Some output)]) + [(manual_primitive_to_type prim) (#.Some output)]) output (^multi [[prim #.Nil] #AutoPrM #0] - [(auto-primitive-to-type prim) (#.Some output)]) + [(auto_primitive_to_type prim) (#.Some output)]) output [[name params] _ _] (let [name (sanitize name) - =params (list\map (class->type' mode type-params in-array?) params)] + =params (list\map (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) +(def: (class->type' mode type_params in_array? class) + (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) (case class (#GenericTypeVar name) (case (list.find (function (_ [pname pbounds]) (and (text\= name pname) (not (list.empty? pbounds)))) - type-params) + type_params) #.None (code.identifier ["" name]) (#.Some [pname pbounds]) - (class->type' mode type-params in-array? (maybe.assume (list.head pbounds)))) + (class->type' mode type_params in_array? (maybe.assume (list.head pbounds)))) (#GenericClass name+params) - (generic-class->type' mode type-params in-array? 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)] + (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) + (#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: (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) +(def: (type_param_type$ [name bounds]) + (-> Type_Parameter Code) (code.identifier ["" name])) -(def: (class-decl-type$ (^slots [#class-name #class-params])) - (-> Class-Declaration Code) - (let [=params (list\map (: (-> Type-Parameter Code) +(def: (class_decl_type$ (^slots [#class_name #class_params])) + (-> Class_Declaration Code) + (let [=params (list\map (: (-> Type_Parameter Code) (function (_ [pname pbounds]) (case pbounds #.Nil (code.identifier ["" pname]) (#.Cons bound1 _) - (class->type #ManualPrM class-params bound1)))) - class-params)] - (` (primitive (~ (code.text (sanitize class-name))) + (class->type #ManualPrM class_params bound1)))) + class_params)] + (` (primitive (~ (code.text (sanitize class_name))) [(~+ =params)])))) -(def: type-var-class Text "java.lang.Object") +(def: type_var_class Text "java.lang.Object") -(def: (simple-class$ env class) - (-> (List Type-Parameter) GenericType Text) +(def: (simple_class$ env class) + (-> (List Type_Parameter) GenericType Text) (case class (#GenericTypeVar name) (case (list.find (function (_ [pname pbounds]) @@ -349,16 +349,16 @@ (not (list.empty? pbounds)))) env) #.None - type-var-class + type_var_class (#.Some [pname pbounds]) - (simple-class$ env (maybe.assume (list.head pbounds)))) + (simple_class$ env (maybe.assume (list.head pbounds)))) (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) - type-var-class + type_var_class - (#GenericWildcard (#.Some [#UpperBound upper-bound])) - (simple-class$ env upper-bound) + (#GenericWildcard (#.Some [#UpperBound upper_bound])) + (simple_class$ env upper_bound) (#GenericClass name env) (sanitize name) @@ -366,7 +366,7 @@ (#GenericArray param') (case param' (#GenericArray param) - (format "[" (simple-class$ env param)) + (format "[" (simple_class$ env param)) (^template [<prim> <class>] [(#GenericClass <prim> #.Nil) @@ -381,44 +381,44 @@ ["char" "[C"]) param - (format "[L" (simple-class$ env param) ";")) + (format "[L" (simple_class$ env param) ";")) )) -(def: (make-get-const-parser class-name field-name) +(def: (make_get_const_parser class_name field_name) (-> Text Text (Parser Code)) (do p.monad - [#let [dotted-name (format "::" field-name)] - _ (s.this! (code.identifier ["" dotted-name]))] - (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class-name ":" field-name)))))))) + [#let [dotted_name (format "::" field_name)] + _ (s.this! (code.identifier ["" dotted_name]))] + (wrap (`' ((~ (code.text (format "jvm getstatic" ":" class_name ":" field_name)))))))) -(def: (make-get-var-parser class-name field-name) +(def: (make_get_var_parser class_name field_name) (-> Text Text (Parser Code)) (do p.monad - [#let [dotted-name (format "::" field-name)] - _ (s.this! (code.identifier ["" dotted-name]))] - (wrap (`' ((~ (code.text (format "jvm getfield" ":" class-name ":" field-name))) _jvm_this))))) + [#let [dotted_name (format "::" field_name)] + _ (s.this! (code.identifier ["" dotted_name]))] + (wrap (`' ((~ (code.text (format "jvm getfield" ":" class_name ":" field_name))) _jvm_this))))) -(def: (make-put-var-parser class-name field-name) +(def: (make_put_var_parser class_name field_name) (-> Text Text (Parser Code)) (do p.monad - [#let [dotted-name (format "::" field-name)] + [#let [dotted_name (format "::" field_name)] [_ _ value] (: (Parser [Any Any Code]) - (s.form ($_ p.and (s.this! (' :=)) (s.this! (code.identifier ["" dotted-name])) s.any)))] - (wrap (`' ((~ (code.text (format "jvm putfield" ":" class-name ":" field-name))) _jvm_this (~ value)))))) + (s.form ($_ p.and (s.this! (' :=)) (s.this! (code.identifier ["" dotted_name])) s.any)))] + (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) -(def: (pre-walk-replace f input) +(def: (pre_walk_replace f input) (-> (-> Code Code) Code Code) (case (f input) (^template [<tag>] [[meta (<tag> parts)] - [meta (<tag> (list\map (pre-walk-replace f) parts))]]) + [meta (<tag> (list\map (pre_walk_replace f) parts))]]) ([#.Form] [#.Tuple]) [meta (#.Record pairs)] [meta (#.Record (list\map (: (-> [Code Code] [Code Code]) (function (_ [key val]) - [(pre-walk-replace f key) (pre-walk-replace f val)])) + [(pre_walk_replace f key) (pre_walk_replace f val)])) pairs))] ast' @@ -434,74 +434,74 @@ ast )) -(def: (field->parser class-name [[field-name _ _] field]) - (-> Text [Member-Declaration FieldDecl] (Parser Code)) +(def: (field->parser class_name [[field_name _ _] field]) + (-> Text [Member_Declaration FieldDecl] (Parser Code)) (case field (#ConstantField _) - (make-get-const-parser class-name field-name) + (make_get_const_parser class_name field_name) (#VariableField _) - (p.either (make-get-var-parser class-name field-name) - (make-put-var-parser class-name field-name)))) + (p.either (make_get_var_parser class_name field_name) + (make_put_var_parser class_name field_name)))) -(def: (make-constructor-parser params class-name arg-decls) - (-> (List Type-Parameter) Text (List ArgDecl) (Parser Code)) +(def: (make_constructor_parser params class_name arg_decls) + (-> (List Type_Parameter) Text (List ArgDecl) (Parser Code)) (do p.monad [args (: (Parser (List Code)) (s.form (p.after (s.this! (' ::new!)) - (s.tuple (p.exactly (list.size arg-decls) s.any))))) - #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ params)) arg-decls))]] - (wrap (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls')))) + (s.tuple (p.exactly (list.size arg_decls) s.any))))) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] + (wrap (` ((~ (code.text (format "jvm new" ":" class_name ":" (text.join_with "," arg_decls')))) (~+ args)))))) -(def: (make-static-method-parser params class-name method-name arg-decls) - (-> (List Type-Parameter) Text Text (List ArgDecl) (Parser Code)) +(def: (make_static_method_parser params class_name method_name arg_decls) + (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) (do p.monad - [#let [dotted-name (format "::" method-name "!")] + [#let [dotted_name (format "::" method_name "!")] args (: (Parser (List Code)) - (s.form (p.after (s.this! (code.identifier ["" dotted-name])) - (s.tuple (p.exactly (list.size arg-decls) s.any))))) - #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ params)) arg-decls))]] - (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) + (s.form (p.after (s.this! (code.identifier ["" dotted_name])) + (s.tuple (p.exactly (list.size arg_decls) s.any))))) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] + (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class_name ":" method_name ":" (text.join_with "," arg_decls')))) (~+ args)))))) -(template [<name> <jvm-op>] - [(def: (<name> params class-name method-name arg-decls) - (-> (List Type-Parameter) Text Text (List ArgDecl) (Parser Code)) +(template [<name> <jvm_op>] + [(def: (<name> params class_name method_name arg_decls) + (-> (List Type_Parameter) Text Text (List ArgDecl) (Parser Code)) (do p.monad - [#let [dotted-name (format "::" method-name "!")] + [#let [dotted_name (format "::" method_name "!")] args (: (Parser (List Code)) - (s.form (p.after (s.this! (code.identifier ["" dotted-name])) - (s.tuple (p.exactly (list.size arg-decls) s.any))))) - #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ params)) arg-decls))]] - (wrap (`' ((~ (code.text (format <jvm-op> ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) + (s.form (p.after (s.this! (code.identifier ["" dotted_name])) + (s.tuple (p.exactly (list.size arg_decls) s.any))))) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ params)) arg_decls))]] + (wrap (`' ((~ (code.text (format <jvm_op> ":" class_name ":" method_name ":" (text.join_with "," arg_decls')))) (~' _jvm_this) (~+ args))))))] - [make-special-method-parser "jvm invokespecial"] - [make-virtual-method-parser "jvm invokevirtual"] + [make_special_method_parser "jvm invokespecial"] + [make_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) - (make-constructor-parser params class-name args) +(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) + (make_constructor_parser params class_name args) - (#StaticMethod strict? type-vars args return-type return-expr exs) - (make-static-method-parser params class-name method-name args) + (#StaticMethod strict? type_vars args return_type return_expr exs) + (make_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)) - (make-special-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)) + (make_special_method_parser params class_name method_name args) - (#AbstractMethod type-vars args return-type exs) - (make-virtual-method-parser params class-name method-name args) + (#AbstractMethod type_vars args return_type exs) + (make_virtual_method_parser params class_name method_name args) - (#NativeMethod type-vars args return-type exs) - (make-virtual-method-parser params class-name method-name args))) + (#NativeMethod type_vars args return_type exs) + (make_virtual_method_parser params class_name method_name args))) ## Parsers -(def: privacy-modifier^ +(def: privacy_modifier^ (Parser PrivacyModifier) (let [(^open ".") p.monad] ($_ p.or @@ -510,7 +510,7 @@ (s.this! (' #protected)) (wrap [])))) -(def: inheritance-modifier^ +(def: inheritance_modifier^ (Parser InheritanceModifier) (let [(^open ".") p.monad] ($_ p.or @@ -518,18 +518,18 @@ (s.this! (' #abstract)) (wrap [])))) -(def: bound-kind^ +(def: bound_kind^ (Parser BoundKind) (p.or (s.this! (' <)) (s.this! (' >)))) -(def: (assert-no-periods name) +(def: (assert_no_periods name) (-> Text (Parser Any)) (p.assert "Names in class declarations cannot contain periods." (not (text.contains? "." name)))) -(def: (generic-type^ type-vars) - (-> (List Type-Parameter) (Parser GenericType)) +(def: (generic_type^ type_vars) + (-> (List Type_Parameter) (Parser GenericType)) (p.rec (function (_ recur^) ($_ p.either @@ -538,13 +538,13 @@ (wrap (#GenericWildcard #.None))) (s.tuple (do p.monad [_ (s.this! (' ?)) - bound-kind bound-kind^ + bound_kind bound_kind^ bound recur^] - (wrap (#GenericWildcard (#.Some [bound-kind bound]))))) + (wrap (#GenericWildcard (#.Some [bound_kind bound]))))) (do p.monad - [name s.local-identifier - _ (assert-no-periods name)] - (if (list.member? text.equivalence (list\map product.left type-vars) name) + [name s.local_identifier + _ (assert_no_periods name)] + (if (list.member? text.equivalence (list\map product.left type_vars) name) (wrap (#GenericTypeVar name)) (wrap (#GenericClass name (list))))) (s.tuple (do p.monad @@ -565,68 +565,68 @@ _ (wrap (#GenericArray component))))) (s.form (do p.monad - [name s.local-identifier - _ (assert-no-periods name) + [name s.local_identifier + _ (assert_no_periods name) params (p.some recur^) _ (p.assert (format name " cannot be a type-parameter!") - (not (list.member? text.equivalence (list\map product.left type-vars) name)))] + (not (list.member? text.equivalence (list\map product.left type_vars) name)))] (wrap (#GenericClass name params)))) )))) -(def: type-param^ - (Parser Type-Parameter) +(def: type_param^ + (Parser Type_Parameter) (p.either (do p.monad - [param-name s.local-identifier] - (wrap [param-name (list)])) + [param_name s.local_identifier] + (wrap [param_name (list)])) (s.tuple (do p.monad - [param-name s.local-identifier + [param_name s.local_identifier _ (s.this! (' <)) - bounds (p.many (..generic-type^ (list)))] - (wrap [param-name bounds]))))) + bounds (p.many (..generic_type^ (list)))] + (wrap [param_name bounds]))))) -(def: type-params^ - (Parser (List Type-Parameter)) - (|> ..type-param^ +(def: type_params^ + (Parser (List Type_Parameter)) + (|> ..type_param^ p.some s.tuple (p.default (list)))) -(def: class-decl^ - (Parser Class-Declaration) +(def: class_decl^ + (Parser Class_Declaration) (p.either (do p.monad - [name s.local-identifier - _ (assert-no-periods name)] + [name s.local_identifier + _ (assert_no_periods name)] (wrap [name (list)])) (s.form (do p.monad - [name s.local-identifier - _ (assert-no-periods name) - params (p.some ..type-param^)] + [name s.local_identifier + _ (assert_no_periods name) + params (p.some ..type_param^)] (wrap [name params]))) )) -(def: (super-class-decl^ type-vars) - (-> (List Type-Parameter) (Parser Super-Class-Decl)) +(def: (super_class_decl^ type_vars) + (-> (List Type_Parameter) (Parser Super_Class_Decl)) (p.either (do p.monad - [name s.local-identifier - _ (assert-no-periods name)] + [name s.local_identifier + _ (assert_no_periods name)] (wrap [name (list)])) (s.form (do p.monad - [name s.local-identifier - _ (assert-no-periods name) - params (p.some (..generic-type^ type-vars))] + [name s.local_identifier + _ (assert_no_periods name) + params (p.some (..generic_type^ type_vars))] (wrap [name params]))))) -(def: annotation-params^ +(def: annotation_params^ (Parser (List AnnotationParam)) - (s.record (p.some (p.and s.local-tag s.any)))) + (s.record (p.some (p.and s.local_tag s.any)))) (def: annotation^ (Parser Annotation) (p.either (do p.monad - [ann-name s.local-identifier] - (wrap [ann-name (list)])) - (s.form (p.and s.local-identifier - annotation-params^)))) + [ann_name s.local_identifier] + (wrap [ann_name (list)])) + (s.form (p.and s.local_identifier + annotation_params^)))) (def: annotations^' (Parser (List Annotation)) @@ -640,207 +640,207 @@ [anns?? (p.maybe ..annotations^')] (wrap (maybe.default (list) anns??)))) -(def: (throws-decl'^ type-vars) - (-> (List Type-Parameter) (Parser (List GenericType))) +(def: (throws_decl'^ type_vars) + (-> (List Type_Parameter) (Parser (List GenericType))) (do p.monad [_ (s.this! (' #throws))] - (s.tuple (p.some (..generic-type^ type-vars))))) + (s.tuple (p.some (..generic_type^ type_vars))))) -(def: (throws-decl^ type-vars) - (-> (List Type-Parameter) (Parser (List GenericType))) +(def: (throws_decl^ type_vars) + (-> (List Type_Parameter) (Parser (List GenericType))) (do p.monad - [exs? (p.maybe (throws-decl'^ type-vars))] + [exs? (p.maybe (throws_decl'^ type_vars))] (wrap (maybe.default (list) exs?)))) -(def: (method-decl^ type-vars) - (-> (List Type-Parameter) (Parser [Member-Declaration MethodDecl])) +(def: (method_decl^ type_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration MethodDecl])) (s.form (do p.monad - [tvars ..type-params^ - name s.local-identifier + [tvars ..type_params^ + name s.local_identifier anns ..annotations^ - inputs (s.tuple (p.some (..generic-type^ type-vars))) - output (..generic-type^ type-vars) - exs (..throws-decl^ type-vars)] - (wrap [[name #PublicPM anns] {#method-tvars tvars - #method-inputs inputs - #method-output output - #method-exs exs}])))) - -(def: state-modifier^ + inputs (s.tuple (p.some (..generic_type^ type_vars))) + output (..generic_type^ type_vars) + exs (..throws_decl^ type_vars)] + (wrap [[name #PublicPM anns] {#method_tvars tvars + #method_inputs inputs + #method_output output + #method_exs exs}])))) + +(def: state_modifier^ (Parser StateModifier) ($_ p.or (s.this! (' #volatile)) (s.this! (' #final)) (\ p.monad wrap []))) -(def: (field-decl^ type-vars) - (-> (List Type-Parameter) (Parser [Member-Declaration FieldDecl])) +(def: (field_decl^ type_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration FieldDecl])) (p.either (s.form (do p.monad [_ (s.this! (' #const)) - name s.local-identifier + name s.local_identifier anns ..annotations^ - type (..generic-type^ type-vars) + type (..generic_type^ type_vars) body s.any] (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) (s.form (do p.monad - [pm privacy-modifier^ - sm state-modifier^ - name s.local-identifier + [pm privacy_modifier^ + sm state_modifier^ + name s.local_identifier anns ..annotations^ - type (..generic-type^ type-vars)] + type (..generic_type^ type_vars)] (wrap [[name pm anns] (#VariableField [sm type])]))))) -(def: (arg-decl^ type-vars) - (-> (List Type-Parameter) (Parser ArgDecl)) - (s.record (p.and s.local-identifier - (..generic-type^ type-vars)))) +(def: (arg_decl^ type_vars) + (-> (List Type_Parameter) (Parser ArgDecl)) + (s.record (p.and s.local_identifier + (..generic_type^ type_vars)))) -(def: (arg-decls^ type-vars) - (-> (List Type-Parameter) (Parser (List ArgDecl))) - (p.some (arg-decl^ type-vars))) +(def: (arg_decls^ type_vars) + (-> (List Type_Parameter) (Parser (List ArgDecl))) + (p.some (arg_decl^ type_vars))) -(def: (constructor-arg^ type-vars) - (-> (List Type-Parameter) (Parser ConstructorArg)) - (s.record (p.and (..generic-type^ type-vars) s.any))) +(def: (constructor_arg^ type_vars) + (-> (List Type_Parameter) (Parser ConstructorArg)) + (s.record (p.and (..generic_type^ type_vars) s.any))) -(def: (constructor-args^ type-vars) - (-> (List Type-Parameter) (Parser (List ConstructorArg))) - (s.tuple (p.some (constructor-arg^ type-vars)))) +(def: (constructor_args^ type_vars) + (-> (List Type_Parameter) (Parser (List ConstructorArg))) + (s.tuple (p.some (constructor_arg^ type_vars)))) -(def: (constructor-method^ class-vars) - (-> (List Type-Parameter) (Parser [Member-Declaration Method-Definition])) +(def: (constructor_method^ class_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) (s.form (do p.monad - [pm privacy-modifier^ - strict-fp? (p.parses? (s.this! (' #strict))) - method-vars ..type-params^ - #let [total-vars (list\compose class-vars method-vars)] - [_ arg-decls] (s.form (p.and (s.this! (' new)) - (..arg-decls^ total-vars))) - constructor-args (..constructor-args^ total-vars) - exs (..throws-decl^ total-vars) + [pm privacy_modifier^ + strict_fp? (p.parses? (s.this! (' #strict))) + method_vars ..type_params^ + #let [total_vars (list\compose class_vars method_vars)] + [_ arg_decls] (s.form (p.and (s.this! (' new)) + (..arg_decls^ total_vars))) + constructor_args (..constructor_args^ total_vars) + exs (..throws_decl^ total_vars) annotations ..annotations^ body s.any] - (wrap [{#member-name constructor-method-name - #member-privacy pm - #member-anns annotations} - (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) + (wrap [{#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])) +(def: (virtual_method_def^ class_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) (s.form (do p.monad - [pm privacy-modifier^ - strict-fp? (p.parses? (s.this! (' #strict))) + [pm privacy_modifier^ + strict_fp? (p.parses? (s.this! (' #strict))) final? (p.parses? (s.this! (' #final))) - method-vars ..type-params^ - #let [total-vars (list\compose class-vars method-vars)] - [name this-name arg-decls] (s.form ($_ p.and - s.local-identifier - s.local-identifier - (..arg-decls^ total-vars))) - return-type (..generic-type^ total-vars) - exs (..throws-decl^ total-vars) + method_vars ..type_params^ + #let [total_vars (list\compose class_vars method_vars)] + [name this_name arg_decls] (s.form ($_ p.and + s.local_identifier + s.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) annotations ..annotations^ body s.any] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#VirtualMethod final? strict-fp? - method-vars - this-name arg-decls return-type + (wrap [{#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]) +(def: overriden_method_def^ + (Parser [Member_Declaration Method_Definition]) (s.form (do p.monad - [strict-fp? (p.parses? (s.this! (' #strict))) - owner-class ..class-decl^ - method-vars ..type-params^ - #let [total-vars (list\compose (product.right owner-class) method-vars)] - [name this-name arg-decls] (s.form ($_ p.and - s.local-identifier - s.local-identifier - (..arg-decls^ total-vars))) - return-type (..generic-type^ total-vars) - exs (..throws-decl^ total-vars) + [strict_fp? (p.parses? (s.this! (' #strict))) + owner_class ..class_decl^ + method_vars ..type_params^ + #let [total_vars (list\compose (product.right owner_class) method_vars)] + [name this_name arg_decls] (s.form ($_ p.and + s.local_identifier + s.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) annotations ..annotations^ body s.any] - (wrap [{#member-name name - #member-privacy #PublicPM - #member-anns annotations} - (#OverridenMethod strict-fp? - owner-class method-vars - this-name arg-decls return-type + (wrap [{#member_name name + #member_privacy #PublicPM + #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]) +(def: static_method_def^ + (Parser [Member_Declaration Method_Definition]) (s.form (do p.monad - [pm privacy-modifier^ - strict-fp? (p.parses? (s.this! (' #strict))) + [pm privacy_modifier^ + strict_fp? (p.parses? (s.this! (' #strict))) _ (s.this! (' #static)) - method-vars ..type-params^ - #let [total-vars method-vars] - [name arg-decls] (s.form (p.and s.local-identifier - (..arg-decls^ total-vars))) - return-type (..generic-type^ total-vars) - exs (..throws-decl^ total-vars) + method_vars ..type_params^ + #let [total_vars method_vars] + [name arg_decls] (s.form (p.and s.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) annotations ..annotations^ body s.any] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) + (wrap [{#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]) +(def: abstract_method_def^ + (Parser [Member_Declaration Method_Definition]) (s.form (do p.monad - [pm privacy-modifier^ + [pm privacy_modifier^ _ (s.this! (' #abstract)) - method-vars ..type-params^ - #let [total-vars method-vars] - [name arg-decls] (s.form (p.and s.local-identifier - (..arg-decls^ total-vars))) - return-type (..generic-type^ total-vars) - exs (..throws-decl^ total-vars) + method_vars ..type_params^ + #let [total_vars method_vars] + [name arg_decls] (s.form (p.and s.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) annotations ..annotations^] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#AbstractMethod method-vars arg-decls return-type exs)])))) + (wrap [{#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]) +(def: native_method_def^ + (Parser [Member_Declaration Method_Definition]) (s.form (do p.monad - [pm privacy-modifier^ + [pm privacy_modifier^ _ (s.this! (' #native)) - method-vars ..type-params^ - #let [total-vars method-vars] - [name arg-decls] (s.form (p.and s.local-identifier - (..arg-decls^ total-vars))) - return-type (..generic-type^ total-vars) - exs (..throws-decl^ total-vars) + method_vars ..type_params^ + #let [total_vars method_vars] + [name arg_decls] (s.form (p.and s.local_identifier + (..arg_decls^ total_vars))) + return_type (..generic_type^ total_vars) + exs (..throws_decl^ total_vars) annotations ..annotations^] - (wrap [{#member-name name - #member-privacy pm - #member-anns annotations} - (#NativeMethod method-vars arg-decls return-type exs)])))) + (wrap [{#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])) +(def: (method_def^ class_vars) + (-> (List Type_Parameter) (Parser [Member_Declaration Method_Definition])) ($_ p.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) + (..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) (s.form (p.and s.identifier (p.some s.any)))) -(def: class-kind^ - (Parser Class-Kind) +(def: class_kind^ + (Parser Class_Kind) (p.either (do p.monad [_ (s.this! (' #class))] (wrap #Class)) @@ -849,334 +849,334 @@ (wrap #Interface)) )) -(def: import-member-alias^ +(def: import_member_alias^ (Parser (Maybe Text)) (p.maybe (do p.monad [_ (s.this! (' #as))] - s.local-identifier))) + s.local_identifier))) -(def: (import-member-args^ type-vars) - (-> (List Type-Parameter) (Parser (List [Bit GenericType]))) - (s.tuple (p.some (p.and (p.parses? (s.this! (' #?))) (..generic-type^ type-vars))))) +(def: (import_member_args^ type_vars) + (-> (List Type_Parameter) (Parser (List [Bit GenericType]))) + (s.tuple (p.some (p.and (p.parses? (s.this! (' #?))) (..generic_type^ type_vars))))) -(def: import-member-return-flags^ +(def: import_member_return_flags^ (Parser [Bit Bit Bit]) ($_ p.and (p.parses? (s.this! (' #io))) (p.parses? (s.this! (' #try))) (p.parses? (s.this! (' #?))))) -(def: primitive-mode^ - (Parser Primitive-Mode) +(def: primitive_mode^ + (Parser Primitive_Mode) (p.or (s.this! (' #manual)) (s.this! (' #auto)))) -(def: (import-member-decl^ owner-vars) - (-> (List Type-Parameter) (Parser Import-Member-Declaration)) +(def: (import_member_decl^ owner_vars) + (-> (List Type_Parameter) (Parser Import_Member_Declaration)) ($_ p.either (s.form (do p.monad [_ (s.this! (' #enum)) - enum-members (p.some s.local-identifier)] - (wrap (#EnumDecl enum-members)))) + enum_members (p.some s.local_identifier)] + (wrap (#EnumDecl enum_members)))) (s.form (do p.monad - [tvars ..type-params^ + [tvars ..type_params^ _ (s.this! (' new)) - ?alias import-member-alias^ - #let [total-vars (list\compose owner-vars tvars)] - ?prim-mode (p.maybe primitive-mode^) - args (..import-member-args^ total-vars) - [io? try? maybe?] import-member-return-flags^] - (wrap (#ConstructorDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode) - #import-member-alias (maybe.default "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?} + ?alias import_member_alias^ + #let [total_vars (list\compose owner_vars tvars)] + ?prim_mode (p.maybe primitive_mode^) + args (..import_member_args^ total_vars) + [io? try? maybe?] import_member_return_flags^] + (wrap (#ConstructorDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) + #import_member_alias (maybe.default "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?} {}])) )) (s.form (do p.monad [kind (: (Parser ImportMethodKind) (p.or (s.this! (' #static)) (wrap []))) - tvars ..type-params^ - name s.local-identifier - ?alias import-member-alias^ - #let [total-vars (list\compose owner-vars tvars)] - ?prim-mode (p.maybe primitive-mode^) - args (..import-member-args^ total-vars) - [io? try? maybe?] import-member-return-flags^ - return (..generic-type^ total-vars)] - (wrap (#MethodDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode) - #import-member-alias (maybe.default 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 + tvars ..type_params^ + name s.local_identifier + ?alias import_member_alias^ + #let [total_vars (list\compose owner_vars tvars)] + ?prim_mode (p.maybe primitive_mode^) + args (..import_member_args^ total_vars) + [io? try? maybe?] import_member_return_flags^ + return (..generic_type^ total_vars)] + (wrap (#MethodDecl [{#import_member_mode (maybe.default #AutoPrM ?prim_mode) + #import_member_alias (maybe.default 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 }])))) (s.form (do p.monad [static? (p.parses? (s.this! (' #static))) - name s.local-identifier - ?prim-mode (p.maybe primitive-mode^) - gtype (..generic-type^ owner-vars) + name s.local_identifier + ?prim_mode (p.maybe primitive_mode^) + gtype (..generic_type^ owner_vars) maybe? (p.parses? (s.this! (' #?))) setter? (p.parses? (s.this! (' #!)))] - (wrap (#FieldAccessDecl {#import-field-mode (maybe.default #AutoPrM ?prim-mode) - #import-field-name name - #import-field-static? static? - #import-field-maybe? maybe? - #import-field-setter? setter? - #import-field-type gtype})))) + (wrap (#FieldAccessDecl {#import_field_mode (maybe.default #AutoPrM ?prim_mode) + #import_field_name name + #import_field_static? static? + #import_field_maybe? maybe? + #import_field_setter? setter? + #import_field_type gtype})))) )) (def: bundle - (-> (List Type-Parameter) (Parser [Text (List Import-Member-Declaration)])) - (|>> ..import-member-decl^ + (-> (List Type_Parameter) (Parser [Text (List Import_Member_Declaration)])) + (|>> ..import_member_decl^ p.some (p.and s.text) s.tuple)) ## Generators -(def: with-parens - (-> JVM-Code JVM-Code) +(def: with_parens + (-> JVM_Code JVM_Code) (text.enclose ["(" ")"])) -(def: with-brackets - (-> JVM-Code JVM-Code) +(def: with_brackets + (-> JVM_Code JVM_Code) (text.enclose ["[" "]"])) (def: spaced - (-> (List JVM-Code) JVM-Code) - (text.join-with " ")) + (-> (List JVM_Code) JVM_Code) + (text.join_with " ")) -(def: (privacy-modifier$ pm) - (-> PrivacyModifier JVM-Code) +(def: (privacy_modifier$ pm) + (-> PrivacyModifier JVM_Code) (case pm #PublicPM "public" #PrivatePM "private" #ProtectedPM "protected" #DefaultPM "default")) -(def: (inheritance-modifier$ im) - (-> InheritanceModifier JVM-Code) +(def: (inheritance_modifier$ im) + (-> InheritanceModifier JVM_Code) (case im #FinalIM "final" #AbstractIM "abstract" #DefaultIM "default")) -(def: (annotation-param$ [name value]) - (-> AnnotationParam JVM-Code) +(def: (annotation_param$ [name value]) + (-> AnnotationParam JVM_Code) (format name "=" (code.format value))) (def: (annotation$ [name params]) - (-> Annotation JVM-Code) - (format "(" name " " "{" (text.join-with text.tab (list\map annotation-param$ params)) "}" ")")) + (-> Annotation JVM_Code) + (format "(" name " " "{" (text.join_with text.tab (list\map annotation_param$ params)) "}" ")")) -(def: (bound-kind$ kind) - (-> BoundKind JVM-Code) +(def: (bound_kind$ kind) + (-> BoundKind JVM_Code) (case kind #UpperBound "<" #LowerBound ">")) -(def: (generic-type$ gtype) - (-> GenericType JVM-Code) +(def: (generic_type$ gtype) + (-> GenericType JVM_Code) (case gtype (#GenericTypeVar name) name (#GenericClass name params) - (format "(" (sanitize name) " " (spaced (list\map generic-type$ params)) ")") + (format "(" (sanitize name) " " (spaced (list\map generic_type$ params)) ")") (#GenericArray param) - (format "(" array.type-name " " (generic-type$ param) ")") + (format "(" array.type_name " " (generic_type$ param) ")") (#GenericWildcard #.None) "?" - (#GenericWildcard (#.Some [bound-kind bound])) - (format (bound-kind$ bound-kind) (generic-type$ bound)))) + (#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\map generic-type$ bounds)) ")")) +(def: (type_param$ [name bounds]) + (-> Type_Parameter JVM_Code) + (format "(" name " " (spaced (list\map generic_type$ bounds)) ")")) -(def: (class-decl$ (^open ".")) - (-> Class-Declaration JVM-Code) - (format "(" (sanitize class-name) " " (spaced (list\map type-param$ class-params)) ")")) +(def: (class_decl$ (^open ".")) + (-> Class_Declaration JVM_Code) + (format "(" (sanitize class_name) " " (spaced (list\map type_param$ class_params)) ")")) -(def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) - (-> Super-Class-Decl JVM-Code) - (format "(" (sanitize super-class-name) " " (spaced (list\map generic-type$ super-class-params)) ")")) +(def: (super_class_decl$ (^slots [#super_class_name #super_class_params])) + (-> Super_Class_Decl JVM_Code) + (format "(" (sanitize super_class_name) " " (spaced (list\map generic_type$ super_class_params)) ")")) -(def: (method-decl$ [[name pm anns] method-decl]) - (-> [Member-Declaration MethodDecl] JVM-Code) - (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] - (with-parens +(def: (method_decl$ [[name pm anns] method_decl]) + (-> [Member_Declaration MethodDecl] JVM_Code) + (let [(^slots [#method_tvars #method_inputs #method_output #method_exs]) method_decl] + (with_parens (spaced (list name - (with-brackets (spaced (list\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ method-tvars))) - (with-brackets (spaced (list\map generic-type$ method-exs))) - (with-brackets (spaced (list\map generic-type$ method-inputs))) - (generic-type$ method-output)) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ method_tvars))) + (with_brackets (spaced (list\map generic_type$ method_exs))) + (with_brackets (spaced (list\map generic_type$ method_inputs))) + (generic_type$ method_output)) )))) -(def: (state-modifier$ sm) - (-> StateModifier JVM-Code) +(def: (state_modifier$ sm) + (-> StateModifier JVM_Code) (case sm #VolatileSM "volatile" #FinalSM "final" #DefaultSM "default")) -(def: (field-decl$ [[name pm anns] field]) - (-> [Member-Declaration FieldDecl] JVM-Code) +(def: (field_decl$ [[name pm anns] field]) + (-> [Member_Declaration FieldDecl] JVM_Code) (case field (#ConstantField class value) - (with-parens + (with_parens (spaced (list "constant" name - (with-brackets (spaced (list\map annotation$ anns))) - (generic-type$ class) + (with_brackets (spaced (list\map annotation$ anns))) + (generic_type$ class) (code.format value)) )) (#VariableField sm class) - (with-parens + (with_parens (spaced (list "variable" name - (privacy-modifier$ pm) - (state-modifier$ sm) - (with-brackets (spaced (list\map annotation$ anns))) - (generic-type$ class)) + (privacy_modifier$ pm) + (state_modifier$ sm) + (with_brackets (spaced (list\map 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 +(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\encode strict-fp?) - (with-brackets (spaced (list\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ type-vars))) - (with-brackets (spaced (list\map generic-type$ exs))) - (with-brackets (spaced (list\map arg-decl$ arg-decls))) - (with-brackets (spaced (list\map constructor-arg$ constructor-args))) - (code.format (pre-walk-replace replacer body)) + (privacy_modifier$ pm) + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (with_brackets (spaced (list\map 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 + (#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs) + (with_parens (spaced (list "virtual" name - (privacy-modifier$ pm) + (privacy_modifier$ pm) (bit\encode final?) - (bit\encode strict-fp?) - (with-brackets (spaced (list\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ type-vars))) - (with-brackets (spaced (list\map generic-type$ exs))) - (with-brackets (spaced (list\map arg-decl$ arg-decls))) - (generic-type$ return-type) - (code.format (pre-walk-replace replacer (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)] + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type) + (code.format (pre_walk_replace replacer (` (let [(~ (code.local_identifier 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 (s.form (do p.monad + (#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs) + (let [super_replacer (parser->replacer (s.form (do p.monad [_ (s.this! (' ::super!)) - args (s.tuple (p.exactly (list.size arg-decls) s.any)) - #let [arg-decls' (: (List Text) (list\map (|>> product.right (simple-class$ (list))) - arg-decls))]] + args (s.tuple (p.exactly (list.size arg_decls) s.any)) + #let [arg_decls' (: (List Text) (list\map (|>> product.right (simple_class$ (list))) + arg_decls))]] (wrap (`' ((~ (code.text (format "jvm invokespecial" - ":" (get@ #super-class-name super-class) + ":" (get@ #super_class_name super_class) ":" name - ":" (text.join-with "," arg-decls')))) + ":" (text.join_with "," arg_decls')))) (~' _jvm_this) (~+ args)))))))] - (with-parens + (with_parens (spaced (list "override" - (class-decl$ class-decl) + (class_decl$ class_decl) name - (bit\encode strict-fp?) - (with-brackets (spaced (list\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ type-vars))) - (with-brackets (spaced (list\map generic-type$ exs))) - (with-brackets (spaced (list\map arg-decl$ arg-decls))) - (generic-type$ return-type) - (|> (` (let [(~ (code.local-identifier this-name)) (~' _jvm_this)] + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type) + (|> (` (let [(~ (code.local_identifier this_name)) (~' _jvm_this)] (~ body))) - (pre-walk-replace replacer) - (pre-walk-replace super-replacer) + (pre_walk_replace replacer) + (pre_walk_replace super_replacer) (code.format)) )))) - (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) - (with-parens + (#StaticMethod strict_fp? type_vars arg_decls return_type body exs) + (with_parens (spaced (list "static" name - (privacy-modifier$ pm) - (bit\encode strict-fp?) - (with-brackets (spaced (list\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ type-vars))) - (with-brackets (spaced (list\map generic-type$ exs))) - (with-brackets (spaced (list\map 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 + (privacy_modifier$ pm) + (bit\encode strict_fp?) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map 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\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ type-vars))) - (with-brackets (spaced (list\map generic-type$ exs))) - (with-brackets (spaced (list\map arg-decl$ arg-decls))) - (generic-type$ return-type)))) - - (#NativeMethod type-vars arg-decls return-type exs) - (with-parens + (privacy_modifier$ pm) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map 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\map annotation$ anns))) - (with-brackets (spaced (list\map type-param$ type-vars))) - (with-brackets (spaced (list\map generic-type$ exs))) - (with-brackets (spaced (list\map arg-decl$ arg-decls))) - (generic-type$ return-type)))) + (privacy_modifier$ pm) + (with_brackets (spaced (list\map annotation$ anns))) + (with_brackets (spaced (list\map type_param$ type_vars))) + (with_brackets (spaced (list\map generic_type$ exs))) + (with_brackets (spaced (list\map arg_decl$ arg_decls))) + (generic_type$ return_type)))) )) -(def: (complete-call$ g!obj [method args]) - (-> Code Partial-Call Code) +(def: (complete_call$ g!obj [method args]) + (-> Code Partial_Call Code) (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) ## [Syntax] -(def: object-super-class - Super-Class-Decl - {#super-class-name "java/lang/Object" - #super-class-params (list)}) +(def: object_super_class + Super_Class_Decl + {#super_class_name "java/lang/Object" + #super_class_params (list)}) (syntax: #export (class: - {im inheritance-modifier^} - {class-decl ..class-decl^} - {#let [full-class-name (product.left class-decl)]} - {#let [class-vars (product.right class-decl)]} - {super (p.default object-super-class - (..super-class-decl^ class-vars))} + {im inheritance_modifier^} + {class_decl ..class_decl^} + {#let [full_class_name (product.left class_decl)]} + {#let [class_vars (product.right class_decl)]} + {super (p.default object_super_class + (..super_class_decl^ class_vars))} {interfaces (p.default (list) - (s.tuple (p.some (..super-class-decl^ class-vars))))} + (s.tuple (p.some (..super_class_decl^ class_vars))))} {annotations ..annotations^} - {fields (p.some (..field-decl^ class-vars))} - {methods (p.some (..method-def^ class-vars))}) + {fields (p.some (..field_decl^ class_vars))} + {methods (p.some (..method_def^ class_vars))}) {#.doc (doc "Allows defining JVM classes in Lux code." "For example:" (class: #final (TestClass A) [Runnable] @@ -1208,49 +1208,49 @@ "(::resolve! container [value]) for calling the 'resolve' method." )} (do meta.monad - [current-module meta.current-module-name - #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name) - field-parsers (list\map (field->parser fully-qualified-class-name) fields) - method-parsers (list\map (method->parser (product.right class-decl) fully-qualified-class-name) methods) + [current_module meta.current_module_name + #let [fully_qualified_class_name (format (sanitize current_module) "." full_class_name) + field_parsers (list\map (field->parser fully_qualified_class_name) fields) + method_parsers (list\map (method->parser (product.right class_decl) fully_qualified_class_name) methods) replacer (parser->replacer (list\fold p.either (p.fail "") - (list\compose field-parsers method-parsers))) - def-code (format "jvm class:" - (spaced (list (class-decl$ class-decl) - (super-class-decl$ super) - (with-brackets (spaced (list\map super-class-decl$ interfaces))) - (inheritance-modifier$ im) - (with-brackets (spaced (list\map annotation$ annotations))) - (with-brackets (spaced (list\map field-decl$ fields))) - (with-brackets (spaced (list\map (method-def$ replacer super) methods))))))]] - (wrap (list (` ((~ (code.text def-code)))))))) + (list\compose field_parsers method_parsers))) + def_code (format "jvm class:" + (spaced (list (class_decl$ class_decl) + (super_class_decl$ super) + (with_brackets (spaced (list\map super_class_decl$ interfaces))) + (inheritance_modifier$ im) + (with_brackets (spaced (list\map annotation$ annotations))) + (with_brackets (spaced (list\map field_decl$ fields))) + (with_brackets (spaced (list\map (method_def$ replacer super) methods))))))]] + (wrap (list (` ((~ (code.text def_code)))))))) (syntax: #export (interface: - {class-decl ..class-decl^} - {#let [class-vars (product.right class-decl)]} + {class_decl ..class_decl^} + {#let [class_vars (product.right class_decl)]} {supers (p.default (list) - (s.tuple (p.some (..super-class-decl^ class-vars))))} + (s.tuple (p.some (..super_class_decl^ class_vars))))} {annotations ..annotations^} - {members (p.some (..method-decl^ class-vars))}) + {members (p.some (..method_decl^ class_vars))}) {#.doc (doc "Allows defining JVM interfaces." (interface: TestInterface ([] foo [boolean String] void #throws [Exception])))} - (let [def-code (format "jvm interface:" - (spaced (list (class-decl$ class-decl) - (with-brackets (spaced (list\map super-class-decl$ supers))) - (with-brackets (spaced (list\map annotation$ annotations))) - (spaced (list\map method-decl$ members)))))] - (wrap (list (` ((~ (code.text def-code)))))) + (let [def_code (format "jvm interface:" + (spaced (list (class_decl$ class_decl) + (with_brackets (spaced (list\map super_class_decl$ supers))) + (with_brackets (spaced (list\map annotation$ annotations))) + (spaced (list\map method_decl$ members)))))] + (wrap (list (` ((~ (code.text def_code)))))) )) (syntax: #export (object - {class-vars (s.tuple (p.some ..type-param^))} - {super (p.default object-super-class - (..super-class-decl^ class-vars))} + {class_vars (s.tuple (p.some ..type_param^))} + {super (p.default object_super_class + (..super_class_decl^ class_vars))} {interfaces (p.default (list) - (s.tuple (p.some (..super-class-decl^ class-vars))))} - {constructor-args (..constructor-args^ class-vars)} - {methods (p.some ..overriden-method-def^)}) + (s.tuple (p.some (..super_class_decl^ class_vars))))} + {constructor_args (..constructor_args^ class_vars)} + {methods (p.some ..overriden_method_def^)}) {#.doc (doc "Allows defining anonymous classes." "The 1st tuple corresponds to class-level type-variables." "The 2nd tuple corresponds to parent interfaces." @@ -1259,15 +1259,15 @@ (object [] [Runnable] [] (Runnable [] (run self) void - (exec (do-something some-value) + (exec (do_something some_value) []))) )} - (let [def-code (format "jvm anon-class:" - (spaced (list (super-class-decl$ super) - (with-brackets (spaced (list\map super-class-decl$ interfaces))) - (with-brackets (spaced (list\map constructor-arg$ constructor-args))) - (with-brackets (spaced (list\map (method-def$ function.identity super) methods))))))] - (wrap (list (` ((~ (code.text def-code)))))))) + (let [def_code (format "jvm anon-class:" + (spaced (list (super_class_decl$ super) + (with_brackets (spaced (list\map super_class_decl$ interfaces))) + (with_brackets (spaced (list\map constructor_arg$ constructor_args))) + (with_brackets (spaced (list\map (method_def$ function.identity super) methods))))))] + (wrap (list (` ((~ (code.text def_code)))))))) (syntax: #export (null) {#.doc (doc "Null object reference." @@ -1289,7 +1289,7 @@ #.None) (= (??? "YOLO") (#.Some "YOLO")))} - (with-gensyms [g!temp] + (with_gensyms [g!temp] (wrap (list (` (let [(~ g!temp) (~ expr)] (if ("jvm object null?" (~ g!temp)) #.None @@ -1302,7 +1302,7 @@ (!!! (??? (: java/lang/Thread (null))))) (= "foo" (!!! (??? "foo"))))} - (with-gensyms [g!value] + (with_gensyms [g!value] (wrap (list (` ({(#.Some (~ g!value)) (~ g!value) @@ -1311,158 +1311,158 @@ (~ expr))))))) (syntax: #export (try expression) - {#.doc (doc (case (try (risky-computation input)) + {#.doc (doc (case (try (risky_computation input)) (#.Right success) - (do-something success) + (do_something success) (#.Left error) - (recover-from-failure error)))} + (recover_from_failure error)))} (wrap (list (` ("lux try" ((~! io.io) (~ expression))))))) -(syntax: #export (check {class (..generic-type^ (list))} +(syntax: #export (check {class (..generic_type^ (list))} {unchecked (p.maybe s.any)}) {#.doc (doc "Checks whether an object is an instance of a particular class." "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." (case (check String "YOLO") - (#.Some value-as-string) + (#.Some value_as_string) #.None))} - (with-gensyms [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 (.:coerce (~ class-type) + (with_gensyms [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 (.:coerce (~ class_type) (~ g!unchecked))) #.None))] (case unchecked (#.Some unchecked) - (wrap (list (` (: (~ check-type) + (wrap (list (` (: (~ check_type) (let [(~ g!unchecked) (~ unchecked)] - (~ check-code)))))) + (~ check_code)))))) #.None - (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check-type)) + (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check_type)) (function ((~ g!_) (~ g!unchecked)) - (~ check-code)))))) + (~ check_code)))))) )))) (syntax: #export (synchronized lock body) {#.doc (doc "Evaluates body, while holding a lock on a given object." - (synchronized object-to-be-locked - (exec (do-something ___) - (do-something-else ___) - (finish-the-computation ___))))} + (synchronized object_to_be_locked + (exec (do_something ___) + (do_something_else ___) + (finish_the_computation ___))))} (wrap (list (` ("jvm object synchronized" (~ lock) (~ body)))))) -(syntax: #export (do-to obj {methods (p.some partial-call^)}) +(syntax: #export (do_to obj {methods (p.some partial_call^)}) {#.doc (doc "Call a variety of methods on an object. Then, return the object." - (do-to object + (do_to object (ClassName::method1 arg0 arg1 arg2) (ClassName::method2 arg3 arg4 arg5)))} - (with-gensyms [g!obj] + (with_gensyms [g!obj] (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~+ (list\map (complete-call$ g!obj) methods)) + (exec (~+ (list\map (complete_call$ g!obj) methods)) (~ g!obj)))))))) -(def: (class-import$ [full-name params]) - (-> Class-Declaration Code) - (let [params' (list\map (|>> product.left code.local-identifier) params)] - (` (def: (~ (code.identifier ["" full-name])) - {#..jvm-class (~ (code.text full-name))} +(def: (class_import$ [full_name params]) + (-> Class_Declaration Code) + (let [params' (list\map (|>> product.left code.local_identifier) params)] + (` (def: (~ (code.identifier ["" full_name])) + {#..jvm_class (~ (code.text full_name))} Type (All [(~+ params')] - (primitive (~ (code.text (sanitize full-name))) + (primitive (~ (code.text (sanitize full_name))) [(~+ params')])))))) -(def: (member-type-vars class-tvars member) - (-> (List Type-Parameter) Import-Member-Declaration (List Type-Parameter)) +(def: (member_type_vars class_tvars member) + (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter)) (case member (#ConstructorDecl [commons _]) - (list\compose class-tvars (get@ #import-member-tvars commons)) + (list\compose class_tvars (get@ #import_member_tvars commons)) (#MethodDecl [commons _]) - (case (get@ #import-member-kind commons) + (case (get@ #import_member_kind commons) #StaticIMK - (get@ #import-member-tvars commons) + (get@ #import_member_tvars commons) _ - (list\compose class-tvars (get@ #import-member-tvars commons))) + (list\compose class_tvars (get@ #import_member_tvars commons))) _ - class-tvars)) + 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)])) +(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 [(^slots [#import-member-tvars #import-member-args]) commons] + (let [(^slots [#import_member_tvars #import_member_args]) commons] (do {! meta.monad} - [arg-inputs (monad.map ! + [arg_inputs (monad.map ! (: (-> [Bit GenericType] (Meta [Bit Code])) (function (_ [maybe? _]) - (with-gensyms [arg-name] - (wrap [maybe? arg-name])))) - import-member-args) - #let [arg-classes (: (List Text) - (list\map (|>> product.right (simple-class$ (list\compose type-params import-member-tvars))) - import-member-args)) - arg-types (list\map (: (-> [Bit GenericType] Code) + (with_gensyms [arg_name] + (wrap [maybe? arg_name])))) + import_member_args) + #let [arg_classes (: (List Text) + (list\map (|>> product.right (simple_class$ (list\compose type_params import_member_tvars))) + import_member_args)) + arg_types (list\map (: (-> [Bit GenericType] Code) (function (_ [maybe? arg]) - (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] + (let [arg_type (class->type (get@ #import_member_mode commons) type_params arg)] (if maybe? - (` (Maybe (~ arg-type))) - arg-type)))) - import-member-args)]] - (wrap [arg-inputs arg-classes arg-types]))) + (` (Maybe (~ arg_type))) + arg_type)))) + import_member_args)]] + (wrap [arg_inputs arg_classes arg_types]))) _ (\ meta.monad wrap [(list) (list) (list)]))) -(def: (decorate-return-maybe member return-term) - (-> Import-Member-Declaration Code Code) +(def: (decorate_return_maybe member return_term) + (-> Import_Member_Declaration Code Code) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ #import-member-maybe? commons) - (` (??? (~ return-term))) + (if (get@ #import_member_maybe? commons) + (` (??? (~ return_term))) (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] - (` (let [(~ g!temp) (~ return-term)] + (` (let [(~ g!temp) (~ return_term)] (if (not (..null? (:coerce (primitive "java.lang.Object") (~ g!temp)))) (~ g!temp) (error! "Cannot produce null references from method calls.")))))) _ - return-term)) + return_term)) -(template [<name> <tag> <term-trans>] - [(def: (<name> member return-term) - (-> Import-Member-Declaration Code Code) +(template [<name> <tag> <term_trans>] + [(def: (<name> member return_term) + (-> Import_Member_Declaration Code Code) (case member (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) (if (get@ <tag> commons) - <term-trans> - return-term) + <term_trans> + return_term) _ - return-term))] + return_term))] - [decorate-return-try #import-member-try? (` (..try (~ return-term)))] - [decorate-return-io #import-member-io? (` ((~! io.io) (~ 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) +(def: (free_type_param? [name bounds]) + (-> Type_Parameter Bit) (case bounds #.Nil #1 _ #0)) -(def: (type-param->type-arg [name _]) - (-> Type-Parameter Code) +(def: (type_param->type_arg [name _]) + (-> Type_Parameter Code) (code.identifier ["" name])) (template [<name> <byte> <short> <int> <float>] [(def: (<name> mode [class expression]) - (-> Primitive-Mode [Text Code] Code) + (-> Primitive_Mode [Text Code] Code) (case mode #ManualPrM expression @@ -1475,78 +1475,78 @@ "float" (` (<float> (~ expression))) _ 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] + [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) +(def: (un_quote quoted) (-> Code Code) (` ((~' ~) (~ quoted)))) -(def: (jvm-extension-inputs mode classes inputs) - (-> Primitive-Mode (List Text) (List [Bit Code]) (List Code)) +(def: (jvm_extension_inputs mode classes inputs) + (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code)) (|> inputs (list\map (function (_ [maybe? input]) (if maybe? - (` ((~! !!!) (~ (un-quote input)))) - (un-quote input)))) + (` ((~! !!!) (~ (un_quote input)))) + (un_quote input)))) (list.zip/2 classes) - (list\map (auto-convert-input mode)))) + (list\map (auto_convert_input mode)))) -(def: (import-name format class member) +(def: (import_name format class member) (-> Text Text Text Text) (|> format - (text.replace-all "#" class) - (text.replace-all "." member))) - -(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 (sanitize full-name) - all-params (|> (member-type-vars class-tvars member) - (list.filter free-type-param?) - (list\map type-param->type-arg))] + (text.replace_all "#" class) + (text.replace_all "." member))) + +(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 (sanitize full_name) + all_params (|> (member_type_vars class_tvars member) + (list.filter free_type_param?) + (list\map type_param->type_arg))] (case member - (#EnumDecl enum-members) + (#EnumDecl enum_members) (do {! meta.monad} - [#let [enum-type (: Code - (case class-tvars + [#let [enum_type (: Code + (case class_tvars #.Nil - (` (primitive (~ (code.text full-name)))) + (` (primitive (~ (code.text full_name)))) _ - (let [=class-tvars (|> class-tvars - (list.filter free-type-param?) - (list\map type-param->type-arg))] - (` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)])))))) - getter-interop (: (-> Text Code) + (let [=class_tvars (|> class_tvars + (list.filter free_type_param?) + (list\map type_param->type_arg))] + (` (All [(~+ =class_tvars)] (primitive (~ (code.text full_name)) [(~+ =class_tvars)])))))) + getter_interop (: (-> Text Code) (function (_ name) - (let [getter-name (code.identifier ["" (..import-name import-format method-prefix name)])] - (` (def: (~ getter-name) - (~ enum-type) - ((~ (code.text (format "jvm getstatic" ":" full-name ":" name)))))))))]] - (wrap (list\map getter-interop enum-members))) + (let [getter_name (code.identifier ["" (..import_name import_format method_prefix name)])] + (` (def: (~ getter_name) + (~ enum_type) + ((~ (code.text (format "jvm getstatic" ":" full_name ":" name)))))))))]] + (wrap (list\map getter_interop enum_members))) (#ConstructorDecl [commons _]) (do meta.monad - [#let [def-name (code.identifier ["" (..import-name import-format method-prefix (get@ #import-member-alias commons))]) - jvm-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes))) - jvm-interop (|> (` ((~ jvm-extension) - (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)))) - (decorate-return-maybe member) - (decorate-return-try member) - (decorate-return-io member))]] - (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list\map product.right arg-function-inputs))) - ((~' wrap) (.list (.` (~ jvm-interop))))))))) + [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) + jvm_extension (code.text (format "jvm new" ":" full_name ":" (text.join_with "," arg_classes))) + jvm_interop (|> (` ((~ jvm_extension) + (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs)))) + (decorate_return_maybe member) + (decorate_return_try member) + (decorate_return_io member))]] + (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs))) + ((~' wrap) (.list (.` (~ jvm_interop))))))))) (#MethodDecl [commons method]) - (with-gensyms [g!obj] + (with_gensyms [g!obj] (do meta.monad - [#let [def-name (code.identifier ["" (..import-name import-format method-prefix (get@ #import-member-alias commons))]) - (^slots [#import-member-kind]) commons - (^slots [#import-method-name]) method - [jvm-op object-ast] (: [Text (List Code)] - (case import-member-kind + [#let [def_name (code.identifier ["" (..import_name import_format method_prefix (get@ #import_member_alias commons))]) + (^slots [#import_member_kind]) commons + (^slots [#import_method_name]) method + [jvm_op object_ast] (: [Text (List Code)] + (case import_member_kind #StaticIMK ["invokestatic" (list)] @@ -1561,103 +1561,103 @@ ["invokeinterface" (list g!obj)] ))) - jvm-extension (code.text (format "jvm " jvm-op ":" full-name ":" import-method-name ":" (text.join-with "," arg-classes))) - jvm-interop (|> [(simple-class$ (list) (get@ #import-method-return method)) - (` ((~ jvm-extension) (~+ (list\map un-quote object-ast)) - (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs))))] - (auto-convert-output (get@ #import-member-mode commons)) - (decorate-return-maybe member) - (decorate-return-try member) - (decorate-return-io member))]] - (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list\map product.right arg-function-inputs)) (~+ object-ast)) - ((~' wrap) (.list (.` (~ jvm-interop)))))))))) + jvm_extension (code.text (format "jvm " jvm_op ":" full_name ":" import_method_name ":" (text.join_with "," arg_classes))) + jvm_interop (|> [(simple_class$ (list) (get@ #import_method_return method)) + (` ((~ jvm_extension) (~+ (list\map un_quote object_ast)) + (~+ (jvm_extension_inputs (get@ #import_member_mode commons) arg_classes arg_function_inputs))))] + (auto_convert_output (get@ #import_member_mode commons)) + (decorate_return_maybe member) + (decorate_return_try member) + (decorate_return_io member))]] + (wrap (list (` ((~! syntax:) ((~ def_name) (~+ (list\map product.right arg_function_inputs)) (~+ object_ast)) + ((~' wrap) (.list (.` (~ jvm_interop)))))))))) (#FieldAccessDecl fad) (do meta.monad [#let [(^open ".") 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 (: (List Code) - (|> class-tvars - (list.filter free-type-param?) - (list\map type-param->type-arg))) - getter-name (code.identifier ["" (..import-name import-format method-prefix import-field-name)]) - setter-name (code.identifier ["" (..import-name import-format method-prefix (format import-field-name "!"))])] - getter-interop (with-gensyms [g!obj] - (let [getter-call (if import-field-static? - (` ((~ getter-name))) - (` ((~ getter-name) (~ g!obj)))) - 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)] - (wrap (` ((~! syntax:) (~ getter-call) - ((~' wrap) (.list (.` (~ getter-body))))))))) - setter-interop (: (Meta (List Code)) - (if import-field-setter? - (with-gensyms [g!obj g!value] - (let [setter-call (if import-field-static? - (` ((~ setter-name) (~ g!value))) - (` ((~ setter-name) (~ g!value) (~ g!obj)))) - 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) + 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 (: (List Code) + (|> class_tvars + (list.filter free_type_param?) + (list\map type_param->type_arg))) + getter_name (code.identifier ["" (..import_name import_format method_prefix import_field_name)]) + setter_name (code.identifier ["" (..import_name import_format method_prefix (format import_field_name "!"))])] + getter_interop (with_gensyms [g!obj] + (let [getter_call (if import_field_static? + (` ((~ getter_name))) + (` ((~ getter_name) (~ g!obj)))) + 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)] + (wrap (` ((~! syntax:) (~ getter_call) + ((~' wrap) (.list (.` (~ getter_body))))))))) + setter_interop (: (Meta (List Code)) + (if import_field_setter? + (with_gensyms [g!obj g!value] + (let [setter_call (if import_field_static? + (` ((~ setter_name) (~ g!value))) + (` ((~ setter_name) (~ g!value) (~ g!obj)))) + 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+ (: (List Code) - (if import-field-static? + (if import_field_static? (list) - (list (un-quote g!obj))))] - (wrap (list (` ((~! syntax:) (~ setter-call) - ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter-command)) (~+ g!obj+) (~ setter-value)))))))))))) + (list (un_quote g!obj))))] + (wrap (list (` ((~! syntax:) (~ setter_call) + ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter_command)) (~+ g!obj+) (~ setter_value)))))))))))) (wrap (list))))] - (wrap (list& getter-interop setter-interop))) + (wrap (list& 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] +(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)))) + [=args (member_def_arg_bindings type_params class member)] + (member_def_interop type_params kind class =args member method_prefix import_format)))) (def: (interface? class) (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) ("jvm invokevirtual:java.lang.Class:isInterface:" class)) -(def: (load-class class-name) +(def: (load_class class_name) (-> Text (Try (primitive "java.lang.Class" [Any]))) - (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class-name))) + (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 (sanitize class-name)] - (case (load-class class-name) +(def: (class_kind [class_name _]) + (-> Class_Declaration (Meta Class_Kind)) + (let [class_name (sanitize class_name)] + (case (load_class class_name) (#.Right class) (\ meta.monad wrap (if (interface? class) #Interface #Class)) (#.Left _) - (meta.fail (format "Unknown class: " class-name))))) + (meta.fail (format "Unknown class: " class_name))))) (syntax: #export (import: - {class-decl ..class-decl^} - {bundles (p.some (..bundle (product.right class-decl)))}) + {class_decl ..class_decl^} + {bundles (p.some (..bundle (product.right class_decl)))}) {#.doc (doc "Allows importing JVM classes, and using them as types." "Their methods, fields and enum options can also be imported." (import: java/lang/Object @@ -1675,7 +1675,7 @@ ["#::." (new [[byte]]) (#static valueOf [char] java/lang/String) - (#static valueOf #as int-valueOf [int] java/lang/String)]) + (#static valueOf #as int_valueOf [int] java/lang/String)]) (import: (java/util/List e) ["#::." @@ -1705,27 +1705,27 @@ "Also, the names of the imported members will look like Class::member" (java/lang/Object::new []) - (java/lang/Object::equals [other-object] my-object) - (java/util/List::size [] my-list) + (java/lang/Object::equals [other_object] my_object) + (java/util/List::size [] my_list) java/lang/Character$UnicodeScript::LATIN )} (do {! meta.monad} - [kind (class-kind class-decl) + [kind (class_kind class_decl) =members (|> bundles - (list\map (function (_ [import-format members]) - (list\map (|>> [import-format]) members))) + (list\map (function (_ [import_format members]) + (list\map (|>> [import_format]) members))) list.concat - (monad.map ! (member-import$ (product.right class-decl) kind class-decl)))] - (wrap (list& (class-import$ class-decl) (list\join =members))))) + (monad.map ! (member_import$ (product.right class_decl) kind class_decl)))] + (wrap (list& (class_import$ class_decl) (list\join =members))))) -(syntax: #export (array {type (..generic-type^ (list))} +(syntax: #export (array {type (..generic_type^ (list))} size) {#.doc (doc "Create an array of the given type, with the given size." (array Object 10))} (case type - (^template [<type> <array-op>] + (^template [<type> <array_op>] [(^ (#GenericClass <type> (list))) - (wrap (list (` (<array-op> (~ size)))))]) + (wrap (list (` (<array_op> (~ size)))))]) (["boolean" "jvm znewarray"] ["byte" "jvm bnewarray"] ["short" "jvm snewarray"] @@ -1736,14 +1736,14 @@ ["char" "jvm cnewarray"]) _ - (wrap (list (` ("jvm anewarray" (~ (code.text (generic-type$ type))) (~ size))))))) + (wrap (list (` ("jvm anewarray" (~ (code.text (generic_type$ type))) (~ size))))))) -(syntax: #export (array-length array) +(syntax: #export (array_length array) {#.doc (doc "Gives the length of an array." - (array-length my-array))} + (array_length my_array))} (wrap (list (` ("jvm arraylength" (~ array)))))) -(def: (type->class-name type) +(def: (type->class_name type) (-> Type (Meta Text)) (if (type\= Any type) (\ meta.monad wrap "java.lang.Object") @@ -1757,26 +1757,26 @@ (meta.fail (format "Cannot apply type: " (type.format F) " to " (type.format A))) (#.Some type') - (type->class-name type')) + (type->class_name type')) (#.Named _ type') - (type->class-name type') + (type->class_name type') _ (meta.fail (format "Cannot convert to JvmType: " (type.format type)))))) -(syntax: #export (array-read idx array) +(syntax: #export (array_read idx array) {#.doc (doc "Loads an element from an array." - (array-read 10 my-array))} + (array_read 10 my_array))} (case array - [_ (#.Identifier array-name)] + [_ (#.Identifier array_name)] (do meta.monad - [array-type (meta.find-type array-name) - array-jvm-type (type->class-name array-type)] - (case array-jvm-type - (^template [<type> <array-op>] + [array_type (meta.find_type array_name) + array_jvm_type (type->class_name array_type)] + (case array_jvm_type + (^template [<type> <array_op>] [<type> - (wrap (list (` (<array-op> (~ array) (~ idx)))))]) + (wrap (list (` (<array_op> (~ array) (~ idx)))))]) (["[Z" "jvm zaload"] ["[B" "jvm baload"] ["[S" "jvm saload"] @@ -1790,22 +1790,22 @@ (wrap (list (` ("jvm aaload" (~ array) (~ idx))))))) _ - (with-gensyms [g!array] + (with_gensyms [g!array] (wrap (list (` (let [(~ g!array) (~ array)] - (..array-read (~ idx) (~ g!array))))))))) + (..array_read (~ idx) (~ g!array))))))))) -(syntax: #export (array-write idx value array) +(syntax: #export (array_write idx value array) {#.doc (doc "Stores an element into an array." - (array-write 10 my-object my-array))} + (array_write 10 my_object my_array))} (case array - [_ (#.Identifier array-name)] + [_ (#.Identifier array_name)] (do meta.monad - [array-type (meta.find-type array-name) - array-jvm-type (type->class-name array-type)] - (case array-jvm-type - (^template [<type> <array-op>] + [array_type (meta.find_type array_name) + array_jvm_type (type->class_name array_type)] + (case array_jvm_type + (^template [<type> <array_op>] [<type> - (wrap (list (` (<array-op> (~ array) (~ idx) (~ value)))))]) + (wrap (list (` (<array_op> (~ array) (~ idx) (~ value)))))]) (["[Z" "jvm zastore"] ["[B" "jvm bastore"] ["[S" "jvm sastore"] @@ -1819,14 +1819,14 @@ (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) _ - (with-gensyms [g!array] + (with_gensyms [g!array] (wrap (list (` (let [(~ g!array) (~ array)] - (..array-write (~ idx) (~ value) (~ g!array))))))))) + (..array_write (~ idx) (~ value) (~ g!array))))))))) -(syntax: #export (class-for {type (..generic-type^ (list))}) +(syntax: #export (class_for {type (..generic_type^ (list))}) {#.doc (doc "Loads the class as a java.lang.Class object." - (class-for java/lang/String))} - (wrap (list (` ("jvm object class" (~ (code.text (simple-class$ (list) type)))))))) + (class_for java/lang/String))} + (wrap (list (` ("jvm object class" (~ (code.text (simple_class$ (list) type)))))))) -(syntax: #export (type {type (..generic-type^ (list))}) +(syntax: #export (type {type (..generic_type^ (list))}) (wrap (list (class->type #ManualPrM (list) type)))) |