aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2022-06-26 00:50:32 -0400
committerEduardo Julian2022-06-26 00:50:32 -0400
commitcfdc546e6834ceeb78cb692d17fd5c60695be982 (patch)
tree3a76dbbcedec800bba566cc573c8547309d5e5e4 /stdlib
parentfb46beb8bd784ba92949bf2c535dc13c2f003ef0 (diff)
(Even) better syntax for invoking super methods inside overriden methods.
Diffstat (limited to '')
-rw-r--r--stdlib/source/library/lux/ffi.jvm.lux270
1 files changed, 175 insertions, 95 deletions
diff --git a/stdlib/source/library/lux/ffi.jvm.lux b/stdlib/source/library/lux/ffi.jvm.lux
index a460fbc5e..b3ece286c 100644
--- a/stdlib/source/library/lux/ffi.jvm.lux
+++ b/stdlib/source/library/lux/ffi.jvm.lux
@@ -14,7 +14,8 @@
[data
["[0]" product]
["[0]" text (.use "[1]#[0]" equivalence)
- ["%" \\format (.only format)]]
+ ["%" \\format (.only format)]
+ ["<[1]>" \\parser]]
[collection
["[0]" array]
["[0]" list (.use "[1]#[0]" monad mix monoid)]
@@ -24,7 +25,10 @@
["^" pattern]
["[0]" code]
["[0]" template]
- ["[0]" local]]
+ ["[0]" context]]
+ [math
+ [number
+ ["n" nat]]]
[target
["[0]" jvm
[encoding
@@ -1089,111 +1093,187 @@
(-> (Typed Code) Code)
(` [(~ (value$ class)) (~ term)]))
-(def (overriden_method_macro super_class name declaration type_vars self_name expected_arguments)
- (-> (Type Class) Text (Type Declaration) (List (Type Var)) Text (List Argument) Macro)
- (syntax (_ [_ (<code>.this (' "super"))
- actual_arguments (<code>.tuple (<>.exactly (list.size expected_arguments) <code>.any))])
- (in (list (` ("jvm member invoke special"
- [(~+ (list#each (|>> ..signature code.text) (product.right (parser.declaration declaration))))]
- (~ (code.text (product.left (parser.read_class super_class))))
- (~ (code.text name))
- [(~+ (list#each (|>> ..signature code.text) type_vars))]
- ("jvm object cast" (~ (code.local self_name)))
- (~+ (|> actual_arguments
- (list#each (|>> ~ "jvm object cast" `))
- (list.zipped_2 (list#each product.right expected_arguments))
- (list#each ..decorate_input)))))))))
-
-(def (method_def$ fully_qualified_class_name method_parser super_class fields [[name pm anns] method_def])
+(.type Super
+ [[External (List (Type Var))]
+ [Member_Declaration MethodDecl]
+ Text])
+
+(context.def [super_context super_expression super_declaration]
+ Super)
+
+(def var^^
+ (Parser (Type Var))
+ (<text>.then parser.var <code>.text))
+
+(def class^^
+ (Parser (Type Class))
+ (<text>.then parser.class <code>.text))
+
+(def type^^
+ (Parser (Type Value))
+ (<text>.then parser.value <code>.text))
+
+(def return^^
+ (Parser (Type Return))
+ (<text>.then parser.return <code>.text))
+
+(def method_decl^^
+ (Parser [Member_Declaration MethodDecl])
+ (<code>.form
+ (do <>.monad
+ [tvars (<code>.tuple (<>.some var^^))
+ name <code>.text
+ anns (<code>.tuple (<>.some ..annotation^))
+ inputs (<code>.tuple (<>.some type^^))
+ output return^^
+ exs (<code>.tuple (<>.some class^^))]
+ (in [[name {#PublicP} anns] [#method_tvars tvars
+ #method_inputs inputs
+ #method_output output
+ #method_exs exs]]))))
+
+(def (method_decl$$ [[name pm anns] method_decl])
+ (-> [Member_Declaration MethodDecl] Code)
+ (let [(open "[0]") method_decl]
+ (` ([(~+ (list#each var$ #method_tvars))]
+ (~ (code.text name))
+ [(~+ (list#each annotation$ anns))]
+ [(~+ (list#each value$ #method_inputs))]
+ (~ (return$ #method_output))
+ [(~+ (list#each class$ #method_exs))]))))
+
+(def .public with_super
+ (syntax (_ [declaration,method,self (<code>.tuple
+ (all <>.and
+ (<text>.then parser.declaration' <code>.text)
+ method_decl^^
+ <code>.text))
+ body <code>.any])
+ (do meta.monad
+ [body (super_expression declaration,method,self body)]
+ (in (list body)))))
+
+(exception: .public (insufficient_parameters [expected Nat
+ actual Nat])
+ (exception.report
+ "Expected" (%.nat expected)
+ "Actual" (%.nat actual)))
+
+(def .public super
+ (syntax (_ [inputs (<>.some <code>.any)])
+ (do meta.monad
+ [[[super_name super_vars] [member method] self] (context.peek ..super_context)
+ .let [expected_arguments (list.size (the #method_inputs method))
+ actual_arguments (list.size inputs)]]
+ (if (n.= expected_arguments actual_arguments)
+ (in (list (` ("jvm member invoke special"
+ [(~+ (list#each (|>> ..signature code.text) super_vars))]
+ (~ (code.text super_name))
+ (~ (code.text (the #member_name member)))
+ [(~+ (list#each (|>> ..signature code.text) (the #method_tvars method)))]
+ ("jvm object cast" (~ (code.local self)))
+ (~+ (|> inputs
+ (list#each (|>> ~ "jvm object cast" `))
+ (list.zipped_2 (the #method_inputs method))
+ (list#each ..decorate_input)))))))
+ (meta.failure (exception.error ..insufficient_parameters [expected_arguments actual_arguments]))))))
+
+(def (method_def$ fully_qualified_class_name method_parser super_class fields [method_declaration method_def])
(-> External (Parser Code) (Type Class) (List [Member_Declaration FieldDecl]) [Member_Declaration Method_Definition] (Meta Code))
- (case method_def
- {#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs}
- (let [replacer (|> (list#each (field->parser fully_qualified_class_name self_name) fields)
- (list#mix <>.either method_parser)
- parser->replacer)]
- (meta#in (` ("init"
- (~ (privacy_modifier$ pm))
- (~ (code.bit strict_fp?))
- [(~+ (list#each annotation$ anns))]
- [(~+ (list#each var$ type_vars))]
- [(~+ (list#each class$ exs))]
- (~ (code.text self_name))
- [(~+ (list#each argument$ arguments))]
- [(~+ (list#each constructor_arg$ constructor_args))]
- (~ (replaced replacer body))
- ))))
-
- {#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs}
- (let [replacer (|> (list#each (field->parser fully_qualified_class_name self_name) fields)
- (list#mix <>.either method_parser)
- parser->replacer)]
- (meta#in (` ("virtual"
+ (let [[name pm anns] method_declaration]
+ (case method_def
+ {#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs}
+ (let [replacer (|> (list#each (field->parser fully_qualified_class_name self_name) fields)
+ (list#mix <>.either method_parser)
+ parser->replacer)]
+ (meta#in (` ("init"
+ (~ (privacy_modifier$ pm))
+ (~ (code.bit strict_fp?))
+ [(~+ (list#each annotation$ anns))]
+ [(~+ (list#each var$ type_vars))]
+ [(~+ (list#each class$ exs))]
+ (~ (code.text self_name))
+ [(~+ (list#each argument$ arguments))]
+ [(~+ (list#each constructor_arg$ constructor_args))]
+ (~ (replaced replacer body))
+ ))))
+
+ {#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs}
+ (let [replacer (|> (list#each (field->parser fully_qualified_class_name self_name) fields)
+ (list#mix <>.either method_parser)
+ parser->replacer)]
+ (meta#in (` ("virtual"
+ (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ (~ (code.bit final?))
+ (~ (code.bit strict_fp?))
+ [(~+ (list#each annotation$ anns))]
+ [(~+ (list#each var$ type_vars))]
+ (~ (code.text self_name))
+ [(~+ (list#each argument$ arguments))]
+ (~ (return$ return_type))
+ [(~+ (list#each class$ exs))]
+ (~ (replaced replacer body))))))
+
+ {#OverridenMethod strict_fp? declaration type_vars self_name expected_arguments return_type body exs}
+ (let [replacer (|> (list#each (field->parser fully_qualified_class_name self_name) fields)
+ (list#mix <>.either method_parser)
+ parser->replacer)]
+ (do meta.monad
+ [@ meta.current_module_name]
+ (in (` ("override"
+ (~ (declaration$ declaration))
+ (~ (code.text name))
+ (~ (code.bit strict_fp?))
+ [(~+ (list#each annotation$ anns))]
+ [(~+ (list#each var$ type_vars))]
+ (~ (code.text self_name))
+ [(~+ (list#each argument$ expected_arguments))]
+ (~ (return$ return_type))
+ [(~+ (list#each class$ exs))]
+ (~ (replaced replacer
+ (` (..with_super [(~ (declaration$ declaration))
+ (~ (method_decl$$ [method_declaration
+ [#method_tvars type_vars
+ #method_inputs (list#each product.right expected_arguments)
+ #method_output return_type
+ #method_exs exs]]))
+ (~ (code.text self_name))]
+ (~ body))))))))))
+
+ {#StaticMethod strict_fp? type_vars arguments return_type body exs}
+ (let [replacer (parser->replacer (<>.failure ""))]
+ (meta#in (` ("static"
+ (~ (code.text name))
+ (~ (privacy_modifier$ pm))
+ (~ (code.bit strict_fp?))
+ [(~+ (list#each annotation$ anns))]
+ [(~+ (list#each var$ type_vars))]
+ [(~+ (list#each argument$ arguments))]
+ (~ (return$ return_type))
+ [(~+ (list#each class$ exs))]
+ (~ (replaced replacer body))))))
+
+ {#AbstractMethod type_vars arguments return_type exs}
+ (meta#in (` ("abstract"
(~ (code.text name))
(~ (privacy_modifier$ pm))
- (~ (code.bit final?))
- (~ (code.bit strict_fp?))
[(~+ (list#each annotation$ anns))]
[(~+ (list#each var$ type_vars))]
- (~ (code.text self_name))
[(~+ (list#each argument$ arguments))]
(~ (return$ return_type))
- [(~+ (list#each class$ exs))]
- (~ (replaced replacer body))))))
-
- {#OverridenMethod strict_fp? declaration type_vars self_name expected_arguments return_type body exs}
- (let [replacer (|> (list#each (field->parser fully_qualified_class_name self_name) fields)
- (list#mix <>.either method_parser)
- parser->replacer)]
- (do meta.monad
- [@ meta.current_module_name
- body/+ (local.with (list [[@ name] (overriden_method_macro super_class name declaration type_vars self_name expected_arguments)])
- #1
- body)]
- (in (` ("override"
- (~ (declaration$ declaration))
- (~ (code.text name))
- (~ (code.bit strict_fp?))
- [(~+ (list#each annotation$ anns))]
- [(~+ (list#each var$ type_vars))]
- (~ (code.text self_name))
- [(~+ (list#each argument$ expected_arguments))]
- (~ (return$ return_type))
- [(~+ (list#each class$ exs))]
- (~+ (list#each (replaced replacer) body/+)))))))
-
- {#StaticMethod strict_fp? type_vars arguments return_type body exs}
- (let [replacer (parser->replacer (<>.failure ""))]
- (meta#in (` ("static"
+ [(~+ (list#each class$ exs))])))
+
+ {#NativeMethod type_vars arguments return_type exs}
+ (meta#in (` ("native"
(~ (code.text name))
(~ (privacy_modifier$ pm))
- (~ (code.bit strict_fp?))
[(~+ (list#each annotation$ anns))]
[(~+ (list#each var$ type_vars))]
- [(~+ (list#each argument$ arguments))]
- (~ (return$ return_type))
[(~+ (list#each class$ exs))]
- (~ (replaced replacer body))))))
-
- {#AbstractMethod type_vars arguments return_type exs}
- (meta#in (` ("abstract"
- (~ (code.text name))
- (~ (privacy_modifier$ pm))
- [(~+ (list#each annotation$ anns))]
- [(~+ (list#each var$ type_vars))]
- [(~+ (list#each argument$ arguments))]
- (~ (return$ return_type))
- [(~+ (list#each class$ exs))])))
-
- {#NativeMethod type_vars arguments return_type exs}
- (meta#in (` ("native"
- (~ (code.text name))
- (~ (privacy_modifier$ pm))
- [(~+ (list#each annotation$ anns))]
- [(~+ (list#each var$ type_vars))]
- [(~+ (list#each class$ exs))]
- [(~+ (list#each argument$ arguments))]
- (~ (return$ return_type)))))
- ))
+ [(~+ (list#each argument$ arguments))]
+ (~ (return$ return_type)))))
+ )))
(def (complete_call$ g!obj [method args])
(-> Code Partial_Call Code)