diff options
Diffstat (limited to 'stdlib/source')
-rw-r--r-- | stdlib/source/lux/control/parser/code.lux | 11 | ||||
-rw-r--r-- | stdlib/source/lux/control/parser/text.lux | 11 | ||||
-rw-r--r-- | stdlib/source/lux/control/try.lux | 9 | ||||
-rw-r--r-- | stdlib/source/lux/macro/syntax/common/reader.lux | 2 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/reflection.lux | 185 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type.lux | 200 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/alias.lux | 112 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/box.lux | 7 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/category.lux | 1 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/descriptor.lux | 49 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/lux.lux | 138 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/parser.lux | 195 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/reflection.lux | 10 | ||||
-rw-r--r-- | stdlib/source/lux/target/jvm/type/signature.lux | 4 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 823 | ||||
-rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux | 6 |
16 files changed, 950 insertions, 813 deletions
diff --git a/stdlib/source/lux/control/parser/code.lux b/stdlib/source/lux/control/parser/code.lux index b20f707a3..5ea2247d6 100644 --- a/stdlib/source/lux/control/parser/code.lux +++ b/stdlib/source/lux/control/parser/code.lux @@ -156,17 +156,6 @@ #.Nil (#try.Success [tokens #1]) _ (#try.Success [tokens #0])))) -(def: #export (lift outcome) - (All [a] (-> (Try a) (Parser a))) - (function (_ input) - (case outcome - (#try.Failure error) - (#try.Failure error) - - (#try.Success value) - (#try.Success [input value]) - ))) - (def: #export (run syntax inputs) (All [a] (-> (Parser a) (List Code) (Try a))) (case (syntax inputs) diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux index bec295f39..44d568eaf 100644 --- a/stdlib/source/lux/control/parser/text.lux +++ b/stdlib/source/lux/control/parser/text.lux @@ -345,7 +345,7 @@ {#.doc "Run a parser with the given input, instead of the real one."} (All [a] (-> Text (Parser a) (Parser a))) (function (_ real-input) - (case (run parser local-input) + (case (..run parser local-input) (#try.Failure error) (#try.Failure error) @@ -363,3 +363,12 @@ #.None (exception.throw ..cannot-slice []))))) + +(def: #export (embed structured text) + (All [s a] + (-> (Parser a) + (//.Parser s Text) + (//.Parser s a))) + (do //.monad + [raw text] + (//.lift (..run structured raw)))) diff --git a/stdlib/source/lux/control/try.lux b/stdlib/source/lux/control/try.lux index 20d4dcab7..3b27fd6a3 100644 --- a/stdlib/source/lux/control/try.lux +++ b/stdlib/source/lux/control/try.lux @@ -110,6 +110,15 @@ (#Failure message) (error! message))) +(def: #export (maybe try) + (All [a] (-> (Try a) (Maybe a))) + (case try + (#Success value) + (#.Some value) + + (#Failure message) + #.None)) + (macro: #export (default tokens compiler) {#.doc (doc "Allows you to provide a default value that will be used" "if a (Try x) value turns out to be #Failure." diff --git a/stdlib/source/lux/macro/syntax/common/reader.lux b/stdlib/source/lux/macro/syntax/common/reader.lux index bd8e3953b..02d947e47 100644 --- a/stdlib/source/lux/macro/syntax/common/reader.lux +++ b/stdlib/source/lux/macro/syntax/common/reader.lux @@ -108,7 +108,7 @@ me-definition-raw (|> definition-raw ////.expand-all (////.run compiler) - s.lift)] + p.lift)] (s.local me-definition-raw (s.form (do @ [_ (s.text! "lux def") diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux index e6ee7e630..992ac9977 100644 --- a/stdlib/source/lux/target/jvm/reflection.lux +++ b/stdlib/source/lux/target/jvm/reflection.lux @@ -20,10 +20,13 @@ ["." dictionary]]]] ["." // #_ [encoding - ["#." name]] + ["#." name (#+ External)]] ["/" type + [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] ["#." lux (#+ Mapping)] - ["." reflection]]]) + ["#." descriptor] + ["#." reflection] + ["#." parser]]]) (import: #long java/lang/String) @@ -88,7 +91,7 @@ (getConstructors [] [(java/lang/reflect/Constructor java/lang/Object)]) (getDeclaredMethods [] [java/lang/reflect/Method])) -(exception: #export (unknown-class {class Text}) +(exception: #export (unknown-class {class External}) (exception.report ["Class" (%.text class)])) @@ -103,7 +106,7 @@ ) (def: #export (load name) - (-> Text (Try (java/lang/Class java/lang/Object))) + (-> External (Try (java/lang/Class java/lang/Object))) (case (java/lang/Class::forName name) (#try.Success class) (#try.Success class) @@ -112,17 +115,63 @@ (exception.throw ..unknown-class name))) (def: #export (sub? super sub) - (-> Text Text (Try Bit)) + (-> External External (Try Bit)) (do try.monad [super (..load super) sub (..load sub)] (wrap (java/lang/Class::isAssignableFrom sub super)))) -(def: #export (generic reflection) - (-> java/lang/reflect/Type (Try /.Generic)) +(def: (class' parameter reflection) + (-> (-> java/lang/reflect/Type (Try (/.Type Parameter))) + java/lang/reflect/Type + (Try (/.Type Class))) + (<| (case (host.check java/lang/Class reflection) + (#.Some class) + (let [class-name (|> class + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (if (or (~~ (template [<reflection>] + [(text@= (/reflection.reflection <reflection>) + class-name)] + + [/reflection.boolean] + [/reflection.byte] + [/reflection.short] + [/reflection.int] + [/reflection.long] + [/reflection.float] + [/reflection.double] + [/reflection.char])) + (text.starts-with? /descriptor.array-prefix class-name)) + (exception.throw ..not-a-class reflection) + (#try.Success (/.class class-name (list)))))) + _) + (case (host.check java/lang/reflect/ParameterizedType reflection) + (#.Some reflection) + (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] + (case (host.check java/lang/Class raw) + (#.Some raw) + (do try.monad + [paramsT (|> reflection + java/lang/reflect/ParameterizedType::getActualTypeArguments + array.to-list + (monad.map @ parameter))] + (wrap (/.class (|> raw + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName) + paramsT))) + + _ + (exception.throw ..not-a-class raw))) + _) + ## else + (exception.throw ..cannot-convert-to-a-lux-type reflection))) + +(def: #export (parameter reflection) + (-> java/lang/reflect/Type (Try (/.Type Parameter))) (<| (case (host.check java/lang/reflect/TypeVariable reflection) (#.Some reflection) - (#try.Success (#/.Var (java/lang/reflect/TypeVariable::getName reflection))) + (#try.Success (/.var (java/lang/reflect/TypeVariable::getName reflection))) _) (case (host.check java/lang/reflect/WildcardType reflection) (#.Some reflection) @@ -136,105 +185,69 @@ (#.Some _) ## TODO: Array bounds should not be "erased" as they ## are right now. - (#try.Success (#/.Wildcard #.None)) + (#try.Success /.wildcard) _ - (:: try.monad map - (|>> [<kind>] #.Some #/.Wildcard) - (generic bound)))) - ([[_ (#.Some bound)] #/.Upper] - [[(#.Some bound) _] #/.Lower]) + (:: try.monad map <kind> (..class' parameter bound)))) + ([[_ (#.Some bound)] /.upper] + [[(#.Some bound) _] /.lower]) _ - (#try.Success (#/.Wildcard #.None))) - _) - (case (host.check java/lang/Class reflection) - (#.Some class) - (let [class-name (|> class - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName)] - (case class-name - (^template [<reflection>] - (^ (static <reflection>)) - (exception.throw ..not-a-class reflection)) - ([reflection.boolean] [reflection.byte] [reflection.short] [reflection.int] - [reflection.long] [reflection.float] [reflection.double] [reflection.char]) - - _ - (if (text.starts-with? /.array-prefix class-name) - (exception.throw ..not-a-class reflection) - (#try.Success (#/.Class class-name (list)))))) + (#try.Success /.wildcard)) _) - (case (host.check java/lang/reflect/ParameterizedType reflection) - (#.Some reflection) - (let [raw (java/lang/reflect/ParameterizedType::getRawType reflection)] - (case (host.check java/lang/Class raw) - (#.Some raw) - (do try.monad - [paramsT (|> reflection - java/lang/reflect/ParameterizedType::getActualTypeArguments - array.to-list - (monad.map @ generic))] - (wrap (#/.Class (|> raw - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - paramsT))) + (..class' parameter reflection))) - _ - (exception.throw ..not-a-class raw))) - _) - ## else - (exception.throw ..cannot-convert-to-a-lux-type reflection))) +(def: #export class + (-> java/lang/reflect/Type + (Try (/.Type Class))) + (..class' ..parameter)) (def: #export (type reflection) - (-> java/lang/reflect/Type (Try /.Type)) + (-> java/lang/reflect/Type (Try (/.Type Value))) (<| (case (host.check java/lang/Class reflection) (#.Some reflection) - (case (|> reflection - (:coerce (java/lang/Class java/lang/Object)) - java/lang/Class::getName) - (^template [<reflection> <type>] - (^ (static <reflection>)) - (#try.Success <type>)) - ([reflection.boolean /.boolean] - [reflection.byte /.byte] - [reflection.short /.short] - [reflection.int /.int] - [reflection.long /.long] - [reflection.float /.float] - [reflection.double /.double] - [reflection.char /.char]) - - class-name - (if (text.starts-with? /.array-prefix class-name) - (<t>.run /.parse-signature (|> class-name //name.internal //name.read)) - (#try.Success (/.class class-name (list))))) + (let [class-name (|> reflection + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (`` (cond (~~ (template [<reflection> <type>] + [(text@= (/reflection.reflection <reflection>) + class-name) + (#try.Success <type>)] + + [/reflection.boolean /.boolean] + [/reflection.byte /.byte] + [/reflection.short /.short] + [/reflection.int /.int] + [/reflection.long /.long] + [/reflection.float /.float] + [/reflection.double /.double] + [/reflection.char /.char])) + (if (text.starts-with? /descriptor.array-prefix class-name) + (<t>.run /parser.value (|> class-name //name.internal //name.read)) + (#try.Success (/.class class-name (list))))))) _) (case (host.check java/lang/reflect/GenericArrayType reflection) (#.Some reflection) (|> reflection java/lang/reflect/GenericArrayType::getGenericComponentType type - (:: try.monad map (/.array 1))) + (:: try.monad map /.array)) _) ## else - (:: try.monad map (|>> #/.Generic) - (..generic reflection)))) + (..parameter reflection))) (def: #export (return reflection) - (-> java/lang/reflect/Type (Try /.Return)) - (with-expansions [<else> (as-is (:: try.monad map (|>> #.Some) - (..type reflection)))] + (-> java/lang/reflect/Type (Try (/.Type Return))) + (with-expansions [<else> (as-is (..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)) - (#try.Success #.None) - - _ - <else>) + (let [class-name (|> reflection + (:coerce (java/lang/Class java/lang/Object)) + java/lang/Class::getName)] + (if (text@= (/reflection.reflection /reflection.void) + class-name) + (#try.Success /.void) + <else>)) #.None <else>))) @@ -327,7 +340,7 @@ (template [<name> <exception> <then?> <else?>] [(def: #export (<name> field class) - (-> Text (java/lang/Class java/lang/Object) (Try [Bit /.Type])) + (-> Text (java/lang/Class java/lang/Object) (Try [Bit (/.Type Value)])) (do try.monad [fieldJ (..field field class) #let [modifiers (java/lang/reflect/Field::getModifiers fieldJ)]] diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux index d1af2ec02..d8b21a829 100644 --- a/stdlib/source/lux/target/jvm/type.lux +++ b/stdlib/source/lux/target/jvm/type.lux @@ -1,15 +1,12 @@ (.module: [lux (#- Type int char) [abstract - [equivalence (#+ Equivalence)] - [monad (#+ do)]] - [control - ["." function] - ["<>" parser ("#@." monad) - ["<t>" text (#+ Parser)]]] + [equivalence (#+ Equivalence)]] [data - ["." text ("#@." equivalence) - ["%" format (#+ format)]] + ["." maybe] + ["." text] + [number + ["n" nat]] [collection ["." list ("#@." functor)]]] [type @@ -18,7 +15,7 @@ [encoding ["#." name (#+ External)]]] ["." / #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." signature (#+ Signature)] ["#." descriptor (#+ Descriptor)] ["#." reflection (#+ Reflection)]]) @@ -28,6 +25,17 @@ [(Signature category) (Descriptor category) (Reflection category)] + (type: #export Argument + [Text (Type Value)]) + + (type: #export (Typed a) + [(Type Value) a]) + + (type: #export Constraint + {#name Text + #super-class (Type Class) + #super-interfaces (List (Type Class))}) + (template [<name> <style>] [(def: #export (<name> type) (All [category] (-> (Type category) (<style> category))) @@ -77,7 +85,7 @@ /reflection.wildcard])) (def: #export (var name) - (-> Text (Type Parameter)) + (-> Text (Type Var)) (:abstraction [(/signature.var name) /descriptor.var @@ -116,141 +124,43 @@ (:: /signature.equivalence = (..signature parameter) (..signature subject)))) - ) -(template [<category> <name> <signature> <type>] - [(def: <name> - (Parser (Type <category>)) - (<>.after (<t>.this (/signature.signature <signature>)) - (<>@wrap <type>)))] - - [Void void-parser /signature.void ..void] - [Primitive boolean-parser /signature.boolean ..boolean] - [Primitive byte-parser /signature.byte ..byte] - [Primitive short-parser /signature.short ..short] - [Primitive int-parser /signature.int ..int] - [Primitive long-parser /signature.long ..long] - [Primitive float-parser /signature.float ..float] - [Primitive double-parser /signature.double ..double] - [Primitive char-parser /signature.char ..char] - [Parameter wildcard-parser /signature.wildcard ..wildcard] + (def: #export (primitive? type) + (-> (Type Value) (Either (Type Object) + (Type Primitive))) + (if (`` (or (~~ (template [<type>] + [(:: ..equivalence = (: (Type Value) <type>) type)] + + [..boolean] + [..byte] + [..short] + [..int] + [..long] + [..float] + [..double] + [..char])))) + (|> type (:coerce (Type Primitive)) #.Right) + (|> type (:coerce (Type Object)) #.Left))) + + (def: #export (void? type) + (-> (Type Return) (Either (Type Value) + (Type Void))) + (if (`` (or (~~ (template [<type>] + [(:: ..equivalence = (: (Type Return) <type>) type)] + + [..void])))) + (|> type (:coerce (Type Void)) #.Right) + (|> type (:coerce (Type Value)) #.Left))) ) -(def: primitive-parser - (Parser (Type Primitive)) - ($_ <>.either - ..boolean-parser - ..byte-parser - ..short-parser - ..int-parser - ..long-parser - ..float-parser - ..double-parser - ..char-parser)) - -(def: valid-var-characters/head - (format "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "_")) - -(def: valid-var-characters/tail - (format valid-var-characters/head - "0123456789")) - -(def: valid-class-characters/head - (format valid-var-characters/head //name.internal-separator)) - -(def: valid-class-characters/tail - (format valid-var-characters/tail //name.internal-separator)) - -(template [<type> <name> <head> <tail> <adapter>] - [(def: #export <name> - (Parser <type>) - (:: <>.functor map <adapter> - (<t>.slice (<t>.and! (<t>.one-of! <head>) - (<t>.some! (<t>.one-of! <tail>))))))] - - [External class-name-parser valid-class-characters/head valid-class-characters/tail (|>> //name.internal //name.external)] - [Text var-name-parser valid-var-characters/head valid-var-characters/tail function.identity] - ) - -(def: #export var-parser - (Parser Text) - (|> ..var-name-parser - (<>.after (<t>.this /signature.var-prefix)) - (<>.before (<t>.this /descriptor.class-suffix)))) - -(def: var-parser' - (Parser (Type Parameter)) - (<>@map ..var ..var-parser)) - -(template [<name> <prefix> <constructor>] - [(def: <name> - (-> (Parser (Type Class)) (Parser (Type Parameter))) - (|>> (<>.after (<t>.this <prefix>)) - (<>@map <constructor>)))] - - [lower-parser /signature.lower-prefix ..lower] - [upper-parser /signature.upper-prefix ..upper] - ) - -(def: (class-parser parameter-parser) - (-> (Parser (Type Parameter)) (Parser (Type Class))) - (|> (do <>.monad - [_ (<t>.this /descriptor.class-prefix) - name ..class-name-parser - parameters (|> (<>.some parameter-parser) - (<>.after (<t>.this /signature.parameters-start)) - (<>.before (<t>.this /signature.parameters-end)) - (<>.default (list))) - _ (<t>.this /descriptor.class-suffix)] - (wrap (..class name parameters))) - (<>.after (<t>.this /descriptor.class-prefix)) - (<>.before (<t>.this /descriptor.class-suffix)))) - -(def: generic-parser - (Parser (Type Parameter)) - (<>.rec - (function (_ generic-parser) - (let [class-parser (..class-parser generic-parser)] - ($_ <>.either - ..var-parser' - ..wildcard-parser - (..lower-parser class-parser) - (..upper-parser class-parser) - class-parser - ))))) - -(def: array-parser - (-> (Parser (Type Value)) (Parser (Type Array))) - (|>> (<>.after (<t>.this /descriptor.array-prefix)) - (<>@map ..array))) - -(def: #export value-parser - (Parser (Type Value)) - (<>.rec - (function (_ parser) - ($_ <>.either - ..primitive-parser - ..generic-parser - (..array-parser parser) - )))) - -(def: #export method-parser - (Parser [(Signature Method) - (Descriptor Method)]) - (let [parameters-parser (: (Parser (List (Type Value))) - (|> (<>.some ..value-parser) - (<>.after (<t>.this /signature.arguments-start)) - (<>.before (<t>.this /signature.arguments-end)))) - return-parser (: (Parser (Type Return)) - (<>.either ..void-parser - ..value-parser)) - exception-parser (: (Parser (Type Class)) - (|> (..class-parser ..generic-parser) - (<>.after (<t>.this /signature.exception-prefix))))] - (do <>.monad - [parameters parameters-parser - return return-parser - exceptions (<>.some exception-parser)] - (wrap (..method [parameters return exceptions]))))) +(def: #export (class? type) + (-> (Type Value) (Maybe External)) + (let [repr (|> type ..descriptor /descriptor.descriptor)] + (if (and (text.starts-with? /descriptor.class-prefix repr) + (text.ends-with? /descriptor.class-suffix repr)) + (|> repr + (text.clip (text.size /descriptor.class-prefix) + (n.- (text.size /descriptor.class-suffix) + (text.size repr))) + (:: maybe.monad map (|>> //name.internal //name.external))) + #.None))) diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux new file mode 100644 index 000000000..dfa1e4356 --- /dev/null +++ b/stdlib/source/lux/target/jvm/type/alias.lux @@ -0,0 +1,112 @@ +(.module: + [lux (#- Type int char type primitive) + [abstract + ["." monad (#+ do)]] + [control + ["." try] + ["." exception (#+ exception:)] + ["<>" parser ("#@." monad) + ["<t>" text (#+ Parser)]]] + [data + ["." product] + ["." maybe] + ["." text + ["%" format (#+ format)]] + [collection + [array (#+ Array)] + ["." dictionary (#+ Dictionary)]]]] + ["." // (#+ Type) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + ["#." descriptor] + ["#." signature (#+ Signature)] + ["#." reflection] + ["#." parser] + ["/#" // #_ + [encoding + ["#." name]]]]) + +(type: #export Aliasing + (Dictionary Text Text)) + +(def: #export fresh + Aliasing + (dictionary.new text.hash)) + +(def: (var aliasing) + (-> Aliasing (Parser (Type Var))) + (do <>.monad + [var //parser.var'] + (wrap (|> aliasing + (dictionary.get var) + (maybe.default var) + //.var)))) + +(def: (class parameter) + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|> (do <>.monad + [_ (<t>.this //descriptor.class-prefix) + name //parser.class-name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters-start)) + (<>.before (<t>.this //signature.parameters-end)) + (<>.default (list))) + _ (<t>.this //descriptor.class-suffix)] + (wrap (//.class name parameters))) + (<>.after (<t>.this //descriptor.class-prefix)) + (<>.before (<t>.this //descriptor.class-suffix)))) + +(template [<name> <prefix> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (<>.after (<t>.this <prefix>)))] + + [lower //signature.lower-prefix ..Lower] + [upper //signature.upper-prefix ..Upper] + ) + +(def: (parameter aliasing) + (-> Aliasing (Parser (Type Parameter))) + (<>.rec + (function (_ parameter) + (let [class (..class parameter)] + ($_ <>.either + (..var aliasing) + //parser.wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: (value aliasing) + (-> Aliasing (Parser (Type Value))) + (<>.rec + (function (_ value) + ($_ <>.either + //parser.primitive + (parameter aliasing) + (//parser.array' value) + )))) + +(def: (return aliasing) + (-> Aliasing (Parser (Type Return))) + ($_ <>.either + //parser.void + (..value aliasing) + )) + +(def: #export (method aliasing signature) + (-> Aliasing (Signature Method) (Signature Method)) + (let [parameters (: (Parser (List (Type Value))) + (|> (<>.some (..value aliasing)) + (<>.after (<t>.this //signature.arguments-start)) + (<>.before (<t>.this //signature.arguments-end)))) + exception (: (Parser (Type Class)) + (|> (..class (..parameter aliasing)) + (<>.after (<t>.this //signature.exception-prefix))))] + (|> (//signature.signature signature) + (<t>.run (do <>.monad + [parameters parameters + return (..return aliasing) + exceptions (<>.some exception)] + (wrap (product.left (//.method [parameters return exceptions]))))) + try.assume))) diff --git a/stdlib/source/lux/target/jvm/type/box.lux b/stdlib/source/lux/target/jvm/type/box.lux index 37f160458..65816b487 100644 --- a/stdlib/source/lux/target/jvm/type/box.lux +++ b/stdlib/source/lux/target/jvm/type/box.lux @@ -1,8 +1,11 @@ (.module: - [lux (#- int char)]) + [lux (#- int char)] + [/// + [encoding + [name (#+ External)]]]) (template [<name> <box>] - [(def: #export <name> <box>)] + [(def: #export <name> External <box>)] [boolean "java.lang.Boolean"] [byte "java.lang.Byte"] diff --git a/stdlib/source/lux/target/jvm/type/category.lux b/stdlib/source/lux/target/jvm/type/category.lux index 3bbf03783..cbeaa53ef 100644 --- a/stdlib/source/lux/target/jvm/type/category.lux +++ b/stdlib/source/lux/target/jvm/type/category.lux @@ -27,6 +27,7 @@ (`` (<| Return' Value' (~~ (template.splice <parents>)) <raw>))))] [[] Primitive] + [[Object' Parameter'] Var] [[Object' Parameter'] Class] [[Object'] Array] ) diff --git a/stdlib/source/lux/target/jvm/type/descriptor.lux b/stdlib/source/lux/target/jvm/type/descriptor.lux index e16693ff4..367f3338d 100644 --- a/stdlib/source/lux/target/jvm/type/descriptor.lux +++ b/stdlib/source/lux/target/jvm/type/descriptor.lux @@ -13,10 +13,10 @@ [type abstract]] ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["/#" // #_ [encoding - ["#." name (#+ External)]]]]) + ["#." name (#+ Internal External)]]]]) (abstract: #export (Descriptor category) {} @@ -53,14 +53,14 @@ (text.enclose [..class-prefix ..class-suffix]) :abstraction)) - (template [<name>] + (template [<name> <category>] [(def: #export <name> - (Descriptor Parameter) + (Descriptor <category>) (:transmutation (..class "java.lang.Object")))] - [var] - [wildcard] + [var Var] + [wildcard Parameter] ) (def: #export (lower descriptor) @@ -97,49 +97,18 @@ (def: (= parameter subject) (text@= (:representation parameter) (:representation subject)))) - (def: #export (primitive? descriptor) - (-> (Descriptor Value) (Either (Descriptor Object) - (Descriptor Primitive))) - (if (`` (or (~~ (template [<descriptor>] - [(:: ..equivalence = <descriptor> descriptor)] - - [..boolean] - [..byte] - [..short] - [..int] - [..long] - [..float] - [..double] - [..char])))) - (|> descriptor :transmutation #.Right) - (|> descriptor :transmutation #.Left))) - - (def: binary-name (|>> ///name.internal ///name.external)) - - (def: #export (class? descriptor) - (-> (Descriptor Value) (Maybe External)) - (let [repr (:representation descriptor)] - (if (and (text.starts-with? ..class-prefix repr) - (text.ends-with? ..class-suffix repr)) - (|> repr - (text.clip (text.size ..class-prefix) - (n.- (text.size ..class-suffix) - (text.size repr))) - (:: maybe.monad map ..binary-name)) - #.None))) - (def: #export class-name - (-> (Descriptor Object) External) + (-> (Descriptor Object) Internal) (let [prefix-size (text.size ..class-prefix) suffix-size (text.size ..class-suffix)] (function (_ descriptor) (let [repr (:representation descriptor)] (if (text.starts-with? ..array-prefix repr) - repr + (///name.internal repr) (|> repr (text.clip prefix-size (n.- suffix-size (text.size repr))) - (:: maybe.monad map ..binary-name) + (:: maybe.monad map ///name.internal) maybe.assume)))))) ) diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux index 06cd81ec0..56203d32b 100644 --- a/stdlib/source/lux/target/jvm/type/lux.lux +++ b/stdlib/source/lux/target/jvm/type/lux.lux @@ -1,8 +1,9 @@ (.module: - [lux (#- type) + [lux (#- int char type primitive) [abstract ["." monad (#+ do)]] [control + ["." try] ["." exception (#+ exception:)] ["<>" parser ("#@." monad) ["<t>" text (#+ Parser)]]] @@ -17,9 +18,11 @@ abstract ["." check (#+ Check) ("#@." monad)]]] ["." // + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." descriptor] ["#." signature] ["#." reflection] + ["#." parser] ["/#" // #_ [encoding ["#." name]]]]) @@ -41,62 +44,63 @@ (exception.report ["Var" (%.text var)])) -(def: void-parser +(def: void (Parser (Check Type)) - (<>.after (<t>.this (//signature.signature //signature.void)) + (<>.after //parser.void (<>@wrap (check@wrap .Any)))) -(template [<name> <signature> <reflection>] +(template [<name> <parser> <reflection>] [(def: <name> (Parser (Check Type)) - (<>.after (<t>.this (//signature.signature <signature>)) + (<>.after <parser> (<>@wrap (check@wrap (#.Primitive (//reflection.reflection <reflection>) #.Nil)))))] - [boolean-parser //signature.boolean //reflection.boolean] - [byte-parser //signature.byte //reflection.byte] - [short-parser //signature.short //reflection.short] - [int-parser //signature.int //reflection.int] - [long-parser //signature.long //reflection.long] - [float-parser //signature.float //reflection.float] - [double-parser //signature.double //reflection.double] - [char-parser //signature.char //reflection.char] + [boolean //parser.boolean //reflection.boolean] + [byte //parser.byte //reflection.byte] + [short //parser.short //reflection.short] + [int //parser.int //reflection.int] + [long //parser.long //reflection.long] + [float //parser.float //reflection.float] + [double //parser.double //reflection.double] + [char //parser.char //reflection.char] ) -(def: primitive-parser +(def: primitive (Parser (Check Type)) ($_ <>.either - ..boolean-parser - ..byte-parser - ..short-parser - ..int-parser - ..long-parser - ..float-parser - ..double-parser - ..char-parser)) - -(def: wildcard-parser + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def: wildcard (Parser (Check Type)) - (<>.after (<t>.this (//signature.signature //signature.wildcard)) + (<>.after //parser.wildcard (<>@wrap (check@map product.right check.existential)))) -(def: (var-parser mapping) +(def: (var mapping) (-> Mapping (Parser (Check Type))) (do <>.monad - [var //.var-parser] - (<>@wrap (case (dictionary.get var mapping) - #.None - (check.throw ..unknown-var [var]) - - (#.Some type) - (check@wrap type))))) - -(def: (class-parser parameter-parser) + [var //parser.var'] + (wrap (case (dictionary.get var mapping) + #.None + (check.throw ..unknown-var [var]) + + (#.Some type) + (check@wrap type))))) + +(def: (class' parameter) (-> (Parser (Check Type)) (Parser (Check Type))) (|> (do <>.monad [_ (<t>.this //descriptor.class-prefix) - name //.class-name-parser - parameters (|> (<>.some parameter-parser) + name //parser.class-name + parameters (|> (<>.some parameter) (<>.after (<t>.this //signature.parameters-start)) (<>.before (<t>.this //signature.parameters-end)) (<>.default (list))) @@ -110,27 +114,33 @@ (template [<name> <prefix> <constructor>] [(def: <name> (-> (Parser (Check Type)) (Parser (Check Type))) - ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. - ## (<>@map (check@map (|>> <ctor> .type))) - (<>.after (<t>.this <prefix>)))] + (|> (<>.after (<t>.this <prefix>)) + ## TODO: Re-enable Lower and Upper, instead of using the simplified limit. + ## (<>@map (check@map (|>> <ctor> .type))) + ))] - [lower-parser //signature.lower-prefix ..Lower] - [upper-parser //signature.upper-prefix ..Upper] + [lower //signature.lower-prefix ..Lower] + [upper //signature.upper-prefix ..Upper] ) -(def: (generic-parser mapping) +(def: (parameter mapping) (-> Mapping (Parser (Check Type))) (<>.rec - (function (_ generic-parser) - (let [class-parser (..class-parser generic-parser)] + (function (_ parameter) + (let [class (..class' parameter)] ($_ <>.either - (..var-parser mapping) - ..wildcard-parser - (..lower-parser class-parser) - (..upper-parser class-parser) - class-parser))))) + (..var mapping) + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: #export class + (-> Mapping (Parser (Check Type))) + (|>> ..parameter ..class')) -(def: array-parser +(def: array (-> (Parser (Check Type)) (Parser (Check Type))) (|>> (<>@map (check@map (function (_ elementT) (case elementT @@ -141,18 +151,28 @@ (|> elementT Array .type))))) (<>.after (<t>.this //descriptor.array-prefix)))) -(def: #export (type-parser mapping) +(def: #export (type mapping) (-> Mapping (Parser (Check Type))) (<>.rec - (function (_ type-parser) + (function (_ type) ($_ <>.either - ..primitive-parser - (generic-parser mapping) - (..array-parser type-parser))))) + ..primitive + (parameter mapping) + (..array type) + )))) -(def: #export (return-parser mapping) +(def: #export (return mapping) (-> Mapping (Parser (Check Type))) ($_ <>.either - ..void-parser - (..type-parser mapping) + ..void + (..type mapping) )) + +(def: #export (check operation input) + (All [a] (-> (Parser (Check a)) Text (Check a))) + (case (<t>.run operation input) + (#try.Success check) + check + + (#try.Failure error) + (check.fail error))) diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux new file mode 100644 index 000000000..fd29e4856 --- /dev/null +++ b/stdlib/source/lux/target/jvm/type/parser.lux @@ -0,0 +1,195 @@ +(.module: + [lux (#- Type int char primitive) + [abstract + [monad (#+ do)]] + [control + ["." try] + ["." function] + ["<>" parser ("#@." monad) + ["<t>" text (#+ Parser)]]] + [data + ["." product] + [text + ["%" format (#+ format)]]]] + ["." // (#+ Type) + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] + ["#." signature (#+ Signature)] + ["#." descriptor (#+ Descriptor)] + ["#." reflection (#+ Reflection)] + ["." // #_ + [encoding + ["#." name (#+ External)]]]]) + +(template [<category> <name> <signature> <type>] + [(def: #export <name> + (Parser (Type <category>)) + (<>.after (<t>.this (//signature.signature <signature>)) + (<>@wrap <type>)))] + + [Void void //signature.void //.void] + [Primitive boolean //signature.boolean //.boolean] + [Primitive byte //signature.byte //.byte] + [Primitive short //signature.short //.short] + [Primitive int //signature.int //.int] + [Primitive long //signature.long //.long] + [Primitive float //signature.float //.float] + [Primitive double //signature.double //.double] + [Primitive char //signature.char //.char] + [Parameter wildcard //signature.wildcard //.wildcard] + ) + +(def: #export primitive + (Parser (Type Primitive)) + ($_ <>.either + ..boolean + ..byte + ..short + ..int + ..long + ..float + ..double + ..char + )) + +(def: var/head + (format "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "_")) + +(def: var/tail + (format var/head + "0123456789")) + +(def: class/head + (format var/head //name.internal-separator)) + +(def: class/tail + (format var/tail //name.internal-separator)) + +(template [<type> <name> <head> <tail> <adapter>] + [(def: #export <name> + (Parser <type>) + (:: <>.functor map <adapter> + (<t>.slice (<t>.and! (<t>.one-of! <head>) + (<t>.some! (<t>.one-of! <tail>))))))] + + [External class-name class/head class/tail (|>> //name.internal //name.external)] + [Text var-name var/head var/tail function.identity] + ) + +(def: #export var' + (Parser Text) + (|> ..var-name + (<>.after (<t>.this //signature.var-prefix)) + (<>.before (<t>.this //descriptor.class-suffix)))) + +(def: #export var + (Parser (Type Var)) + (<>@map //.var ..var')) + +(def: #export var? + (-> (Type Parameter) (Maybe Text)) + (|>> //.signature + //signature.signature + (<t>.run ..var') + try.maybe)) + +(def: #export name + (-> (Type Var) Text) + (|>> //.signature + //signature.signature + (<t>.run ..var') + try.assume)) + +(template [<name> <prefix> <constructor>] + [(def: <name> + (-> (Parser (Type Class)) (Parser (Type Parameter))) + (|>> (<>.after (<t>.this <prefix>)) + (<>@map <constructor>)))] + + [lower //signature.lower-prefix //.lower] + [upper //signature.upper-prefix //.upper] + ) + +(def: (class'' parameter) + (-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))])) + (|> (do <>.monad + [_ (<t>.this //descriptor.class-prefix) + name ..class-name + parameters (|> (<>.some parameter) + (<>.after (<t>.this //signature.parameters-start)) + (<>.before (<t>.this //signature.parameters-end)) + (<>.default (list))) + _ (<t>.this //descriptor.class-suffix)] + (wrap [name parameters])) + (<>.after (<t>.this //descriptor.class-prefix)) + (<>.before (<t>.this //descriptor.class-suffix)))) + +(def: class' + (-> (Parser (Type Parameter)) (Parser (Type Class))) + (|>> ..class'' + (:: <>.monad map (product.uncurry //.class)))) + +(def: #export parameter + (Parser (Type Parameter)) + (<>.rec + (function (_ parameter) + (let [class (..class' parameter)] + ($_ <>.either + ..var + ..wildcard + (..lower class) + (..upper class) + class + ))))) + +(def: #export array' + (-> (Parser (Type Value)) (Parser (Type Array))) + (|>> (<>.after (<t>.this //descriptor.array-prefix)) + (<>@map //.array))) + +(def: #export class + (Parser (Type Class)) + (..class' ..parameter)) + +(def: #export read-class + (-> (Type Class) [External (List (Type Parameter))]) + (|>> //.signature + //signature.signature + (<t>.run (..class'' ..parameter)) + try.assume)) + +(def: #export value + (Parser (Type Value)) + (<>.rec + (function (_ value) + ($_ <>.either + ..primitive + ..parameter + (..array' value) + )))) + +(def: #export array + (Parser (Type Array)) + (..array' ..value)) + +(def: #export return + (Parser (Type Return)) + (<>.either ..void + ..value)) + +(def: #export method + (Parser [(Signature Method) + (Descriptor Method)]) + (let [parameters (: (Parser (List (Type Value))) + (|> (<>.some ..value) + (<>.after (<t>.this //signature.arguments-start)) + (<>.before (<t>.this //signature.arguments-end)))) + exception (: (Parser (Type Class)) + (|> (..class' ..parameter) + (<>.after (<t>.this //signature.exception-prefix))))] + (do <>.monad + [parameters parameters + return ..return + exceptions (<>.some exception)] + (wrap (//.method [parameters return exceptions]))))) diff --git a/stdlib/source/lux/target/jvm/type/reflection.lux b/stdlib/source/lux/target/jvm/type/reflection.lux index 65ee1aa90..ffc26fb8b 100644 --- a/stdlib/source/lux/target/jvm/type/reflection.lux +++ b/stdlib/source/lux/target/jvm/type/reflection.lux @@ -6,7 +6,7 @@ [type abstract]] ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." descriptor] [// [encoding @@ -47,14 +47,14 @@ (format //descriptor.array-prefix) :abstraction)) - (template [<name>] + (template [<name> <category>] [(def: #export <name> - (Reflection Parameter) + (Reflection <category>) (:transmutation (..class "java.lang.Object")))] - [var] - [wildcard] + [var Var] + [wildcard Parameter] ) (def: #export (lower reflection) diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux index 260c564db..56fb04da6 100644 --- a/stdlib/source/lux/target/jvm/type/signature.lux +++ b/stdlib/source/lux/target/jvm/type/signature.lux @@ -10,7 +10,7 @@ [type abstract]] ["." // #_ - [category (#+ Void Value Return Method Primitive Object Class Array Parameter)] + [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)] ["#." descriptor] ["/#" // #_ [encoding @@ -54,7 +54,7 @@ (def: #export var-prefix "T") (def: #export var - (-> Text (Signature Parameter)) + (-> Text (Signature Var)) (|>> (text.enclose [..var-prefix //descriptor.class-suffix]) :abstraction)) 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 af85ebf1c..98f09019e 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -27,10 +27,16 @@ [target ["." jvm #_ [".!" reflection] - ["#" type (#+ Var Bound Primitive Generic Class Type Argument Return Method Typed) - ("method@." method-equivalence) + [encoding + [name (#+ External)]] + ["#" type (#+ Type Argument Typed) + ["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)] ["." box] ["." reflection] + ["." descriptor (#+ Descriptor)] + ["." signature (#+ Signature) ("#@." equivalence)] + ["#-." parser] + ["#-." alias (#+ Aliasing)] [".T" lux (#+ Mapping)]]]]] ["." // #_ ["#." lux (#+ custom)] @@ -46,6 +52,11 @@ ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] ["#." synthesis]]]]]) +(def: reflection (|>> jvm.reflection reflection.reflection)) +(def: signature (|>> jvm.signature signature.signature)) + +(def: object-class "java.lang.Object") + (def: inheritance-relationship-type-name "_jvm_inheritance") (def: #export (inheritance-relationship-type class super-class super-interfaces) (-> .Type .Type (List .Type) .Type) @@ -69,14 +80,14 @@ [String "java.lang.String"] ## Primitives - [boolean reflection.boolean] - [byte reflection.byte] - [short reflection.short] - [int reflection.int] - [long reflection.long] - [float reflection.float] - [double reflection.double] - [char reflection.char] + [boolean (reflection.reflection reflection.boolean)] + [byte (reflection.reflection reflection.byte)] + [short (reflection.reflection reflection.short)] + [int (reflection.reflection reflection.int)] + [long (reflection.reflection reflection.long)] + [float (reflection.reflection reflection.float)] + [double (reflection.reflection reflection.double)] + [char (reflection.reflection reflection.char)] ) (type: Member @@ -98,6 +109,7 @@ [non-object] [non-array] + [non-parameter] ) (template [<name>] @@ -179,7 +191,7 @@ (template [<name> <prefix> <type>] [(def: <name> Bundle - (<| (///bundle.prefix <prefix>) + (<| (///bundle.prefix (reflection.reflection <prefix>)) (|> ///bundle.empty (///bundle.install "+" (//lux.binary <type> <type> <type>)) (///bundle.install "-" (//lux.binary <type> <type> <type>)) @@ -203,7 +215,7 @@ (template [<name> <prefix> <type>] [(def: <name> Bundle - (<| (///bundle.prefix <prefix>) + (<| (///bundle.prefix (reflection.reflection <prefix>)) (|> ///bundle.empty (///bundle.install "+" (//lux.binary <type> <type> <type>)) (///bundle.install "-" (//lux.binary <type> <type> <type>)) @@ -220,7 +232,7 @@ (def: bundle::char Bundle - (<| (///bundle.prefix reflection.char) + (<| (///bundle.prefix (reflection.reflection reflection.char)) (|> ///bundle.empty (///bundle.install "=" (//lux.binary ..char ..char Bit)) (///bundle.install "<" (//lux.binary ..char ..char Bit)) @@ -228,14 +240,14 @@ (def: #export boxes (Dictionary Text Text) - (|> (list [reflection.boolean box.boolean] - [reflection.byte box.byte] - [reflection.short box.short] - [reflection.int box.int] - [reflection.long box.long] - [reflection.float box.float] - [reflection.double box.double] - [reflection.char box.char]) + (|> (list [(reflection.reflection reflection.boolean) box.boolean] + [(reflection.reflection reflection.byte) box.byte] + [(reflection.reflection reflection.short) box.short] + [(reflection.reflection reflection.int) box.int] + [(reflection.reflection reflection.long) box.long] + [(reflection.reflection reflection.float) box.float] + [(reflection.reflection reflection.double) box.double] + [(reflection.reflection reflection.char) box.char]) (dictionary.from-list text.hash))) (def: (array-type-info allow-primitives? arrayT) @@ -269,19 +281,20 @@ (////@wrap [level class])) (#.Ex _) - (////@wrap [level "java.lang.Object"]) + (////@wrap [level ..object-class]) _ (/////analysis.throw ..non-array arrayT)))) (def: (primitive-array-length-handler primitive-type) - (-> Type Handler) + (-> (Type Primitive) Handler) (function (_ extension-name analyse args) (case args (^ (list arrayC)) (do ////.monad [_ (typeA.infer ..int) - arrayA (typeA.with-type (#.Primitive (reflection.class (jvm.array 1 primitive-type)) (list)) + arrayA (typeA.with-type (#.Primitive (|> (jvm.array primitive-type) ..reflection) + (list)) (analyse arrayC))] (wrap (#/////analysis.Extension extension-name (list arrayA)))) @@ -308,14 +321,15 @@ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) (def: (new-primitive-array-handler primitive-type) - (-> Type Handler) + (-> (Type Primitive) Handler) (function (_ extension-name analyse args) (case args (^ (list lengthC)) (do ////.monad [lengthA (typeA.with-type ..int (analyse lengthC)) - _ (typeA.infer (#.Primitive (reflection.class (jvm.array 1 primitive-type)) (list)))] + _ (typeA.infer (#.Primitive (|> (jvm.array primitive-type) ..reflection) + (list)))] (wrap (#/////analysis.Extension extension-name (list lengthA)))) _ @@ -341,52 +355,99 @@ _ (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) +(def: (check-parameter objectT) + (-> .Type (Operation (Type Parameter))) + (case objectT + (^ (#.Primitive (static array.type-name) + (list elementT))) + (/////analysis.throw ..non-parameter objectT) + + (#.Primitive name parameters) + (`` (cond (~~ (template [<reflection>] + [(text@= (reflection.reflection <reflection>) + name) + (/////analysis.throw ..non-parameter objectT)] + + [reflection.boolean] + [reflection.byte] + [reflection.short] + [reflection.int] + [reflection.long] + [reflection.float] + [reflection.double] + [reflection.char])) + + (text.starts-with? descriptor.array-prefix name) + (/////analysis.throw ..non-parameter objectT) + + ## else + (////@wrap (jvm.class name (list))))) + + (#.Named name anonymous) + (check-parameter anonymous) + + (^template [<tag>] + (<tag> id) + (////@wrap (jvm.class ..object-class (list)))) + ([#.Var] + [#.Ex]) + + (^template [<tag>] + (<tag> env unquantified) + (check-parameter unquantified)) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT abstractionT) + (case (type.apply (list inputT) abstractionT) + (#.Some outputT) + (check-parameter outputT) + + #.None + (/////analysis.throw ..non-parameter objectT)) + + _ + (/////analysis.throw ..non-parameter objectT))) + (def: (check-jvm objectT) - (-> .Type (Operation Type)) + (-> .Type (Operation (Type Value))) (case objectT (#.Primitive name #.Nil) - (case name - (^ (static reflection.boolean)) (////@wrap jvm.boolean) - (^ (static reflection.byte)) (////@wrap jvm.byte) - (^ (static reflection.short)) (////@wrap jvm.short) - (^ (static reflection.int)) (////@wrap jvm.int) - (^ (static reflection.long)) (////@wrap jvm.long) - (^ (static reflection.float)) (////@wrap jvm.float) - (^ (static reflection.double)) (////@wrap jvm.double) - (^ (static reflection.char)) (////@wrap jvm.char) - _ (if (text.starts-with? jvm.array-prefix name) - (////.lift (<t>.run jvm.parse-signature name)) - (////@wrap (jvm.class name (list))))) - + (`` (cond (~~ (template [<reflection> <type>] + [(text@= (reflection.reflection <reflection>) + name) + (////@wrap <type>)] + + [reflection.boolean jvm.boolean] + [reflection.byte jvm.byte] + [reflection.short jvm.short] + [reflection.int jvm.int] + [reflection.long jvm.long] + [reflection.float jvm.float] + [reflection.double jvm.double] + [reflection.char jvm.char])) + + (text.starts-with? descriptor.array-prefix name) + (////.lift (<t>.run jvm-parser.value name)) + + ## else + (////@wrap (jvm.class name (list))))) + (^ (#.Primitive (static array.type-name) (list elementT))) (|> elementT check-jvm - (////@map (jvm.array 1))) + (////@map jvm.array)) (#.Primitive name parameters) (do ////.monad - [parameters (monad.map @ check-jvm parameters) - parameters (monad.map @ (function (_ parameter) - (case parameter - (#jvm.Generic generic) - (wrap generic) - - _ - (/////analysis.throw ..primitives-cannot-have-type-parameters name))) - parameters)] + [parameters (monad.map @ check-parameter parameters)] (////@wrap (jvm.class name parameters))) (#.Named name anonymous) (check-jvm anonymous) (^template [<tag>] - (<tag> id) - (////@wrap (jvm.class "java.lang.Object" (list)))) - ([#.Var] - [#.Ex]) - - (^template [<tag>] (<tag> env unquantified) (check-jvm unquantified)) ([#.UnivQ] @@ -401,24 +462,24 @@ (/////analysis.throw ..non-object objectT)) _ - (/////analysis.throw ..non-object objectT))) + (check-parameter objectT))) (def: (check-object objectT) - (-> .Type (Operation Text)) + (-> .Type (Operation External)) (do ////.monad - [name (:: @ map reflection.class (check-jvm objectT))] + [name (:: @ map ..reflection (check-jvm objectT))] (if (dictionary.contains? name ..boxes) (/////analysis.throw ..primitives-are-not-objects [name]) (////@wrap name)))) (def: (check-return type) - (-> .Type (Operation Text)) + (-> .Type (Operation (Type Return))) (if (is? .Any type) - (////@wrap jvm.void-descriptor) - (////@map reflection.class (check-jvm type)))) + (////@wrap jvm.void) + (check-jvm type))) (def: (read-primitive-array-handler lux-type jvm-type) - (-> .Type Type Handler) + (-> .Type (Type Primitive) Handler) (function (_ extension-name analyse args) (case args (^ (list idxC arrayC)) @@ -426,7 +487,8 @@ [_ (typeA.infer lux-type) idxA (typeA.with-type ..int (analyse idxC)) - arrayA (typeA.with-type (#.Primitive (reflection.class (jvm.array 1 jvm-type)) (list)) + arrayA (typeA.with-type (#.Primitive (|> (jvm.array jvm-type) ..reflection) + (list)) (analyse arrayC))] (wrap (#/////analysis.Extension extension-name (list idxA arrayA)))) @@ -457,8 +519,9 @@ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) (def: (write-primitive-array-handler lux-type jvm-type) - (-> .Type Type Handler) - (let [array-type (#.Primitive (reflection.class (jvm.array 1 jvm-type)) (list))] + (-> .Type (Type Primitive) Handler) + (let [array-type (#.Primitive (|> (jvm.array jvm-type) ..reflection) + (list))] (function (_ extension-name analyse args) (case args (^ (list idxC valueC arrayC)) @@ -509,47 +572,47 @@ (|> ///bundle.empty (dictionary.merge (<| (///bundle.prefix "length") (|> ///bundle.empty - (///bundle.install reflection.boolean (primitive-array-length-handler jvm.boolean)) - (///bundle.install reflection.byte (primitive-array-length-handler jvm.byte)) - (///bundle.install reflection.short (primitive-array-length-handler jvm.short)) - (///bundle.install reflection.int (primitive-array-length-handler jvm.int)) - (///bundle.install reflection.long (primitive-array-length-handler jvm.long)) - (///bundle.install reflection.float (primitive-array-length-handler jvm.float)) - (///bundle.install reflection.double (primitive-array-length-handler jvm.double)) - (///bundle.install reflection.char (primitive-array-length-handler jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (primitive-array-length-handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (primitive-array-length-handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (primitive-array-length-handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (primitive-array-length-handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (primitive-array-length-handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (primitive-array-length-handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (primitive-array-length-handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (primitive-array-length-handler jvm.char)) (///bundle.install "object" array::length::object)))) (dictionary.merge (<| (///bundle.prefix "new") (|> ///bundle.empty - (///bundle.install reflection.boolean (new-primitive-array-handler jvm.boolean)) - (///bundle.install reflection.byte (new-primitive-array-handler jvm.byte)) - (///bundle.install reflection.short (new-primitive-array-handler jvm.short)) - (///bundle.install reflection.int (new-primitive-array-handler jvm.int)) - (///bundle.install reflection.long (new-primitive-array-handler jvm.long)) - (///bundle.install reflection.float (new-primitive-array-handler jvm.float)) - (///bundle.install reflection.double (new-primitive-array-handler jvm.double)) - (///bundle.install reflection.char (new-primitive-array-handler jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (new-primitive-array-handler jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (new-primitive-array-handler jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (new-primitive-array-handler jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (new-primitive-array-handler jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (new-primitive-array-handler jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (new-primitive-array-handler jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (new-primitive-array-handler jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (new-primitive-array-handler jvm.char)) (///bundle.install "object" array::new::object)))) (dictionary.merge (<| (///bundle.prefix "read") (|> ///bundle.empty - (///bundle.install reflection.boolean (read-primitive-array-handler ..boolean jvm.boolean)) - (///bundle.install reflection.byte (read-primitive-array-handler ..byte jvm.byte)) - (///bundle.install reflection.short (read-primitive-array-handler ..short jvm.short)) - (///bundle.install reflection.int (read-primitive-array-handler ..int jvm.int)) - (///bundle.install reflection.long (read-primitive-array-handler ..long jvm.long)) - (///bundle.install reflection.float (read-primitive-array-handler ..float jvm.float)) - (///bundle.install reflection.double (read-primitive-array-handler ..double jvm.double)) - (///bundle.install reflection.char (read-primitive-array-handler ..char jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (read-primitive-array-handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (read-primitive-array-handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (read-primitive-array-handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (read-primitive-array-handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (read-primitive-array-handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (read-primitive-array-handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (read-primitive-array-handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (read-primitive-array-handler ..char jvm.char)) (///bundle.install "object" array::read::object)))) (dictionary.merge (<| (///bundle.prefix "write") (|> ///bundle.empty - (///bundle.install reflection.boolean (write-primitive-array-handler ..boolean jvm.boolean)) - (///bundle.install reflection.byte (write-primitive-array-handler ..byte jvm.byte)) - (///bundle.install reflection.short (write-primitive-array-handler ..short jvm.short)) - (///bundle.install reflection.int (write-primitive-array-handler ..int jvm.int)) - (///bundle.install reflection.long (write-primitive-array-handler ..long jvm.long)) - (///bundle.install reflection.float (write-primitive-array-handler ..float jvm.float)) - (///bundle.install reflection.double (write-primitive-array-handler ..double jvm.double)) - (///bundle.install reflection.char (write-primitive-array-handler ..char jvm.char)) + (///bundle.install (reflection.reflection reflection.boolean) (write-primitive-array-handler ..boolean jvm.boolean)) + (///bundle.install (reflection.reflection reflection.byte) (write-primitive-array-handler ..byte jvm.byte)) + (///bundle.install (reflection.reflection reflection.short) (write-primitive-array-handler ..short jvm.short)) + (///bundle.install (reflection.reflection reflection.int) (write-primitive-array-handler ..int jvm.int)) + (///bundle.install (reflection.reflection reflection.long) (write-primitive-array-handler ..long jvm.long)) + (///bundle.install (reflection.reflection reflection.float) (write-primitive-array-handler ..float jvm.float)) + (///bundle.install (reflection.reflection reflection.double) (write-primitive-array-handler ..double jvm.double)) + (///bundle.install (reflection.reflection reflection.char) (write-primitive-array-handler ..char jvm.char)) (///bundle.install "object" array::write::object)))) ))) @@ -693,18 +756,26 @@ (getDeclaredMethods [] [java/lang/reflect/Method])) (def: (reflection-type mapping typeJ) - (-> Mapping Type (Operation .Type)) - (typeA.with-env - (luxT.type mapping typeJ))) - -(def: (reflection-return mapping return) - (-> Mapping Return (Operation .Type)) - (case return - #.None - (////@wrap .Any) - - (#.Some return) - (..reflection-type mapping return))) + (-> Mapping (Type Value) (Operation .Type)) + (case (|> typeJ jvm.signature signature.signature + (<t>.run (luxT.type mapping))) + (#try.Success check) + (typeA.with-env + check) + + (#try.Failure error) + (////.fail error))) + +(def: (reflection-return mapping typeJ) + (-> Mapping (Type Return) (Operation .Type)) + (case (|> typeJ jvm.signature signature.signature + (<t>.run (luxT.return mapping))) + (#try.Success check) + (typeA.with-env + check) + + (#try.Failure error) + (////.fail error))) (def: (class-candidate-parents from-name fromT to-name to-class) (-> Text .Type Text (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit]))) @@ -715,9 +786,9 @@ (function (_ superJT) (do @ [superJT (////.lift (reflection!.type superJT)) - #let [super-name (reflection.class superJT)] + #let [super-name (|> superJT ..reflection)] super-class (////.lift (reflection!.load super-name)) - superT (typeA.with-env (luxT.type mapping superJT))] + superT (reflection-type mapping superJT)] (wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)]))) (case (java/lang/Class::getGenericSuperclass from-class) (#.Some super) @@ -736,7 +807,7 @@ (monad.map ////.monad (function (_ superT) (do ////.monad - [super-name (:: @ map reflection.class (check-jvm superT)) + [super-name (:: @ map ..reflection (check-jvm superT)) super-class (////.lift (reflection!.load super-name))] (wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)]))) @@ -752,56 +823,59 @@ (^ (list fromC)) (do ////.monad [toT (///.lift macro.expected-type) - to-name (:: @ map reflection.class (check-jvm toT)) + to-name (:: @ map ..reflection (check-jvm toT)) [fromT fromA] (typeA.with-inference (analyse fromC)) - from-name (:: @ map reflection.class (check-jvm fromT)) + from-name (:: @ map ..reflection (check-jvm fromT)) can-cast? (: (Operation Bit) - (case [from-name to-name] - (^template [<primitive> <object>] - (^or (^ [(static <primitive>) (static <object>)]) - (^ [(static <object>) (static <primitive>)]) - (^ [(static <primitive>) (static <primitive>)])) - (wrap #1)) - ([reflection.boolean box.boolean] - [reflection.byte box.byte] - [reflection.short box.short] - [reflection.int box.int] - [reflection.long box.long] - [reflection.float box.float] - [reflection.double box.double] - [reflection.char box.char]) - - _ - (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 (////.lift (reflection!.load to-name)) - _ (if (text@= ..inheritance-relationship-type-name from-name) - (wrap []) - (do @ - [from-class (////.lift (reflection!.load from-name))] - (////.assert cannot-cast [fromT toT fromC] - (java/lang/Class::isAssignableFrom from-class to-class))))] - (loop [[current-name currentT] [from-name fromT]] - (if (text@= to-name current-name) - (wrap #1) - (do @ - [candidate-parents (: (Operation (List [[Text .Type] Bit])) - (if (text@= ..inheritance-relationship-type-name current-name) - (inheritance-candidate-parents currentT to-class toT fromC) - (class-candidate-parents current-name currentT to-name to-class)))] - (case (|> candidate-parents - (list.filter product.right) - (list@map product.left)) - (#.Cons [next-name nextT] _) - (recur [next-name nextT]) - - #.Nil - (/////analysis.throw cannot-cast [fromT toT fromC])) - ))))))] + (`` (cond (~~ (template [<primitive> <object>] + [(let [=primitive (reflection.reflection <primitive>)] + (or (and (text@= =primitive from-name) + (or (text@= <object> to-name) + (text@= =primitive to-name))) + (and (text@= <object> from-name) + (text@= =primitive to-name)))) + (wrap true)] + + [reflection.boolean box.boolean] + [reflection.byte box.byte] + [reflection.short box.short] + [reflection.int box.int] + [reflection.long box.long] + [reflection.float box.float] + [reflection.double box.double] + [reflection.char box.char])) + + ## else + (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 (////.lift (reflection!.load to-name)) + _ (if (text@= ..inheritance-relationship-type-name from-name) + (wrap []) + (do @ + [from-class (////.lift (reflection!.load from-name))] + (////.assert cannot-cast [fromT toT fromC] + (java/lang/Class::isAssignableFrom from-class to-class))))] + (loop [[current-name currentT] [from-name fromT]] + (if (text@= to-name current-name) + (wrap true) + (do @ + [candidate-parents (: (Operation (List [[Text .Type] Bit])) + (if (text@= ..inheritance-relationship-type-name current-name) + (inheritance-candidate-parents currentT to-class toT fromC) + (class-candidate-parents current-name currentT to-name to-class)))] + (case (|> candidate-parents + (list.filter product.right) + (list@map product.left)) + (#.Cons [next-name nextT] _) + (recur [next-name nextT]) + + #.Nil + (/////analysis.throw cannot-cast [fromT toT fromC])) + )))))))] (if can-cast? (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name) (/////analysis.text to-name) @@ -839,7 +913,7 @@ (wrap (<| (#/////analysis.Extension extension-name) (list (/////analysis.text class) (/////analysis.text field) - (/////analysis.text (reflection.class fieldJT)))))))])) + (/////analysis.text (|> fieldJT ..reflection)))))))])) (def: static::put Handler @@ -876,8 +950,7 @@ [final? fieldJT] (reflection!.virtual-field field class) mapping (reflection!.correspond class objectT)] (wrap [mapping fieldJT]))) - fieldT (typeA.with-env - (luxT.type mapping fieldJT)) + fieldT (reflection-type mapping fieldJT) _ (typeA.infer fieldT)] (wrap (<| (#/////analysis.Extension extension-name) (list (/////analysis.text class) @@ -899,8 +972,7 @@ [final? fieldJT] (reflection!.virtual-field field class) mapping (reflection!.correspond class objectT)] (wrap [final? mapping fieldJT]))) - fieldT (typeA.with-env - (luxT.type mapping fieldJT)) + fieldT (reflection-type mapping fieldJT) _ (////.assert cannot-set-a-final-field [class field] (not final?)) valueA (typeA.with-type fieldT @@ -924,7 +996,7 @@ [parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method) array.to-list (monad.map try.monad reflection!.type) - (:: try.monad map (list@map reflection.class)) + (:: try.monad map (list@map ..reflection)) ////.lift) #let [modifiers (java/lang/reflect/Method::getModifiers method) correct-class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method)) @@ -961,7 +1033,7 @@ [parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor) array.to-list (monad.map try.monad reflection!.type) - (:: try.monad map (list@map reflection.class)) + (:: try.monad map (list@map ..reflection)) ////.lift)] (wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor)) (n.= (list.size arg-classes) (list.size parameters)) @@ -1150,7 +1222,7 @@ outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) (decorate-inputs argsT argsA))))))])) (def: invoke::virtual @@ -1171,7 +1243,7 @@ outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) objectA (decorate-inputs argsT argsA))))))])) @@ -1187,7 +1259,7 @@ outputJC (check-return outputT)] (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) (decorate-inputs argsT argsA))))))])) (def: invoke::interface @@ -1212,7 +1284,7 @@ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class-name) (/////analysis.text method) - (/////analysis.text outputJC) + (/////analysis.text (..signature outputJC)) objectA (decorate-inputs argsT argsA))))))])) @@ -1249,54 +1321,16 @@ ))) ))) -(def: #export var - (Parser Var) - <c>.text) - -(def: bound - (Parser Bound) - (<>.or (<c>.identifier! ["" ">"]) - (<c>.identifier! ["" "<"]))) - -(def: generic - (Parser Generic) - (<>.rec - (function (_ generic) - (let [wildcard (: (Parser (Maybe [Bound Generic])) - (<>.or (<c>.identifier! ["" "?"]) - (<c>.form (<>.and ..bound generic)))) - class (: (Parser Class) - (<c>.form (<>.and <c>.text (<>.some generic))))] - ($_ <>.or - ..var - wildcard - class))))) - -(def: #export class - (Parser Class) - (<c>.form (<>.and <c>.text (<>.some ..generic)))) - -(def: primitive - (Parser Primitive) - ($_ <>.or - (<c>.identifier! ["" reflection.boolean]) - (<c>.identifier! ["" reflection.byte]) - (<c>.identifier! ["" reflection.short]) - (<c>.identifier! ["" reflection.int]) - (<c>.identifier! ["" reflection.long]) - (<c>.identifier! ["" reflection.float]) - (<c>.identifier! ["" reflection.double]) - (<c>.identifier! ["" reflection.char]) - )) - -(def: #export type - (Parser Type) - (<>.rec - (function (_ type) - ($_ <>.or - ..primitive - ..generic - (<c>.tuple type))))) +(template [<name> <category> <parser>] + [(def: #export <name> + (Parser (Type <category>)) + (<t>.embed <parser> <c>.text))] + + [var Var jvm-parser.var] + [class Class jvm-parser.class] + [type Value jvm-parser.value] + [return Return jvm-parser.return] + ) (def: #export typed (Parser (Typed Code)) @@ -1320,40 +1354,6 @@ (Parser Argument) (<c>.tuple (<>.and <c>.text ..type))) -(def: #export return - (Parser Return) - (<>.or (<c>.identifier! ["" reflection.void]) - ..type)) - -(def: (generic-analysis generic) - (-> Generic Analysis) - (case generic - (#jvm.Var var) - (/////analysis.text var) - - (#jvm.Wildcard wildcard) - (case wildcard - #.None - (/////analysis.constant ["" "?"]) - - (#.Some [bound limit]) - (/////analysis.tuple (list (case bound - #jvm.Lower - (/////analysis.constant ["" ">"]) - - #jvm.Upper - (/////analysis.constant ["" "<"])) - (generic-analysis limit)))) - - (#jvm.Class name parameters) - (/////analysis.tuple (list& (/////analysis.text name) - (list@map generic-analysis parameters))))) - -(def: (class-analysis [name parameters]) - (-> Class Analysis) - (/////analysis.tuple (list& (/////analysis.text name) - (list@map generic-analysis parameters)))) - (def: (annotation-parameter-analysis [name value]) (-> (Annotation-Parameter Analysis) Analysis) (/////analysis.tuple (list (/////analysis.text name) value))) @@ -1363,47 +1363,31 @@ (/////analysis.tuple (list& (/////analysis.text name) (list@map annotation-parameter-analysis parameters)))) -(def: var-analysis - (-> Var Analysis) - (|>> /////analysis.text)) - -(def: (type-analysis type) - (-> Type Analysis) - (case type - (#jvm.Primitive primitive) - (case primitive - #jvm.Boolean (/////analysis.constant ["" reflection.boolean]) - #jvm.Byte (/////analysis.constant ["" reflection.byte]) - #jvm.Short (/////analysis.constant ["" reflection.short]) - #jvm.Int (/////analysis.constant ["" reflection.int]) - #jvm.Long (/////analysis.constant ["" reflection.long]) - #jvm.Float (/////analysis.constant ["" reflection.float]) - #jvm.Double (/////analysis.constant ["" reflection.double]) - #jvm.Char (/////analysis.constant ["" reflection.char])) - - (#jvm.Generic generic) - (generic-analysis generic) - - (#jvm.Array type) - (/////analysis.tuple (list (type-analysis type))))) - -(def: (return-analysis return) - (-> Return Analysis) - (case return - #.None - (/////analysis.constant ["" jvm.void-descriptor]) - - (#.Some type) - (type-analysis type))) +(template [<name> <category>] + [(def: <name> + (-> (Type <category>) Analysis) + (|>> ..signature /////analysis.text))] + + [var-analysis Var] + [class-analysis Class] + [value-analysis Value] + [return-analysis Return] + ) (def: (typed-analysis [type term]) (-> (Typed Analysis) Analysis) - (/////analysis.tuple (list (type-analysis type) term))) + (/////analysis.tuple (list (value-analysis type) term))) + +(def: (argument-analysis [argument argumentJT]) + (-> Argument Analysis) + (/////analysis.tuple + (list (/////analysis.text argument) + (value-analysis argumentJT)))) (template [<name> <filter>] [(def: <name> (-> (java/lang/Class java/lang/Object) - (Try (List [Text Method]))) + (Try (List [Text (Signature Method)]))) (|>> java/lang/Class::getDeclaredMethods array.to-list <filter> @@ -1418,9 +1402,9 @@ reflection!.return) exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method) array.to-list - (monad.map @ reflection!.generic))] + (monad.map @ reflection!.class))] (wrap [(java/lang/reflect/Method::getName method) - (jvm.method inputs return exceptions)]))))))] + (product.left (jvm.method [inputs return exceptions]))]))))))] [abstract-methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))] [methods (<|)] @@ -1430,8 +1414,8 @@ (template [<name> <methods>] [(def: <name> - (-> (List Class) (Try (List [Text Method]))) - (|>> (monad.map try.monad (|>> product.left reflection!.load)) + (-> (List (Type Class)) (Try (List [Text (Signature Method)]))) + (|>> (monad.map try.monad (|>> ..reflection reflection!.load)) (try@map (monad.map try.monad <methods>)) try@join (try@map list@join)))] @@ -1441,11 +1425,11 @@ ) (template [<name>] - [(exception: #export (<name> {methods (List [Text Method])}) + [(exception: #export (<name> {methods (List [Text (Signature Method)])}) (exception.report ["Methods" (exception.enumerate - (function (_ [name method]) - (format (%.text name) " " (jvm.method-signature method))) + (function (_ [name signature]) + (format (%.text name) " " (signature.signature signature))) methods)]))] [missing-abstract-methods] @@ -1453,10 +1437,10 @@ ) (type: #export Visibility - #PublicV - #PrivateV - #ProtectedV - #DefaultV) + #Public + #Private + #Protected + #Default) (type: #export Finality Bit) (type: #export Strictness Bit) @@ -1474,12 +1458,20 @@ (<c>.text! ..protected-tag) (<c>.text! ..default-tag))) +(def: #export (visibility-analysis visibility) + (-> Visibility Analysis) + (/////analysis.text (case visibility + #Public ..public-tag + #Private ..private-tag + #Protected ..protected-tag + #Default ..default-tag))) + (type: #export (Constructor a) [Visibility Strictness (List (Annotation a)) - (List Var) - (List Class) ## Exceptions + (List (Type Var)) + (List (Type Class)) ## Exceptions Text (List Argument) (List (Typed a)) @@ -1519,19 +1511,17 @@ annotations) super-arguments (monad.map @ (function (_ [jvmT super-argC]) (do @ - [luxT (typeA.with-env - (luxT.type mapping jvmT)) + [luxT (reflection-type mapping jvmT) super-argA (typeA.with-type luxT (analyse super-argC))] (wrap [jvmT super-argA]))) super-arguments) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' (#.Cons [self-name selfT]) list.reverse @@ -1539,24 +1529,14 @@ (typeA.with-type .Any) /////analysis.with-scope)] (wrap (/////analysis.tuple (list (/////analysis.text ..constructor-tag) - (/////analysis.text (case visibility - #PublicV ..public-tag - #PrivateV ..private-tag - #ProtectedV ..protected-tag - #DefaultV ..default-tag)) + (visibility-analysis visibility) (/////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)) - (/////analysis.tuple (list@map class-analysis - exceptions)) - (/////analysis.tuple (list@map typed-analysis - super-arguments)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) + (/////analysis.tuple (list@map class-analysis exceptions)) + (/////analysis.tuple (list@map typed-analysis super-arguments)) (#/////analysis.Function (scope.environment scope) (/////analysis.tuple (list bodyA))) @@ -1568,11 +1548,11 @@ Finality Strictness (List (Annotation a)) - (List Var) + (List (Type Var)) Text (List Argument) - Return - (List Class) ## Exceptions + (Type Return) + (List (Type Class)) ## Exceptions a]) (def: virtual-tag "virtual") @@ -1610,15 +1590,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (typeA.with-env - (luxT.return mapping return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + returnT (reflection-return mapping return) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' (#.Cons [self-name selfT]) list.reverse @@ -1627,24 +1605,15 @@ /////analysis.with-scope)] (wrap (/////analysis.tuple (list (/////analysis.text ..virtual-tag) (/////analysis.text method-name) - (/////analysis.text (case visibility - #PublicV ..public-tag - #PrivateV ..private-tag - #ProtectedV ..protected-tag - #DefaultV ..default-tag)) + (visibility-analysis visibility) (/////analysis.bit final?) (/////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)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) (return-analysis return) - (/////analysis.tuple (list@map class-analysis - exceptions)) + (/////analysis.tuple (list@map class-analysis exceptions)) (#/////analysis.Function (scope.environment scope) (/////analysis.tuple (list bodyA))) @@ -1655,10 +1624,10 @@ Visibility Strictness (List (Annotation a)) - (List Var) - (List Class) ## Exceptions + (List (Type Var)) + (List (Type Class)) ## Exceptions (List Argument) - Return + (Type Return) a]) (def: #export static-tag "static") @@ -1694,15 +1663,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (typeA.with-env - (luxT.return mapping return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + returnT (reflection-return mapping return) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' list.reverse (list@fold scope.with-local (analyse body)) @@ -1710,19 +1677,11 @@ /////analysis.with-scope)] (wrap (/////analysis.tuple (list (/////analysis.text ..static-tag) (/////analysis.text method-name) - (/////analysis.text (case visibility - #PublicV ..public-tag - #PrivateV ..private-tag - #ProtectedV ..protected-tag - #DefaultV ..default-tag)) + (visibility-analysis visibility) (/////analysis.bit strict-fp?) (/////analysis.tuple (list@map annotation-analysis annotationsA)) (/////analysis.tuple (list@map var-analysis vars)) - (/////analysis.tuple (list@map (function (_ [argument argumentJT]) - (/////analysis.tuple - (list (/////analysis.text argument) - (type-analysis argumentJT)))) - arguments)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) (return-analysis return) (/////analysis.tuple (list@map class-analysis exceptions)) @@ -1732,15 +1691,15 @@ )))))) (type: #export (Overriden-Method a) - [Class + [(Type Class) Text Bit (List (Annotation a)) - (List Var) + (List (Type Var)) Text (List Argument) - Return - (List Class) + (Type Return) + (List (Type Class)) a]) (def: #export overriden-tag "override") @@ -1778,15 +1737,13 @@ parameters)] (wrap [name parametersA]))) annotations) - returnT (typeA.with-env - (luxT.return mapping return)) - arguments' (typeA.with-env - (monad.map check.monad - (function (_ [name jvmT]) - (do check.monad - [luxT (luxT.type mapping jvmT)] - (wrap [name luxT]))) - arguments)) + returnT (reflection-return mapping return) + arguments' (monad.map @ + (function (_ [name jvmT]) + (do @ + [luxT (reflection-type mapping jvmT)] + (wrap [name luxT]))) + arguments) [scope bodyA] (|> arguments' (#.Cons [self-name selfT]) list.reverse @@ -1800,11 +1757,7 @@ (/////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)) + (/////analysis.tuple (list@map ..argument-analysis arguments)) (return-analysis return) (/////analysis.tuple (list@map class-analysis exceptions)) @@ -1817,7 +1770,7 @@ (#Overriden-Method (Overriden-Method a))) (def: #export parameter-types - (-> (List Var) (Check (List [Var .Type]))) + (-> (List (Type Var)) (Check (List [(Type Var) .Type]))) (monad.map check.monad (function (_ parameterJ) (do check.monad @@ -1825,31 +1778,30 @@ (wrap [parameterJ parameterT]))))) (def: (mismatched-methods super-set sub-set) - (-> (List [Text Method]) (List [Text Method]) (List [Text Method])) + (-> (List [Text (Signature Method)]) (List [Text (Signature Method)]) (List [Text (Signature Method)])) (list.filter (function (_ [sub-name subJT]) (|> super-set (list.filter (function (_ [super-name superJT]) (and (text@= super-name sub-name) - (method@= superJT subJT)))) + (signature@= superJT subJT)))) list.size (n.= 1) not)) sub-set)) (exception: #export (class-parameter-mismatch {expected (List Text)} - {actual (List jvm.Generic)}) + {actual (List (Type Parameter))}) (exception.report ["Expected (amount)" (%.nat (list.size expected))] ["Expected (parameters)" (exception.enumerate %.text expected)] ["Actual (amount)" (%.nat (list.size actual))] - ["Actual (parameters)" (exception.enumerate (|>> #jvm.Generic jvm.signature) actual)])) + ["Actual (parameters)" (exception.enumerate ..signature actual)])) -(type: Renamer (Dictionary Text Text)) - -(def: (re-map-super [name actual-parameters]) - (-> Class (Operation Renamer)) +(def: (super-aliasing class) + (-> (Type Class) (Operation Aliasing)) (do ////.monad - [class (////.lift (reflection!.load name)) + [#let [[name actual-parameters] (jvm-parser.read-class class)] + class (////.lift (reflection!.load name)) #let [expected-parameters (|> (java/lang/Class::getTypeParameters class) array.to-list (list@map (|>> java/lang/reflect/TypeVariable::getName)))] @@ -1858,57 +1810,13 @@ (list.size actual-parameters)))] (wrap (|> (list.zip2 expected-parameters actual-parameters) (list@fold (function (_ [expected actual] mapping) - (case actual - (#jvm.Var actual) + (case (jvm-parser.var? actual) + (#.Some actual) (dictionary.put actual expected mapping) - _ + #.None mapping)) - (dictionary.new text.hash)))))) - -(def: (re-map-generic mapping generic) - (-> Renamer jvm.Generic jvm.Generic) - (case generic - (#jvm.Var var) - (#jvm.Var (|> mapping (dictionary.get var) (maybe.default var))) - - (#jvm.Wildcard wildcard) - (case wildcard - #.None - generic - - (#.Some [bound limit]) - (#jvm.Wildcard (#.Some [bound (re-map-generic mapping limit)]))) - - (#jvm.Class name parameters) - (#jvm.Class name (list@map (re-map-generic mapping) parameters)))) - -(def: (re-map-type mapping type) - (-> Renamer jvm.Type jvm.Type) - (case type - (#jvm.Primitive primitive) - type - - (#jvm.Generic generic) - (#jvm.Generic (re-map-generic mapping generic)) - - (#jvm.Array type) - (#jvm.Array (re-map-type mapping type)))) - -(def: (re-map-return mapping return) - (-> Renamer jvm.Return jvm.Return) - (case return - #.None - return - - (#.Some return) - (#.Some (re-map-type mapping return)))) - -(def: (re-map-method mapping [inputs output exceptions]) - (-> Renamer jvm.Method jvm.Method) - [(list@map (re-map-type mapping) inputs) - (re-map-return mapping output) - (list@map (re-map-generic mapping) exceptions)]) + jvm-alias.fresh))))) (def: class::anonymous Handler @@ -1928,7 +1836,9 @@ [parameters (typeA.with-env (..parameter-types parameters)) #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping) - (dictionary.put parameterJ parameterT mapping)) + (dictionary.put (jvm-parser.name parameterJ) + parameterT + mapping)) luxT.fresh parameters)] name (///.lift (do macro.monad @@ -1938,18 +1848,17 @@ ..jvm-package-separator "anonymous-class" (%.nat id))))) super-classT (typeA.with-env - (luxT.class mapping super-class)) + (luxT.check (luxT.class mapping) (..signature super-class))) super-interfaceT+ (typeA.with-env (monad.map check.monad - (luxT.class mapping) + (|>> ..signature (luxT.check (luxT.class mapping))) 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 mapping type)) + [argT (reflection-type mapping type) termA (typeA.with-type argT (analyse term))] (wrap [type termA]))) @@ -1962,11 +1871,12 @@ self-name arguments return exceptions body]) (do @ - [re-mapping (re-map-super parent-type)] - (wrap [method-name (re-map-method re-mapping - (jvm.method (list@map product.right arguments) - return - (list@map (|>> #jvm.Class) exceptions)))]))) + [aliasing (super-aliasing parent-type)] + (wrap [method-name (|> (jvm.method [(list@map product.right arguments) + return + exceptions]) + product.left + (jvm-alias.method aliasing))]))) methods) #let [missing-abstract-methods (mismatched-methods overriden-methods required-abstract-methods) invalid-overriden-methods (mismatched-methods available-methods overriden-methods)] @@ -1980,8 +1890,7 @@ (class-analysis super-class) (/////analysis.tuple (list@map class-analysis super-interfaces)) (/////analysis.tuple (list@map typed-analysis constructor-argsA+)) - (/////analysis.tuple methodsA)))) - ))])) + (/////analysis.tuple methodsA))))))])) (def: bundle::class Bundle diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux index 56067c845..eef4731d2 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux @@ -14,7 +14,6 @@ [text ["%" format (#+ format)]] [collection - ["." list ("#;." functor)] ["." dictionary]]] ["." macro ["." code]] @@ -152,11 +151,10 @@ [current-module (/////statement.lift-analysis (///.lift macro.current-module-name)) #let [full-name [current-module short-name]] - [_ annotationsT annotations] (evaluate! Code annotationsC) - #let [annotations (:coerce Code annotations)] [type valueT valueN value] (..definition full-name #.None valueC) + [_ annotationsT annotations] (evaluate! Code annotationsC) _ (/////statement.lift-analysis - (module.define short-name (#.Right [exported? type annotations value]))) + (module.define short-name (#.Right [exported? type (:coerce Code annotations) value]))) #let [_ (log! (format "Definition " (%.name full-name)))] _ (/////statement.lift-generation (////generation.learn full-name valueN)) |