aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/code.lux11
-rw-r--r--stdlib/source/lux/control/parser/text.lux11
-rw-r--r--stdlib/source/lux/control/try.lux9
-rw-r--r--stdlib/source/lux/macro/syntax/common/reader.lux2
-rw-r--r--stdlib/source/lux/target/jvm/reflection.lux185
-rw-r--r--stdlib/source/lux/target/jvm/type.lux200
-rw-r--r--stdlib/source/lux/target/jvm/type/alias.lux112
-rw-r--r--stdlib/source/lux/target/jvm/type/box.lux7
-rw-r--r--stdlib/source/lux/target/jvm/type/category.lux1
-rw-r--r--stdlib/source/lux/target/jvm/type/descriptor.lux49
-rw-r--r--stdlib/source/lux/target/jvm/type/lux.lux138
-rw-r--r--stdlib/source/lux/target/jvm/type/parser.lux195
-rw-r--r--stdlib/source/lux/target/jvm/type/reflection.lux10
-rw-r--r--stdlib/source/lux/target/jvm/type/signature.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux823
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/statement/lux.lux6
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))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-25 06:31:09 +0000