diff options
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 34 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/reflection.lux | 43 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/type.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/type/lux.lux | 11 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 617 |
5 files changed, 373 insertions, 344 deletions
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 362eed4e5..88ffc16f6 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -1358,10 +1358,10 @@ (#.Some value-as-string) #.None))} (with-gensyms [g!_ g!unchecked] - (let [class-name (jvm.signature class) + (let [class-name (reflection.class class) class-type (` (.primitive (~ (code.text class-name)))) check-type (` (.Maybe (~ class-type))) - check-code (` (if ((~ (code.text (format "jvm instanceof" ":" class-name))) (~ g!unchecked)) + check-code (` (if ("jvm object instance?" (~ (code.text class-name)) (~ g!unchecked)) (#.Some (.:coerce (~ class-type) (~ g!unchecked))) #.None))] @@ -1492,10 +1492,20 @@ (-> Var Code) code.local-identifier) -(def: string-class "java.lang.String") - -(def: string-descriptor - (jvm.signature (jvm.class ..string-class (list)))) +(template [<jvm> <class> <descriptor>] + [(def: <class> <jvm>) + (def: <descriptor> (jvm.signature (jvm.class <jvm> (list))))] + + ["java.lang.String" string-class string-descriptor] + [box.boolean boolean-box-class boolean-box-descriptor] + [box.byte byte-box-class byte-box-descriptor] + [box.short short-box-class short-box-descriptor] + [box.int int-box-class int-box-descriptor] + [box.long long-box-class long-box-descriptor] + [box.float float-box-class float-box-descriptor] + [box.double double-box-class double-box-descriptor] + [box.char char-box-class char-box-descriptor] + ) (template [<input?> <name> <unbox/box> <special+>] [(def: (<name> mode [unboxed raw]) @@ -1542,7 +1552,10 @@ [jvm.long-descriptor jvm.long-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long)))))) []] [jvm.float-descriptor jvm.float-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double))))) (` ..double-to-float)) []] [jvm.double-descriptor jvm.double-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double)))))) []] - [..string-descriptor ..string-descriptor (list (` (.: .Text)) (` (.:coerce (.primitive (~ (code.text ..string-class)))))) []]]] + [..string-descriptor ..string-descriptor (list (` (.: .Text)) (` (.:coerce (.primitive (~ (code.text ..string-class)))))) []] + [..boolean-box-descriptor ..boolean-box-descriptor (list (` (.: .Bit)) (` (.:coerce (.primitive (~ (code.text ..boolean-box-class)))))) []] + [..long-box-descriptor ..long-box-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text ..long-box-class)))))) []] + [..double-box-descriptor ..double-box-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text ..double-box-class)))))) []]]] [#0 auto-convert-output ..box [[jvm.boolean-descriptor jvm.boolean-descriptor (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:coerce .Bit))]] [jvm.byte-descriptor jvm.long-descriptor (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]] @@ -1551,7 +1564,10 @@ [jvm.long-descriptor jvm.long-descriptor (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]] [jvm.float-descriptor jvm.double-descriptor (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]] [jvm.double-descriptor jvm.double-descriptor (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]] - [..string-descriptor ..string-descriptor (list) [(` (.: (.primitive (~ (code.text ..string-class))))) (` (.:coerce .Text))]]]] + [..string-descriptor ..string-descriptor (list) [(` (.: (.primitive (~ (code.text ..string-class))))) (` (.:coerce .Text))]] + [..boolean-box-descriptor ..boolean-box-descriptor (list) [(` (.: (.primitive (~ (code.text ..boolean-box-class))))) (` (.:coerce .Bit))]] + [..long-box-descriptor ..long-box-descriptor (list) [(` (.: (.primitive (~ (code.text ..long-box-class))))) (` (.:coerce .Int))]] + [..double-box-descriptor ..double-box-descriptor (list) [(` (.: (.primitive (~ (code.text ..double-box-class))))) (` (.:coerce .Frac))]]]] ) (def: (un-quote quoted) @@ -1958,7 +1974,7 @@ {type (..type^ imports (list))}) {#.doc (doc "Loads the class as a java.lang.Class object." (class-for java/lang/String))} - (wrap (list (` ("jvm object class" (~ (code.text (jvm.signature type)))))))) + (wrap (list (` ("jvm object class" (~ (code.text (reflection.class type)))))))) (def: get-compiler (Meta Lux) diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux index afea0b0c2..4ae3ce64f 100644 --- a/stdlib/source/lux/target/jvm/reflection.lux +++ b/stdlib/source/lux/target/jvm/reflection.lux @@ -1,6 +1,7 @@ (.module: [lux (#- type) ["." host (#+ import:)] + ["." type] [abstract ["." monad (#+ do)]] [control @@ -100,7 +101,7 @@ (def: #export (load name) (-> Text (Error (java/lang/Class java/lang/Object))) (case (java/lang/Class::forName name) - (#error.Success [class]) + (#error.Success class) (#error.Success class) (#error.Failure error) @@ -140,7 +141,7 @@ ([[_ (#.Some bound)] #/.Upper] [[(#.Some bound) _] #/.Lower]) - [#.None #.None] + _ (#error.Success (#/.Wildcard #.None))) _) (case (host.check java/lang/Class reflection) @@ -218,21 +219,21 @@ (def: #export (return reflection) (-> java/lang/reflect/Type (Error /.Return)) - (case (host.check java/lang/Class reflection) - (#.Some class) - (case (|> class - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - (^ (static reflection.void)) - (#error.Success #.None) - - _ - (:: error.monad map (|>> #.Some) - (..type reflection))) - - #.None - (:: error.monad map (|>> #.Some) - (..type reflection)))) + (with-expansions [<else> (as-is (:: error.monad map (|>> #.Some) + (..type reflection)))] + (case (host.check java/lang/Class reflection) + (#.Some class) + (case (|> class + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName) + (^ (static reflection.void)) + (#error.Success #.None) + + _ + <else>) + + #.None + <else>))) (exception: #export (cannot-correspond {class (java/lang/Class java/lang/Object)} {type Type}) @@ -277,6 +278,14 @@ (#.Named name anonymousT) (correspond class anonymousT) + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (correspond class outputT) + + #.None + (exception.throw ..non-jvm-type [type])) + _ (exception.throw ..non-jvm-type [type]))) diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux index 2c3b2b1e2..19289a5d0 100644 --- a/stdlib/source/lux/target/jvm/type.lux +++ b/stdlib/source/lux/target/jvm/type.lux @@ -3,6 +3,7 @@ [abstract [equivalence (#+ Equivalence)]] [control + ["." function] ["<>" parser ["<t>" text (#+ Parser)]]] [data @@ -305,14 +306,15 @@ [#Upper ..upper-prefix])) )) -(template [<name> <head> <tail>] +(template [<name> <head> <tail> <adapter>] [(def: <name> (Parser Text) - (<t>.slice (<t>.and! (<t>.one-of! <head>) - (<t>.some! (<t>.one-of! <tail>)))))] + (:: <>.functor map <adapter> + (<t>.slice (<t>.and! (<t>.one-of! <head>) + (<t>.some! (<t>.one-of! <tail>))))))] - [parse-class-name valid-class-characters/head valid-class-characters/tail] - [parse-var-name valid-var-characters/head valid-var-characters/tail] + [parse-class-name valid-class-characters/head valid-class-characters/tail ..syntax-name] + [parse-var-name valid-var-characters/head valid-var-characters/tail function.identity] ) (def: parse-var diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux index 2e1529ba6..547c388b7 100644 --- a/stdlib/source/lux/target/jvm/type/lux.lux +++ b/stdlib/source/lux/target/jvm/type/lux.lux @@ -55,11 +55,14 @@ (do check.monad [limitT (generic mapping limit)] (case bound - (^template [<tag> <ctor>] + (^template [<tag> <ctor> <limit>] <tag> - (wrap (.type (<ctor> limitT)))) - ([#//.Lower ..Lower] - [#//.Upper ..Upper])))) + ## TODO: Re-enable Lower and Upper, instead of using the + ## simplified limit. + ## (wrap (.type (<ctor> limitT))) + (wrap <limit>)) + ([#//.Lower ..Lower (primitive "java.lang.Object")] + [#//.Upper ..Upper limitT])))) (#//.Class name parameters) (do check.monad diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux index fadb92667..1f7cbe26e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -31,7 +31,7 @@ ["." reflection] [".T" lux (#+ Mapping)]]]]] ["." // #_ - ["#." common] + ["#." common (#+ custom)] ["/#" // ["#." bundle] ["/#" // ("#@." monad) @@ -40,6 +40,7 @@ [".A" inference] ["." scope]] ["/#" // #_ + [reference (#+)] ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] ["#." synthesis]]]]]) @@ -76,19 +77,6 @@ [char reflection.char] ) -(def: (custom [syntax handler]) - (All [s] - (-> [(Parser s) - (-> Text Phase s (Operation Analysis))] - Handler)) - (function (_ extension-name analyse args) - (case (s.run syntax args) - (#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}) @@ -253,13 +241,16 @@ (loop [level 0 currentT arrayT] (case currentT + (#.Named name anonymous) + (recur level anonymous) + (#.Apply inputT abstractionT) (case (type.apply (list inputT) abstractionT) (#.Some outputT) (recur level outputT) #.None - (/////analysis.throw non-array arrayT)) + (/////analysis.throw ..non-array arrayT)) (^ (#.Primitive (static array.type-name) (list elemT))) (recur (inc level) elemT) @@ -274,9 +265,12 @@ (if (dictionary.contains? class boxes) (/////analysis.throw ..primitives-cannot-have-type-parameters class) (////@wrap [level class])) + + (#.Ex _) + (////@wrap [level "java.lang.Object"]) _ - (/////analysis.throw non-array arrayT)))) + (/////analysis.throw ..non-array arrayT)))) (def: (primitive-array-length-handler primitive-type) (-> Type Handler) @@ -337,7 +331,7 @@ [level elem-class] (array-type-info false expectedT) _ (if (n/> 0 level) (wrap []) - (/////analysis.throw non-array expectedT))] + (/////analysis.throw ..non-array expectedT))] (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (dec level)) (/////analysis.text elem-class) lengthA)))) @@ -449,10 +443,10 @@ (analyse arrayC)) varT (typeA.with-env (check.clean varT)) - [nesting elem-class] (array-type-info false varT) + [nesting elem-class] (array-type-info false (.type (Array varT))) idxA (typeA.with-type ..int (analyse idxC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (inc nesting)) + (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat nesting) (/////analysis.text elem-class) idxA arrayA)))) @@ -493,12 +487,12 @@ (analyse arrayC)) varT (typeA.with-env (check.clean varT)) - [nesting elem-class] (array-type-info false varT) + [nesting elem-class] (array-type-info false (.type (Array 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)) + (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat nesting) (/////analysis.text elem-class) idxA valueA @@ -640,26 +634,18 @@ (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) - ? (////.lift (reflection!.sub? class object-class))] - (if ? - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))) - (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name %code args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + (..custom + [($_ p.and s.text s.any) + (function (_ extension-name analyse [sub-class objectC]) + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (////.lift (reflection!.sub? object-class sub-class))] + (if ? + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text sub-class) objectA))) + (/////analysis.throw cannot-possibly-be-an-instance (format sub-class " !<= " object-class)))))])) (import: #long java/lang/Object (equals [java/lang/Object] boolean)) @@ -736,7 +722,10 @@ (list& super (array.to-list (java/lang/Class::getGenericInterfaces from-class))) #.None - (array.to-list (java/lang/Class::getGenericInterfaces from-class)))))) + (if (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers from-class)) + (#.Cons (:coerce java/lang/reflect/Type (host.class-for java/lang/Object)) + (array.to-list (java/lang/Class::getGenericInterfaces from-class))) + (array.to-list (java/lang/Class::getGenericInterfaces from-class))))))) (def: (inheritance-candidate-parents fromT to-class toT fromC) (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit]))) @@ -835,86 +824,90 @@ (def: static::get Handler - (..custom [..member - (function (_ extension-name analyse [class field]) - (do ////.monad - [[final? fieldJT] (////.lift - (do error.monad - [class (reflection!.load class)] - (reflection!.static-field field class))) - fieldT (reflection-type luxT.fresh fieldJT) - _ (typeA.infer fieldT)] - (wrap (<| (#/////analysis.Extension extension-name) - (list (/////analysis.text class) - (/////analysis.text field) - (/////analysis.text (reflection.class fieldJT)))))))])) + (..custom + [..member + (function (_ extension-name analyse [class field]) + (do ////.monad + [[final? fieldJT] (////.lift + (do error.monad + [class (reflection!.load class)] + (reflection!.static-field field class))) + fieldT (reflection-type luxT.fresh fieldJT) + _ (typeA.infer fieldT)] + (wrap (<| (#/////analysis.Extension extension-name) + (list (/////analysis.text class) + (/////analysis.text field) + (/////analysis.text (reflection.class fieldJT)))))))])) (def: static::put Handler - (..custom [($_ p.and ..member s.any) - (function (_ extension-name analyse [[class field] valueC]) - (do ////.monad - [_ (typeA.infer Any) - [final? fieldJT] (////.lift - (do error.monad - [class (reflection!.load class)] - (reflection!.static-field field class))) - fieldT (reflection-type luxT.fresh fieldJT) - _ (////.assert ..cannot-set-a-final-field [class field] - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (<| (#/////analysis.Extension extension-name) - (list (/////analysis.text class) - (/////analysis.text field) - valueA)))))])) + (..custom + [($_ p.and ..member s.any) + (function (_ extension-name analyse [[class field] valueC]) + (do ////.monad + [_ (typeA.infer Any) + [final? fieldJT] (////.lift + (do error.monad + [class (reflection!.load class)] + (reflection!.static-field field class))) + fieldT (reflection-type luxT.fresh fieldJT) + _ (////.assert ..cannot-set-a-final-field [class field] + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (<| (#/////analysis.Extension extension-name) + (list (/////analysis.text class) + (/////analysis.text field) + valueA)))))])) (def: virtual::get Handler - (..custom [($_ p.and ..member s.any) - (function (_ extension-name analyse [[class field] objectC]) - (do ////.monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - [mapping fieldJT] (////.lift - (do error.monad - [class (reflection!.load class) - [final? fieldJT] (reflection!.virtual-field field class) - mapping (reflection!.correspond class objectT)] - (wrap [mapping fieldJT]))) - fieldT (typeA.with-env - (luxT.type mapping fieldJT)) - _ (typeA.infer fieldT)] - (wrap (<| (#/////analysis.Extension extension-name) - (list (/////analysis.text class) - (/////analysis.text field) - objectA)))))])) + (..custom + [($_ p.and ..member s.any) + (function (_ extension-name analyse [[class field] objectC]) + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [mapping fieldJT] (////.lift + (do error.monad + [class (reflection!.load class) + [final? fieldJT] (reflection!.virtual-field field class) + mapping (reflection!.correspond class objectT)] + (wrap [mapping fieldJT]))) + fieldT (typeA.with-env + (luxT.type mapping fieldJT)) + _ (typeA.infer fieldT)] + (wrap (<| (#/////analysis.Extension extension-name) + (list (/////analysis.text class) + (/////analysis.text field) + objectA)))))])) (def: virtual::put Handler - (..custom [($_ p.and ..member s.any s.any) - (function (_ extension-name analyse [[class field] valueC objectC]) - (do ////.monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (typeA.infer objectT) - [final? mapping fieldJT] (////.lift - (do error.monad - [class (reflection!.load class) - [final? fieldJT] (reflection!.virtual-field field class) - mapping (reflection!.correspond class objectT)] - (wrap [final? mapping fieldJT]))) - fieldT (typeA.with-env - (luxT.type mapping fieldJT)) - _ (////.assert cannot-set-a-final-field [class field] - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (<| (#/////analysis.Extension extension-name) - (list (/////analysis.text class) - (/////analysis.text field) - valueA - objectA)))))])) + (..custom + [($_ p.and ..member s.any s.any) + (function (_ extension-name analyse [[class field] valueC objectC]) + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [final? mapping fieldJT] (////.lift + (do error.monad + [class (reflection!.load class) + [final? fieldJT] (reflection!.virtual-field field class) + mapping (reflection!.correspond class objectT)] + (wrap [final? mapping fieldJT]))) + fieldT (typeA.with-env + (luxT.type mapping fieldJT)) + _ (////.assert cannot-set-a-final-field [class field] + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (<| (#/////analysis.Extension extension-name) + (list (/////analysis.text class) + (/////analysis.text field) + valueA + objectA)))))])) (type: Method-Style #Static @@ -1017,9 +1010,9 @@ ////@join) outputT (|> method java/lang/reflect/Method::getGenericReturnType - reflection!.type + reflection!.return ////.lift - (////@map (reflection-type mapping)) + (////@map (..reflection-return mapping)) ////@join) exceptionsT (|> (java/lang/reflect/Method::getGenericExceptionTypes method) array.to-list @@ -1139,93 +1132,98 @@ (def: (decorate-inputs typesT inputsA) (-> (List Text) (List Analysis) (List Analysis)) (|> inputsA - (list.zip2 (list@map /////analysis.text typesT)) + (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-return outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (/////analysis.text method) - (/////analysis.text outputJC) - (decorate-inputs argsT argsA))))))])) + (..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-return 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-return outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (/////analysis.text method) - (/////analysis.text outputJC) - objectA - (decorate-inputs argsT argsA))))))])) + (..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-return 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-return outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) - (/////analysis.text method) - (/////analysis.text outputJC) - (decorate-inputs argsT argsA))))))])) + (..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-return 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 (////.lift (reflection!.load class-name)) - _ (////.assert non-interface class-name - (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))) - [methodT exceptionsT] (method-candidate class-name method #Interface argsT) - [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJC (check-return outputT)] - (wrap (#/////analysis.Extension extension-name - (list& (/////analysis.text class-name) - (/////analysis.text method) - (/////analysis.text outputJC) - objectA - (decorate-inputs argsT argsA))))))])) + (..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 (////.lift (reflection!.load class-name)) + _ (////.assert non-interface class-name + (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))) + [methodT exceptionsT] (method-candidate class-name method #Interface argsT) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJC (check-return outputT)] + (wrap (#/////analysis.Extension extension-name + (list& (/////analysis.text class-name) + (/////analysis.text method) + (/////analysis.text outputJC) + objectA + (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))))))])) + (..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 @@ -1397,7 +1395,7 @@ (def: var-analysis (-> Var Analysis) - /////analysis.text) + (|>> /////analysis.text)) (def: (type-analysis type) (-> Type Analysis) @@ -1483,128 +1481,129 @@ (def: class::anonymous Handler - (..custom [($_ p.and - ..class - (s.tuple (p.some ..class)) - (s.tuple (p.some ..typed)) - (s.tuple (p.some ..overriden-method-definition))) - (function (_ extension-name analyse [super-class - super-interfaces - constructor-args - methods]) - (do ////.monad - [name (///.lift (do macro.monad - [where macro.current-module-name - id macro.count] - (wrap (format (text.replace-all .module-separator ..jvm-package-separator where) - ..jvm-package-separator - "anonymous-class" (%n id))))) - super-classT (typeA.with-env - (luxT.class luxT.fresh super-class)) - super-interfaceT+ (typeA.with-env - (monad.map check.monad - (luxT.class luxT.fresh) - super-interfaces)) - #let [selfT (inheritance-relationship-type (#.Primitive name (list)) - super-classT - super-interfaceT+)] - constructor-argsA+ (monad.map @ (function (_ [type term]) - (do @ - [argT (typeA.with-env - (luxT.type luxT.fresh type)) - termA (typeA.with-type argT - (analyse term))] - (wrap [type termA]))) - constructor-args) - methodsA (monad.map @ (function (_ [parent-type method-name - strict-fp? annotations vars - self-name arguments return exceptions - body]) - - (do @ - [annotationsA (monad.map @ (function (_ [name parameters]) - (do @ - [parametersA (monad.map @ (function (_ [name value]) - (do @ - [valueA (analyse value)] - (wrap [name valueA]))) - parameters)] - (wrap [name parametersA]))) - annotations) - returnT (typeA.with-env - (luxT.return luxT.fresh return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type luxT.fresh jvmT)] - (wrap [name luxT]))) - arguments)) - [scope bodyA] (|> arguments' - (#.Cons [self-name selfT]) - list.reverse - (list@fold scope.with-local (analyse body)) - (typeA.with-type returnT) - /////analysis.with-scope)] - (wrap (/////analysis.tuple (list (class-analysis parent-type) - (/////analysis.text method-name) - (/////analysis.bit strict-fp?) - (/////analysis.tuple (list@map annotation-analysis annotationsA)) - (/////analysis.tuple (list@map var-analysis vars)) - (/////analysis.text self-name) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) - (return-analysis return) - (/////analysis.tuple (list@map class-analysis - exceptions)) - (#/////analysis.Function - (scope.environment scope) - (/////analysis.tuple (list bodyA))) - ))))) - methods) - required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces))) - available-methods (////.lift (all-methods (list& super-class super-interfaces))) - #let [overriden-methods (list@map (function (_ [parent-type method-name - strict-fp? annotations vars - self-name arguments return exceptions - body]) - [method-name (jvm.method (list@map product.right arguments) - return - (list@map (|>> #jvm.Class) exceptions))]) - methods) - missing-abstract-methods (list.filter (function (_ [abstract-method-name abstract-methodJT]) - (|> overriden-methods - (list.filter (function (_ [method-name methodJT]) - (and (text@= method-name abstract-method-name) - (method@= abstract-methodJT methodJT)))) - list.size - (n/= 1) - not)) - required-abstract-methods) - invalid-overriden-methods (list.filter (function (_ [method-name methodJT]) - (|> available-methods - (list.filter (function (_ [abstract-method-name abstract-methodJT]) - (and (text@= method-name abstract-method-name) - (method@= abstract-methodJT methodJT)))) - list.size - (n/= 1) - not)) - overriden-methods)] - _ (typeA.infer selfT) - _ (////.assert ..missing-abstract-methods (list@map product.left missing-abstract-methods) - (list.empty? missing-abstract-methods)) - _ (////.assert ..invalid-overriden-methods (list@map product.left invalid-overriden-methods) - (list.empty? invalid-overriden-methods))] - (wrap (#/////analysis.Extension extension-name - (list (/////analysis.text name) - (class-analysis super-class) - (/////analysis.tuple (list@map class-analysis super-interfaces)) - (/////analysis.tuple (list@map typed-analysis constructor-argsA+)) - (/////analysis.tuple methodsA)))) - ))])) + (..custom + [($_ p.and + ..class + (s.tuple (p.some ..class)) + (s.tuple (p.some ..typed)) + (s.tuple (p.some ..overriden-method-definition))) + (function (_ extension-name analyse [super-class + super-interfaces + constructor-args + methods]) + (do ////.monad + [name (///.lift (do macro.monad + [where macro.current-module-name + id macro.count] + (wrap (format (text.replace-all .module-separator ..jvm-package-separator where) + ..jvm-package-separator + "anonymous-class" (%n id))))) + super-classT (typeA.with-env + (luxT.class luxT.fresh super-class)) + super-interfaceT+ (typeA.with-env + (monad.map check.monad + (luxT.class luxT.fresh) + super-interfaces)) + #let [selfT (inheritance-relationship-type (#.Primitive name (list)) + super-classT + super-interfaceT+)] + constructor-argsA+ (monad.map @ (function (_ [type term]) + (do @ + [argT (typeA.with-env + (luxT.type luxT.fresh type)) + termA (typeA.with-type argT + (analyse term))] + (wrap [type termA]))) + constructor-args) + methodsA (monad.map @ (function (_ [parent-type method-name + strict-fp? annotations vars + self-name arguments return exceptions + body]) + + (do @ + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + returnT (typeA.with-env + (luxT.return luxT.fresh return)) + arguments' (typeA.with-env + (monad.map check.monad + (function (_ [name jvmT]) + (do check.monad + [luxT (luxT.type luxT.fresh jvmT)] + (wrap [name luxT]))) + arguments)) + [scope bodyA] (|> arguments' + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type returnT) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (class-analysis parent-type) + (/////analysis.text method-name) + (/////analysis.bit strict-fp?) + (/////analysis.tuple (list@map annotation-analysis annotationsA)) + (/////analysis.tuple (list@map var-analysis vars)) + (/////analysis.text self-name) + (/////analysis.tuple (list@map (function (_ [argument argumentJT]) + (/////analysis.tuple + (list (/////analysis.text argument) + (type-analysis argumentJT)))) + arguments)) + (return-analysis return) + (/////analysis.tuple (list@map class-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + (/////analysis.tuple (list bodyA))) + ))))) + methods) + required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces))) + available-methods (////.lift (all-methods (list& super-class super-interfaces))) + #let [overriden-methods (list@map (function (_ [parent-type method-name + strict-fp? annotations vars + self-name arguments return exceptions + body]) + [method-name (jvm.method (list@map product.right arguments) + return + (list@map (|>> #jvm.Class) exceptions))]) + methods) + missing-abstract-methods (list.filter (function (_ [abstract-method-name abstract-methodJT]) + (|> overriden-methods + (list.filter (function (_ [method-name methodJT]) + (and (text@= method-name abstract-method-name) + (method@= abstract-methodJT methodJT)))) + list.size + (n/= 1) + not)) + required-abstract-methods) + invalid-overriden-methods (list.filter (function (_ [method-name methodJT]) + (|> available-methods + (list.filter (function (_ [abstract-method-name abstract-methodJT]) + (and (text@= method-name abstract-method-name) + (method@= abstract-methodJT methodJT)))) + list.size + (n/= 1) + not)) + overriden-methods)] + _ (typeA.infer selfT) + _ (////.assert ..missing-abstract-methods (list@map product.left missing-abstract-methods) + (list.empty? missing-abstract-methods)) + _ (////.assert ..invalid-overriden-methods (list@map product.left invalid-overriden-methods) + (list.empty? invalid-overriden-methods))] + (wrap (#/////analysis.Extension extension-name + (list (/////analysis.text name) + (class-analysis super-class) + (/////analysis.tuple (list@map class-analysis super-interfaces)) + (/////analysis.tuple (list@map typed-analysis constructor-argsA+)) + (/////analysis.tuple methodsA)))) + ))])) (def: bundle::class Bundle |