aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
authorEduardo Julian2021-07-23 01:05:41 -0400
committerEduardo Julian2021-07-23 01:05:41 -0400
commit4248cc22881a7eaa8f74bc426f2b0ba284b23153 (patch)
treeb6730483b658a185901c2a7c871632d85a434b23 /stdlib/source
parent51a5c28b0f9efd514e3fae7c2634fd5e9bd714e2 (diff)
Automatically handling input/output conversions for methods in new JVM compiler.
Diffstat (limited to '')
-rw-r--r--stdlib/source/library/lux/target/jvm/type/lux.lux63
-rw-r--r--stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux92
-rw-r--r--stdlib/source/test/lux.lux79
-rw-r--r--stdlib/source/test/lux/ffi.jvm.lux56
4 files changed, 233 insertions, 57 deletions
diff --git a/stdlib/source/library/lux/target/jvm/type/lux.lux b/stdlib/source/library/lux/target/jvm/type/lux.lux
index 45fd34c8d..b4abe4093 100644
--- a/stdlib/source/library/lux/target/jvm/type/lux.lux
+++ b/stdlib/source/library/lux/target/jvm/type/lux.lux
@@ -7,7 +7,7 @@
["." try]
["." exception (#+ exception:)]
["<>" parser ("#\." monad)
- ["<t>" text (#+ Parser)]]]
+ ["<.>" text (#+ Parser)]]]
[data
["." product]
["." text ("#\." equivalence)
@@ -24,6 +24,7 @@
["#." signature]
["#." reflection]
["#." parser]
+ ["#." box]
["/#" // #_
[encoding
["#." name]]]])
@@ -66,6 +67,22 @@
[char //parser.char //reflection.char]
)
+(template [<name> <parser> <box>]
+ [(def: <name>
+ (Parser (Check Type))
+ (<>.after <parser>
+ (<>\wrap (check\wrap (#.Primitive <box> #.Nil)))))]
+
+ [boxed_boolean //parser.boolean //box.boolean]
+ [boxed_byte //parser.byte //box.byte]
+ [boxed_short //parser.short //box.short]
+ [boxed_int //parser.int //box.int]
+ [boxed_long //parser.long //box.long]
+ [boxed_float //parser.float //box.float]
+ [boxed_double //parser.double //box.double]
+ [boxed_char //parser.char //box.char]
+ )
+
(def: primitive
(Parser (Check Type))
($_ <>.either
@@ -79,6 +96,19 @@
..char
))
+(def: boxed_primitive
+ (Parser (Check Type))
+ ($_ <>.either
+ ..boxed_boolean
+ ..boxed_byte
+ ..boxed_short
+ ..boxed_int
+ ..boxed_long
+ ..boxed_float
+ ..boxed_double
+ ..boxed_char
+ ))
+
(def: wildcard
(Parser (Check Type))
(<>.after //parser.wildcard
@@ -101,19 +131,19 @@
(|> (do <>.monad
[name //parser.class_name
parameters (|> (<>.some parameter)
- (<>.after (<t>.this //signature.parameters_start))
- (<>.before (<t>.this //signature.parameters_end))
+ (<>.after (<text>.this //signature.parameters_start))
+ (<>.before (<text>.this //signature.parameters_end))
(<>.default (list)))]
(wrap (do {! check.monad}
[parameters (monad.seq ! parameters)]
(wrap (#.Primitive name parameters)))))
- (<>.after (<t>.this //descriptor.class_prefix))
- (<>.before (<t>.this //descriptor.class_suffix))))
+ (<>.after (<text>.this //descriptor.class_prefix))
+ (<>.before (<text>.this //descriptor.class_suffix))))
(template [<name> <prefix> <constructor>]
[(def: <name>
(-> (Parser (Check Type)) (Parser (Check Type)))
- (|> (<>.after (<t>.this <prefix>))
+ (|> (<>.after (<text>.this <prefix>))
## TODO: Re-enable Lower and Upper, instead of using the simplified limit.
## (<>\map (check\map (|>> <ctor> .type)))
))]
@@ -160,7 +190,7 @@
_
(|> elementT array.Array .type)))))
- (<>.after (<t>.this //descriptor.array_prefix))))
+ (<>.after (<text>.this //descriptor.array_prefix))))
(def: #export (type mapping)
(-> Mapping (Parser (Check Type)))
@@ -172,6 +202,16 @@
(..array type)
))))
+(def: #export (boxed_type mapping)
+ (-> Mapping (Parser (Check Type)))
+ (<>.rec
+ (function (_ type)
+ ($_ <>.either
+ ..boxed_primitive
+ (parameter mapping)
+ (..array type)
+ ))))
+
(def: #export (return mapping)
(-> Mapping (Parser (Check Type)))
($_ <>.either
@@ -179,9 +219,16 @@
(..type mapping)
))
+(def: #export (boxed_return mapping)
+ (-> Mapping (Parser (Check Type)))
+ ($_ <>.either
+ ..void
+ (..boxed_type mapping)
+ ))
+
(def: #export (check operation input)
(All [a] (-> (Parser (Check a)) Text (Check a)))
- (case (<t>.run operation input)
+ (case (<text>.run operation input)
(#try.Success check)
check
diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
index 66f7271db..e5af044c3 100644
--- a/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux
@@ -853,7 +853,9 @@
(#try.Failure error)
(phase.fail error)))]
+ [boxed_reflection_type Value luxT.boxed_type]
[reflection_type Value luxT.type]
+ [boxed_reflection_return Return luxT.boxed_return]
[reflection_return Return luxT.return]
)
@@ -1679,7 +1681,7 @@
arguments' (monad.map !
(function (_ [name jvmT])
(do !
- [luxT (reflection_type mapping jvmT)]
+ [luxT (boxed_reflection_type mapping jvmT)]
(wrap [name luxT])))
arguments)
[scope bodyA] (|> arguments'
@@ -1755,7 +1757,7 @@
arguments' (monad.map !
(function (_ [name jvmT])
(do !
- [luxT (reflection_type mapping jvmT)]
+ [luxT (boxed_reflection_type mapping jvmT)]
(wrap [name luxT])))
arguments)
[scope bodyA] (|> arguments'
@@ -1829,7 +1831,7 @@
arguments' (monad.map !
(function (_ [name jvmT])
(do !
- [luxT (reflection_type mapping jvmT)]
+ [luxT (boxed_reflection_type mapping jvmT)]
(wrap [name luxT])))
arguments)
[scope bodyA] (|> arguments'
@@ -1944,6 +1946,35 @@
mapping
override_mapping))))
+(def: #export (hide_method_body arity bodyA)
+ (-> Nat Analysis Analysis)
+ (<| /////analysis.tuple
+ (list (/////analysis.unit))
+ (case arity
+ (^or 0 1)
+ bodyA
+
+ 2
+ (#/////analysis.Case (/////analysis.unit)
+ [{#/////analysis.when
+ (#/////analysis.Bind 2)
+
+ #/////analysis.then
+ bodyA}
+ (list)])
+
+ _
+ (#/////analysis.Case (/////analysis.unit)
+ [{#/////analysis.when
+ (#/////analysis.Complex
+ (#/////analysis.Tuple (|> arity
+ list.indices
+ (list\map (|>> (n.+ 2) #/////analysis.Bind)))))
+
+ #/////analysis.then
+ bodyA}
+ (list)]))))
+
(def: #export (analyse_overriden_method analyse archive selfT mapping supers method)
(-> Phase Archive .Type Mapping (List (Type Class)) (Overriden_Method Code) (Operation Analysis))
(let [[parent_type method_name
@@ -1965,10 +1996,10 @@
arguments' (monad.map !
(function (_ [name jvmT])
(do !
- [luxT (reflection_type mapping jvmT)]
+ [luxT (boxed_reflection_type mapping jvmT)]
(wrap [name luxT])))
arguments)
- returnT (reflection_return mapping return)
+ returnT (boxed_reflection_return mapping return)
[scope bodyA] (|> arguments'
(#.Cons [self_name selfT])
list.reverse
@@ -1989,7 +2020,7 @@
(#/////analysis.Function
(list\map (|>> /////analysis.variable)
(scope.environment scope))
- (/////analysis.tuple (list bodyA)))
+ (..hide_method_body (list.size arguments) bodyA))
))))))
(type: #export (Method_Definition a)
@@ -2052,6 +2083,31 @@
local (format "anonymous-class" (%.nat id))]
(format global ..jvm_package_separator local)))
+(def: #export (require_complete_method_concretion class_loader supers methods)
+ (-> java/lang/ClassLoader (List (Type Class)) (List (Overriden_Method Code)) (Operation Any))
+ (do {! phase.monad}
+ [required_abstract_methods (phase.lift (all_abstract_methods class_loader supers))
+ available_methods (phase.lift (all_methods class_loader supers))
+ overriden_methods (monad.map ! (function (_ [parent_type method_name
+ strict_fp? annotations type_vars
+ self_name arguments return exceptions
+ body])
+ (do !
+ [aliasing (super_aliasing class_loader parent_type)]
+ (wrap [method_name (|> (jvm.method [type_vars
+ (list\map product.right arguments)
+ return
+ exceptions])
+ (jvm_alias.method aliasing))])))
+ methods)
+ #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods)
+ invalid_overriden_methods (mismatched_methods available_methods overriden_methods)]
+ _ (phase.assert ..missing_abstract_methods missing_abstract_methods
+ (list.empty? missing_abstract_methods))
+ _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods
+ (list.empty? invalid_overriden_methods))]
+ (wrap [])))
+
(def: (class::anonymous class_loader)
(-> java/lang/ClassLoader Handler)
(..custom
@@ -2097,27 +2153,9 @@
(analyse archive term))]
(wrap [type termA])))
constructor_args)
- methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping (#.Cons super_class super_interfaces)) methods)
- required_abstract_methods (phase.lift (all_abstract_methods class_loader (list& super_class super_interfaces)))
- available_methods (phase.lift (all_methods class_loader (list& super_class super_interfaces)))
- overriden_methods (monad.map ! (function (_ [parent_type method_name
- strict_fp? annotations type_vars
- self_name arguments return exceptions
- body])
- (do !
- [aliasing (super_aliasing class_loader parent_type)]
- (wrap [method_name (|> (jvm.method [type_vars
- (list\map product.right arguments)
- return
- exceptions])
- (jvm_alias.method aliasing))])))
- methods)
- #let [missing_abstract_methods (mismatched_methods overriden_methods required_abstract_methods)
- invalid_overriden_methods (mismatched_methods available_methods overriden_methods)]
- _ (phase.assert ..missing_abstract_methods missing_abstract_methods
- (list.empty? missing_abstract_methods))
- _ (phase.assert ..invalid_overriden_methods invalid_overriden_methods
- (list.empty? invalid_overriden_methods))]
+ #let [supers (#.Cons super_class super_interfaces)]
+ _ (..require_complete_method_concretion class_loader supers methods)
+ methodsA (monad.map ! (analyse_overriden_method analyse archive selfT mapping supers) methods)]
(wrap (#/////analysis.Extension extension_name
(list (class_analysis super_class)
(/////analysis.tuple (list\map class_analysis super_interfaces))
diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux
index 20d21d74d..fcf33fa79 100644
--- a/stdlib/source/test/lux.lux
+++ b/stdlib/source/test/lux.lux
@@ -61,22 +61,6 @@
[_ (wrap [])]
body)))
-(def: identity
- Test
- (do {! random.monad}
- [value random.nat
- #let [object (: (Random (Atom Nat))
- (\ ! map atom.atom (wrap value)))]
- self object]
- ($_ _.and
- (_.test "Every value is identical to itself."
- (is? self self))
- (do !
- [other object]
- (_.test "Values created separately can't be identical."
- (not (is? self other))))
- )))
-
(def: prelude_macros
Test
($_ _.and
@@ -739,12 +723,70 @@
dummy))))
)))
+(def: for_value
+ Test
+ (do random.monad
+ [left random.nat
+ right (random.ascii/lower 1)]
+ ($_ _.and
+ (_.cover [/.Either]
+ (and (exec
+ (: (/.Either Nat Text)
+ (#.Left left))
+ true)
+ (exec
+ (: (/.Either Nat Text)
+ (#.Right right))
+ true)))
+ (_.cover [/.Any]
+ (and (exec
+ (: /.Any
+ left)
+ true)
+ (exec
+ (: /.Any
+ right)
+ true)))
+ (_.cover [/.Nothing]
+ (and (exec
+ (: (-> /.Any /.Nothing)
+ (function (_ _)
+ (undefined)))
+ true)
+ (exec
+ (: (-> /.Any /.Int)
+ (function (_ _)
+ (: /.Int (undefined))))
+ true)))
+ (_.cover [/.All]
+ (let [identity (: (/.All [a] (-> a a))
+ (|>>))]
+ (and (exec
+ (: Nat
+ (identity left))
+ true)
+ (exec
+ (: Text
+ (identity right))
+ true))))
+ (_.cover [/.Ex]
+ (let [hide (: (/.Ex [a] (-> Nat a))
+ (|>>))]
+ (exec
+ (: /.Any
+ (hide left))
+ true)))
+ (_.cover [/.is?]
+ (let [not_left (|> left inc dec)]
+ (and (/.is? left left)
+ (and (n.= not_left left)
+ (not (/.is? not_left left))))))
+ )))
+
(def: test
Test
(<| (_.covering /._)
($_ _.and
- (<| (_.context "Identity.")
- ..identity)
(<| (_.context "Prelude macros.")
..prelude_macros)
@@ -764,6 +806,7 @@
..for_slot
..for_associative
..for_expansion
+ ..for_value
..sub_tests
)))
diff --git a/stdlib/source/test/lux/ffi.jvm.lux b/stdlib/source/test/lux/ffi.jvm.lux
index b0ae4fc0f..1396e1646 100644
--- a/stdlib/source/test/lux/ffi.jvm.lux
+++ b/stdlib/source/test/lux/ffi.jvm.lux
@@ -247,10 +247,19 @@
["#::."
(actual3 [] a)])
+(/.interface: test/TestInterface4
+ ([] actual4 [long long long] long))
+
+(/.import: test/TestInterface4
+ ["#::."
+ (actual4 [long long long] long)])
+
(def: for_interface
Test
(do random.monad
[expected random.nat
+ left random.int
+ right random.int
#let [object/0 (/.object [] [test/TestInterface0]
[]
(test/TestInterface0
@@ -306,12 +315,26 @@
expected)))
example/3!
(is? (: Any expected)
- (: Any (test/TestInterface3::actual3 object/3)))]]
+ (: Any (test/TestInterface3::actual3 object/3)))
+
+ example/4!
+ (let [expected (i.+ left right)
+ object/4 (/.object [] [test/TestInterface4]
+ []
+ (test/TestInterface4
+ [] (actual4 self {actual_left long} {actual_right long} {_ long})
+ long
+ (:as java/lang/Long
+ (i.+ (:as Int actual_left)
+ (:as Int actual_right)))))]
+ (i.= expected
+ (test/TestInterface4::actual4 left right right object/4)))]]
(_.cover [/.interface: /.object]
(and example/0!
example/1!
example/2!
- example/3!))))
+ example/3!
+ example/4!))))
(/.class: #final test/TestClass0 [test/TestInterface0]
## Fields
@@ -425,10 +448,28 @@
["#::."
(new [])])
+(/.class: #final test/TestClass8 [test/TestInterface4]
+ ## Constructors
+ (#public [] (new self) []
+ [])
+ ## Methods
+ (test/TestInterface4
+ [] (actual4 self {actual_left long} {actual_right long} {_ long})
+ long
+ (:as java/lang/Long
+ (i.+ (:as Int actual_left)
+ (:as Int actual_right)))))
+
+(/.import: test/TestClass8
+ ["#::."
+ (new [])])
+
(def: for_class
Test
(do random.monad
[expected random.nat
+ left random.int
+ right random.int
#let [object/0 (test/TestClass0::new (.int expected))
example/0!
@@ -474,7 +515,13 @@
object/7 (test/TestClass7::new)
example/7!
(n.= expected
- (.nat (test/TestClass6::actual6 (.int expected) object/7)))]]
+ (.nat (test/TestClass6::actual6 (.int expected) object/7)))
+
+ example/8!
+ (let [expected (i.+ left right)
+ object/8 (test/TestClass8::new)]
+ (i.= expected
+ (test/TestInterface4::actual4 left right right object/8)))]]
(_.cover [/.class: /.import:]
(and example/0!
example/1!
@@ -482,7 +529,8 @@
example/3!
example/4!
example/5!
- example/7!))))
+ example/7!
+ example/8!))))
(def: #export test
(<| (_.covering /._)