aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux')
-rw-r--r--stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux1271
1 files changed, 1271 insertions, 0 deletions
diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux
new file mode 100644
index 000000000..0edd20d2b
--- /dev/null
+++ b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux
@@ -0,0 +1,1271 @@
+(.module:
+ [lux (#- char int)
+ [control
+ ["." monad (#+ do)]
+ ["p" parser]
+ ["ex" exception (#+ exception:)]
+ pipe]
+ [data
+ ["e" error]
+ ["." maybe]
+ ["." product]
+ ["." text ("text/." Equivalence<Text>)
+ format]
+ [collection
+ ["." list ("list/." Fold<List> Functor<List> Monoid<List>)]
+ ["." array]
+ ["." dictionary (#+ Dictionary)]]]
+ ["." type
+ ["." check]]
+ ["." macro
+ ["s" syntax]]
+ ["." host]]
+ [//
+ ["." common]
+ ["/." //
+ ["." bundle]
+ ["//." // ("operation/." Monad<Operation>)
+ ["." analysis (#+ Analysis Operation Handler Bundle)
+ [".A" type]
+ [".A" inference]]]]]
+ )
+
+(type: Method-Signature
+ {#method Type
+ #exceptions (List Type)})
+
+(host.import: #long java/lang/reflect/Type
+ (getTypeName [] String))
+
+(do-template [<name>]
+ [(exception: #export (<name> {jvm-type java/lang/reflect/Type})
+ (ex.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]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {type Type})
+ (%type type))]
+
+ [non-object]
+ [non-array]
+ [non-jvm-type]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {name Text})
+ name)]
+
+ [non-interface]
+ [non-throwable]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {message Text})
+ message)]
+
+ [unknown-class]
+ [primitives-cannot-have-type-parameters]
+ [primitives-are-not-objects]
+ [invalid-type-for-array-element]
+
+ [unknown-field]
+ [mistaken-field-owner]
+ [not-a-virtual-field]
+ [not-a-static-field]
+ [cannot-set-a-final-field]
+
+ [cannot-cast]
+
+ [cannot-possibly-be-an-instance]
+
+ [unknown-type-var]
+ [type-parameter-mismatch]
+ [cannot-correspond-type-with-a-class]
+ )
+
+(do-template [<name>]
+ [(exception: #export (<name> {class Text}
+ {method Text}
+ {hints (List Method-Signature)})
+ (ex.report ["Class" class]
+ ["Method" method]
+ ["Hints" (|> hints
+ (list/map (|>> product.left %type (format "\n\t")))
+ (text.join-with ""))]))]
+
+ [no-candidates]
+ [too-many-candidates]
+ )
+
+(do-template [<name> <class>]
+ [(def: #export <name> Type (#.Primitive <class> (list)))]
+
+ ## 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 "convert")
+ (|> bundle.empty
+ (bundle.install "double-to-float" (common.unary Double Float))
+ (bundle.install "double-to-int" (common.unary Double Integer))
+ (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 Integer))
+ (bundle.install "float-to-long" (common.unary Float Long))
+ (bundle.install "int-to-byte" (common.unary Integer Byte))
+ (bundle.install "int-to-char" (common.unary Integer Character))
+ (bundle.install "int-to-double" (common.unary Integer Double))
+ (bundle.install "int-to-float" (common.unary Integer Float))
+ (bundle.install "int-to-long" (common.unary Integer Long))
+ (bundle.install "int-to-short" (common.unary Integer 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 Integer))
+ (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 Character Byte))
+ (bundle.install "char-to-short" (common.unary Character Short))
+ (bundle.install "char-to-int" (common.unary Character Integer))
+ (bundle.install "char-to-long" (common.unary Character Long))
+ (bundle.install "byte-to-long" (common.unary Byte Long))
+ (bundle.install "short-to-long" (common.unary Short Long))
+ )))
+
+(do-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" Integer]
+ [bundle::long "long" Long]
+ )
+
+(do-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 Character Character Bit))
+ (bundle.install "<" (common.binary Character Character 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<Text>)))
+
+(def: array::length
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list arrayC))
+ (do ////.Monad<Operation>
+ [_ (typeA.infer Nat)
+ [var-id varT] (typeA.with-env check.var)
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))]
+ (wrap (#analysis.Extension extension-name (list arrayA))))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: array::new
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list lengthC))
+ (do ////.Monad<Operation>
+ [lengthA (typeA.with-type Nat
+ (analyse lengthC))
+ expectedT (///.lift macro.expected-type)
+ [level elem-class] (: (Operation [Nat Text])
+ (loop [analysisT expectedT
+ level +0]
+ (case analysisT
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (recur outputT level)
+
+ #.None
+ (////.throw non-array expectedT))
+
+ (^ (#.Primitive "#Array" (list elemT)))
+ (recur elemT (inc level))
+
+ (#.Primitive class _)
+ (wrap [level class])
+
+ _
+ (////.throw non-array expectedT))))
+ _ (if (n/> +0 level)
+ (wrap [])
+ (////.throw non-array expectedT))]
+ (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level))
+ (analysis.text elem-class)
+ lengthA))))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: (check-jvm objectT)
+ (-> Type (Operation Text))
+ (case objectT
+ (#.Primitive name _)
+ (operation/wrap name)
+
+ (#.Named name unnamed)
+ (check-jvm unnamed)
+
+ (#.Var id)
+ (operation/wrap "java.lang.Object")
+
+ (^template [<tag>]
+ (<tag> env unquantified)
+ (check-jvm unquantified))
+ ([#.UnivQ]
+ [#.ExQ])
+
+ (#.Apply inputT funcT)
+ (case (type.apply (list inputT) funcT)
+ (#.Some outputT)
+ (check-jvm outputT)
+
+ #.None
+ (////.throw non-object objectT))
+
+ _
+ (////.throw non-object objectT)))
+
+(def: (check-object objectT)
+ (-> Type (Operation Text))
+ (do ////.Monad<Operation>
+ [name (check-jvm objectT)]
+ (if (dictionary.contains? name boxes)
+ (////.throw primitives-are-not-objects name)
+ (operation/wrap name))))
+
+(def: (box-array-element-type elemT)
+ (-> Type (Operation [Type Text]))
+ (case elemT
+ (#.Primitive name #.Nil)
+ (let [boxed-name (|> (dictionary.get name boxes)
+ (maybe.default name))]
+ (operation/wrap [(#.Primitive boxed-name #.Nil)
+ boxed-name]))
+
+ (#.Primitive name _)
+ (if (dictionary.contains? name boxes)
+ (////.throw primitives-cannot-have-type-parameters name)
+ (operation/wrap [elemT name]))
+
+ _
+ (////.throw invalid-type-for-array-element (%type elemT))))
+
+(def: array::read
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list arrayC idxC))
+ (do ////.Monad<Operation>
+ [[var-id varT] (typeA.with-env check.var)
+ _ (typeA.infer varT)
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ ?elemT (typeA.with-env
+ (check.read var-id))
+ [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (typeA.with-type Nat
+ (analyse idxC))]
+ (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA))))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
+
+(def: array::write
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list arrayC idxC valueC))
+ (do ////.Monad<Operation>
+ [[var-id varT] (typeA.with-env check.var)
+ _ (typeA.infer (type (Array varT)))
+ arrayA (typeA.with-type (type (Array varT))
+ (analyse arrayC))
+ ?elemT (typeA.with-env
+ (check.read var-id))
+ [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT))
+ idxA (typeA.with-type Nat
+ (analyse idxC))
+ valueA (typeA.with-type valueT
+ (analyse valueC))]
+ (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA))))
+
+ _
+ (////.throw bundle.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<Operation>
+ [expectedT (///.lift macro.expected-type)
+ _ (check-object expectedT)]
+ (wrap (#analysis.Extension extension-name (list))))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +0 (list.size args)]))))
+
+(def: object::null?
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list objectC))
+ (do ////.Monad<Operation>
+ [_ (typeA.infer Bit)
+ [objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ _ (check-object objectT)]
+ (wrap (#analysis.Extension extension-name (list objectA))))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +1 (list.size args)]))))
+
+(def: object::synchronized
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list monitorC exprC))
+ (do ////.Monad<Operation>
+ [[monitorT monitorA] (typeA.with-inference
+ (analyse monitorC))
+ _ (check-object monitorT)
+ exprA (analyse exprC)]
+ (wrap (#analysis.Extension extension-name (list monitorA exprA))))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
+
+(host.import: java/lang/Object
+ (equals [Object] boolean))
+
+(host.import: java/lang/ClassLoader)
+
+(host.import: java/lang/reflect/GenericArrayType
+ (getGenericComponentType [] java/lang/reflect/Type))
+
+(host.import: java/lang/reflect/ParameterizedType
+ (getRawType [] java/lang/reflect/Type)
+ (getActualTypeArguments [] (Array java/lang/reflect/Type)))
+
+(host.import: (java/lang/reflect/TypeVariable d)
+ (getName [] String)
+ (getBounds [] (Array java/lang/reflect/Type)))
+
+(host.import: (java/lang/reflect/WildcardType d)
+ (getLowerBounds [] (Array java/lang/reflect/Type))
+ (getUpperBounds [] (Array java/lang/reflect/Type)))
+
+(host.import: java/lang/reflect/Modifier
+ (#static isStatic [int] boolean)
+ (#static isFinal [int] boolean)
+ (#static isInterface [int] boolean)
+ (#static isAbstract [int] boolean))
+
+(host.import: java/lang/reflect/Field
+ (getDeclaringClass [] (java/lang/Class Object))
+ (getModifiers [] int)
+ (getGenericType [] java/lang/reflect/Type))
+
+(host.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)))
+
+(host.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)))
+
+(host.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<Operation>
+ []
+ (case (Class::forName [name])
+ (#e.Success [class])
+ (wrap class)
+
+ (#e.Error error)
+ (////.throw unknown-class name))))
+
+(def: (sub-class? super sub)
+ (-> Text Text (Operation Bit))
+ (do ////.Monad<Operation>
+ [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<Operation>
+ [_ (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 [])
+ (////.throw non-throwable exception-class)))]
+ (wrap (#analysis.Extension extension-name (list exceptionA))))
+
+ _
+ (////.throw bundle.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<Operation>
+ [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list)))))
+ _ (load-class class)]
+ (wrap (#analysis.Extension extension-name (list (analysis.text class)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))
+
+ _
+ (////.throw bundle.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<Operation>
+ [_ (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))))
+ (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
+
+(def: (java-type-to-class jvm-type)
+ (-> java/lang/reflect/Type (Operation Text))
+ (cond (host.instance? Class jvm-type)
+ (operation/wrap (Class::getName [] (:coerce Class jvm-type)))
+
+ (host.instance? ParameterizedType jvm-type)
+ (java-type-to-class (ParameterizedType::getRawType [] (:coerce ParameterizedType jvm-type)))
+
+ ## else
+ (////.throw cannot-convert-to-a-class jvm-type)))
+
+(type: Mappings
+ (Dictionary Text Type))
+
+(def: fresh-mappings Mappings (dictionary.new text.Hash<Text>))
+
+(def: (java-type-to-lux-type mappings java-type)
+ (-> Mappings java/lang/reflect/Type (Operation Type))
+ (cond (host.instance? TypeVariable java-type)
+ (let [var-name (TypeVariable::getName [] (:coerce TypeVariable java-type))]
+ (case (dictionary.get var-name mappings)
+ (#.Some var-type)
+ (operation/wrap var-type)
+
+ #.None
+ (////.throw unknown-type-var var-name)))
+
+ (host.instance? WildcardType java-type)
+ (let [java-type (:coerce WildcardType 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)
+
+ _
+ (operation/wrap Any)))
+
+ (host.instance? Class java-type)
+ (let [java-type (:coerce (Class Object) java-type)
+ class-name (Class::getName [] java-type)]
+ (operation/wrap (case (array.size (Class::getTypeParameters [] java-type))
+ +0
+ (#.Primitive class-name (list))
+
+ arity
+ (|> (list.n/range +0 (dec arity))
+ list.reverse
+ (list/map (|>> (n/* +2) inc #.Parameter))
+ (#.Primitive class-name)
+ (type.univ-q arity)))))
+
+ (host.instance? ParameterizedType java-type)
+ (let [java-type (:coerce ParameterizedType java-type)
+ raw (ParameterizedType::getRawType [] java-type)]
+ (if (host.instance? Class raw)
+ (do ////.Monad<Operation>
+ [paramsT (|> java-type
+ (ParameterizedType::getActualTypeArguments [])
+ array.to-list
+ (monad.map @ (java-type-to-lux-type mappings)))]
+ (operation/wrap (#.Primitive (Class::getName [] (:coerce (Class Object) raw))
+ paramsT)))
+ (////.throw jvm-type-is-not-a-class raw)))
+
+ (host.instance? GenericArrayType java-type)
+ (do ////.Monad<Operation>
+ [innerT (|> (:coerce GenericArrayType java-type)
+ (GenericArrayType::getGenericComponentType [])
+ (java-type-to-lux-type mappings))]
+ (wrap (#.Primitive "#Array" (list innerT))))
+
+ ## else
+ (////.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))
+ (////.throw cannot-correspond-type-with-a-class
+ (format "Class = " class-name "\n"
+ "Type = " (%type type)))
+
+ (not (n/= num-class-params num-type-params))
+ (////.throw type-parameter-mismatch
+ (format "Expected: " (%i (.int num-class-params)) "\n"
+ " Actual: " (%i (.int num-type-params)) "\n"
+ " Class: " class-name "\n"
+ " Type: " (%type type)))
+
+ ## else
+ (operation/wrap (|> params
+ (list.zip2 (list/map (TypeVariable::getName []) class-params))
+ (dictionary.from-list text.Hash<Text>)))
+ ))
+
+ _
+ (////.throw non-jvm-type type)))
+
+(def: object::cast
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list valueC))
+ (do ////.Monad<Operation>
+ [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 "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")
+ (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
+ (////.throw cannot-cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n")))
+ ))))))]
+ (if can-cast?
+ (wrap (#analysis.Extension extension-name (list (analysis.text from-name)
+ (analysis.text to-name)
+ valueA)))
+ (////.throw cannot-cast (format "From class/primitive: " from-name "\n"
+ " To class/primitive: " to-name "\n"
+ " For value: " (%code valueC) "\n"))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(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<Operation>
+ [class (load-class class-name)]
+ (case (Class::getDeclaredField [field-name] class)
+ (#e.Success field)
+ (let [owner (Field::getDeclaringClass [] field)]
+ (if (is? owner class)
+ (wrap [class field])
+ (////.throw mistaken-field-owner
+ (format " Field: " field-name "\n"
+ " Owner Class: " (Class::getName [] owner) "\n"
+ "Target Class: " class-name "\n"))))
+
+ (#e.Error _)
+ (////.throw unknown-field (format class-name "#" field-name)))))
+
+(def: (static-field class-name field-name)
+ (-> Text Text (Operation [Type Bit]))
+ (do ////.Monad<Operation>
+ [[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)]
+ (wrap [fieldT (Modifier::isFinal [modifiers])])))
+ (////.throw not-a-static-field (format class-name "#" field-name)))))
+
+(def: (virtual-field class-name field-name objectT)
+ (-> Text Text Type (Operation [Type Bit]))
+ (do ////.Monad<Operation>
+ [[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)) "\n"
+ " Actual: " (%i (.int num-vars)) "\n"
+ " Class: " _class-name "\n"
+ " Type: " (%type objectT))
+ (n/= num-params num-vars))]
+ (wrap (|> (list.zip2 var-names _class-params)
+ (dictionary.from-list text.Hash<Text>))))
+
+ _
+ (////.throw non-object objectT)))
+ fieldT (java-type-to-lux-type mappings fieldJT)]
+ (wrap [fieldT (Modifier::isFinal [modifiers])]))
+ (////.throw not-a-virtual-field (format class-name "#" field-name)))))
+
+(def: static::get
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list classC fieldC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do ////.Monad<Operation>
+ [[fieldT final?] (static-field class field)]
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +2 (list.size args)]))))
+
+(def: static::put
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list classC fieldC valueC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do ////.Monad<Operation>
+ [_ (typeA.infer Any)
+ [fieldT final?] (static-field class field)
+ _ (////.assert cannot-set-a-final-field (format class "#" field)
+ (not final?))
+ valueA (typeA.with-type fieldT
+ (analyse valueC))]
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +3 (list.size args)]))))
+
+(def: virtual::get
+ Handler
+ (function (_ extension-name analyse args)
+ (case args
+ (^ (list classC fieldC objectC))
+ (case [classC fieldC]
+ [[_ (#.Text class)] [_ (#.Text field)]]
+ (do ////.Monad<Operation>
+ [[objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ [fieldT final?] (virtual-field class field objectT)]
+ (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))
+
+ _
+ (////.throw bundle.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<Operation>
+ [[objectT objectA] (typeA.with-inference
+ (analyse objectC))
+ _ (typeA.infer objectT)
+ [fieldT final?] (virtual-field class field objectT)
+ _ (////.assert cannot-set-a-final-field (format 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))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))
+
+ _
+ (////.throw bundle.incorrect-arity [extension-name +4 (list.size args)]))))
+
+(def: (java-type-to-parameter type)
+ (-> java/lang/reflect/Type (Operation Text))
+ (cond (host.instance? Class type)
+ (operation/wrap (Class::getName [] (:coerce Class type)))
+
+ (host.instance? ParameterizedType type)
+ (java-type-to-parameter (ParameterizedType::getRawType [] (:coerce ParameterizedType type)))
+
+ (or (host.instance? TypeVariable type)
+ (host.instance? WildcardType type))
+ (operation/wrap "java.lang.Object")
+
+ (host.instance? GenericArrayType type)
+ (do ////.Monad<Operation>
+ [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:coerce GenericArrayType type)))]
+ (wrap (format componentP "[]")))
+
+ ## else
+ (////.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<Operation>
+ [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<Operation>
+ [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: (type-vars amount offset)
+ (-> Nat Nat (List Type))
+ (if (n/= +0 amount)
+ (list)
+ (|> (list.n/range offset (|> amount dec (n/+ offset)))
+ (list/map idx-to-parameter))))
+
+(def: (method-signature method-style method)
+ (-> Method-Style Method (Operation Method-Signature))
+ (let [owner (Method::getDeclaringClass [] method)
+ owner-name (Class::getName [] owner)
+ 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 [])))
+ num-owner-tvars (list.size owner-tvars)
+ num-method-tvars (list.size method-tvars)
+ all-tvars (list/compose owner-tvars method-tvars)
+ num-all-tvars (list.size all-tvars)
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ method-tvarsT (type-vars num-method-tvars num-owner-tvars)
+ mappings (: Mappings
+ (if (list.empty? all-tvars)
+ fresh-mappings
+ (|> (list/compose owner-tvarsT method-tvarsT)
+ list.reverse
+ (list.zip2 all-tvars)
+ (dictionary.from-list text.Hash<Text>))))]
+ (do ////.Monad<Operation>
+ [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 num-all-tvars)
+ (type.function (case method-style
+ #Static
+ inputsT
+
+ _
+ (list& (#.Primitive owner-name (list.reverse owner-tvarsT))
+ inputsT)))
+ outputT)]]
+ (wrap [methodT exceptionsT]))))
+
+(type: Evaluation
+ (#Pass Method-Signature)
+ (#Hint Method-Signature)
+ #Fail)
+
+(do-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<Operation>
+ [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)
+ #.Nil
+ (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)])
+
+ (#.Cons method #.Nil)
+ (wrap method)
+
+ candidates
+ (////.throw too-many-candidates [class-name method-name candidates]))))
+
+(def: (constructor-signature constructor)
+ (-> (Constructor Object) (Operation Method-Signature))
+ (let [owner (Constructor::getDeclaringClass [] constructor)
+ owner-name (Class::getName [] owner)
+ owner-tvars (|> (Class::getTypeParameters [] owner)
+ array.to-list
+ (list/map (TypeVariable::getName [])))
+ constructor-tvars (|> (Constructor::getTypeParameters [] constructor)
+ array.to-list
+ (list/map (TypeVariable::getName [])))
+ num-owner-tvars (list.size owner-tvars)
+ all-tvars (list/compose owner-tvars constructor-tvars)
+ num-all-tvars (list.size all-tvars)
+ owner-tvarsT (type-vars num-owner-tvars +0)
+ constructor-tvarsT (type-vars num-all-tvars num-owner-tvars)
+ mappings (: Mappings
+ (if (list.empty? all-tvars)
+ fresh-mappings
+ (|> (list/compose owner-tvarsT constructor-tvarsT)
+ list.reverse
+ (list.zip2 all-tvars)
+ (dictionary.from-list text.Hash<Text>))))]
+ (do ////.Monad<Operation>
+ [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 owner-name (list.reverse owner-tvarsT))
+ constructorT (<| (type.univ-q num-all-tvars)
+ (type.function inputsT)
+ objectT)]]
+ (wrap [constructorT exceptionsT]))))
+
+(def: constructor-method "<init>")
+
+(def: (constructor-candidate class-name arg-classes)
+ (-> Text (List Text) (Operation Method-Signature))
+ (do ////.Monad<Operation>
+ [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)
+ #.Nil
+ (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)])
+
+ (#.Cons constructor #.Nil)
+ (wrap constructor)
+
+ candidates
+ (////.throw too-many-candidates [class-name ..constructor-method candidates]))))
+
+(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.product-analysis (list type value))))))
+
+(def: invoke::static
+ Handler
+ (function (_ extension-name analyse args)
+ (case (: (e.Error [Text Text (List [Text Code])])
+ (s.run args ($_ p.seq s.text s.text (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class method argsTC])
+ (do ////.Monad<Operation>
+ [#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)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(def: invoke::virtual
+ Handler
+ (function (_ extension-name analyse args)
+ (case (: (e.Error [Text Text Code (List [Text Code])])
+ (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class method objectC argsTC])
+ (do ////.Monad<Operation>
+ [#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)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(def: invoke::special
+ Handler
+ (function (_ extension-name analyse args)
+ (case (: (e.Error [(List Code) [Text Text Code (List [Text Code]) Any]])
+ (p.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))) s.end!)))
+ (#e.Success [_ [class method objectC argsTC _]])
+ (do ////.Monad<Operation>
+ [#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)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(def: invoke::interface
+ Handler
+ (function (_ extension-name analyse args)
+ (case (: (e.Error [Text Text Code (List [Text Code])])
+ (s.run args ($_ p.seq s.text s.text s.any (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class-name method objectC argsTC])
+ (do ////.Monad<Operation>
+ [#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)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(def: invoke::constructor
+ Handler
+ (function (_ extension-name analyse args)
+ (case (: (e.Error [Text (List [Text Code])])
+ (s.run args ($_ p.seq s.text (p.some (s.tuple (p.seq s.text s.any))))))
+ (#e.Success [class argsTC])
+ (do ////.Monad<Operation>
+ [#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)))))
+
+ _
+ (////.throw bundle.invalid-syntax extension-name))))
+
+(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 2024-09-13 22:22:21 +0000