aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2019-05-18 23:20:58 -0400
committerEduardo Julian2019-05-18 23:20:58 -0400
commit77ca0d2049d54e17b0133818dd1667d8c7f4e221 (patch)
tree77c8e1b482f65c25b2bc0d8c21e864c4fdd5d403
parentc246adaad066d7192527a95ffaa49f8668d10d15 (diff)
Moved some of the reflection machinery to its own modules.
* WIP: Implementation of completeness testing for anonymous classes.
Diffstat (limited to '')
-rw-r--r--documentation/research/operating_system.md2
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux2
-rw-r--r--stdlib/source/lux/target/jvm/reflection.lux320
-rw-r--r--stdlib/source/lux/target/jvm/type/lux.lux109
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux815
5 files changed, 678 insertions, 570 deletions
diff --git a/documentation/research/operating_system.md b/documentation/research/operating_system.md
index 4997a3cb2..bc7ecaf05 100644
--- a/documentation/research/operating_system.md
+++ b/documentation/research/operating_system.md
@@ -106,6 +106,7 @@
1. http://queue.acm.org/detail.cfm?id=1317400
1. The Art of Unix Programming &&& http://www.catb.org/esr/writings/taoup/html/index.html
1. https://shivambharuka.wordpress.com/2017/10/25/arrakis-the-operating-system-is-the-control-plane/
+1. [Arrakis: The Operating System is the Control Plane](https://www.usenix.org/system/files/conference/osdi14/osdi14-paper-peter_simon.pdf)
1. https://sortix.org/os-test/
1. https://existentialtype.wordpress.com/2016/07/11/pclsring-in-semantics/
1. Database/Operating System Co-Design &&& https://www.research-collection.ethz.ch/handle/20.500.11850/136
@@ -185,6 +186,7 @@
1. [OS-level Attacks and Defenses: from Software to Hardware-based Exploits](http://tuprints.ulb.tu-darmstadt.de/8482/1/gens_diss.pdf)
1. [Time Protection: The Missing OS Abstraction](https://ts.data61.csiro.au/publications/csiro_full_text//Ge_YCH_19.pdf)
1. [Light-weight Contexts: An OS Abstraction for Safety and Performance](https://www.usenix.org/system/files/conference/osdi16/osdi16-litton.pdf)
+1. https://natsys-lab.blogspot.com/2019/05/goodbye-fast-system-calls.html
# Driver
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index ae54dccc7..e57101660 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -719,7 +719,7 @@
(phase.throw invalid-syntax-for-argument-generation [])))
(def: (method-return-type description)
- (-> Text (Operation (Maybe Type)))
+ (-> Text (Operation Return))
(case description
(^ (static jvm.void-descriptor))
(phase@wrap #.None)
diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux
new file mode 100644
index 000000000..e65b6061f
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/reflection.lux
@@ -0,0 +1,320 @@
+(.module:
+ [lux (#- type)
+ ["." host (#+ import:)]
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]
+ [parser
+ ["<t>" text]]]
+ [data
+ ["." error (#+ Error)]
+ ["." text ("#@." equivalence)
+ format]
+ [collection
+ ["." list ("#@." fold functor)]
+ ["." array]
+ ["." dictionary]]]]
+ [//
+ ["/" type
+ ["#." lux (#+ Mapping)]
+ ["." reflection]]])
+
+(import: #long java/lang/String)
+
+(import: #long java/lang/Object
+ (toString [] java/lang/String))
+
+(import: #long java/lang/reflect/Type
+ (getTypeName [] java/lang/String))
+
+(import: #long java/lang/reflect/GenericArrayType
+ (getGenericComponentType [] java/lang/reflect/Type))
+
+(import: #long java/lang/reflect/ParameterizedType
+ (getRawType [] java/lang/reflect/Type)
+ (getActualTypeArguments [] (Array java/lang/reflect/Type)))
+
+(import: #long (java/lang/reflect/TypeVariable d)
+ (getName [] java/lang/String)
+ (getBounds [] (Array java/lang/reflect/Type)))
+
+(import: #long (java/lang/reflect/WildcardType d)
+ (getLowerBounds [] (Array java/lang/reflect/Type))
+ (getUpperBounds [] (Array java/lang/reflect/Type)))
+
+(import: #long java/lang/reflect/Modifier
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean))
+
+(import: #long java/lang/reflect/Field
+ (getDeclaringClass [] (java/lang/Class java/lang/Object))
+ (getModifiers [] int)
+ (getGenericType [] java/lang/reflect/Type))
+
+(import: #long java/lang/reflect/Method
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class java/lang/Object))
+ (getTypeParameters [] (Array (java/lang/reflect/TypeVariable java/lang/reflect/Method)))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericReturnType [] java/lang/reflect/Type)
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(import: #long (java/lang/reflect/Constructor c)
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class c))
+ (getTypeParameters [] (Array (java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(import: #long (java/lang/Class c)
+ (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
+ (getTypeParameters [] (Array (java/lang/reflect/TypeVariable (java/lang/Class c))))
+ (getGenericInterfaces [] (Array java/lang/reflect/Type))
+ (getGenericSuperclass [] #? java/lang/reflect/Type)
+ (getDeclaredField [java/lang/String] #try java/lang/reflect/Field)
+ (getConstructors [] (Array (java/lang/reflect/Constructor java/lang/Object)))
+ (getDeclaredMethods [] (Array java/lang/reflect/Method)))
+
+(exception: #export (unknown-class {class Text})
+ (exception.report
+ ["Class" (%t class)]))
+
+(template [<name>]
+ [(exception: #export (<name> {jvm-type java/lang/reflect/Type})
+ (exception.report
+ ["Type" (java/lang/reflect/Type::getTypeName jvm-type)]))]
+
+ [not-a-class]
+ [cannot-convert-to-a-parameter]
+ [cannot-convert-to-a-lux-type]
+ )
+
+(def: #export (load name)
+ (-> Text (Error (java/lang/Class java/lang/Object)))
+ (case (java/lang/Class::forName name)
+ (#error.Success [class])
+ (#error.Success class)
+
+ (#error.Failure error)
+ (exception.throw ..unknown-class name)))
+
+(def: #export (sub? super sub)
+ (-> Text Text (Error Bit))
+ (do error.monad
+ [super (..load super)
+ sub (..load sub)]
+ (wrap (java/lang/Class::isAssignableFrom sub super))))
+
+(def: #export (generic reflection)
+ (-> java/lang/reflect/Type (Error /.Generic))
+ (<| (case (host.check java/lang/reflect/TypeVariable reflection)
+ (#.Some reflection)
+ (#error.Success (#/.Var (java/lang/reflect/TypeVariable::getName reflection)))
+ _)
+ (case (host.check java/lang/reflect/WildcardType reflection)
+ (#.Some reflection)
+ (case [(array.read 0 (java/lang/reflect/WildcardType::getLowerBounds reflection))
+ (array.read 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))]
+ (^template [<pattern> <kind>]
+ <pattern>
+ (do error.monad
+ [bound (generic bound)]
+ (wrap (#/.Wildcard (#.Some [<kind> bound])))))
+ ([[_ (#.Some bound)] #/.Upper]
+ [[(#.Some bound) _] #/.Lower])
+
+ [#.None #.None]
+ (#error.Success (#/.Wildcard #.None)))
+ _)
+ (case (host.check java/lang/Class reflection)
+ (#.Some class)
+ (let [class-name (|> class
+ (:coerce (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)]
+ (case class-name
+ (^template [<reflection>]
+ (^ (static <reflection>))
+ (exception.throw ..not-a-class reflection))
+ ([reflection.boolean] [reflection.byte] [reflection.short] [reflection.int]
+ [reflection.long] [reflection.float] [reflection.double] [reflection.char])
+
+ _
+ (if (text.starts-with? /.array-prefix class-name)
+ (exception.throw ..not-a-class reflection)
+ (#error.Success (#/.Class class-name (list))))))
+ _)
+ (case (host.check java/lang/reflect/ParameterizedType reflection)
+ (#.Some reflection)
+ (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)]
+ (case (host.check java/lang/Class raw)
+ (#.Some raw)
+ (do error.monad
+ [paramsT (|> reflection
+ java/lang/reflect/ParameterizedType::getActualTypeArguments
+ array.to-list
+ (monad.map @ generic))]
+ (wrap (#/.Class (|> raw
+ (:coerce (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)
+ paramsT)))
+
+ _
+ (exception.throw ..not-a-class raw)))
+ _)
+ ## else
+ (exception.throw ..cannot-convert-to-a-lux-type reflection)))
+
+(def: #export (type reflection)
+ (-> java/lang/reflect/Type (Error /.Type))
+ (<| (case (host.check java/lang/Class reflection)
+ (#.Some reflection)
+ (case (|> reflection
+ (:coerce (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)
+ (^template [<reflection> <type>]
+ (^ (static <reflection>))
+ (#error.Success <type>))
+ ([reflection.boolean /.boolean]
+ [reflection.byte /.byte]
+ [reflection.short /.short]
+ [reflection.int /.int]
+ [reflection.long /.long]
+ [reflection.float /.float]
+ [reflection.double /.double]
+ [reflection.char /.char])
+
+ class-name
+ (if (text.starts-with? /.array-prefix class-name)
+ (<t>.run /.parse-signature (/.binary-name class-name))
+ (#error.Success (/.class class-name (list)))))
+ _)
+ (case (host.check java/lang/reflect/GenericArrayType reflection)
+ (#.Some reflection)
+ (|> reflection
+ java/lang/reflect/GenericArrayType::getGenericComponentType
+ type
+ (:: error.monad map (/.array 1)))
+ _)
+ ## else
+ (:: error.monad map (|>> #/.Generic)
+ (..generic reflection))))
+
+(def: #export (return reflection)
+ (-> java/lang/reflect/Type (Error /.Return))
+ (case (host.check java/lang/Class reflection)
+ (#.Some class)
+ (case (|> class
+ (:coerce (java/lang/Class java/lang/Object))
+ java/lang/Class::getName)
+ (^ (static reflection.void))
+ (#error.Success #.None)
+
+ _
+ (:: error.monad map (|>> #.Some)
+ (..type reflection)))
+
+ #.None
+ (:: error.monad map (|>> #.Some)
+ (..type reflection))))
+
+(exception: #export (cannot-correspond {class (java/lang/Class java/lang/Object)}
+ {type Type})
+ (exception.report
+ ["Class" (java/lang/Object::toString class)]
+ ["Type" (%type type)]))
+
+(exception: #export (type-parameter-mismatch {expected Nat}
+ {actual Nat}
+ {class (java/lang/Class java/lang/Object)}
+ {type Type})
+ (exception.report
+ ["Expected" (%n expected)]
+ ["Actual" (%n actual)]
+ ["Class" (java/lang/Object::toString class)]
+ ["Type" (%type type)]))
+
+(exception: #export (non-jvm-type {type Type})
+ (exception.report
+ ["Type" (%type type)]))
+
+(def: #export (correspond class type)
+ (-> (java/lang/Class java/lang/Object) Type (Error Mapping))
+ (case type
+ (#.Primitive name params)
+ (let [class-name (java/lang/Class::getName class)
+ class-params (array.to-list (java/lang/Class::getTypeParameters class))
+ num-class-params (list.size class-params)
+ num-type-params (list.size params)]
+ (if (text@= class-name name)
+ (if (n/= num-class-params num-type-params)
+ (|> params
+ (list.zip2 (list@map (|>> java/lang/reflect/TypeVariable::getName)
+ class-params))
+ (list@fold (function (_ [name paramT] mapping)
+ (dictionary.put name paramT mapping))
+ /lux.fresh)
+ #error.Success)
+ (exception.throw ..type-parameter-mismatch [num-class-params num-type-params class type]))
+ (exception.throw ..cannot-correspond [class type])))
+
+ (#.Named name anonymousT)
+ (correspond class anonymousT)
+
+ _
+ (exception.throw ..non-jvm-type [type])))
+
+(exception: #export (mistaken-field-owner {field java/lang/reflect/Field}
+ {owner (java/lang/Class java/lang/Object)}
+ {target (java/lang/Class java/lang/Object)})
+ (exception.report
+ ["Field" (java/lang/Object::toString field)]
+ ["Owner" (java/lang/Object::toString owner)]
+ ["Target" (java/lang/Object::toString target)]))
+
+(template [<name>]
+ [(exception: #export (<name> {field Text}
+ {class (java/lang/Class java/lang/Object)})
+ (exception.report
+ ["Field" (%t field)]
+ ["Class" (java/lang/Object::toString class)]))]
+
+ [unknown-field]
+ [not-a-static-field]
+ [not-a-virtual-field]
+ )
+
+(def: #export (field field target)
+ (-> Text (java/lang/Class java/lang/Object) (Error java/lang/reflect/Field))
+ (case (java/lang/Class::getDeclaredField field target)
+ (#error.Success field)
+ (let [owner (java/lang/reflect/Field::getDeclaringClass field)]
+ (if (is? owner target)
+ (#error.Success field)
+ (exception.throw ..mistaken-field-owner [field owner target])))
+
+ (#error.Failure _)
+ (exception.throw ..unknown-field [field target])))
+
+(template [<name> <exception> <then?> <else?>]
+ [(def: #export (<name> field class)
+ (-> Text (java/lang/Class java/lang/Object) (Error [Bit /.Type]))
+ (do error.monad
+ [fieldJ (..field field class)
+ #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]]
+ (case (java/lang/reflect/Modifier::isStatic modifiers)
+ <then?> (|> fieldJ
+ java/lang/reflect/Field::getGenericType
+ ..type
+ (:: @ map (|>> [(java/lang/reflect/Modifier::isFinal modifiers)])))
+ <else?> (exception.throw <exception> [field class]))))]
+
+ [static-field ..not-a-static-field #1 #0]
+ [virtual-field ..not-a-virtual-field #0 #1]
+ )
diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux
new file mode 100644
index 000000000..92bc05091
--- /dev/null
+++ b/stdlib/source/lux/target/jvm/type/lux.lux
@@ -0,0 +1,109 @@
+(.module:
+ [lux (#- type)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["." exception (#+ exception:)]]
+ [data
+ ["." text
+ format]
+ [collection
+ [array (#+ Array)]
+ ["." dictionary (#+ Dictionary)]]]
+ [type
+ abstract
+ ["." check (#+ Check) ("#@." monad)]]]
+ ["." //
+ ["#." reflection]])
+
+(template [<name>]
+ [(abstract: #export (<name> class) {} Any)]
+
+ [Lower] [Upper]
+ )
+
+(type: #export Mapping
+ (Dictionary //.Var Type))
+
+(def: #export fresh
+ Mapping
+ (dictionary.new text.hash))
+
+(exception: #export (unknown-var {var //.Var})
+ (exception.report
+ ["Var" (%t var)]))
+
+(def: (generic mapping input)
+ (-> Mapping //.Generic (Check Type))
+ (case input
+ (#//.Var var)
+ (case (dictionary.get var mapping)
+ #.None
+ (check.throw ..unknown-var var)
+
+ (#.Some type)
+ (check@wrap type))
+
+ (#//.Wildcard wildcard)
+ (case wildcard
+ #.None
+ (do check.monad
+ [[id type] check.existential]
+ (wrap type))
+
+ (#.Some [bound limit])
+ (do check.monad
+ [limitT (generic mapping limit)]
+ (case bound
+ (^template [<tag> <ctor>]
+ <tag>
+ (wrap (.type (<ctor> limitT))))
+ ([#//.Lower ..Lower]
+ [#//.Upper ..Upper]))))
+
+ (#//.Class name parameters)
+ (do check.monad
+ [parametersT+ (monad.map @ (generic mapping) parameters)]
+ (wrap (#.Primitive name parametersT+)))))
+
+(def: #export (class mapping [name parameters])
+ (-> Mapping //.Class (Check Type))
+ (do check.monad
+ [parametersT+ (monad.map @ (..generic mapping) parameters)]
+ (wrap (#.Primitive name parametersT+))))
+
+(def: #export (type mapping input)
+ (-> Mapping //.Type (Check Type))
+ (case input
+ (#//.Primitive primitive)
+ (check@wrap (case primitive
+ #//.Boolean (#.Primitive //reflection.boolean #.Nil)
+ #//.Byte (#.Primitive //reflection.byte #.Nil)
+ #//.Short (#.Primitive //reflection.short #.Nil)
+ #//.Int (#.Primitive //reflection.int #.Nil)
+ #//.Long (#.Primitive //reflection.long #.Nil)
+ #//.Float (#.Primitive //reflection.float #.Nil)
+ #//.Double (#.Primitive //reflection.double #.Nil)
+ #//.Char (#.Primitive //reflection.char #.Nil)))
+
+ (#//.Generic generic)
+ (..generic mapping generic)
+
+ (#//.Array elementT)
+ (case elementT
+ (#//.Primitive primitive)
+ (check@wrap (#.Primitive (//.descriptor (//.array 1 input)) #.Nil))
+
+ _
+ (do check.monad
+ [elementT (type mapping input)]
+ (wrap (.type (Array elementT)))))))
+
+(def: #export (return mapping input)
+ (-> Mapping //.Return (Check Type))
+ (case input
+ #.None
+ (check@wrap Any)
+
+ (#.Some input)
+ (..type mapping input)))
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
index 01265c29a..8679135f1 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -11,22 +11,24 @@
["." exception (#+ exception:)]
pipe]
[data
- ["." error (#+ Error)]
+ ["." error (#+ Error) ("#@." monad)]
["." maybe]
["." product]
["." text ("#@." equivalence)
format]
[collection
- ["." list ("#@." fold functor monoid)]
+ ["." list ("#@." fold monad monoid)]
["." array (#+ Array)]
["." dictionary (#+ Dictionary)]]]
["." type
["." check (#+ Check) ("#@." monad)]]
[target
["." jvm #_
- ["#" type (#+ Var Bound Primitive Generic Class Type Argument Return Typed)
+ [".!" reflection]
+ ["#" type (#+ Var Bound Primitive Generic Class Type Argument Return Method Typed)
["." box]
- ["." reflection]]]]]
+ ["." reflection]
+ [".T" lux (#+ Mapping)]]]]]
["." // #_
["#." common]
["/#" //
@@ -46,16 +48,6 @@
(#.Primitive ..inheritance-relationship-type-name
(list& class super-class super-interfaces)))
-(template [<label> <constant> <function>]
- [(def: <constant> <label>)
- (def: (<function> class)
- (-> .Type .Type)
- (#.Primitive <constant> (list class)))]
-
- ["_jvm_lower" lower-relationship-name lower-relationship-type]
- ["_jvm_upper" upper-relationship-name upper-relationship-type]
- )
-
## TODO: Get rid of this template block and use the definition in
## lux/host.jvm.lux ASAP
(template [<name> <class>]
@@ -83,90 +75,6 @@
[char reflection.char]
)
-(type: Mapping
- (Dictionary Var .Type))
-
-(def: fresh-mapping Mapping (dictionary.new text.hash))
-
-(exception: #export (unknown-jvm-type-var {var Var})
- (exception.report
- ["Var" (%t var)]))
-
-(def: (generic-type mapping generic)
- (-> Mapping Generic (Check .Type))
- (case generic
- (#jvm.Var var)
- (case (dictionary.get var mapping)
- #.None
- (check.throw ..unknown-jvm-type-var var)
-
- (#.Some type)
- (check@wrap type))
-
- (#jvm.Wildcard wildcard)
- (case wildcard
- #.None
- (do check.monad
- [[id type] check.existential]
- (wrap type))
-
- (#.Some [bound limit])
- (do check.monad
- [limitT (generic-type mapping limit)]
- (case bound
- #jvm.Lower
- (wrap (lower-relationship-type limitT))
-
- #jvm.Upper
- (wrap (upper-relationship-type limitT)))))
-
- (#jvm.Class name parameters)
- (do check.monad
- [parametersT+ (monad.map @ (generic-type mapping) parameters)]
- (wrap (#.Primitive name parametersT+)))))
-
-(def: (class-type mapping [name parameters])
- (-> Mapping Class (Check .Type))
- (do check.monad
- [parametersT+ (monad.map @ (generic-type mapping) parameters)]
- (wrap (#.Primitive name parametersT+))))
-
-(def: (jvm-type mapping type)
- (-> Mapping Type (Check .Type))
- (case type
- (#jvm.Primitive primitive)
- (check@wrap (case primitive
- #jvm.Boolean ..boolean
- #jvm.Byte ..byte
- #jvm.Short ..short
- #jvm.Int ..int
- #jvm.Long ..long
- #jvm.Float ..float
- #jvm.Double ..double
- #jvm.Char ..char))
-
- (#jvm.Generic generic)
- (generic-type mapping generic)
-
- (#jvm.Array type)
- (case type
- (#jvm.Primitive primitive)
- (check@wrap (#.Primitive (jvm.descriptor (jvm.array 1 type)) (list)))
-
- _
- (do check.monad
- [elementT (jvm-type mapping type)]
- (wrap (.type (Array elementT)))))))
-
-(def: (return-type mapping type)
- (-> Mapping Return (Check .Type))
- (case type
- #.None
- (check@wrap Any)
-
- (#.Some type)
- (jvm-type mapping type)))
-
(def: (custom [syntax handler])
(All [s]
(-> [(Parser s)
@@ -192,20 +100,6 @@
{#method .Type
#exceptions (List .Type)})
-(import: #long java/lang/reflect/Type
- (getTypeName [] String))
-
-(template [<name>]
- [(exception: #export (<name> {jvm-type java/lang/reflect/Type})
- (exception.report
- ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))]
-
- [jvm-type-is-not-a-class]
- [cannot-convert-to-a-class]
- [cannot-convert-to-a-parameter]
- [cannot-convert-to-a-lux-type]
- )
-
(template [<name>]
[(exception: #export (<name> {type .Type})
(exception.report
@@ -213,7 +107,6 @@
[non-object]
[non-array]
- [non-jvm-type]
)
(template [<name>]
@@ -221,23 +114,15 @@
(exception.report
["Class/type" (%t class)]))]
- [unknown-class]
[non-interface]
[non-throwable]
[primitives-are-not-objects]
)
-(template [<name>]
- [(exception: #export (<name> {class Text} {field Text})
- (exception.report
- ["Class" (%t class)]
- ["Field" (%t field)]))]
-
- [unknown-field]
- [not-a-static-field]
- [not-a-virtual-field]
- [cannot-set-a-final-field]
- )
+(exception: #export (cannot-set-a-final-field {field Text} {class Text})
+ (exception.report
+ ["Field" (%t field)]
+ ["Class" (%t class)]))
(template [<name>]
[(exception: #export (<name> {class Text}
@@ -266,13 +151,9 @@
[primitives-cannot-have-type-parameters]
- [mistaken-field-owner]
-
[cannot-possibly-be-an-instance]
[unknown-type-var]
- [type-parameter-mismatch]
- [cannot-correspond-type-with-a-class]
)
(def: bundle::conversion
@@ -537,7 +418,7 @@
(-> .Type (Operation Text))
(if (is? .Any type)
(////@wrap jvm.void-descriptor)
- (////@map jvm.signature (check-jvm type))))
+ (////@map jvm.descriptor (check-jvm type))))
(def: (read-primitive-array-handler lux-type jvm-type)
(-> .Type Type Handler)
@@ -718,83 +599,6 @@
_
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
-(import: #long java/lang/Object
- (equals [java/lang/Object] boolean))
-
-(import: java/lang/ClassLoader)
-
-(import: java/lang/reflect/GenericArrayType
- (getGenericComponentType [] java/lang/reflect/Type))
-
-(import: java/lang/reflect/ParameterizedType
- (getRawType [] java/lang/reflect/Type)
- (getActualTypeArguments [] (Array java/lang/reflect/Type)))
-
-(import: (java/lang/reflect/TypeVariable d)
- (getName [] String)
- (getBounds [] (Array java/lang/reflect/Type)))
-
-(import: (java/lang/reflect/WildcardType d)
- (getLowerBounds [] (Array java/lang/reflect/Type))
- (getUpperBounds [] (Array java/lang/reflect/Type)))
-
-(import: java/lang/reflect/Modifier
- (#static isStatic [int] boolean)
- (#static isFinal [int] boolean)
- (#static isInterface [int] boolean)
- (#static isAbstract [int] boolean))
-
-(import: java/lang/reflect/Field
- (getDeclaringClass [] (java/lang/Class java/lang/Object))
- (getModifiers [] int)
- (getGenericType [] java/lang/reflect/Type))
-
-(import: java/lang/reflect/Method
- (getName [] String)
- (getModifiers [] int)
- (getDeclaringClass [] (java/lang/Class java/lang/Object))
- (getTypeParameters [] (Array (TypeVariable Method)))
- (getGenericParameterTypes [] (Array java/lang/reflect/Type))
- (getGenericReturnType [] java/lang/reflect/Type)
- (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
-
-(import: (java/lang/reflect/Constructor c)
- (getModifiers [] int)
- (getDeclaringClass [] (java/lang/Class c))
- (getTypeParameters [] (Array (TypeVariable (Constructor c))))
- (getGenericParameterTypes [] (Array java/lang/reflect/Type))
- (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
-
-(import: #long (java/lang/Class c)
- (getName [] String)
- (getModifiers [] int)
- (#static forName [String] #try (java/lang/Class java/lang/Object))
- (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
- (getTypeParameters [] (Array (TypeVariable (java/lang/Class c))))
- (getGenericInterfaces [] (Array java/lang/reflect/Type))
- (getGenericSuperclass [] #? java/lang/reflect/Type)
- (getDeclaredField [String] #try Field)
- (getConstructors [] (Array (Constructor java/lang/Object)))
- (getDeclaredMethods [] (Array Method)))
-
-(def: (load-class name)
- (-> Text (Operation (java/lang/Class java/lang/Object)))
- (do ////.monad
- []
- (case (java/lang/Class::forName name)
- (#error.Success [class])
- (wrap class)
-
- (#error.Failure error)
- (/////analysis.throw unknown-class name))))
-
-(def: (sub-class? super sub)
- (-> Text Text (Operation Bit))
- (do ////.monad
- [super (load-class super)
- sub (load-class sub)]
- (wrap (java/lang/Class::isAssignableFrom sub super))))
-
(def: object::throw
Handler
(function (_ extension-name analyse args)
@@ -805,7 +609,7 @@
[exceptionT exceptionA] (typeA.with-inference
(analyse exceptionC))
exception-class (check-object exceptionT)
- ? (sub-class? "java.lang.Throwable" exception-class)
+ ? (////.lift (reflection!.sub? "java.lang.Throwable" exception-class))
_ (: (Operation Any)
(if ?
(wrap [])
@@ -824,7 +628,7 @@
[_ (#.Text class)]
(do ////.monad
[_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
- _ (load-class class)]
+ _ (////.lift (reflection!.load class))]
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))))
_
@@ -845,7 +649,7 @@
[objectT objectA] (typeA.with-inference
(analyse objectC))
object-class (check-object objectT)
- ? (sub-class? class object-class)]
+ ? (////.lift (reflection!.sub? class object-class))]
(if ?
(wrap (#/////analysis.Extension extension-name (list (/////analysis.text class))))
(/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class))))
@@ -856,146 +660,75 @@
_
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
-(def: (java-type-to-class jvm-type)
- (-> java/lang/reflect/Type (Operation Text))
- (<| (case (host.check java/lang/Class jvm-type)
- (#.Some jvm-type)
- (////@wrap (java/lang/Class::getName jvm-type))
-
- _)
- (case (host.check ParameterizedType jvm-type)
- (#.Some jvm-type)
- (java-type-to-class (ParameterizedType::getRawType jvm-type))
-
- _)
- ## else
- (/////analysis.throw cannot-convert-to-a-class jvm-type)))
-
-(def: (java-type-to-lux-type mapping java-type)
- (-> Mapping java/lang/reflect/Type (Operation .Type))
- (<| (case (host.check TypeVariable java-type)
- (#.Some java-type)
- (let [var-name (TypeVariable::getName java-type)]
- (case (dictionary.get var-name mapping)
- (#.Some var-type)
- (////@wrap var-type)
-
- #.None
- (/////analysis.throw unknown-type-var var-name)))
-
- _)
- (case (host.check WildcardType java-type)
- (#.Some java-type)
- (case [(array.read 0 (WildcardType::getUpperBounds java-type))
- (array.read 0 (WildcardType::getLowerBounds java-type))]
- (^or [(#.Some bound) _] [_ (#.Some bound)])
- (java-type-to-lux-type mapping bound)
-
- _
- (////@wrap Any))
-
- _)
- (case (host.check java/lang/Class java-type)
- (#.Some java-type)
- (let [java-type (:coerce (java/lang/Class java/lang/Object) java-type)
- class-name (java/lang/Class::getName java-type)]
- (case (array.size (java/lang/Class::getTypeParameters java-type))
- 0
- (case class-name
- (^ (static reflection.void))
- (////@wrap Any)
-
- _
- (if (text.starts-with? jvm.array-prefix class-name)
- (case (<t>.run jvm.parse-signature (jvm.binary-name class-name))
- (#error.Success jtype)
- (typeA.with-env
- (jvm-type fresh-mapping jtype))
-
- (#error.Failure error)
- (/////analysis.fail error))
- (////@wrap (#.Primitive class-name (list)))))
-
- arity
- (////@wrap (|> (list.indices arity)
- list.reverse
- (list@map (|>> (n/* 2) inc #.Parameter))
- (#.Primitive class-name)
- (type.univ-q arity)))))
-
- _)
- (case (host.check ParameterizedType java-type)
- (#.Some java-type)
- (let [raw (ParameterizedType::getRawType java-type)]
- (case (host.check java/lang/Class raw)
- (#.Some raw)
- (do ////.monad
- [paramsT (|> java-type
- ParameterizedType::getActualTypeArguments
- array.to-list
- (monad.map @ (java-type-to-lux-type mapping)))]
- (////@wrap (#.Primitive (java/lang/Class::getName (:coerce (java/lang/Class java/lang/Object) raw))
- paramsT)))
-
- _
- (/////analysis.throw jvm-type-is-not-a-class raw)))
-
- _)
- (case (host.check GenericArrayType java-type)
- (#.Some java-type)
- (do ////.monad
- [innerT (|> java-type
- GenericArrayType::getGenericComponentType
- (java-type-to-lux-type mapping))]
- (wrap (#.Primitive array.type-name (list innerT))))
-
- _)
- ## else
- (/////analysis.throw ..cannot-convert-to-a-lux-type java-type)))
-
-(def: (correspond-type-params class type)
- (-> (java/lang/Class java/lang/Object) .Type (Operation Mapping))
- (case type
- (#.Primitive name params)
- (let [class-name (java/lang/Class::getName class)
- class-params (array.to-list (java/lang/Class::getTypeParameters class))
- num-class-params (list.size class-params)
- num-type-params (list.size params)]
- (cond (not (text@= class-name name))
- (/////analysis.throw cannot-correspond-type-with-a-class
- (format "Class = " class-name text.new-line
- "Type = " (%type type)))
-
- (not (n/= num-class-params num-type-params))
- (/////analysis.throw type-parameter-mismatch
- (format "Expected: " (%i (.int num-class-params)) text.new-line
- " Actual: " (%i (.int num-type-params)) text.new-line
- " Class: " class-name text.new-line
- " Type: " (%type type)))
-
- ## else
- (////@wrap (|> params
- (list.zip2 (list@map (|>> TypeVariable::getName) class-params))
- (dictionary.from-list text.hash)))
- ))
-
- (#.Named name anonymousT)
- (correspond-type-params class anonymousT)
+(import: #long java/lang/Object
+ (equals [java/lang/Object] boolean))
- _
- (/////analysis.throw ..non-jvm-type type)))
+(import: #long java/lang/reflect/Type)
+
+(import: #long (java/lang/reflect/TypeVariable d)
+ (getName [] java/lang/String)
+ (getBounds [] (Array java/lang/reflect/Type)))
+
+(import: #long java/lang/reflect/Modifier
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean))
+
+(import: #long java/lang/reflect/Method
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class java/lang/Object))
+ (getTypeParameters [] (Array (java/lang/reflect/TypeVariable java/lang/reflect/Method)))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericReturnType [] java/lang/reflect/Type)
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(import: #long (java/lang/reflect/Constructor c)
+ (getModifiers [] int)
+ (getDeclaringClass [] (java/lang/Class c))
+ (getTypeParameters [] (Array (java/lang/reflect/TypeVariable (java/lang/reflect/Constructor c))))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(import: #long (java/lang/Class c)
+ (#static forName [java/lang/String] #try (java/lang/Class java/lang/Object))
+ (getName [] java/lang/String)
+ (getModifiers [] int)
+ (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean)
+ (getTypeParameters [] (Array (java/lang/reflect/TypeVariable (java/lang/Class c))))
+ (getGenericInterfaces [] (Array java/lang/reflect/Type))
+ (getGenericSuperclass [] #? java/lang/reflect/Type)
+ (getDeclaredField [java/lang/String] #try java/lang/reflect/Field)
+ (getConstructors [] (Array (java/lang/reflect/Constructor java/lang/Object)))
+ (getDeclaredMethods [] (Array java/lang/reflect/Method)))
+
+(def: (reflection-type mapping typeJ)
+ (-> Mapping Type (Operation .Type))
+ (typeA.with-env
+ (luxT.type mapping typeJ)))
-(def: (class-candiate-parents from-name fromT to-name to-class)
+(def: (reflection-return mapping return)
+ (-> Mapping Return (Operation .Type))
+ (case return
+ #.None
+ (////@wrap .Any)
+
+ (#.Some return)
+ (..reflection-type mapping return)))
+
+(def: (class-candidate-parents from-name fromT to-name to-class)
(-> Text .Type Text (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit])))
(do ////.monad
- [from-class (load-class from-name)
- mapping (correspond-type-params from-class fromT)]
+ [from-class (////.lift (reflection!.load from-name))
+ mapping (////.lift (reflection!.correspond from-class fromT))]
(monad.map @
(function (_ superJT)
(do @
- [super-name (java-type-to-class superJT)
- super-class (load-class super-name)
- superT (java-type-to-lux-type mapping superJT)]
+ [superJT (////.lift (reflection!.type superJT))
+ #let [super-name (reflection.class superJT)]
+ super-class (////.lift (reflection!.load super-name))
+ superT (typeA.with-env (luxT.type mapping superJT))]
(wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)])))
(case (java/lang/Class::getGenericSuperclass from-class)
(#.Some super)
@@ -1004,7 +737,7 @@
#.None
(array.to-list (java/lang/Class::getGenericInterfaces from-class))))))
-(def: (inheritance-candiate-parents fromT to-class toT fromC)
+(def: (inheritance-candidate-parents fromT to-class toT fromC)
(-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit])))
(case fromT
(^ (#.Primitive _ (list& self-classT super-classT super-interfacesT+)))
@@ -1012,7 +745,7 @@
(function (_ superT)
(do ////.monad
[super-name (:: @ map reflection.class (check-jvm superT))
- super-class (load-class super-name)]
+ super-class (////.lift (reflection!.load super-name))]
(wrap [[super-name superT]
(java/lang/Class::isAssignableFrom super-class to-class)])))
(list& super-classT super-interfacesT+))
@@ -1053,22 +786,22 @@
(not (dictionary.contains? from-name boxes)))
_ (////.assert ..primitives-are-not-objects [to-name]
(not (dictionary.contains? to-name boxes)))
- to-class (load-class to-name)
+ to-class (////.lift (reflection!.load to-name))
_ (if (text@= ..inheritance-relationship-type-name from-name)
(wrap [])
(do @
- [from-class (load-class from-name)]
+ [from-class (////.lift (reflection!.load from-name))]
(////.assert cannot-cast [fromT toT fromC]
(java/lang/Class::isAssignableFrom from-class to-class))))]
(loop [[current-name currentT] [from-name fromT]]
(if (text@= to-name current-name)
(wrap #1)
(do @
- [candiate-parents (: (Operation (List [[Text .Type] Bit]))
- (if (text@= ..inheritance-relationship-type-name current-name)
- (inheritance-candiate-parents currentT to-class toT fromC)
- (class-candiate-parents current-name currentT to-name to-class)))]
- (case (|> candiate-parents
+ [candidate-parents (: (Operation (List [[Text .Type] Bit]))
+ (if (text@= ..inheritance-relationship-type-name current-name)
+ (inheritance-candidate-parents currentT to-class toT fromC)
+ (class-candidate-parents current-name currentT to-name to-class)))]
+ (case (|> candidate-parents
(list.filter product.right)
(list@map product.left))
(#.Cons [next-name nextT] _)
@@ -1099,179 +832,88 @@
(///bundle.install "cast" object::cast)
)))
-(def: (find-field class-name field-name)
- (-> Text Text (Operation [(java/lang/Class java/lang/Object) Field]))
- (do ////.monad
- [class (load-class class-name)]
- (case (java/lang/Class::getDeclaredField field-name class)
- (#error.Success field)
- (let [owner (Field::getDeclaringClass field)]
- (if (is? owner class)
- (wrap [class field])
- (/////analysis.throw mistaken-field-owner
- (format " Field: " field-name text.new-line
- " Owner Class: " (java/lang/Class::getName owner) text.new-line
- "Target Class: " class-name text.new-line))))
-
- (#error.Failure _)
- (/////analysis.throw unknown-field [class-name field-name]))))
-
-(def: (static-field class-name field-name)
- (-> Text Text (Operation [.Type Text Bit]))
- (do ////.monad
- [[class fieldJ] (find-field class-name field-name)
- #let [modifiers (Field::getModifiers fieldJ)]]
- (if (Modifier::isStatic modifiers)
- (let [fieldJT (Field::getGenericType fieldJ)]
- (do @
- [fieldT (java-type-to-lux-type fresh-mapping fieldJT)
- unboxed (java-type-to-class fieldJT)]
- (wrap [fieldT unboxed (Modifier::isFinal modifiers)])))
- (/////analysis.throw ..not-a-static-field [class-name field-name]))))
-
(def: static::get
Handler
(..custom [..member
(function (_ extension-name analyse [class field])
(do ////.monad
- [[fieldT unboxed final?] (static-field class field)
+ [[final? fieldJT] (////.lift
+ (do error.monad
+ [class (reflection!.load class)]
+ (reflection!.static-field field class)))
+ fieldT (reflection-type luxT.fresh fieldJT)
_ (typeA.infer fieldT)]
(wrap (<| (#/////analysis.Extension extension-name)
(list (/////analysis.text class)
(/////analysis.text field)
- (/////analysis.text unboxed))))))]))
+ (/////analysis.text (reflection.class fieldJT)))))))]))
(def: static::put
Handler
- (function (_ extension-name analyse args)
- (case args
- (^ (list classC fieldC valueC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do ////.monad
- [_ (typeA.infer Any)
- [fieldT unboxed final?] (static-field class field)
- _ (////.assert cannot-set-a-final-field [class field]
- (not final?))
- valueA (typeA.with-type fieldT
- (analyse valueC))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA))))
-
- _
- (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
-
- _
- (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
-
-(def: (virtual-field class-name field-name objectT)
- (-> Text Text .Type (Operation [.Type Bit]))
- (do ////.monad
- [[class fieldJ] (find-field class-name field-name)
- #let [modifiers (Field::getModifiers fieldJ)]]
- (if (not (Modifier::isStatic modifiers))
- (do @
- [#let [fieldJT (Field::getGenericType fieldJ)
- var-names (|> class
- java/lang/Class::getTypeParameters
- array.to-list
- (list@map (|>> TypeVariable::getName)))]
- mapping (: (Operation Mapping)
- (case objectT
- (#.Primitive _class-name _class-params)
- (do @
- [#let [num-params (list.size _class-params)
- num-vars (list.size var-names)]
- _ (////.assert type-parameter-mismatch
- (format "Expected: " (%i (.int num-params)) text.new-line
- " Actual: " (%i (.int num-vars)) text.new-line
- " Class: " _class-name text.new-line
- " Type: " (%type objectT))
- (n/= num-params num-vars))]
- (wrap (|> (list.zip2 var-names _class-params)
- (dictionary.from-list text.hash))))
-
- _
- (/////analysis.throw ..non-object objectT)))
- fieldT (java-type-to-lux-type mapping fieldJT)]
- (wrap [fieldT (Modifier::isFinal modifiers)]))
- (/////analysis.throw not-a-virtual-field [class-name field-name]))))
+ (..custom [($_ p.and ..member s.any)
+ (function (_ extension-name analyse [[class field] valueC])
+ (do ////.monad
+ [_ (typeA.infer Any)
+ [final? fieldJT] (////.lift
+ (do error.monad
+ [class (reflection!.load class)]
+ (reflection!.static-field field class)))
+ fieldT (reflection-type luxT.fresh fieldJT)
+ _ (////.assert ..cannot-set-a-final-field [class field]
+ (not final?))
+ valueA (typeA.with-type fieldT
+ (analyse valueC))]
+ (wrap (<| (#/////analysis.Extension extension-name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ valueA)))))]))
(def: virtual::get
Handler
- (function (_ extension-name analyse args)
- (case args
- (^ (list classC fieldC objectC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do ////.monad
- [[objectT objectA] (typeA.with-inference
- (analyse objectC))
- [fieldT final?] (virtual-field class field objectT)
- _ (typeA.infer fieldT)]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA))))
-
- _
- (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
-
- _
- (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
+ (..custom [($_ p.and ..member s.any)
+ (function (_ extension-name analyse [[class field] objectC])
+ (do ////.monad
+ [[objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ [mapping fieldJT] (////.lift
+ (do error.monad
+ [class (reflection!.load class)
+ [final? fieldJT] (reflection!.virtual-field field class)
+ mapping (reflection!.correspond class objectT)]
+ (wrap [mapping fieldJT])))
+ fieldT (typeA.with-env
+ (luxT.type mapping fieldJT))
+ _ (typeA.infer fieldT)]
+ (wrap (<| (#/////analysis.Extension extension-name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ objectA)))))]))
(def: virtual::put
Handler
- (function (_ extension-name analyse args)
- (case args
- (^ (list classC fieldC valueC objectC))
- (case [classC fieldC]
- [[_ (#.Text class)] [_ (#.Text field)]]
- (do ////.monad
- [[objectT objectA] (typeA.with-inference
- (analyse objectC))
- _ (typeA.infer objectT)
- [fieldT final?] (virtual-field class field objectT)
- _ (////.assert cannot-set-a-final-field [class field]
- (not final?))
- valueA (typeA.with-type fieldT
- (analyse valueC))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA))))
-
- _
- (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
-
- _
- (/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)]))))
-
-(def: (java-type-to-parameter type)
- (-> java/lang/reflect/Type (Operation Text))
- (<| (case (host.check java/lang/Class type)
- (#.Some type)
- (////@wrap (java/lang/Class::getName type))
-
- _)
- (case (host.check ParameterizedType type)
- (#.Some type)
- (java-type-to-parameter (ParameterizedType::getRawType type))
-
- _)
- (case (host.check TypeVariable type)
- (#.Some type)
- (////@wrap "java.lang.Object")
-
- _)
- (case (host.check WildcardType type)
- (#.Some type)
- (////@wrap "java.lang.Object")
-
- _)
- (case (host.check GenericArrayType type)
- (#.Some type)
- (do ////.monad
- [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType type))]
- (wrap (format componentP "[]")))
-
- _)
-
- ## else
- (/////analysis.throw cannot-convert-to-a-parameter type)))
+ (..custom [($_ p.and ..member s.any s.any)
+ (function (_ extension-name analyse [[class field] valueC objectC])
+ (do ////.monad
+ [[objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ _ (typeA.infer objectT)
+ [final? mapping fieldJT] (////.lift
+ (do error.monad
+ [class (reflection!.load class)
+ [final? fieldJT] (reflection!.virtual-field field class)
+ mapping (reflection!.correspond class objectT)]
+ (wrap [final? mapping fieldJT])))
+ fieldT (typeA.with-env
+ (luxT.type mapping fieldJT))
+ _ (////.assert cannot-set-a-final-field [class field]
+ (not final?))
+ valueA (typeA.with-type fieldT
+ (analyse valueC))]
+ (wrap (<| (#/////analysis.Extension extension-name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ valueA
+ objectA)))))]))
(type: Method-Style
#Static
@@ -1280,32 +922,27 @@
#Special
#Interface)
-(def: reflection-arguments
- (-> (List Text) (Operation (List Text)))
- (|>> (monad.map error.monad (<t>.run jvm.parse-signature))
- (:: error.monad map (list@map reflection.class))
- ////.lift))
-
(def: (check-method class method-name method-style arg-classes method)
- (-> (java/lang/Class java/lang/Object) Text Method-Style (List Text) Method (Operation Bit))
+ (-> (java/lang/Class java/lang/Object) Text Method-Style (List Text) java/lang/reflect/Method (Operation Bit))
(do ////.monad
- [arg-classes (reflection-arguments arg-classes)
- parameters (|> (Method::getGenericParameterTypes method)
+ [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method)
array.to-list
- (monad.map @ java-type-to-parameter))
- #let [modifiers (Method::getModifiers method)]
- #let [correct-class? (java/lang/Object::equals class (Method::getDeclaringClass method))
- correct-method? (text@= method-name (Method::getName method))
+ (monad.map error.monad reflection!.type)
+ (:: error.monad map (list@map jvm.signature))
+ ////.lift)
+ #let [modifiers (java/lang/reflect/Method::getModifiers method)
+ correct-class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method))
+ correct-method? (text@= method-name (java/lang/reflect/Method::getName method))
static-matches? (case method-style
#Static
- (Modifier::isStatic modifiers)
+ (java/lang/reflect/Modifier::isStatic modifiers)
_
#1)
special-matches? (case method-style
#Special
- (not (or (Modifier::isInterface (java/lang/Class::getModifiers class))
- (Modifier::isAbstract modifiers)))
+ (not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))
+ (java/lang/reflect/Modifier::isAbstract modifiers)))
_
#1)
@@ -1323,13 +960,14 @@
inputs-match?))))
(def: (check-constructor class arg-classes constructor)
- (-> (java/lang/Class java/lang/Object) (List Text) (Constructor java/lang/Object) (Operation Bit))
+ (-> (java/lang/Class java/lang/Object) (List Text) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit))
(do ////.monad
- [arg-classes (reflection-arguments arg-classes)
- parameters (|> (Constructor::getGenericParameterTypes constructor)
+ [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
array.to-list
- (monad.map @ java-type-to-parameter))]
- (wrap (and (java/lang/Object::equals class (Constructor::getDeclaringClass constructor))
+ (monad.map error.monad reflection!.type)
+ (:: error.monad map (list@map jvm.signature))
+ ////.lift)]
+ (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor))
(n/= (list.size arg-classes) (list.size parameters))
(list@fold (function (_ [expectedJC actualJC] prev)
(and prev
@@ -1356,8 +994,8 @@
[owner-tvarsT mapping]))
(def: (method-signature method-style method)
- (-> Method-Style Method (Operation Method-Signature))
- (let [owner (Method::getDeclaringClass method)
+ (-> Method-Style java/lang/reflect/Method (Operation Method-Signature))
+ (let [owner (java/lang/reflect/Method::getDeclaringClass method)
owner-tvars (case method-style
#Static
(list)
@@ -1365,19 +1003,28 @@
_
(|> (java/lang/Class::getTypeParameters owner)
array.to-list
- (list@map (|>> TypeVariable::getName))))
- method-tvars (|> (Method::getTypeParameters method)
+ (list@map (|>> java/lang/reflect/TypeVariable::getName))))
+ method-tvars (|> (java/lang/reflect/Method::getTypeParameters method)
array.to-list
- (list@map (|>> TypeVariable::getName)))
+ (list@map (|>> java/lang/reflect/TypeVariable::getName)))
[owner-tvarsT mapping] (jvm-type-var-mapping owner-tvars method-tvars)]
(do ////.monad
- [inputsT (|> (Method::getGenericParameterTypes method)
+ [inputsT (|> (java/lang/reflect/Method::getGenericParameterTypes method)
array.to-list
- (monad.map @ (java-type-to-lux-type mapping)))
- outputT (java-type-to-lux-type mapping (Method::getGenericReturnType method))
- exceptionsT (|> (Method::getGenericExceptionTypes method)
+ (monad.map @ (|>> reflection!.type ////.lift))
+ (////@map (monad.map @ (reflection-type mapping)))
+ ////@join)
+ outputT (|> method
+ java/lang/reflect/Method::getGenericReturnType
+ reflection!.type
+ ////.lift
+ (////@map (reflection-type mapping))
+ ////@join)
+ exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
array.to-list
- (monad.map @ (java-type-to-lux-type mapping)))
+ (monad.map @ (|>> reflection!.type ////.lift))
+ (////@map (monad.map @ (reflection-type mapping)))
+ ////@join)
#let [methodT (<| (type.univ-q (dictionary.size mapping))
(type.function (case method-style
#Static
@@ -1390,22 +1037,26 @@
(wrap [methodT exceptionsT]))))
(def: (constructor-signature constructor)
- (-> (Constructor java/lang/Object) (Operation Method-Signature))
- (let [owner (Constructor::getDeclaringClass constructor)
+ (-> (java/lang/reflect/Constructor java/lang/Object) (Operation Method-Signature))
+ (let [owner (java/lang/reflect/Constructor::getDeclaringClass constructor)
owner-tvars (|> (java/lang/Class::getTypeParameters owner)
array.to-list
- (list@map (|>> TypeVariable::getName)))
- method-tvars (|> (Constructor::getTypeParameters constructor)
+ (list@map (|>> java/lang/reflect/TypeVariable::getName)))
+ method-tvars (|> (java/lang/reflect/Constructor::getTypeParameters constructor)
array.to-list
- (list@map (|>> TypeVariable::getName)))
+ (list@map (|>> java/lang/reflect/TypeVariable::getName)))
[owner-tvarsT mapping] (jvm-type-var-mapping owner-tvars method-tvars)]
(do ////.monad
- [inputsT (|> (Constructor::getGenericParameterTypes constructor)
+ [inputsT (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
array.to-list
- (monad.map @ (java-type-to-lux-type mapping)))
- exceptionsT (|> (Constructor::getGenericExceptionTypes constructor)
+ (monad.map @ (|>> reflection!.type ////.lift))
+ (////@map (monad.map @ (reflection-type mapping)))
+ ////@join)
+ exceptionsT (|> (java/lang/reflect/Constructor::getGenericExceptionTypes constructor)
array.to-list
- (monad.map @ (java-type-to-lux-type mapping)))
+ (monad.map @ (|>> reflection!.type ////.lift))
+ (////@map (monad.map @ (reflection-type mapping)))
+ ////@join)
#let [objectT (#.Primitive (java/lang/Class::getName owner) owner-tvarsT)
constructorT (<| (type.univ-q (dictionary.size mapping))
(type.function inputsT)
@@ -1414,8 +1065,7 @@
(type: Evaluation
(#Pass Method-Signature)
- (#Hint Method-Signature)
- #Fail)
+ (#Hint Method-Signature))
(template [<name> <tag>]
[(def: <name>
@@ -1433,22 +1083,19 @@
(def: (method-candidate class-name method-name method-style arg-classes)
(-> Text Text Method-Style (List Text) (Operation Method-Signature))
(do ////.monad
- [class (load-class class-name)
+ [class (////.lift (reflection!.load class-name))
candidates (|> class
java/lang/Class::getDeclaredMethods
array.to-list
- (monad.map @ (: (-> Method (Operation Evaluation))
+ (list.filter (|>> java/lang/reflect/Method::getName (text@= method-name)))
+ (monad.map @ (: (-> java/lang/reflect/Method (Operation Evaluation))
(function (_ method)
(do @
[passes? (check-method class method-name method-style arg-classes method)]
- (cond passes?
- (:: @ map (|>> #Pass) (method-signature method-style method))
-
- (text@= method-name (Method::getName method))
- (:: @ map (|>> #Hint) (method-signature method-style method))
-
- ## else
- (wrap #Fail)))))))]
+ (:: @ map (if passes?
+ (|>> #Pass)
+ (|>> #Hint))
+ (method-signature method-style method)))))))]
(case (list.search-all pass! candidates)
(#.Cons method #.Nil)
(wrap method)
@@ -1464,7 +1111,7 @@
(def: (constructor-candidate class-name arg-classes)
(-> Text (List Text) (Operation Method-Signature))
(do ////.monad
- [class (load-class class-name)
+ [class (////.lift (reflection!.load class-name))
candidates (|> class
java/lang/Class::getConstructors
array.to-list
@@ -1550,9 +1197,9 @@
(function (_ extension-name analyse [[class-name method] objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
- class (load-class class-name)
+ class (////.lift (reflection!.load class-name))
_ (////.assert non-interface class-name
- (Modifier::isInterface (java/lang/Class::getModifiers class)))
+ (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)))
[methodT exceptionsT] (method-candidate class-name method #Interface argsT)
[outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
#let [[objectA argsA] (case allA
@@ -1784,8 +1431,36 @@
(-> (Typed Analysis) Analysis)
(/////analysis.tuple (list (type-analysis type) term)))
+(def: abstract-methods
+ (-> (java/lang/Class java/lang/Object)
+ (Error (List [Text Method])))
+ (|>> java/lang/Class::getDeclaredMethods
+ array.to-list
+ (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))
+ (monad.map error.monad
+ (function (_ method)
+ (do error.monad
+ [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method)
+ array.to-list
+ (monad.map @ reflection!.type))
+ return (|> method
+ java/lang/reflect/Method::getGenericReturnType
+ reflection!.return)
+ exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
+ array.to-list
+ (monad.map @ reflection!.generic))]
+ (wrap [(java/lang/reflect/Method::getName method)
+ (jvm.method inputs return exceptions)]))))))
+
(def: jvm-package-separator ".")
+(def: all-abstract-methods
+ (-> (List Class) (Error (List [Text Method])))
+ (|>> (monad.map error.monad (|>> product.left reflection!.load))
+ (error@map (monad.map error.monad ..abstract-methods))
+ error@join
+ (error@map list@join)))
+
(def: class::anonymous
Handler
(..custom [($_ p.and
@@ -1805,10 +1480,10 @@
..jvm-package-separator
"anonymous-class" (%n id)))))
super-classT (typeA.with-env
- (class-type fresh-mapping super-class))
+ (luxT.class luxT.fresh super-class))
super-interfaceT+ (typeA.with-env
(monad.map check.monad
- (class-type fresh-mapping)
+ (luxT.class luxT.fresh)
super-interfaces))
#let [selfT (inheritance-relationship-type (#.Primitive name (list))
super-classT
@@ -1816,7 +1491,7 @@
constructor-argsA+ (monad.map @ (function (_ [type term])
(do @
[argT (typeA.with-env
- (jvm-type fresh-mapping type))
+ (luxT.type luxT.fresh type))
termA (typeA.with-type argT
(analyse term))]
(wrap [type termA])))
@@ -1825,7 +1500,7 @@
strict-fp? annotations vars
self-name arguments return exceptions
body])
-
+
(do @
[annotationsA (monad.map @ (function (_ [name parameters])
(do @
@@ -1837,12 +1512,12 @@
(wrap [name parametersA])))
annotations)
returnT (typeA.with-env
- (return-type fresh-mapping return))
+ (luxT.return luxT.fresh return))
arguments' (typeA.with-env
(monad.map check.monad
(function (_ [name jvmT])
(do check.monad
- [luxT (jvm-type fresh-mapping jvmT)]
+ [luxT (luxT.type luxT.fresh jvmT)]
(wrap [name luxT])))
arguments))
[scope bodyA] (|> arguments'
@@ -1870,13 +1545,15 @@
(/////analysis.tuple (list bodyA)))
)))))
methods)
+ required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces)))
_ (typeA.infer selfT)]
(wrap (#/////analysis.Extension extension-name
(list (/////analysis.text name)
(class-analysis super-class)
(/////analysis.tuple (list@map class-analysis super-interfaces))
(/////analysis.tuple (list@map typed-analysis constructor-argsA+))
- (/////analysis.tuple methodsA))))))]))
+ (/////analysis.tuple methodsA))))
+ ))]))
(def: bundle::class
Bundle