(.module: [lux #- char int] (lux (control [monad #+ do] ["p" parser] ["ex" exception #+ exception:]) (concurrency ["A" atom]) (data ["e" error] [maybe] [product] [bool "bool/" Eq] [text "text/" Eq] (text format ["l" lexer]) (coll [list "list/" Fold Functor Monoid] [array] (dictionary ["dict" unordered #+ Dict]))) [macro "macro/" Monad] (macro [code] ["s" syntax]) [lang] (lang [type] (type ["tc" check]) [".L" analysis #+ Analysis] (analysis [".A" type] [".A" inference])) [host]) ["/" //common] [///] ) (host.import #long java/lang/reflect/Type (getTypeName [] String)) (def: jvm-type-name (-> java/lang/reflect/Type Text) (java/lang/reflect/Type::getTypeName [])) (exception: #export (jvm-type-is-not-a-class {jvm-type java/lang/reflect/Type}) (jvm-type-name jvm-type)) (do-template [] [(exception: #export ( {type Type}) (%type type))] [non-object] [non-array] [non-jvm-type] ) (do-template [] [(exception: #export ( {name Text}) name)] [non-interface] [non-throwable] ) (do-template [] [(exception: #export ( {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-Virtual-Field] [Not-Static-Field] [Cannot-Set-Final-Field] [No-Candidates] [Too-Many-Candidates] [Cannot-Cast] [Cannot-Possibly-Be-Instance] [Cannot-Convert-To-Class] [Cannot-Convert-To-Parameter] [Cannot-Convert-To-Lux-Type] [Unknown-Type-Var] [Type-Parameter-Mismatch] [Cannot-Correspond-Type-With-Class] ) (do-template [ ] [(def: #export Type (#.Primitive (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: conversion-procs /.Bundle (<| (/.prefix "convert") (|> (dict.new text.Hash) (/.install "double-to-float" (/.unary Double Float)) (/.install "double-to-int" (/.unary Double Integer)) (/.install "double-to-long" (/.unary Double Long)) (/.install "float-to-double" (/.unary Float Double)) (/.install "float-to-int" (/.unary Float Integer)) (/.install "float-to-long" (/.unary Float Long)) (/.install "int-to-byte" (/.unary Integer Byte)) (/.install "int-to-char" (/.unary Integer Character)) (/.install "int-to-double" (/.unary Integer Double)) (/.install "int-to-float" (/.unary Integer Float)) (/.install "int-to-long" (/.unary Integer Long)) (/.install "int-to-short" (/.unary Integer Short)) (/.install "long-to-double" (/.unary Long Double)) (/.install "long-to-float" (/.unary Long Float)) (/.install "long-to-int" (/.unary Long Integer)) (/.install "long-to-short" (/.unary Long Short)) (/.install "long-to-byte" (/.unary Long Byte)) (/.install "char-to-byte" (/.unary Character Byte)) (/.install "char-to-short" (/.unary Character Short)) (/.install "char-to-int" (/.unary Character Integer)) (/.install "char-to-long" (/.unary Character Long)) (/.install "byte-to-long" (/.unary Byte Long)) (/.install "short-to-long" (/.unary Short Long)) ))) (do-template [ ] [(def: /.Bundle (<| (/.prefix ) (|> (dict.new text.Hash) (/.install "+" (/.binary )) (/.install "-" (/.binary )) (/.install "*" (/.binary )) (/.install "/" (/.binary )) (/.install "%" (/.binary )) (/.install "=" (/.binary Boolean)) (/.install "<" (/.binary Boolean)) (/.install "and" (/.binary )) (/.install "or" (/.binary )) (/.install "xor" (/.binary )) (/.install "shl" (/.binary Integer )) (/.install "shr" (/.binary Integer )) (/.install "ushr" (/.binary Integer )) )))] [int-procs "int" Integer] [long-procs "long" Long] ) (do-template [ ] [(def: /.Bundle (<| (/.prefix ) (|> (dict.new text.Hash) (/.install "+" (/.binary )) (/.install "-" (/.binary )) (/.install "*" (/.binary )) (/.install "/" (/.binary )) (/.install "%" (/.binary )) (/.install "=" (/.binary Boolean)) (/.install "<" (/.binary Boolean)) )))] [float-procs "float" Float] [double-procs "double" Double] ) (def: char-procs /.Bundle (<| (/.prefix "char") (|> (dict.new text.Hash) (/.install "=" (/.binary Character Character Boolean)) (/.install "<" (/.binary Character Character Boolean)) ))) (def: #export boxes (Dict 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"]) (dict.from-list text.Hash))) (def: (array//length proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list arrayC)) (do macro.Monad [_ (typeA.infer Nat) [var-id varT] (typeA.with-env tc.var) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC))] (wrap (#analysisL.Extension proc (list arrayA)))) _ (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) (def: (array//new proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list lengthC)) (do macro.Monad [lengthA (typeA.with-type Nat (analyse lengthC)) expectedT macro.expected-type [level elem-class] (: (Meta [Nat Text]) (loop [analysisT expectedT level +0] (case analysisT (#.Apply inputT funcT) (case (type.apply (list inputT) funcT) (#.Some outputT) (recur outputT level) #.None (lang.throw non-array expectedT)) (^ (#.Primitive "#Array" (list elemT))) (recur elemT (inc level)) (#.Primitive class _) (wrap [level class]) _ (lang.throw non-array expectedT)))) _ (if (n/> +0 level) (wrap []) (lang.throw non-array expectedT))] (wrap (#analysisL.Extension proc (list (analysisL.nat (dec level)) (analysisL.text elem-class) lengthA)))) _ (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) (def: (check-jvm objectT) (-> Type (Meta Text)) (case objectT (#.Primitive name _) (macro/wrap name) (#.Named name unnamed) (check-jvm unnamed) (#.Var id) (macro/wrap "java.lang.Object") (^template [] ( env unquantified) (check-jvm unquantified)) ([#.UnivQ] [#.ExQ]) (#.Apply inputT funcT) (case (type.apply (list inputT) funcT) (#.Some outputT) (check-jvm outputT) #.None (lang.throw non-object objectT)) _ (lang.throw non-object objectT))) (def: (check-object objectT) (-> Type (Meta Text)) (do macro.Monad [name (check-jvm objectT)] (if (dict.contains? name boxes) (lang.throw Primitives-Are-Not-Objects name) (macro/wrap name)))) (def: (box-array-element-type elemT) (-> Type (Meta [Type Text])) (case elemT (#.Primitive name #.Nil) (let [boxed-name (|> (dict.get name boxes) (maybe.default name))] (macro/wrap [(#.Primitive boxed-name #.Nil) boxed-name])) (#.Primitive name _) (if (dict.contains? name boxes) (lang.throw Primitives-Cannot-Have-Type-Parameters name) (macro/wrap [elemT name])) _ (lang.throw Invalid-Type-For-Array-Element (%type elemT)))) (def: (array//read proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list arrayC idxC)) (do macro.Monad [[var-id varT] (typeA.with-env tc.var) _ (typeA.infer varT) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) ?elemT (typeA.with-env (tc.read var-id)) [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) idxA (typeA.with-type Nat (analyse idxC))] (wrap (#analysisL.Extension proc (list (analysisL.text elem-class) idxA arrayA)))) _ (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) (def: (array//write proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list arrayC idxC valueC)) (do macro.Monad [[var-id varT] (typeA.with-env tc.var) _ (typeA.infer (type (Array varT))) arrayA (typeA.with-type (type (Array varT)) (analyse arrayC)) ?elemT (typeA.with-env (tc.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 (#analysisL.Extension proc (list (analysisL.text elem-class) idxA valueA arrayA)))) _ (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) (def: array-procs /.Bundle (<| (/.prefix "array") (|> (dict.new text.Hash) (/.install "length" array//length) (/.install "new" array//new) (/.install "read" array//read) (/.install "write" array//write) ))) (def: (object//null proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list)) (do macro.Monad [expectedT macro.expected-type _ (check-object expectedT)] (wrap (#analysisL.Extension proc (list)))) _ (lang.throw /.incorrect-extension-arity [proc +0 (list.size args)])))) (def: (object//null? proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list objectC)) (do macro.Monad [_ (typeA.infer Bool) [objectT objectA] (typeA.with-inference (analyse objectC)) _ (check-object objectT)] (wrap (#analysisL.Extension proc (list objectA)))) _ (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) (def: (object//synchronized proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list monitorC exprC)) (do macro.Monad [[monitorT monitorA] (typeA.with-inference (analyse monitorC)) _ (check-object monitorT) exprA (analyse exprC)] (wrap (#analysisL.Extension proc (list monitorA exprA)))) _ (lang.throw /.incorrect-extension-arity [proc +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 (Meta (Class Object))) (do macro.Monad [] (case (Class::forName [name]) (#e.Success [class]) (wrap class) (#e.Error error) (lang.throw Unknown-Class name)))) (def: (sub-class? super sub) (-> Text Text (Meta Bool)) (do macro.Monad [super (load-class super) sub (load-class sub)] (wrap (Class::isAssignableFrom [sub] super)))) (def: (object//throw proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list exceptionC)) (do macro.Monad [_ (typeA.infer Nothing) [exceptionT exceptionA] (typeA.with-inference (analyse exceptionC)) exception-class (check-object exceptionT) ? (sub-class? "java.lang.Throwable" exception-class) _ (: (Meta Any) (if ? (wrap []) (lang.throw non-throwable exception-class)))] (wrap (#analysisL.Extension proc (list exceptionA)))) _ (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) (def: (object//class proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list classC)) (case classC [_ (#.Text class)] (do macro.Monad [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) _ (load-class class)] (wrap (#analysisL.Extension proc (list (analysisL.text class))))) _ (lang.throw /.invalid-syntax [proc args])) _ (lang.throw /.incorrect-extension-arity [proc +1 (list.size args)])))) (def: (object//instance? proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list classC objectC)) (case classC [_ (#.Text class)] (do macro.Monad [_ (typeA.infer Bool) [objectT objectA] (typeA.with-inference (analyse objectC)) object-class (check-object objectT) ? (sub-class? class object-class)] (if ? (wrap (#analysisL.Extension proc (list (analysisL.text class)))) (lang.throw Cannot-Possibly-Be-Instance (format object-class " !<= " class)))) _ (lang.throw /.invalid-syntax [proc args])) _ (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) (def: (java-type-to-class type) (-> java/lang/reflect/Type (Meta Text)) (cond (host.instance? Class type) (macro/wrap (Class::getName [] (:! Class type))) (host.instance? ParameterizedType type) (java-type-to-class (ParameterizedType::getRawType [] (:! ParameterizedType type))) ## else (lang.throw Cannot-Convert-To-Class (jvm-type-name type)))) (type: Mappings (Dict Text Type)) (def: fresh-mappings Mappings (dict.new text.Hash)) (def: (java-type-to-lux-type mappings java-type) (-> Mappings java/lang/reflect/Type (Meta Type)) (cond (host.instance? TypeVariable java-type) (let [var-name (TypeVariable::getName [] (:! TypeVariable java-type))] (case (dict.get var-name mappings) (#.Some var-type) (macro/wrap var-type) #.None (lang.throw Unknown-Type-Var var-name))) (host.instance? WildcardType java-type) (let [java-type (:! 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) _ (macro/wrap Any))) (host.instance? Class java-type) (let [java-type (:! (Class Object) java-type) class-name (Class::getName [] java-type)] (macro/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 #.Bound)) (#.Primitive class-name) (type.univ-q arity))))) (host.instance? ParameterizedType java-type) (let [java-type (:! ParameterizedType java-type) raw (ParameterizedType::getRawType [] java-type)] (if (host.instance? Class raw) (do macro.Monad [paramsT (|> java-type (ParameterizedType::getActualTypeArguments []) array.to-list (monad.map @ (java-type-to-lux-type mappings)))] (macro/wrap (#.Primitive (Class::getName [] (:! (Class Object) raw)) paramsT))) (lang.throw jvm-type-is-not-a-class raw))) (host.instance? GenericArrayType java-type) (do macro.Monad [innerT (|> (:! GenericArrayType java-type) (GenericArrayType::getGenericComponentType []) (java-type-to-lux-type mappings))] (wrap (#.Primitive "#Array" (list innerT)))) ## else (lang.throw Cannot-Convert-To-Lux-Type (jvm-type-name java-type)))) (def: (correspond-type-params class type) (-> (Class Object) Type (Meta 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)) (lang.throw Cannot-Correspond-Type-With-Class (format "Class = " class-name "\n" "Type = " (%type type))) (not (n/= num-class-params num-type-params)) (lang.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 (macro/wrap (|> params (list.zip2 (list/map (TypeVariable::getName []) class-params)) (dict.from-list text.Hash))) )) _ (lang.throw non-jvm-type type))) (def: (object//cast proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list valueC)) (do macro.Monad [toT macro.expected-type to-name (check-jvm toT) [valueT valueA] (typeA.with-inference (analyse valueC)) from-name (check-jvm valueT) can-cast? (: (Meta Bool) (case [from-name to-name] (^template [ ] (^or [ ] [ ]) (do @ [_ (typeA.infer (#.Primitive to-name (list)))] (wrap true))) (["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 @ [_ (lang.assert Primitives-Are-Not-Objects from-name (not (dict.contains? from-name boxes))) _ (lang.assert Primitives-Are-Not-Objects to-name (not (dict.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 true)) (do @ [current-class (load-class current-name) _ (lang.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 (lang.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 (#analysisL.Extension proc (list (analysisL.text from-name) (analysisL.text to-name) valueA))) (lang.throw Cannot-Cast (format "From class/primitive: " from-name "\n" " To class/primitive: " to-name "\n" " For value: " (%code valueC) "\n")))) _ (lang.throw /.invalid-syntax [proc args])))) (def: object-procs /.Bundle (<| (/.prefix "object") (|> (dict.new text.Hash) (/.install "null" object//null) (/.install "null?" object//null?) (/.install "synchronized" object//synchronized) (/.install "throw" object//throw) (/.install "class" object//class) (/.install "instance?" object//instance?) (/.install "cast" object//cast) ))) (def: (find-field class-name field-name) (-> Text Text (Meta [(Class Object) Field])) (do macro.Monad [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]) (lang.throw Mistaken-Field-Owner (format " Field: " field-name "\n" " Owner Class: " (Class::getName [] owner) "\n" "Target Class: " class-name "\n")))) (#e.Error _) (lang.throw Unknown-Field (format class-name "#" field-name))))) (def: (static-field class-name field-name) (-> Text Text (Meta [Type Bool])) (do macro.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)] (wrap [fieldT (Modifier::isFinal [modifiers])]))) (lang.throw Not-Static-Field (format class-name "#" field-name))))) (def: (virtual-field class-name field-name objectT) (-> Text Text Type (Meta [Type Bool])) (do macro.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 (: (Meta Mappings) (case objectT (#.Primitive _class-name _class-params) (do @ [#let [num-params (list.size _class-params) num-vars (list.size var-names)] _ (lang.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) (dict.from-list text.Hash)))) _ (lang.throw non-object objectT))) fieldT (java-type-to-lux-type mappings fieldJT)] (wrap [fieldT (Modifier::isFinal [modifiers])])) (lang.throw Not-Virtual-Field (format class-name "#" field-name))))) (def: (static//get proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list classC fieldC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad [[fieldT final?] (static-field class field)] (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field))))) _ (lang.throw /.invalid-syntax [proc args])) _ (lang.throw /.incorrect-extension-arity [proc +2 (list.size args)])))) (def: (static//put proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list classC fieldC valueC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad [_ (typeA.infer Any) [fieldT final?] (static-field class field) _ (lang.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA)))) _ (lang.throw /.invalid-syntax [proc args])) _ (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) (def: (virtual//get proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list classC fieldC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad [[objectT objectA] (typeA.with-inference (analyse objectC)) [fieldT final?] (virtual-field class field objectT)] (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) objectA)))) _ (lang.throw /.invalid-syntax [proc args])) _ (lang.throw /.incorrect-extension-arity [proc +3 (list.size args)])))) (def: (virtual//put proc) (-> Text ///.Analysis) (function (_ analyse eval args) (case args (^ (list classC fieldC valueC objectC)) (case [classC fieldC] [[_ (#.Text class)] [_ (#.Text field)]] (do macro.Monad [[objectT objectA] (typeA.with-inference (analyse objectC)) _ (typeA.infer objectT) [fieldT final?] (virtual-field class field objectT) _ (lang.assert Cannot-Set-Final-Field (format class "#" field) (not final?)) valueA (typeA.with-type fieldT (analyse valueC))] (wrap (#analysisL.Extension proc (list (analysisL.text class) (analysisL.text field) valueA objectA)))) _ (lang.throw /.invalid-syntax [proc args])) _ (lang.throw /.incorrect-extension-arity [proc +4 (list.size args)])))) (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Meta Text)) (cond (host.instance? Class type) (macro/wrap (Class::getName [] (:! Class type))) (host.instance? ParameterizedType type) (java-type-to-parameter (ParameterizedType::getRawType [] (:! ParameterizedType type))) (or (host.instance? TypeVariable type) (host.instance? WildcardType type)) (macro/wrap "java.lang.Object") (host.instance? GenericArrayType type) (do macro.Monad [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType [] (:! GenericArrayType type)))] (wrap (format componentP "[]"))) ## else (lang.throw Cannot-Convert-To-Parameter (jvm-type-name type)))) (type: Method-Type #Static #Abstract #Virtual #Special #Interface) (def: (check-method class method-name method-type arg-classes method) (-> (Class Object) Text Method-Type (List Text) Method (Meta Bool)) (do macro.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]) _ true) (case method-type #Special (not (or (Modifier::isInterface [(Class::getModifiers [] class)]) (Modifier::isAbstract [modifiers]))) _ true) (n/= (list.size arg-classes) (list.size parameters)) (list/fold (function (_ [expectedJC actualJC] prev) (and prev (text/= expectedJC actualJC))) true (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) (-> (Class Object) (List Text) (Constructor Object) (Meta Bool)) (do macro.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))) true (list.zip2 arg-classes parameters)))))) (def: idx-to-bound (-> Nat Type) (|>> (n/* +2) inc #.Bound)) (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-bound)))) (def: (method-to-type method-type method) (-> Method-Type Method (Meta [Type (List Type)])) (let [owner (Method::getDeclaringClass [] method) owner-name (Class::getName [] owner) owner-tvars (case method-type #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) (dict.from-list text.Hash))))] (do macro.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 num-all-tvars) (type.function (case method-type #Static inputsT _ (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) (def: (methods class-name method-name method-type arg-classes) (-> Text Text Method-Type (List Text) (Meta [Type (List Type)])) (do macro.Monad [class (load-class class-name) candidates (|> class (Class::getDeclaredMethods []) array.to-list (monad.map @ (function (_ method) (do @ [passes? (check-method class method-name method-type arg-classes method)] (wrap [passes? method])))))] (case (list.filter product.left candidates) #.Nil (lang.throw No-Candidates (format class-name "#" method-name)) (#.Cons candidate #.Nil) (|> candidate product.right (method-to-type method-type)) _ (lang.throw Too-Many-Candidates (format class-name "#" method-name))))) (def: (constructor-to-type constructor) (-> (Constructor Object) (Meta [Type (List Type)])) (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) (dict.from-list text.Hash))))] (do macro.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 owner-name (list.reverse owner-tvarsT)) constructorT (<| (type.univ-q num-all-tvars) (type.function inputsT) objectT)]] (wrap [constructorT exceptionsT])))) (def: (constructor-methods class-name arg-classes) (-> Text (List Text) (Meta [Type (List Type)])) (do macro.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)] (wrap [passes? constructor])))))] (case (list.filter product.left candidates) #.Nil (lang.throw No-Candidates (format class-name "(" (text.join-with ", " arg-classes) ")")) (#.Cons candidate #.Nil) (|> candidate product.right constructor-to-type) _ (lang.throw Too-Many-Candidates class-name)))) (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) (|> inputsA (list.zip2 (list/map analysisL.text typesT)) (list/map (function (_ [type value]) (analysisL.product-analysis (list type value)))))) (def: (invoke//static proc) (-> Text ///.Analysis) (function (_ analyse eval 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 macro.Monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Static argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) outputJC (check-jvm outputT)] (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) (analysisL.text outputJC) (decorate-inputs argsT argsA))))) _ (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//virtual proc) (-> Text ///.Analysis) (function (_ analyse eval 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 macro.Monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods 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 (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) (analysisL.text outputJC) objectA (decorate-inputs argsT argsA))))) _ (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//special proc) (-> Text ///.Analysis) (function (_ analyse eval 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 macro.Monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (methods class method #Special argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] (wrap (#analysisL.Extension proc (list& (analysisL.text class) (analysisL.text method) (analysisL.text outputJC) (decorate-inputs argsT argsA))))) _ (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//interface proc) (-> Text ///.Analysis) (function (_ analyse eval 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 macro.Monad [#let [argsT (list/map product.left argsTC)] class (load-class class-name) _ (lang.assert non-interface class-name (Modifier::isInterface [(Class::getModifiers [] class)])) [methodT exceptionsT] (methods class-name method #Interface argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) outputJC (check-jvm outputT)] (wrap (#analysisL.Extension proc (list& (analysisL.text class-name) (analysisL.text method) (analysisL.text outputJC) (decorate-inputs argsT argsA))))) _ (lang.throw /.invalid-syntax [proc args])))) (def: (invoke//constructor proc) (-> Text ///.Analysis) (function (_ analyse eval 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 macro.Monad [#let [argsT (list/map product.left argsTC)] [methodT exceptionsT] (constructor-methods class argsT) [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] (wrap (#analysisL.Extension proc (list& (analysisL.text class) (decorate-inputs argsT argsA))))) _ (lang.throw /.invalid-syntax [proc args])))) (def: member-procs /.Bundle (<| (/.prefix "member") (|> (dict.new text.Hash) (dict.merge (<| (/.prefix "static") (|> (dict.new text.Hash) (/.install "get" static//get) (/.install "put" static//put)))) (dict.merge (<| (/.prefix "virtual") (|> (dict.new text.Hash) (/.install "get" virtual//get) (/.install "put" virtual//put)))) (dict.merge (<| (/.prefix "invoke") (|> (dict.new text.Hash) (/.install "static" invoke//static) (/.install "virtual" invoke//virtual) (/.install "special" invoke//special) (/.install "interface" invoke//interface) (/.install "constructor" invoke//constructor) ))) ))) (def: #export extensions /.Bundle (<| (/.prefix "jvm") (|> (dict.new text.Hash) (dict.merge conversion-procs) (dict.merge int-procs) (dict.merge long-procs) (dict.merge float-procs) (dict.merge double-procs) (dict.merge char-procs) (dict.merge array-procs) (dict.merge object-procs) (dict.merge member-procs) )))