diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/library/lux/ffi.jvm.lux | 183 | ||||
| -rw-r--r-- | stdlib/source/library/lux/ffi.old.lux | 78 | ||||
| -rw-r--r-- | stdlib/source/library/lux/tool/compiler/language/lux/directive.lux | 14 | ||||
| -rw-r--r-- | stdlib/source/library/lux/tool/compiler/language/lux/phase/extension/analysis/jvm.lux | 40 | ||||
| -rw-r--r-- | stdlib/source/test/lux.lux | 80 | ||||
| -rw-r--r-- | stdlib/source/test/lux/ffi.jvm.lux | 239 |
6 files changed, 422 insertions, 212 deletions
diff --git a/stdlib/source/library/lux/ffi.jvm.lux b/stdlib/source/library/lux/ffi.jvm.lux index fbcd39119..c05a2afe2 100644 --- a/stdlib/source/library/lux/ffi.jvm.lux +++ b/stdlib/source/library/lux/ffi.jvm.lux @@ -187,21 +187,21 @@ #ManualPrM #AutoPrM) -(type: Privacy +(type: #export Privacy #PublicP #PrivateP #ProtectedP #DefaultP) -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) +(type: #export State + #VolatileS + #FinalS + #DefaultS) -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) +(type: #export Inheritance + #FinalI + #AbstractI + #DefaultI) (type: Class_Kind #Class @@ -224,7 +224,7 @@ (type: FieldDecl (#ConstantField (Type Value) Code) - (#VariableField StateModifier (Type Value))) + (#VariableField State (Type Value))) (type: MethodDecl {#method_tvars (List (Type Var)) @@ -397,20 +397,24 @@ _ (<code>.this! (code.identifier ["" dotted_name]))] (wrap (get_static_field class_name field_name)))) -(def: (make_get_var_parser class_name field_name) - (-> Text Text (Parser Code)) +(def: (make_get_var_parser class_name field_name self_name) + (-> Text Text Text (Parser Code)) (do <>.monad [#let [dotted_name (format "::" field_name)] _ (<code>.this! (code.identifier ["" dotted_name]))] - (wrap (get_virtual_field class_name field_name (' _jvm_this))))) + (wrap (get_virtual_field class_name field_name (code.local_identifier self_name))))) -(def: (make_put_var_parser class_name field_name) - (-> Text Text (Parser Code)) +(def: (make_put_var_parser class_name field_name self_name) + (-> Text Text Text (Parser Code)) (do <>.monad [#let [dotted_name (format "::" field_name)] [_ _ value] (: (Parser [Any Any Code]) (<code>.form ($_ <>.and (<code>.this! (' :=)) (<code>.this! (code.identifier ["" dotted_name])) <code>.any)))] - (wrap (`' ((~ (code.text (format "jvm putfield" ":" class_name ":" field_name))) _jvm_this (~ value)))))) + (wrap (`' ("jvm member put virtual" + (~ (code.text class_name)) + (~ (code.text field_name)) + (~ value) + (~ (code.local_identifier self_name))))))) (def: (pre_walk_replace f input) (-> (-> Code Code) Code Code) @@ -440,15 +444,15 @@ ast )) -(def: (field->parser class_name [[field_name _ _] field]) - (-> Text [Member_Declaration FieldDecl] (Parser Code)) +(def: (field->parser class_name self_name [[field_name _ _] field]) + (-> Text Text [Member_Declaration FieldDecl] (Parser Code)) (case field (#ConstantField _) (make_get_const_parser class_name field_name) (#VariableField _) - (<>.either (make_get_var_parser class_name field_name) - (make_put_var_parser class_name field_name)))) + (<>.either (make_get_var_parser class_name field_name self_name) + (make_put_var_parser class_name field_name self_name)))) (def: (decorate_input [class value]) (-> [(Type Value) Code] Code) @@ -478,15 +482,15 @@ (list\map ..decorate_input)))))))) (template [<name> <jvm_op>] - [(def: (<name> class_name method_name arguments) - (-> Text Text (List Argument) (Parser Code)) + [(def: (<name> class_name method_name arguments self_name) + (-> Text Text (List Argument) Text (Parser Code)) (do <>.monad [#let [dotted_name (format "::" method_name "!")] args (: (Parser (List Code)) (<code>.form (<>.after (<code>.this! (code.identifier ["" dotted_name])) (<code>.tuple (<>.exactly (list.size arguments) <code>.any)))))] (wrap (` (<jvm_op> (~ (code.text class_name)) (~ (code.text method_name)) - (~' _jvm_this) + (~ (code.local_identifier self_name)) (~+ (|> args (list.zip/2 (list\map product.right arguments)) (list\map ..decorate_input))))))))] @@ -503,16 +507,18 @@ (#StaticMethod strict? type_vars args return_type return_expr exs) (make_static_method_parser class_name method_name args) + + (#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs) + (make_virtual_method_parser class_name method_name args self_name) - (^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 class_name method_name args) + (#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs) + (make_special_method_parser class_name method_name args self_name) (#AbstractMethod type_vars args return_type exs) - (make_virtual_method_parser class_name method_name args) + (make_virtual_method_parser class_name method_name args "") (#NativeMethod type_vars args return_type exs) - (make_virtual_method_parser class_name method_name args))) + (make_virtual_method_parser class_name method_name args ""))) (def: privacy_modifier^ (Parser Privacy) @@ -524,7 +530,7 @@ (wrap [])))) (def: inheritance_modifier^ - (Parser InheritanceModifier) + (Parser Inheritance) (let [(^open ".") <>.monad] ($_ <>.or (<code>.this! (' #final)) @@ -732,7 +738,7 @@ #method_exs exs}])))) (def: state_modifier^ - (Parser StateModifier) + (Parser State) ($_ <>.or (<code>.this! (' #volatile)) (<code>.this! (' #final)) @@ -1012,11 +1018,11 @@ #DefaultP (code.text "default"))) (def: (inheritance_modifier$ im) - (-> InheritanceModifier Code) + (-> Inheritance Code) (case im - #FinalIM (code.text "final") - #AbstractIM (code.text "abstract") - #DefaultIM (code.text "default"))) + #FinalI (code.text "final") + #AbstractI (code.text "abstract") + #DefaultI (code.text "default"))) (def: (annotation_parameter$ [name value]) (-> Annotation_Parameter Code) @@ -1054,11 +1060,11 @@ (~ (return$ method_output)))))) (def: (state_modifier$ sm) - (-> StateModifier Code) + (-> State Code) (case sm - #VolatileSM (' "volatile") - #FinalSM (' "final") - #DefaultSM (' "default"))) + #VolatileS (' "volatile") + #FinalS (' "final") + #DefaultS (' "default"))) (def: (field_decl$ [[name pm anns] field]) (-> [Member_Declaration FieldDecl] Code) @@ -1087,44 +1093,53 @@ (-> (Typed Code) Code) (` [(~ (value$ class)) (~ term)])) -(def: (method_def$ replacer super_class [[name pm anns] method_def]) - (-> (-> Code Code) (Type Class) [Member_Declaration Method_Definition] Code) +(def: (method_def$ fully_qualified_class_name method_parser super_class fields [[name pm anns] method_def]) + (-> External (Parser Code) (Type Class) (List [Member_Declaration FieldDecl]) [Member_Declaration Method_Definition] Code) (case method_def (#ConstructorMethod strict_fp? type_vars self_name arguments constructor_args body exs) - (` ("init" - (~ (privacy_modifier$ pm)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - [(~+ (list\map constructor_arg$ constructor_args))] - (~ (pre_walk_replace replacer body)) - )) + (let [replacer (|> (list\map (field->parser fully_qualified_class_name self_name) fields) + (list\fold <>.either method_parser) + parser->replacer)] + (` ("init" + (~ (privacy_modifier$ pm)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map class$ exs))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + [(~+ (list\map constructor_arg$ constructor_args))] + (~ (pre_walk_replace replacer body)) + ))) (#VirtualMethod final? strict_fp? type_vars self_name arguments return_type body exs) - (` ("virtual" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (code.bit final?)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - (~ (code.text self_name)) - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - [(~+ (list\map class$ exs))] - (~ (pre_walk_replace replacer body)))) + (let [replacer (|> (list\map (field->parser fully_qualified_class_name self_name) fields) + (list\fold <>.either method_parser) + parser->replacer)] + (` ("virtual" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (code.bit final?)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + (~ (code.text self_name)) + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + [(~+ (list\map class$ exs))] + (~ (pre_walk_replace replacer body))))) (#OverridenMethod strict_fp? declaration type_vars self_name arguments return_type body exs) - (let [super_replacer (parser->replacer (<code>.form (do <>.monad + (let [replacer (|> (list\map (field->parser fully_qualified_class_name self_name) fields) + (list\fold <>.either method_parser) + parser->replacer) + super_replacer (parser->replacer (<code>.form (do <>.monad [_ (<code>.this! (' ::super!)) args (<code>.tuple (<>.exactly (list.size arguments) <code>.any))] (wrap (` ("jvm member invoke special" (~ (code.text (product.left (parser.read_class super_class)))) (~ (code.text name)) - (~' _jvm_this) + (~ (code.local_identifier self_name)) (~+ (|> args (list.zip/2 (list\map product.right arguments)) (list\map ..decorate_input)))))))))] @@ -1144,16 +1159,17 @@ ))) (#StaticMethod strict_fp? type_vars arguments return_type body exs) - (` ("static" - (~ (code.text name)) - (~ (privacy_modifier$ pm)) - (~ (code.bit strict_fp?)) - [(~+ (list\map annotation$ anns))] - [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] - [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)) - (~ (pre_walk_replace replacer body)))) + (let [replacer (parser->replacer (<>.fail ""))] + (` ("static" + (~ (code.text name)) + (~ (privacy_modifier$ pm)) + (~ (code.bit strict_fp?)) + [(~+ (list\map annotation$ anns))] + [(~+ (list\map var$ type_vars))] + [(~+ (list\map argument$ arguments))] + (~ (return$ return_type)) + [(~+ (list\map class$ exs))] + (~ (pre_walk_replace replacer body))))) (#AbstractMethod type_vars arguments return_type exs) (` ("abstract" @@ -1161,9 +1177,9 @@ (~ (privacy_modifier$ pm)) [(~+ (list\map annotation$ anns))] [(~+ (list\map var$ type_vars))] - [(~+ (list\map class$ exs))] [(~+ (list\map argument$ arguments))] - (~ (return$ return_type)))) + (~ (return$ return_type)) + [(~+ (list\map class$ exs))])) (#NativeMethod type_vars arguments return_type exs) (` ("native" @@ -1228,11 +1244,10 @@ )} (do meta.monad [#let [fully_qualified_class_name full_class_name - field_parsers (list\map (field->parser fully_qualified_class_name) fields) - method_parsers (list\map (method->parser fully_qualified_class_name) methods) - replacer (parser->replacer (list\fold <>.either - (<>.fail "") - (list\compose field_parsers method_parsers)))]] + method_parser (: (Parser Code) + (|> methods + (list\map (method->parser fully_qualified_class_name)) + (list\fold <>.either (<>.fail ""))))]] (wrap (list (` ("jvm class" (~ (declaration$ (type.declaration full_class_name class_vars))) (~ (class$ super)) @@ -1240,7 +1255,7 @@ (~ (inheritance_modifier$ im)) [(~+ (list\map annotation$ annotations))] [(~+ (list\map field_decl$ fields))] - [(~+ (list\map (method_def$ replacer super) methods))])))))) + [(~+ (list\map (method_def$ fully_qualified_class_name method_parser super fields) methods))])))))) (syntax: #export (interface: {#let [! <>.monad]} @@ -1282,7 +1297,7 @@ (~ (class$ super)) [(~+ (list\map class$ interfaces))] [(~+ (list\map constructor_arg$ constructor_args))] - [(~+ (list\map (method_def$ function.identity super) methods))]))))) + [(~+ (list\map (method_def$ "" (<>.fail "") super (list)) methods))]))))) (syntax: #export (null) {#.doc (doc "Null object reference." diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux index c8de0eb03..832d3907f 100644 --- a/stdlib/source/library/lux/ffi.old.lux +++ b/stdlib/source/library/lux/ffi.old.lux @@ -89,21 +89,21 @@ #ManualPrM #AutoPrM) -(type: PrivacyModifier - #PublicPM - #PrivatePM - #ProtectedPM - #DefaultPM) - -(type: StateModifier - #VolatileSM - #FinalSM - #DefaultSM) - -(type: InheritanceModifier - #FinalIM - #AbstractIM - #DefaultIM) +(type: #export Privacy + #PublicP + #PrivateP + #ProtectedP + #DefaultP) + +(type: #export State + #VolatileS + #FinalS + #DefaultS) + +(type: #export Inheritance + #FinalI + #AbstractI + #DefaultI) (type: Class_Kind #Class @@ -129,12 +129,12 @@ (type: Member_Declaration {#member_name Text - #member_privacy PrivacyModifier + #member_privacy Privacy #member_anns (List Annotation)}) (type: FieldDecl (#ConstantField GenericType Code) - (#VariableField StateModifier GenericType)) + (#VariableField State GenericType)) (type: MethodDecl {#method_tvars (List Type_Parameter) @@ -502,7 +502,7 @@ ## Parsers (def: privacy_modifier^ - (Parser PrivacyModifier) + (Parser Privacy) (let [(^open ".") <>.monad] ($_ <>.or (<code>.this! (' #public)) @@ -511,7 +511,7 @@ (wrap [])))) (def: inheritance_modifier^ - (Parser InheritanceModifier) + (Parser Inheritance) (let [(^open ".") <>.monad] ($_ <>.or (<code>.this! (' #final)) @@ -661,13 +661,13 @@ inputs (<code>.tuple (<>.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}])))) + (wrap [[name #PublicP anns] {#method_tvars tvars + #method_inputs inputs + #method_output output + #method_exs exs}])))) (def: state_modifier^ - (Parser StateModifier) + (Parser State) ($_ <>.or (<code>.this! (' #volatile)) (<code>.this! (' #final)) @@ -681,7 +681,7 @@ anns ..annotations^ type (..generic_type^ type_vars) body <code>.any] - (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (wrap [[name #PublicP anns] (#ConstantField [type body])]))) (<code>.form (do <>.monad [pm privacy_modifier^ sm state_modifier^ @@ -765,7 +765,7 @@ annotations ..annotations^ body <code>.any] (wrap [{#member_name name - #member_privacy #PublicPM + #member_privacy #PublicP #member_anns annotations} (#OverridenMethod strict_fp? owner_class method_vars @@ -952,19 +952,19 @@ (text.join_with " ")) (def: (privacy_modifier$ pm) - (-> PrivacyModifier JVM_Code) + (-> Privacy JVM_Code) (case pm - #PublicPM "public" - #PrivatePM "private" - #ProtectedPM "protected" - #DefaultPM "default")) + #PublicP "public" + #PrivateP "private" + #ProtectedP "protected" + #DefaultP "default")) (def: (inheritance_modifier$ im) - (-> InheritanceModifier JVM_Code) + (-> Inheritance JVM_Code) (case im - #FinalIM "final" - #AbstractIM "abstract" - #DefaultIM "default")) + #FinalI "final" + #AbstractI "abstract" + #DefaultI "default")) (def: (annotation_param$ [name value]) (-> AnnotationParam JVM_Code) @@ -1023,11 +1023,11 @@ )))) (def: (state_modifier$ sm) - (-> StateModifier JVM_Code) + (-> State JVM_Code) (case sm - #VolatileSM "volatile" - #FinalSM "final" - #DefaultSM "default")) + #VolatileS "volatile" + #FinalS "final" + #DefaultS "default")) (def: (field_decl$ [[name pm anns] field]) (-> [Member_Declaration FieldDecl] JVM_Code) diff --git a/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux index 49ab15299..bb8a578bd 100644 --- a/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux +++ b/stdlib/source/library/lux/tool/compiler/language/lux/directive.lux @@ -3,6 +3,8 @@ [lux (#- Module) [abstract [monad (#+ do)]] + [control + ["." try]] [data [collection ["." list ("#\." monoid)]]]]] @@ -59,6 +61,18 @@ [Bundle extension.Bundle] ) +(template [<name> <component> <phase>] + [(def: #export <name> + (All [anchor expression directive] + (Operation anchor expression directive <phase>)) + (function (_ [bundle state]) + (#try.Success [[bundle state] (get@ [<component> #..phase] state)])))] + + [analysis #..analysis analysis.Phase] + [synthesis #..synthesis synthesis.Phase] + [generation #..generation (generation.Phase anchor expression directive)] + ) + (template [<name> <component> <operation>] [(def: #export <name> (All [anchor expression directive output] 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 3c458c041..66f7271db 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 @@ -843,7 +843,7 @@ (/////analysis.throw cannot_possibly_be_an_instance (format sub_class " !<= " object_class)))))])) (template [<name> <category> <parser>] - [(def: (<name> mapping typeJ) + [(def: #export (<name> mapping typeJ) (-> Mapping (Type <category>) (Operation .Type)) (case (|> typeJ ..signature (<text>.run (<parser> mapping))) (#try.Success check) @@ -1043,6 +1043,7 @@ (wrap (<| (#/////analysis.Extension extension_name) (list (/////analysis.text class) (/////analysis.text field) + (/////analysis.text (..reflection fieldJT)) objectA)))))])) (def: (put::virtual class_loader) @@ -1071,6 +1072,7 @@ (wrap (<| (#/////analysis.Extension extension_name) (list (/////analysis.text class) (/////analysis.text field) + (/////analysis.text (..reflection fieldJT)) valueA objectA)))))])) @@ -1919,6 +1921,29 @@ #.None (phase.lift (exception.throw ..unknown_super [parent_name supers]))))) +(def: #export (with_fresh_type_vars vars mapping) + (-> (List (Type Var)) Mapping (Operation Mapping)) + (do {! phase.monad} + [pairings (monad.map ! (function (_ var) + (do ! + [[_ exT] (typeA.with_env + check.existential)] + (wrap [var exT]))) + vars)] + (wrap (list\fold (function (_ [varJ varT] mapping) + (dictionary.put (jvm_parser.name varJ) varT mapping)) + mapping + pairings)))) + +(def: #export (with_override_mapping supers parent_type mapping) + (-> (List (Type Class)) (Type Class) Mapping (Operation Mapping)) + (do phase.monad + [override_mapping (..override_mapping mapping supers parent_type)] + (wrap (list\fold (function (_ [super_var bound_type] mapping) + (dictionary.put super_var bound_type mapping)) + mapping + override_mapping)))) + (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 @@ -1926,15 +1951,8 @@ self_name arguments return exceptions body] method] (do {! phase.monad} - [override_mapping (..override_mapping mapping supers parent_type) - #let [mapping (list\fold (function (_ [super_var bound_type] mapping) - (dictionary.put super_var bound_type mapping)) - mapping - override_mapping) - mapping (list\fold (function (_ varJ mapping) - (dictionary.put (jvm_parser.name varJ) java/lang/Object mapping)) - mapping - vars)] + [mapping (..with_override_mapping supers parent_type mapping) + mapping (..with_fresh_type_vars vars mapping) annotationsA (monad.map ! (function (_ [name parameters]) (do ! [parametersA (monad.map ! (function (_ [name value]) @@ -1944,13 +1962,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (reflection_return mapping return) arguments' (monad.map ! (function (_ [name jvmT]) (do ! [luxT (reflection_type mapping jvmT)] (wrap [name luxT]))) arguments) + returnT (reflection_return mapping return) [scope bodyA] (|> arguments' (#.Cons [self_name selfT]) list.reverse diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index cbc63d90d..20d21d74d 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -93,40 +93,6 @@ value))))) )) -(template: (quadrance cat0 cat1) - (n.+ (n.* cat0 cat0) (n.* cat1 cat1))) - -(def: templates - Test - (do random.monad - [cat0 random.nat - cat1 random.nat] - (_.test "Template application is a stand-in for the templated code." - (n.= (n.+ (n.* cat0 cat0) (n.* cat1 cat1)) - (quadrance cat0 cat1))))) - -(def: cross_platform_support - Test - (do random.monad - [on_default random.nat - on_fake_host random.nat - on_valid_host random.nat] - ($_ _.and - (_.test "Can provide default in case there is no particular host/platform support." - (n.= on_default - (for {"" on_fake_host} - on_default))) - (_.test "Can pick code depending on the host/platform being targeted." - (n.= on_valid_host - (for {@.old on_valid_host - @.jvm on_valid_host - @.js on_valid_host - @.python on_valid_host - @.lua on_valid_host - @.ruby on_valid_host - @.php on_valid_host} - on_default)))))) - (def: sub_tests Test (with_expansions [## TODO: Update & expand tests for this @@ -732,6 +698,47 @@ (not (code\= (' <left_association>) (' <right_association>)))))))) +(def: for_expansion + Test + (do random.monad + [left random.nat + right random.nat + dummy random.nat + #let [expected (n.+ left right)]] + ($_ _.and + (_.cover [/.as_is] + (`` (and (~~ (as_is true + true + true))))) + (_.cover [/.with_expansions] + (/.with_expansions [<operands> (as_is left right)] + (n.= expected + (n.+ <operands>)))) + (_.cover [/.comment] + (/.with_expansions [<dummy> (/.comment dummy) + <operands> (as_is left right)] + (n.= expected + ($_ n.+ <operands> <dummy>)))) + (_.cover [/.``] + (n.= expected + (/.`` ($_ n.+ + (~~ (as_is left right)) + (~~ (/.comment dummy)))))) + (_.cover [/.for] + (and (n.= expected + (/.for {"fake host" dummy} + expected)) + (n.= expected + (/.for {@.old expected + @.jvm expected + @.js expected + @.python expected + @.lua expected + @.ruby expected + @.php expected} + dummy)))) + ))) + (def: test Test (<| (_.covering /._) @@ -740,10 +747,6 @@ ..identity) (<| (_.context "Prelude macros.") ..prelude_macros) - (<| (_.context "Templates.") - ..templates) - (<| (_.context "Cross-platform support.") - ..cross_platform_support) ..for_bit ..for_try @@ -760,6 +763,7 @@ ..for_static ..for_slot ..for_associative + ..for_expansion ..sub_tests ))) diff --git a/stdlib/source/test/lux/ffi.jvm.lux b/stdlib/source/test/lux/ffi.jvm.lux index e8e07e7e1..b0ae4fc0f 100644 --- a/stdlib/source/test/lux/ffi.jvm.lux +++ b/stdlib/source/test/lux/ffi.jvm.lux @@ -38,25 +38,6 @@ ["#::." (getName [] java/lang/String)]) -## TODO: Handle "/.class:" ASAP. -## (/.class: #final (TestClass A) [java/lang/Runnable] -## ## Fields -## (#private foo boolean) -## (#private bar A) -## (#private baz java/lang/Object) -## ## Methods -## (#public [] (new self {value A}) [] -## (exec (:= ::foo #1) -## (:= ::bar value) -## (:= ::baz "") -## [])) -## (#public (virtual self) java/lang/Object -## "") -## (#public #static (static) java/lang/Object -## "") -## (java/lang/Runnable [] (run self) void -## [])) - (template [<name> <type> <conversion> <lux> <=>] [(def: (<name> left right) (-> <type> <type> Bit) @@ -83,14 +64,16 @@ (#try.Failure error) (#try.Success [lux (list (code.text error))]))))) -(def: conversions +(def: for_conversions Test (do {! random.monad} [long (\ ! map (|>> (:as /.Long)) random.int) integer (\ ! map (|>> (:as /.Long) /.long_to_int) random.int) byte (\ ! map (|>> (:as /.Long) /.long_to_byte) random.int) short (\ ! map (|>> (:as /.Long) /.long_to_short) random.int) - float (\ ! map (|>> (:as /.Double) /.double_to_float) random.frac)] + float (|> random.frac + (random.filter (|>> f.not_a_number? not)) + (\ ! map (|>> (:as /.Double) /.double_to_float)))] (`` ($_ _.and (~~ (template [<sample> <=> <to> <from>] [(_.cover [<to> <from>] @@ -116,7 +99,7 @@ [float float\= /.float_to_double /.double_to_float] )))))) -(def: arrays +(def: for_arrays Test (do {! random.monad} [size (|> random.nat (\ ! map (|>> (n.% 100) (n.max 1)))) @@ -142,7 +125,7 @@ ..macro_error (text.contains? (get@ #exception.label /.cannot_convert_to_jvm_type)))))))) -(def: miscellaneous +(def: for_miscellaneous Test (`` (do {! random.monad} [sample (\ ! map (|>> (:as java/lang/Object)) @@ -152,8 +135,12 @@ short (\ ! map (|>> (:as /.Long) /.long_to_short) random.int) integer (\ ! map (|>> (:as /.Long) /.long_to_int) random.int) long (\ ! map (|>> (:as /.Long)) random.int) - float (\ ! map (|>> (:as /.Double) /.double_to_float) random.frac) - double (\ ! map (|>> (:as /.Double)) random.frac) + float (|> random.frac + (random.filter (|>> f.not_a_number? not)) + (\ ! map (|>> (:as /.Double) /.double_to_float))) + double (|> random.frac + (random.filter (|>> f.not_a_number? not)) + (\ ! map (|>> (:as /.Double)))) character (\ ! map (|>> (:as /.Long) /.long_to_int /.int_to_char) random.int) string (\ ! map (|>> (:as java/lang/String)) (random.ascii 1))] @@ -260,7 +247,8 @@ ["#::." (actual3 [] a)]) -(def: interface +(def: for_interface + Test (do random.monad [expected random.nat #let [object/0 (/.object [] [test/TestInterface0] @@ -270,6 +258,10 @@ java/lang/Long (:as java/lang/Long expected))) + example/0! + (is? (: Any expected) + (: Any (test/TestInterface0::actual0 object/0))) + object/1 (/.object [] [test/TestInterface1] [] (test/TestInterface1 @@ -280,12 +272,31 @@ (error! "YOLO") (:as java/lang/Long expected)))) + example/1! + (and (case (test/TestInterface1::actual1 false object/1) + (#try.Success actual) + (is? (: Any expected) + (: Any actual)) + + (#try.Failure error) + false) + (case (test/TestInterface1::actual1 true object/1) + (#try.Success actual) + false + + (#try.Failure error) + true)) + object/2 (/.object [] [test/TestInterface2] [] (test/TestInterface2 [a] (actual2 self {input a}) a input)) + example/2! + (is? (: Any expected) + (: Any (test/TestInterface2::actual2 (:as java/lang/Long expected) object/2))) + object/3 (/.object [] [(test/TestInterface3 java/lang/Long)] [] ((test/TestInterface3 a) @@ -293,16 +304,143 @@ a (:as java/lang/Long expected))) + example/3! + (is? (: Any expected) + (: Any (test/TestInterface3::actual3 object/3)))]] + (_.cover [/.interface: /.object] + (and example/0! + example/1! + example/2! + example/3!)))) + +(/.class: #final test/TestClass0 [test/TestInterface0] + ## Fields + (#private value java/lang/Long) + ## Constructors + (#public [] (new self {value java/lang/Long}) [] + (:= ::value value)) + ## Methods + (test/TestInterface0 [] (actual0 self) java/lang/Long + ::value)) + +(/.import: test/TestClass0 + ["#::." + (new [java/lang/Long])]) + +(/.class: #final test/TestClass1 [test/TestInterface1] + ## Fields + (#private value java/lang/Long) + ## Constructors + (#public [] (new self {value java/lang/Long}) [] + (:= ::value value)) + ## Methods + (test/TestInterface1 [] (actual1 self {throw? java/lang/Boolean}) java/lang/Long #throws [java/lang/Throwable] + (if (:as Bit throw?) + (error! "YOLO") + ::value))) + +(/.import: test/TestClass1 + ["#::." + (new [java/lang/Long])]) + +(/.class: #final test/TestClass2 [test/TestInterface2] + ## Constructors + (#public [] (new self) [] + []) + ## Methods + (test/TestInterface2 + [a] (actual2 self {input a}) + a + input)) + +(/.import: test/TestClass2 + ["#::." + (new [])]) + +(/.class: #final (test/TestClass3 a) [(test/TestInterface3 a)] + ## Fields + (#private value a) + ## Constructors + (#public [] (new self {value a}) [] + (:= ::value value)) + ## Methods + ((test/TestInterface3 a) + [] (actual3 self) + a + ::value)) + +(/.import: (test/TestClass3 a) + ["#::." + (new [a])]) + +(/.class: #final test/TestClass4 [] + ## Constructors + (#public [] (new self) [] + []) + ## Methods + (#public (actual4 self {value java/lang/Long}) java/lang/Long + value)) + +(/.import: test/TestClass4 + ["#::." + (new []) + (actual4 [java/lang/Long] java/lang/Long)]) + +(/.class: #final test/TestClass5 [] + ## Constructors + (#public [] (new self) [] + []) + ## Methods + (#public #static (actual5 {value java/lang/Long}) + java/lang/Long + value)) + +(/.import: test/TestClass5 + ["#::." + (#static actual5 [java/lang/Long] java/lang/Long)]) + +(/.class: #abstract test/TestClass6 [] + ## Constructors + (#public [] (new self) [] + []) + ## Methods + (#public #abstract (actual6 {value java/lang/Long}) + java/lang/Long)) + +(/.import: test/TestClass6 + ["#::." + (actual6 [java/lang/Long] java/lang/Long)]) +(/.class: #final test/TestClass7 test/TestClass6 [] + ## Constructors + (#public [] (new self) [] + []) + ## Methods + (test/TestClass6 + [] (actual6 self {input java/lang/Long}) + java/lang/Long + input)) + +(/.import: test/TestClass7 + ["#::." + (new [])]) + +(def: for_class + Test + (do random.monad + [expected random.nat + + #let [object/0 (test/TestClass0::new (.int expected)) example/0! - (is? (: Any expected) - (: Any (test/TestInterface0::actual0 object/0))) + (n.= expected + (:as Nat (test/TestInterface0::actual0 object/0))) + object/1 (test/TestClass1::new (.int expected)) example/1! (and (case (test/TestInterface1::actual1 false object/1) (#try.Success actual) - (is? (: Any expected) - (: Any actual)) + (n.= expected + (:as Nat actual)) (#try.Failure error) false) @@ -313,24 +451,45 @@ (#try.Failure error) true)) + object/2 (test/TestClass2::new) example/2! - (is? (: Any expected) - (: Any (test/TestInterface2::actual2 (:as /.Long expected) object/2))) + (n.= expected + (: Nat (test/TestInterface2::actual2 (:as java/lang/Long expected) object/2))) + object/3 (: (test/TestClass3 java/lang/Long) + (test/TestClass3::new (:as java/lang/Long expected))) example/3! - (is? (: Any expected) - (: Any (test/TestInterface3::actual3 object/3)))]] - (_.cover [/.interface:] + (n.= expected + (: Nat (test/TestInterface3::actual3 object/3))) + + object/4 (test/TestClass4::new) + example/4! + (n.= expected + (.nat (test/TestClass4::actual4 (.int expected) object/4))) + + example/5! + (n.= expected + (.nat (test/TestClass5::actual5 (.int expected)))) + + object/7 (test/TestClass7::new) + example/7! + (n.= expected + (.nat (test/TestClass6::actual6 (.int expected) object/7)))]] + (_.cover [/.class: /.import:] (and example/0! example/1! example/2! - example/3!)))) + example/3! + example/4! + example/5! + example/7!)))) (def: #export test (<| (_.covering /._) ($_ _.and - ..conversions - ..arrays - ..miscellaneous - ..interface + ..for_conversions + ..for_arrays + ..for_miscellaneous + ..for_interface + ..for_class ))) |