diff options
Diffstat (limited to 'stdlib/source')
| -rw-r--r-- | stdlib/source/library/lux/target/jvm/type/lux.lux | 63 | ||||
| -rw-r--r-- | stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux | 92 | ||||
| -rw-r--r-- | stdlib/source/test/lux.lux | 79 | ||||
| -rw-r--r-- | stdlib/source/test/lux/ffi.jvm.lux | 56 |
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 /._) |