From 9c495323d4fb683e2293d1230e37a566efbd7eb3 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Fri, 19 Apr 2019 00:19:59 -0400 Subject: Re-named "lux/tool/compiler/phase/extension/analysis/host.old.lux" to "lux/tool/compiler/phase/extension/analysis/jvm.lux". --- .../lux/tool/compiler/phase/extension/analysis.lux | 31 +- .../compiler/phase/extension/analysis/host.old.lux | 1305 -------------------- .../tool/compiler/phase/extension/analysis/jvm.lux | 1305 ++++++++++++++++++++ 3 files changed, 1323 insertions(+), 1318 deletions(-) delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux index 15e525d5d..446e769f1 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux @@ -1,17 +1,22 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [//// - [default - [evaluation (#+ Eval)]] - [analysis (#+ Bundle)]] - [/ - ["." common] - ["." host]]) +(.`` (.module: + [lux #* + [data + [collection + ["." dictionary]]] + [tool + [compiler + ["@" host]]]] + [//// + [default + [evaluation (#+ Eval)]] + [analysis (#+ Bundle)]] + [/ + ["." common] + ["." (~~ (.for {"{old}" jvm + "JVM" jvm}))]])) (def: #export (bundle eval) (-> Eval Bundle) - (dictionary.merge host.bundle + (dictionary.merge (`` (for {(~~ (static @.old)) jvm.bundle + (~~ (static @.jvm)) jvm.bundle})) (common.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux deleted file mode 100644 index 998590d1c..000000000 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux +++ /dev/null @@ -1,1305 +0,0 @@ -(.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 [] - [(exception: #export ( {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 [] - [(exception: #export ( {type Type}) - (exception.report - ["Type" (%type type)]))] - - [non-object] - [non-array] - [non-jvm-type] - ) - -(template [] - [(exception: #export ( {class Text}) - (exception.report - ["Class" (%t class)]))] - - [unknown-class] - [non-interface] - [non-throwable] - ) - -(template [] - [(exception: #export ( {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 [] - [(exception: #export ( {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 [] - [(exception: #export ( {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 [ ] - [(type: #export (primitive ))] - - ## 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 [ ] - [(def: - Bundle - (<| (///bundle.prefix ) - (|> ///bundle.empty - (///bundle.install "+" (//common.binary )) - (///bundle.install "-" (//common.binary )) - (///bundle.install "*" (//common.binary )) - (///bundle.install "/" (//common.binary )) - (///bundle.install "%" (//common.binary )) - (///bundle.install "=" (//common.binary Bit)) - (///bundle.install "<" (//common.binary Bit)) - (///bundle.install "and" (//common.binary )) - (///bundle.install "or" (//common.binary )) - (///bundle.install "xor" (//common.binary )) - (///bundle.install "shl" (//common.binary Integer )) - (///bundle.install "shr" (//common.binary Integer )) - (///bundle.install "ushr" (//common.binary Integer )) - )))] - - [bundle::int "int" ..long] - [bundle::long "long" ..long] - ) - -(template [ ] - [(def: - Bundle - (<| (///bundle.prefix ) - (|> ///bundle.empty - (///bundle.install "+" (//common.binary )) - (///bundle.install "-" (//common.binary )) - (///bundle.install "*" (//common.binary )) - (///bundle.install "/" (//common.binary )) - (///bundle.install "%" (//common.binary )) - (///bundle.install "=" (//common.binary Bit)) - (///bundle.install "<" (//common.binary 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 [] - ( 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 [ ] - (^or [ ] - [ ]) - (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 [ ] - [(def: - (-> Evaluation (Maybe Method-Signature)) - (|>> (case> ( 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 "") - -(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) - ))) 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 [] + [(exception: #export ( {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 [] + [(exception: #export ( {type Type}) + (exception.report + ["Type" (%type type)]))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(template [] + [(exception: #export ( {class Text}) + (exception.report + ["Class" (%t class)]))] + + [unknown-class] + [non-interface] + [non-throwable] + ) + +(template [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 [] + [(exception: #export ( {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 [ ] + [(type: #export (primitive ))] + + ## 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 [ ] + [(def: + Bundle + (<| (///bundle.prefix ) + (|> ///bundle.empty + (///bundle.install "+" (//common.binary )) + (///bundle.install "-" (//common.binary )) + (///bundle.install "*" (//common.binary )) + (///bundle.install "/" (//common.binary )) + (///bundle.install "%" (//common.binary )) + (///bundle.install "=" (//common.binary Bit)) + (///bundle.install "<" (//common.binary Bit)) + (///bundle.install "and" (//common.binary )) + (///bundle.install "or" (//common.binary )) + (///bundle.install "xor" (//common.binary )) + (///bundle.install "shl" (//common.binary Integer )) + (///bundle.install "shr" (//common.binary Integer )) + (///bundle.install "ushr" (//common.binary Integer )) + )))] + + [bundle::int "int" ..long] + [bundle::long "long" ..long] + ) + +(template [ ] + [(def: + Bundle + (<| (///bundle.prefix ) + (|> ///bundle.empty + (///bundle.install "+" (//common.binary )) + (///bundle.install "-" (//common.binary )) + (///bundle.install "*" (//common.binary )) + (///bundle.install "/" (//common.binary )) + (///bundle.install "%" (//common.binary )) + (///bundle.install "=" (//common.binary Bit)) + (///bundle.install "<" (//common.binary 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 [] + ( 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 [ ] + (^or [ ] + [ ]) + (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 [ ] + [(def: + (-> Evaluation (Maybe Method-Signature)) + (|>> (case> ( 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 "") + +(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) + ))) -- cgit v1.2.3