aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux')
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux1305
1 files changed, 1305 insertions, 0 deletions
diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
new file mode 100644
index 000000000..998590d1c
--- /dev/null
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -0,0 +1,1305 @@
+(.module:
+ [lux (#- char int)
+ [abstract
+ ["." monad (#+ do)]]
+ [control
+ ["p" parser]
+ ["." exception (#+ exception:)]
+ pipe]
+ [data
+ ["." error (#+ Error)]
+ ["." maybe]
+ ["." product]
+ ["." text ("#@." equivalence)
+ format]
+ [collection
+ ["." list ("#@." fold functor monoid)]
+ ["." array (#+ Array)]
+ ["." dictionary (#+ Dictionary)]]]
+ ["." type
+ ["." check]]
+ ["." macro
+ ["s" syntax (#+ Syntax)]]
+ ["." host (#+ import:)]]
+ ["." // #_
+ ["#." common]
+ ["#/" //
+ ["#." bundle]
+ ["#/" // ("#@." monad)
+ [analysis
+ [".A" type]
+ [".A" inference]]
+ ["#/" // #_
+ ["#." analysis (#+ Analysis Operation Phase Handler Bundle)]
+ ["#." synthesis]]]]])
+
+(def: (custom [syntax handler])
+ (All [s]
+ (-> [(Syntax s)
+ (-> Text Phase s (Operation Analysis))]
+ Handler))
+ (function (_ extension-name analyse args)
+ (case (s.run args syntax)
+ (#error.Success inputs)
+ (handler extension-name analyse inputs)
+
+ (#error.Failure error)
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
+
+(type: Member
+ {#class Text
+ #member Text})
+
+(def: member
+ (Syntax Member)
+ ($_ p.and s.text s.text))
+
+(type: Method-Signature
+ {#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
+ ["Type" (%type type)]))]
+
+ [non-object]
+ [non-array]
+ [non-jvm-type]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {class Text})
+ (exception.report
+ ["Class" (%t class)]))]
+
+ [unknown-class]
+ [non-interface]
+ [non-throwable]
+ )
+
+(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]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {class Text}
+ {method Text}
+ {hints (List Method-Signature)})
+ (exception.report
+ ["Class" class]
+ ["Method" method]
+ ["Hints" (|> hints
+ (list@map (|>> product.left %type (format text.new-line text.tab)))
+ (text.join-with ""))]))]
+
+ [no-candidates]
+ [too-many-candidates]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [primitives-cannot-have-type-parameters]
+ [primitives-are-not-objects]
+
+ [mistaken-field-owner]
+
+ [cannot-cast]
+
+ [cannot-possibly-be-an-instance]
+
+ [unknown-type-var]
+ [type-parameter-mismatch]
+ [cannot-correspond-type-with-a-class]
+ )
+
+## TODO: Get rid of this template block and use the definition in
+## lux/host.jvm.lux ASAP
+(template [<name> <class>]
+ [(type: #export <name> (primitive <class>))]
+
+ ## Boxes
+ [Boolean "java.lang.Boolean"]
+ [Byte "java.lang.Byte"]
+ [Short "java.lang.Short"]
+ [Integer "java.lang.Integer"]
+ [Long "java.lang.Long"]
+ [Float "java.lang.Float"]
+ [Double "java.lang.Double"]
+ [Character "java.lang.Character"]
+ [String "java.lang.String"]
+
+ ## Primitives
+ [boolean "boolean"]
+ [byte "byte"]
+ [short "short"]
+ [int "int"]
+ [long "long"]
+ [float "float"]
+ [double "double"]
+ [char "char"]
+ )
+
+(def: bundle::conversion
+ Bundle
+ (<| (///bundle.prefix "conversion")
+ (|> ///bundle.empty
+ (///bundle.install "double-to-float" (//common.unary ..double ..float))
+ (///bundle.install "double-to-int" (//common.unary ..double ..int))
+ (///bundle.install "double-to-long" (//common.unary ..double ..long))
+ (///bundle.install "float-to-double" (//common.unary ..float ..double))
+ (///bundle.install "float-to-int" (//common.unary ..float ..int))
+ (///bundle.install "float-to-long" (//common.unary ..float ..long))
+ (///bundle.install "int-to-byte" (//common.unary ..int ..byte))
+ (///bundle.install "int-to-char" (//common.unary ..int ..char))
+ (///bundle.install "int-to-double" (//common.unary ..int ..double))
+ (///bundle.install "int-to-float" (//common.unary ..int ..float))
+ (///bundle.install "int-to-long" (//common.unary ..int ..long))
+ (///bundle.install "int-to-short" (//common.unary ..int ..short))
+ (///bundle.install "long-to-double" (//common.unary ..long ..double))
+ (///bundle.install "long-to-float" (//common.unary ..long ..float))
+ (///bundle.install "long-to-int" (//common.unary ..long ..int))
+ (///bundle.install "long-to-short" (//common.unary ..long ..short))
+ (///bundle.install "long-to-byte" (//common.unary ..long ..byte))
+ (///bundle.install "char-to-byte" (//common.unary ..char ..byte))
+ (///bundle.install "char-to-short" (//common.unary ..char ..short))
+ (///bundle.install "char-to-int" (//common.unary ..char ..int))
+ (///bundle.install "char-to-long" (//common.unary ..char ..long))
+ (///bundle.install "byte-to-long" (//common.unary ..byte ..long))
+ (///bundle.install "short-to-long" (//common.unary ..short ..long))
+ )))
+
+(template [<name> <prefix> <type>]
+ [(def: <name>
+ Bundle
+ (<| (///bundle.prefix <prefix>)
+ (|> ///bundle.empty
+ (///bundle.install "+" (//common.binary <type> <type> <type>))
+ (///bundle.install "-" (//common.binary <type> <type> <type>))
+ (///bundle.install "*" (//common.binary <type> <type> <type>))
+ (///bundle.install "/" (//common.binary <type> <type> <type>))
+ (///bundle.install "%" (//common.binary <type> <type> <type>))
+ (///bundle.install "=" (//common.binary <type> <type> Bit))
+ (///bundle.install "<" (//common.binary <type> <type> Bit))
+ (///bundle.install "and" (//common.binary <type> <type> <type>))
+ (///bundle.install "or" (//common.binary <type> <type> <type>))
+ (///bundle.install "xor" (//common.binary <type> <type> <type>))
+ (///bundle.install "shl" (//common.binary <type> Integer <type>))
+ (///bundle.install "shr" (//common.binary <type> Integer <type>))
+ (///bundle.install "ushr" (//common.binary <type> Integer <type>))
+ )))]
+
+ [bundle::int "int" ..long]
+ [bundle::long "long" ..long]
+ )
+
+(template [<name> <prefix> <type>]
+ [(def: <name>
+ Bundle
+ (<| (///bundle.prefix <prefix>)
+ (|> ///bundle.empty
+ (///bundle.install "+" (//common.binary <type> <type> <type>))
+ (///bundle.install "-" (//common.binary <type> <type> <type>))
+ (///bundle.install "*" (//common.binary <type> <type> <type>))
+ (///bundle.install "/" (//common.binary <type> <type> <type>))
+ (///bundle.install "%" (//common.binary <type> <type> <type>))
+ (///bundle.install "=" (//common.binary <type> <type> Bit))
+ (///bundle.install "<" (//common.binary <type> <type> Bit))
+ )))]
+
+ [bundle::float "float" ..float]
+ [bundle::double "double" ..double]
+ )
+
+(def: bundle::char
+ Bundle
+ (<| (///bundle.prefix "char")
+ (|> ///bundle.empty
+ (///bundle.install "=" (//common.binary ..char ..char Bit))
+ (///bundle.install "<" (//common.binary ..char ..char Bit))
+ )))
+
+(def: #export boxes
+ (Dictionary Text Text)
+ (|> (list ["boolean" "java.lang.Boolean"]
+ ["byte" "java.lang.Byte"]
+ ["short" "java.lang.Short"]
+ ["int" "java.lang.Integer"]
+ ["long" "java.lang.Long"]
+ ["float" "java.lang.Float"]
+ ["double" "java.lang.Double"]
+ ["char" "java.lang.Character"])
+ (dictionary.from-list text.hash)))
+
+(def: (array-type-info arrayT)
+ (-> Type (Operation [Nat Text]))
+ (loop [level 0
+ currentT arrayT]
+ (case currentT
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (recur level outputT)
+
+ #.None
+ (/////analysis.throw non-array arrayT))
+
+ (^ (#.Primitive (static array.type-name) (list elemT)))
+ (recur (inc level) elemT)
+
+ (#.Primitive class #.Nil)
+ (////@wrap [level class])
+
+ (#.Primitive class _)
+ (if (dictionary.contains? class boxes)
+ (/////analysis.throw primitives-cannot-have-type-parameters class)
+ (////@wrap [level class]))
+
+ _
+ (/////analysis.throw non-array arrayT))))
+
+(def: array::length
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list arrayC))
+ (do ////.monad
+ [_ (typeA.infer ..int)
+ [var-id varT] (typeA.with-env check.var)
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ varT (typeA.with-env (check.clean varT))
+ [array-nesting elem-class] (array-type-info (type (Array varT)))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat array-nesting)
+ (/////analysis.text elem-class)
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
+
+(def: array::new
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list lengthC))
+ (do ////.monad
+ [lengthA (typeA.with-type ..int
+ (analyse lengthC))
+ expectedT (///.lift macro.expected-type)
+ [level elem-class] (array-type-info expectedT)
+ _ (if (n/> 0 level)
+ (wrap [])
+ (/////analysis.throw non-array expectedT))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (dec level))
+ (/////analysis.text elem-class)
+ lengthA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
+
+(def: (check-jvm objectT)
+ (-> Type (Operation Text))
+ (case objectT
+ (#.Primitive name _)
+ (////@wrap name)
+
+ (#.Named name unnamed)
+ (check-jvm unnamed)
+
+ (#.Var id)
+ (////@wrap "java.lang.Object")
+
+ (^template [<tag>]
+ (<tag> env unquantified)
+ (check-jvm unquantified))
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (check-jvm outputT)
+
+ #.None
+ (/////analysis.throw non-object objectT))
+
+ _
+ (/////analysis.throw non-object objectT)))
+
+(def: (check-object objectT)
+ (-> Type (Operation Text))
+ (do ////.monad
+ [name (check-jvm objectT)]
+ (if (dictionary.contains? name boxes)
+ (/////analysis.throw primitives-are-not-objects name)
+ (////@wrap name))))
+
+(def: array::read
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list idxC arrayC))
+ (do ////.monad
+ [[var-id varT] (typeA.with-env check.var)
+ _ (typeA.infer varT)
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ varT (typeA.with-env
+ (check.clean varT))
+ [nesting elem-class] (array-type-info varT)
+ idxA (typeA.with-type ..int
+ (analyse idxC))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting))
+ (/////analysis.text elem-class)
+ idxA
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
+
+(def: array::write
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list idxC valueC arrayC))
+ (do ////.monad
+ [[var-id varT] (typeA.with-env check.var)
+ _ (typeA.infer (type (Array varT)))
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ varT (typeA.with-env
+ (check.clean varT))
+ [nesting elem-class] (array-type-info varT)
+ idxA (typeA.with-type ..int
+ (analyse idxC))
+ valueA (typeA.with-type varT
+ (analyse valueC))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting))
+ (/////analysis.text elem-class)
+ idxA
+ valueA
+ arrayA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
+
+(def: bundle::array
+ Bundle
+ (<| (///bundle.prefix "array")
+ (|> ///bundle.empty
+ (///bundle.install "length" array::length)
+ (///bundle.install "new" array::new)
+ (///bundle.install "read" array::read)
+ (///bundle.install "write" array::write)
+ )))
+
+(def: object::null
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list))
+ (do ////.monad
+ [expectedT (///.lift macro.expected-type)
+ _ (check-object expectedT)]
+ (wrap (#/////analysis.Extension extension-name (list))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 0 (list.size args)]))))
+
+(def: object::null?
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list objectC))
+ (do ////.monad
+ [_ (typeA.infer Bit)
+ [objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ _ (check-object objectT)]
+ (wrap (#/////analysis.Extension extension-name (list objectA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
+
+(def: object::synchronized
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list monitorC exprC))
+ (do ////.monad
+ [[monitorT monitorA] (typeA.with-inference
+ (analyse monitorC))
+ _ (check-object monitorT)
+ exprA (analyse exprC)]
+ (wrap (#/////analysis.Extension extension-name (list monitorA exprA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
+
+(import: java/lang/Object
+ (equals [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 Object))
+ (getModifiers [] int)
+ (getGenericType [] java/lang/reflect/Type))
+
+(import: java/lang/reflect/Method
+ (getName [] String)
+ (getModifiers [] int)
+ (getDeclaringClass [] (Class 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 [] (Class c))
+ (getTypeParameters [] (Array (TypeVariable (Constructor c))))
+ (getGenericParameterTypes [] (Array java/lang/reflect/Type))
+ (getGenericExceptionTypes [] (Array java/lang/reflect/Type)))
+
+(import: (java/lang/Class c)
+ (getName [] String)
+ (getModifiers [] int)
+ (#static forName [String] #try (Class Object))
+ (isAssignableFrom [(Class Object)] boolean)
+ (getTypeParameters [] (Array (TypeVariable (Class c))))
+ (getGenericInterfaces [] (Array java/lang/reflect/Type))
+ (getGenericSuperclass [] java/lang/reflect/Type)
+ (getDeclaredField [String] #try Field)
+ (getConstructors [] (Array (Constructor Object)))
+ (getDeclaredMethods [] (Array Method)))
+
+(def: (load-class name)
+ (-> Text (Operation (Class Object)))
+ (do ////.monad
+ []
+ (case (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 (Class::isAssignableFrom sub super))))
+
+(def: object::throw
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list exceptionC))
+ (do ////.monad
+ [_ (typeA.infer Nothing)
+ [exceptionT exceptionA] (typeA.with-inference
+ (analyse exceptionC))
+ exception-class (check-object exceptionT)
+ ? (sub-class? "java.lang.Throwable" exception-class)
+ _ (: (Operation Any)
+ (if ?
+ (wrap [])
+ (/////analysis.throw non-throwable exception-class)))]
+ (wrap (#/////analysis.Extension extension-name (list exceptionA))))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
+
+(def: object::class
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list classC))
+ (case classC
+ [_ (#.Text class)]
+ (do ////.monad
+ [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
+ _ (load-class class)]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))))
+
+ _
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
+
+ _
+ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
+
+(def: object::instance?
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list classC objectC))
+ (case classC
+ [_ (#.Text class)]
+ (do ////.monad
+ [_ (typeA.infer Bit)
+ [objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ object-class (check-object objectT)
+ ? (sub-class? class object-class)]
+ (if ?
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class))))
+ (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class))))
+
+ _
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))
+
+ _
+ (/////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 Class jvm-type)
+ (#.Some jvm-type)
+ (////@wrap (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)))
+
+(type: Mappings
+ (Dictionary Text Type))
+
+(def: fresh-mappings Mappings (dictionary.new text.hash))
+
+(def: (java-type-to-lux-type mappings java-type)
+ (-> Mappings 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 mappings)
+ (#.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 mappings bound)
+
+ _
+ (////@wrap Any))
+
+ _)
+ (case (host.check Class java-type)
+ (#.Some java-type)
+ (let [java-type (:coerce (Class Object) java-type)
+ class-name (Class::getName java-type)]
+ (////@wrap (case (array.size (Class::getTypeParameters java-type))
+ 0
+ (#.Primitive class-name (list))
+
+ arity
+ (|> (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 Class raw)
+ (#.Some raw)
+ (do ////.monad
+ [paramsT (|> java-type
+ ParameterizedType::getActualTypeArguments
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))]
+ (////@wrap (#.Primitive (Class::getName (:coerce (Class 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 mappings))]
+ (wrap (#.Primitive array.type-name (list innerT))))
+
+ _)
+ ## else
+ (/////analysis.throw cannot-convert-to-a-lux-type java-type)))
+
+(def: (correspond-type-params class type)
+ (-> (Class Object) Type (Operation Mappings))
+ (case type
+ (#.Primitive name params)
+ (let [class-name (Class::getName class)
+ class-params (array.to-list (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)))
+ ))
+
+ _
+ (/////analysis.throw non-jvm-type type)))
+
+(def: object::cast
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list valueC))
+ (do ////.monad
+ [toT (///.lift macro.expected-type)
+ to-name (check-jvm toT)
+ [valueT valueA] (typeA.with-inference
+ (analyse valueC))
+ from-name (check-jvm valueT)
+ can-cast? (: (Operation Bit)
+ (case [from-name to-name]
+ (^template [<primitive> <object>]
+ (^or [<primitive> <object>]
+ [<object> <primitive>])
+ (do @
+ [_ (typeA.infer (#.Primitive to-name (list)))]
+ (wrap #1)))
+ (["boolean" "java.lang.Boolean"]
+ ["byte" "java.lang.Byte"]
+ ["short" "java.lang.Short"]
+ ["int" "java.lang.Integer"]
+ ["long" "java.lang.Long"]
+ ["float" "java.lang.Float"]
+ ["double" "java.lang.Double"]
+ ["char" "java.lang.Character"])
+
+ _
+ (do @
+ [_ (////.assert primitives-are-not-objects from-name
+ (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)]
+ (loop [[current-name currentT] [from-name valueT]]
+ (if (text@= to-name current-name)
+ (do @
+ [_ (typeA.infer toT)]
+ (wrap #1))
+ (do @
+ [current-class (load-class current-name)
+ _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line
+ " To class/primitive: " to-name text.new-line
+ " For value: " (%code valueC) text.new-line)
+ (Class::isAssignableFrom current-class to-class))
+ candiate-parents (monad.map @
+ (function (_ java-type)
+ (do @
+ [class-name (java-type-to-class java-type)
+ class (load-class class-name)]
+ (wrap [[class-name java-type] (Class::isAssignableFrom class to-class)])))
+ (list& (Class::getGenericSuperclass current-class)
+ (array.to-list (Class::getGenericInterfaces current-class))))]
+ (case (|> candiate-parents
+ (list.filter product.right)
+ (list@map product.left))
+ (#.Cons [next-name nextJT] _)
+ (do @
+ [mapping (correspond-type-params current-class currentT)
+ nextT (java-type-to-lux-type mapping nextJT)]
+ (recur [next-name nextT]))
+
+ #.Nil
+ (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line
+ " To class/primitive: " to-name text.new-line
+ " For value: " (%code valueC) text.new-line)))
+ ))))))]
+ (if can-cast?
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name)
+ (/////analysis.text to-name)
+ valueA)))
+ (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line
+ " To class/primitive: " to-name text.new-line
+ " For value: " (%code valueC) text.new-line))))
+
+ _
+ (/////analysis.throw ///.invalid-syntax [extension-name %code args]))))
+
+(def: bundle::object
+ Bundle
+ (<| (///bundle.prefix "object")
+ (|> ///bundle.empty
+ (///bundle.install "null" object::null)
+ (///bundle.install "null?" object::null?)
+ (///bundle.install "synchronized" object::synchronized)
+ (///bundle.install "throw" object::throw)
+ (///bundle.install "class" object::class)
+ (///bundle.install "instance?" object::instance?)
+ (///bundle.install "cast" object::cast)
+ )))
+
+(def: (find-field class-name field-name)
+ (-> Text Text (Operation [(Class Object) Field]))
+ (do ////.monad
+ [class (load-class class-name)]
+ (case (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: " (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-mappings 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)
+ _ (typeA.infer fieldT)]
+ (wrap (<| (#/////analysis.Extension extension-name)
+ (list (/////analysis.text class)
+ (/////analysis.text field)
+ (/////analysis.text unboxed))))))]))
+
+(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
+ Class::getTypeParameters
+ array.to-list
+ (list@map (|>> TypeVariable::getName)))]
+ mappings (: (Operation Mappings)
+ (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 mappings fieldJT)]
+ (wrap [fieldT (Modifier::isFinal modifiers)]))
+ (/////analysis.throw not-a-virtual-field [class-name field-name]))))
+
+(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)]))))
+
+(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 Class type)
+ (#.Some type)
+ (////@wrap (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)))
+
+(type: Method-Style
+ #Static
+ #Abstract
+ #Virtual
+ #Special
+ #Interface)
+
+(def: (check-method class method-name method-style arg-classes method)
+ (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit))
+ (do ////.monad
+ [parameters (|> (Method::getGenericParameterTypes method)
+ array.to-list
+ (monad.map @ java-type-to-parameter))
+ #let [modifiers (Method::getModifiers method)]]
+ (wrap (and (Object::equals class (Method::getDeclaringClass method))
+ (text@= method-name (Method::getName method))
+ (case #Static
+ #Special
+ (Modifier::isStatic modifiers)
+
+ _
+ #1)
+ (case method-style
+ #Special
+ (not (or (Modifier::isInterface (Class::getModifiers class))
+ (Modifier::isAbstract modifiers)))
+
+ _
+ #1)
+ (n/= (list.size arg-classes) (list.size parameters))
+ (list@fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (text@= expectedJC actualJC)))
+ #1
+ (list.zip2 arg-classes parameters))))))
+
+(def: (check-constructor class arg-classes constructor)
+ (-> (Class Object) (List Text) (Constructor Object) (Operation Bit))
+ (do ////.monad
+ [parameters (|> (Constructor::getGenericParameterTypes constructor)
+ array.to-list
+ (monad.map @ java-type-to-parameter))]
+ (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor))
+ (n/= (list.size arg-classes) (list.size parameters))
+ (list@fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (text@= expectedJC actualJC)))
+ #1
+ (list.zip2 arg-classes parameters))))))
+
+(def: idx-to-parameter
+ (-> Nat Type)
+ (|>> (n/* 2) inc #.Parameter))
+
+(def: (jvm-type-var-mappings owner-tvars method-tvars)
+ (-> (List Text) (List Text) [(List Type) Mappings])
+ (let [jvm-tvars (list@compose owner-tvars method-tvars)
+ lux-tvars (|> jvm-tvars
+ list.reverse
+ list.enumerate
+ (list@map (function (_ [idx name])
+ [name (idx-to-parameter idx)]))
+ list.reverse)
+ num-owner-tvars (list.size owner-tvars)
+ owner-tvarsT (|> lux-tvars (list.take num-owner-tvars) (list@map product.right))
+ mappings (dictionary.from-list text.hash lux-tvars)]
+ [owner-tvarsT mappings]))
+
+(def: (method-signature method-style method)
+ (-> Method-Style Method (Operation Method-Signature))
+ (let [owner (Method::getDeclaringClass method)
+ owner-tvars (case method-style
+ #Static
+ (list)
+
+ _
+ (|> (Class::getTypeParameters owner)
+ array.to-list
+ (list@map (|>> TypeVariable::getName))))
+ method-tvars (|> (Method::getTypeParameters method)
+ array.to-list
+ (list@map (|>> TypeVariable::getName)))
+ [owner-tvarsT mappings] (jvm-type-var-mappings owner-tvars method-tvars)]
+ (do ////.monad
+ [inputsT (|> (Method::getGenericParameterTypes method)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method))
+ exceptionsT (|> (Method::getGenericExceptionTypes method)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ #let [methodT (<| (type.univ-q (dictionary.size mappings))
+ (type.function (case method-style
+ #Static
+ inputsT
+
+ _
+ (list& (#.Primitive (Class::getName owner) owner-tvarsT)
+ inputsT)))
+ outputT)]]
+ (wrap [methodT exceptionsT]))))
+
+(def: (constructor-signature constructor)
+ (-> (Constructor Object) (Operation Method-Signature))
+ (let [owner (Constructor::getDeclaringClass constructor)
+ owner-tvars (|> (Class::getTypeParameters owner)
+ array.to-list
+ (list@map (|>> TypeVariable::getName)))
+ method-tvars (|> (Constructor::getTypeParameters constructor)
+ array.to-list
+ (list@map (|>> TypeVariable::getName)))
+ [owner-tvarsT mappings] (jvm-type-var-mappings owner-tvars method-tvars)]
+ (do ////.monad
+ [inputsT (|> (Constructor::getGenericParameterTypes constructor)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ exceptionsT (|> (Constructor::getGenericExceptionTypes constructor)
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))
+ #let [objectT (#.Primitive (Class::getName owner) owner-tvarsT)
+ constructorT (<| (type.univ-q (dictionary.size mappings))
+ (type.function inputsT)
+ objectT)]]
+ (wrap [constructorT exceptionsT]))))
+
+(type: Evaluation
+ (#Pass Method-Signature)
+ (#Hint Method-Signature)
+ #Fail)
+
+(template [<name> <tag>]
+ [(def: <name>
+ (-> Evaluation (Maybe Method-Signature))
+ (|>> (case> (<tag> output)
+ (#.Some output)
+
+ _
+ #.None)))]
+
+ [pass! #Pass]
+ [hint! #Hint]
+ )
+
+(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)
+ candidates (|> class
+ Class::getDeclaredMethods
+ array.to-list
+ (monad.map @ (: (-> 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)))))))]
+ (case (list.search-all pass! candidates)
+ (#.Cons method #.Nil)
+ (wrap method)
+
+ #.Nil
+ (/////analysis.throw no-candidates [class-name method-name (list.search-all hint! candidates)])
+
+ candidates
+ (/////analysis.throw too-many-candidates [class-name method-name candidates]))))
+
+(def: constructor-method "<init>")
+
+(def: (constructor-candidate class-name arg-classes)
+ (-> Text (List Text) (Operation Method-Signature))
+ (do ////.monad
+ [class (load-class class-name)
+ candidates (|> class
+ Class::getConstructors
+ array.to-list
+ (monad.map @ (function (_ constructor)
+ (do @
+ [passes? (check-constructor class arg-classes constructor)]
+ (:: @ map
+ (if passes? (|>> #Pass) (|>> #Hint))
+ (constructor-signature constructor))))))]
+ (case (list.search-all pass! candidates)
+ (#.Cons constructor #.Nil)
+ (wrap constructor)
+
+ #.Nil
+ (/////analysis.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)])
+
+ candidates
+ (/////analysis.throw too-many-candidates [class-name ..constructor-method candidates]))))
+
+(def: typed-input
+ (Syntax [Text Code])
+ (s.tuple (p.and s.text s.any)))
+
+(def: (decorate-inputs typesT inputsA)
+ (-> (List Text) (List Analysis) (List Analysis))
+ (|> inputsA
+ (list.zip2 (list@map /////analysis.text typesT))
+ (list@map (function (_ [type value])
+ (/////analysis.tuple (list type value))))))
+
+(def: invoke::static
+ Handler
+ (..custom [($_ p.and ..member (p.some ..typed-input))
+ (function (_ extension-name analyse [[class method] argsTC])
+ (do ////.monad
+ [#let [argsT (list@map product.left argsTC)]
+ [methodT exceptionsT] (method-candidate class method #Static argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))
+ outputJC (check-jvm outputT)]
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ (decorate-inputs argsT argsA))))))]))
+
+(def: invoke::virtual
+ Handler
+ (..custom [($_ p.and ..member s.any (p.some ..typed-input))
+ (function (_ extension-name analyse [[class method] objectC argsTC])
+ (do ////.monad
+ [#let [argsT (list@map product.left argsTC)]
+ [methodT exceptionsT] (method-candidate class method #Virtual argsT)
+ [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
+ #let [[objectA argsA] (case allA
+ (#.Cons objectA argsA)
+ [objectA argsA]
+
+ _
+ (undefined))]
+ outputJC (check-jvm outputT)]
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ objectA
+ (decorate-inputs argsT argsA))))))]))
+
+(def: invoke::special
+ Handler
+ (..custom [($_ p.and ..member s.any (p.some ..typed-input))
+ (function (_ extension-name analyse [[class method] objectC argsTC])
+ (do ////.monad
+ [#let [argsT (list@map product.left argsTC)]
+ [methodT exceptionsT] (method-candidate class method #Special argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
+ outputJC (check-jvm outputT)]
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ (decorate-inputs argsT argsA))))))]))
+
+(def: invoke::interface
+ Handler
+ (..custom [($_ p.and ..member s.any (p.some ..typed-input))
+ (function (_ extension-name analyse [[class-name method] objectC argsTC])
+ (do ////.monad
+ [#let [argsT (list@map product.left argsTC)]
+ class (load-class class-name)
+ _ (////.assert non-interface class-name
+ (Modifier::isInterface (Class::getModifiers class)))
+ [methodT exceptionsT] (method-candidate class-name method #Interface argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
+ outputJC (check-jvm outputT)]
+ (wrap (#/////analysis.Extension extension-name
+ (list& (/////analysis.text class-name)
+ (/////analysis.text method)
+ (/////analysis.text outputJC)
+ (decorate-inputs argsT argsA))))))]))
+
+(def: invoke::constructor
+ (..custom [($_ p.and s.text (p.some ..typed-input))
+ (function (_ extension-name analyse [class argsTC])
+ (do ////.monad
+ [#let [argsT (list@map product.left argsTC)]
+ [methodT exceptionsT] (constructor-candidate class argsT)
+ [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))]
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (decorate-inputs argsT argsA))))))]))
+
+(def: bundle::member
+ Bundle
+ (<| (///bundle.prefix "member")
+ (|> ///bundle.empty
+ (dictionary.merge (<| (///bundle.prefix "static")
+ (|> ///bundle.empty
+ (///bundle.install "get" static::get)
+ (///bundle.install "put" static::put))))
+ (dictionary.merge (<| (///bundle.prefix "virtual")
+ (|> ///bundle.empty
+ (///bundle.install "get" virtual::get)
+ (///bundle.install "put" virtual::put))))
+ (dictionary.merge (<| (///bundle.prefix "invoke")
+ (|> ///bundle.empty
+ (///bundle.install "static" invoke::static)
+ (///bundle.install "virtual" invoke::virtual)
+ (///bundle.install "special" invoke::special)
+ (///bundle.install "interface" invoke::interface)
+ (///bundle.install "constructor" invoke::constructor)
+ )))
+ )))
+
+(def: #export bundle
+ Bundle
+ (<| (///bundle.prefix "jvm")
+ (|> ///bundle.empty
+ (dictionary.merge bundle::conversion)
+ (dictionary.merge bundle::int)
+ (dictionary.merge bundle::long)
+ (dictionary.merge bundle::float)
+ (dictionary.merge bundle::double)
+ (dictionary.merge bundle::char)
+ (dictionary.merge bundle::array)
+ (dictionary.merge bundle::object)
+ (dictionary.merge bundle::member)
+ )))
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-11 19:32:54 +0000