aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux2
-rw-r--r--stdlib/source/lux/control/parser/text.lux82
-rw-r--r--stdlib/source/lux/control/parser/xml.lux14
-rw-r--r--stdlib/source/lux/data/format/json.lux2
-rw-r--r--stdlib/source/lux/data/format/xml.lux4
-rw-r--r--stdlib/source/lux/host.jvm.lux53
-rw-r--r--stdlib/source/lux/math/modular.lux13
-rw-r--r--stdlib/source/lux/target/jvm/type.lux97
-rw-r--r--stdlib/source/lux/time/date.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux78
10 files changed, 242 insertions, 109 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index b3d6281c8..8b8ba87ee 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -696,7 +696,7 @@
(def: (generate-type argD)
(-> Text (Operation Type))
- (case (<t>.run argD java-type)
+ (case (<t>.run java-type argD)
(#error.Failure error)
(phase.throw invalid-syntax-for-jvm-type argD)
diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux
index bf4c45867..7c7c7fe4a 100644
--- a/stdlib/source/lux/control/parser/text.lux
+++ b/stdlib/source/lux/control/parser/text.lux
@@ -28,8 +28,6 @@
{#basis Offset
#distance Offset})
-(def: cannot-lex-error Text "Cannot lex from empty text.")
-
(def: (remaining offset tape)
(-> Offset Text Text)
(|> tape (/.split offset) maybe.assume product.right))
@@ -40,27 +38,35 @@
["Input size" (nat@encode (/.size tape))]
["Remaining input" (remaining offset tape)]))
-(def: #export (run input lexer)
- (All [a] (-> Text (Parser a) (Error a)))
- (case (lexer [start-offset input])
+(exception: #export (expected-to-fail {offset Offset} {tape Text})
+ (exception.report
+ ["Offset" (nat@encode offset)]
+ ["Input" (remaining offset tape)]))
+
+(exception: #export cannot-parse)
+(exception: #export cannot-slice)
+
+(def: #export (run parser input)
+ (All [a] (-> (Parser a) Text (Error a)))
+ (case (parser [start-offset input])
(#error.Failure msg)
(#error.Failure msg)
(#error.Success [[end-offset _] output])
(if (n/= end-offset (/.size input))
(#error.Success output)
- (exception.throw unconsumed-input [end-offset input]))))
+ (exception.throw ..unconsumed-input [end-offset input]))))
(def: #export offset
(Parser Offset)
(function (_ (^@ input [offset tape]))
(#error.Success [input offset])))
-(def: (with-slices lexer)
+(def: (with-slices parser)
(-> (Parser (List Slice)) (Parser Slice))
(do //.monad
[offset ..offset
- slices lexer]
+ slices parser]
(wrap (list@fold (function (_ [slice::basis slice::distance]
[total::basis total::distance])
[total::basis ("lux i64 +" slice::distance total::distance)])
@@ -77,7 +83,7 @@
(#error.Success [[("lux i64 +" 1 offset) tape] (/.from-code output)])
_
- (#error.Failure cannot-lex-error))))
+ (exception.throw ..cannot-parse []))))
(def: #export any!
{#.doc "Just returns the next character without applying any logic."}
@@ -89,7 +95,7 @@
(template [<name> <type> <any>]
[(def: #export (<name> p)
- {#.doc "Produce a character if the lexer fails."}
+ {#.doc "Produce a character if the parser fails."}
(All [a] (-> (Parser a) (Parser <type>)))
(function (_ input)
(case (p input)
@@ -97,7 +103,7 @@
(<any> input)
_
- (#error.Failure "Expected to fail@ yet succeeded."))))]
+ (exception.throw ..expected-to-fail input))))]
[not Text ..any]
[not! Slice ..any!]
@@ -130,15 +136,15 @@
(#error.Success [input #0]))))
(def: #export end
- {#.doc "Ensure the lexer's input is empty."}
+ {#.doc "Ensure the parser's input is empty."}
(Parser Any)
(function (_ (^@ input [offset tape]))
(if (n/= offset (/.size tape))
(#error.Success [input []])
- (exception.throw unconsumed-input [offset tape]))))
+ (exception.throw ..unconsumed-input input))))
(def: #export end?
- {#.doc "Ask if the lexer's input is empty."}
+ {#.doc "Ask if the parser's input is empty."}
(Parser Bit)
(function (_ (^@ input [offset tape]))
(#error.Success [input (n/= offset (/.size tape))])))
@@ -152,7 +158,7 @@
(#error.Success [input (/.from-code output)])
_
- (#error.Failure cannot-lex-error))))
+ (exception.throw ..cannot-parse []))))
(def: #export get-input
{#.doc "Get all of the remaining input (without consuming it)."}
@@ -216,7 +222,7 @@
"be one of: " options))))
_
- (#error.Failure cannot-lex-error))))]
+ (exception.throw ..cannot-parse []))))]
[one-of "" |>]
[none-of " not" .not]
@@ -239,7 +245,7 @@
"be one of: " options))))
_
- (#error.Failure cannot-lex-error))))]
+ (exception.throw ..cannot-parse []))))]
[one-of! "" |>]
[none-of! " not" .not]
@@ -256,7 +262,7 @@
(#error.Failure ($_ /@compose "Character does not satisfy predicate: " (/.from-code output))))
_
- (#error.Failure cannot-lex-error))))
+ (exception.throw ..cannot-parse []))))
(def: #export space
{#.doc "Only lex white-space."}
@@ -278,30 +284,30 @@
(wrap [left::basis ("lux i64 +" left::distance right::distance)])))
(template [<name> <base> <doc-modifier>]
- [(def: #export (<name> lexer)
+ [(def: #export (<name> parser)
{#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " characters as a single continuous text."))}
(-> (Parser Text) (Parser Text))
- (|> lexer <base> (:: //.monad map /.concat)))]
+ (|> parser <base> (:: //.monad map /.concat)))]
[some //.some "some"]
[many //.many "many"]
)
(template [<name> <base> <doc-modifier>]
- [(def: #export (<name> lexer)
+ [(def: #export (<name> parser)
{#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " characters as a single continuous text."))}
(-> (Parser Slice) (Parser Slice))
- (with-slices (<base> lexer)))]
+ (with-slices (<base> parser)))]
[some! //.some "some"]
[many! //.many "many"]
)
(template [<name> <base> <doc-modifier>]
- [(def: #export (<name> amount lexer)
+ [(def: #export (<name> amount parser)
{#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " N characters."))}
(-> Nat (Parser Text) (Parser Text))
- (|> lexer (<base> amount) (:: //.monad map /.concat)))]
+ (|> parser (<base> amount) (:: //.monad map /.concat)))]
[exactly //.exactly "exactly"]
[at-most //.at-most "at most"]
@@ -309,51 +315,51 @@
)
(template [<name> <base> <doc-modifier>]
- [(def: #export (<name> amount lexer)
+ [(def: #export (<name> amount parser)
{#.doc (code.text ($_ /@compose "Lex " <doc-modifier> " N characters."))}
(-> Nat (Parser Slice) (Parser Slice))
- (with-slices (<base> amount lexer)))]
+ (with-slices (<base> amount parser)))]
[exactly! //.exactly "exactly"]
[at-most! //.at-most "at most"]
[at-least! //.at-least "at least"]
)
-(def: #export (between from to lexer)
+(def: #export (between from to parser)
{#.doc "Lex between N and M characters."}
(-> Nat Nat (Parser Text) (Parser Text))
- (|> lexer (//.between from to) (:: //.monad map /.concat)))
+ (|> parser (//.between from to) (:: //.monad map /.concat)))
-(def: #export (between! from to lexer)
+(def: #export (between! from to parser)
{#.doc "Lex between N and M characters."}
(-> Nat Nat (Parser Slice) (Parser Slice))
- (with-slices (//.between from to lexer)))
+ (with-slices (//.between from to parser)))
-(def: #export (enclosed [start end] lexer)
+(def: #export (enclosed [start end] parser)
(All [a] (-> [Text Text] (Parser a) (Parser a)))
- (|> lexer
+ (|> parser
(//.before (this end))
(//.after (this start))))
-(def: #export (local local-input lexer)
- {#.doc "Run a lexer with the given input, instead of the real one."}
+(def: #export (local local-input parser)
+ {#.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 local-input lexer)
+ (case (run parser local-input)
(#error.Failure error)
(#error.Failure error)
(#error.Success value)
(#error.Success [real-input value]))))
-(def: #export (slice lexer)
+(def: #export (slice parser)
(-> (Parser Slice) (Parser Text))
(do //.monad
- [[basis distance] lexer]
+ [[basis distance] parser]
(function (_ (^@ input [offset tape]))
(case (/.clip basis ("lux i64 +" basis distance) tape)
(#.Some output)
(#error.Success [input output])
#.None
- (#error.Failure "Cannot slice.")))))
+ (exception.throw ..cannot-slice [])))))
diff --git a/stdlib/source/lux/control/parser/xml.lux b/stdlib/source/lux/control/parser/xml.lux
index a2ae5dbec..be5c0f7b6 100644
--- a/stdlib/source/lux/control/parser/xml.lux
+++ b/stdlib/source/lux/control/parser/xml.lux
@@ -68,9 +68,9 @@
(#.Some value)
(#error.Success [docs value]))))))
-(def: (run' docs reader)
- (All [a] (-> (List XML) (Parser a) (Error a)))
- (case (//.run docs reader)
+(def: (run' reader docs)
+ (All [a] (-> (Parser a) (List XML) (Error a)))
+ (case (//.run reader docs)
(#error.Success [remaining output])
(if (list.empty? remaining)
(#error.Success output)
@@ -110,7 +110,7 @@
(#/.Node _tag _attrs _children)
(do error.monad
- [output (run' _children reader)]
+ [output (run' reader _children)]
(wrap [tail output]))))))
(def: #export ignore
@@ -123,6 +123,6 @@
(#.Cons head tail)
(#error.Success [tail []]))))
-(def: #export (run document reader)
- (All [a] (-> XML (Parser a) (Error a)))
- (run' (list document) reader))
+(def: #export (run reader document)
+ (All [a] (-> (Parser a) XML (Error a)))
+ (run' reader (list document)))
diff --git a/stdlib/source/lux/data/format/json.lux b/stdlib/source/lux/data/format/json.lux
index 1bbdc4ee0..219f7cd9b 100644
--- a/stdlib/source/lux/data/format/json.lux
+++ b/stdlib/source/lux/data/format/json.lux
@@ -356,4 +356,4 @@
(structure: #export codec (Codec Text JSON)
(def: encode ..format)
- (def: decode (function (_ input) (l.run input (json~' [])))))
+ (def: decode (l.run (json~' []))))
diff --git a/stdlib/source/lux/data/format/xml.lux b/stdlib/source/lux/data/format/xml.lux
index bd4fef488..3c81ef889 100644
--- a/stdlib/source/lux/data/format/xml.lux
+++ b/stdlib/source/lux/data/format/xml.lux
@@ -171,9 +171,9 @@
(p.after (p.some comment^))
(p.after (p.maybe xml-header^))))
-(def: #export (read input)
+(def: #export read
(-> Text (Error XML))
- (l.run input xml^))
+ (l.run xml^))
(def: (sanitize-value input)
(-> Text Text)
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index 8a5b0d849..cb08e1cce 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -29,7 +29,7 @@
["#" type (#+ Primitive Var Bound Class Generic Type Argument Return Typed)]]]])
(template [<name> <class>]
- [(type: #export <name> (#.Primitive <class> #.Nil))]
+ [(def: #export <name> .Type (#.Primitive <class> #.Nil))]
## Boxes
[Boolean "java.lang.Boolean"]
@@ -460,13 +460,44 @@
(-> [Text Code] Code)
(` [(~ (code.text class)) (~ value)]))
+(def: (simple-class type)
+ (-> Type Text)
+ (case type
+ (#jvm.Primitive prim)
+ (case prim
+ #jvm.Boolean "boolean"
+ #jvm.Byte "byte"
+ #jvm.Short "short"
+ #jvm.Int "int"
+ #jvm.Long "long"
+ #jvm.Float "float"
+ #jvm.Double "double"
+ #jvm.Char "char")
+
+ (#jvm.Array sub)
+ (sanitize (jvm.descriptor type))
+
+ (#jvm.Generic generic)
+ (case generic
+ (#jvm.Class class params)
+ (sanitize class)
+
+ (^or (#jvm.Var name)
+ (#jvm.Wildcard #.None)
+ (#jvm.Wildcard (#.Some [#jvm.Lower bound])))
+ "java.lang.Object"
+
+ (#jvm.Wildcard (#.Some [#jvm.Upper bound]))
+ (simple-class (#jvm.Generic bound)))
+ ))
+
(def: (make-constructor-parser class-name arguments)
(-> Text (List Argument) (Parser Code))
(do p.monad
[args (: (Parser (List Code))
(s.form (p.after (s.this! (' ::new!))
(s.tuple (p.exactly (list.size arguments) s.any)))))
- #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]]
+ #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]]
(wrap (` ("jvm member invoke constructor" (~ (code.text class-name))
(~+ (|> args
(list.zip2 arguments')
@@ -479,7 +510,7 @@
args (: (Parser (List Code))
(s.form (p.after (s.this! (code.identifier ["" dotted-name]))
(s.tuple (p.exactly (list.size arguments) s.any)))))
- #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]]
+ #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]]
(wrap (` ("jvm member invoke static" (~ (code.text class-name)) (~ (code.text method-name))
(~+ (|> args
(list.zip2 arguments')
@@ -493,7 +524,7 @@
args (: (Parser (List Code))
(s.form (p.after (s.this! (code.identifier ["" dotted-name]))
(s.tuple (p.exactly (list.size arguments) s.any)))))
- #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]]
+ #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]]
(wrap (` (<jvm-op> (~ (code.text class-name)) (~ (code.text method-name))
(~' _jvm_this)
(~+ (|> args
@@ -1111,7 +1142,7 @@
(let [super-replacer (parser->replacer (s.form (do p.monad
[_ (s.this! (' ::super!))
args (s.tuple (p.exactly (list.size arguments) s.any))
- #let [arguments' (list@map (|>> product.right jvm.signature) arguments)]]
+ #let [arguments' (list@map (|>> product.right ..simple-class) arguments)]]
(wrap (` ("jvm member invoke special"
(~ (code.text (product.left super-class)))
(~ (code.text name))
@@ -1344,7 +1375,7 @@
(#.Some value-as-string)
#.None))}
(with-gensyms [g!_ g!unchecked]
- (let [class-name (jvm.signature class)
+ (let [class-name (..simple-class class)
class-type (` (.primitive (~ (code.text class-name))))
check-type (` (.Maybe (~ class-type)))
check-code (` (if ((~ (code.text (format "jvm instanceof" ":" class-name))) (~ g!unchecked))
@@ -1424,7 +1455,7 @@
(with-gensyms [arg-name]
(wrap [maybe? arg-name]))))
import-member-args)
- #let [arg-classes (list@map (|>> product.right jvm.signature) import-member-args)
+ #let [arg-classes (list@map (|>> product.right ..simple-class) import-member-args)
arg-types (list@map (: (-> [Bit Type] Code)
(function (_ [maybe? arg])
(let [arg-type (jvm-type (get@ #import-member-mode commons) arg)]
@@ -1610,7 +1641,7 @@
jvm.void-descriptor
(#.Some return)
- (jvm.signature return))
+ (..simple-class return))
jvm-interop (|> [method-return-class
(` ((~ (code.text jvm-op))
(~ (code.text full-name))
@@ -1643,7 +1674,7 @@
(` ((~ getter-name)))
(` ((~ getter-name) (~ g!obj))))
getter-body (<| (auto-convert-output import-field-mode)
- [(jvm.signature import-field-type)
+ [(..simple-class import-field-type)
(if import-field-static?
(get-static-field full-name import-field-name)
(get-virtual-field full-name import-field-name (un-quote g!obj)))])
@@ -1661,7 +1692,7 @@
(let [setter-call (if import-field-static?
(` ((~ setter-name) (~ g!value)))
(` ((~ setter-name) (~ g!value) (~ g!obj))))
- setter-value (|> [(jvm.signature import-field-type) (un-quote g!value)]
+ setter-value (|> [(..simple-class import-field-type) (un-quote g!value)]
..jvm-input
(auto-convert-input import-field-mode))
setter-value (if import-field-maybe?
@@ -1884,7 +1915,7 @@
{type (..type^ imports (list))})
{#.doc (doc "Loads the class as a java.lang.Class object."
(class-for java/lang/String))}
- (wrap (list (` ("jvm object class" (~ (code.text (jvm.signature type))))))))
+ (wrap (list (` ("jvm object class" (~ (code.text (..simple-class type))))))))
(def: get-compiler
(Meta Lux)
diff --git a/stdlib/source/lux/math/modular.lux b/stdlib/source/lux/math/modular.lux
index 76c85ec1b..fa26f0abe 100644
--- a/stdlib/source/lux/math/modular.lux
+++ b/stdlib/source/lux/math/modular.lux
@@ -96,13 +96,12 @@
separator
(int@encode (to-int modulus)))))
- (def: (decode text)
- (<| (l.run text)
- (do p.monad
- [[remainder _ _modulus] ($_ p.and intL (l.this separator) intL)
- _ (p.assert (ex.construct incorrect-modulus [modulus _modulus])
- (i/= (to-int modulus) _modulus))]
- (wrap (mod modulus remainder))))))
+ (def: decode
+ (l.run (do p.monad
+ [[remainder _ _modulus] ($_ p.and intL (l.this separator) intL)
+ _ (p.assert (ex.construct incorrect-modulus [modulus _modulus])
+ (i/= (to-int modulus) _modulus))]
+ (wrap (mod modulus remainder))))))
(def: #export (equalize reference sample)
(All [r s] (-> (Mod r) (Mod s) (Error (Mod r))))
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index 703352139..ff30cf782 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -1,6 +1,10 @@
(.module:
[lux (#- Type int char)
+ [control
+ ["<>" parser
+ ["<t>" text (#+ Parser)]]]
[data
+ [error (#+ Error)]
["." maybe ("#@." functor)]
["." text
format]
@@ -23,9 +27,31 @@
(def: array-prefix "[")
(def: object-prefix "L")
+(def: var-prefix "T")
+(def: wildcard-descriptor "*")
+(def: lower-prefix "-")
+(def: upper-prefix "+")
(def: object-suffix ";")
(def: object-class "java.lang.Object")
+(def: valid-var-characters/head
+ (format "abcdefghijklmnopqrstuvwxyz"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
+ "_"))
+
+(def: valid-var-characters/tail
+ (format valid-var-characters/head
+ "0123456789"))
+
+(def: syntax-package-separator ".")
+(def: binary-package-separator "/")
+
+(def: valid-class-characters/head
+ (format valid-var-characters/head ..binary-package-separator))
+
+(def: valid-class-characters/tail
+ (format valid-var-characters/tail ..binary-package-separator))
+
(type: #export Bound
#Lower
#Upper)
@@ -104,7 +130,7 @@
(def: #export binary-name
(-> Text Text)
- (text.replace-all "." "/"))
+ (text.replace-all ..syntax-package-separator ..binary-package-separator))
(def: #export (descriptor type)
(-> Type Text)
@@ -180,18 +206,79 @@
(format ..object-prefix (binary-name class) =params ..object-suffix))
(#Var name)
- (format "T" name ..object-suffix)
+ (format ..var-prefix name ..object-suffix)
(#Wildcard #.None)
- "*"
+ ..wildcard-descriptor
(^template [<tag> <prefix>]
(#Wildcard (#.Some [<tag> bound]))
(format <prefix> (signature (#Generic bound))))
- ([#Upper "+"]
- [#Lower "-"]))
+ ([#Lower ..lower-prefix]
+ [#Upper ..upper-prefix]))
))
+(template [<name> <head> <tail>]
+ [(def: <name>
+ (Parser Text)
+ (<t>.slice (<t>.and! (<t>.one-of! <head>)
+ (<t>.some! (<t>.one-of! <tail>)))))]
+
+ [parse-class-name valid-class-characters/head valid-class-characters/tail]
+ [parse-var-name valid-var-characters/head valid-var-characters/tail]
+ )
+
+(def: parse-var
+ (Parser Var)
+ (|> ..parse-var-name
+ (<>.after (<t>.this ..var-prefix))
+ (<>.before (<t>.this ..object-suffix))))
+
+(def: parse-bound
+ (Parser Bound)
+ ($_ <>.or
+ (<t>.this ..lower-prefix)
+ (<t>.this ..upper-prefix)))
+
+(def: parse-generic
+ (Parser Generic)
+ (<>.rec
+ (function (_ recur)
+ ($_ <>.or
+ ..parse-var
+ ($_ <>.or
+ (<t>.this ..wildcard-descriptor)
+ (<>.and ..parse-bound recur)
+ )
+ (|> (<>.and ..parse-class-name
+ (|> (<>.some recur)
+ (<>.after (<t>.this "<"))
+ (<>.before (<t>.this ">"))
+ (<>.default (list))))
+ (<>.after (<t>.this ..object-prefix))
+ (<>.before (<t>.this ..object-suffix)))
+ ))))
+
+(def: #export parse-signature
+ (-> Text (Error Type))
+ (<t>.run (<>.rec
+ (function (_ recur)
+ ($_ <>.or
+ ($_ <>.or
+ (<t>.this ..boolean-descriptor)
+ (<t>.this ..byte-descriptor)
+ (<t>.this ..short-descriptor)
+ (<t>.this ..int-descriptor)
+ (<t>.this ..long-descriptor)
+ (<t>.this ..float-descriptor)
+ (<t>.this ..double-descriptor)
+ (<t>.this ..char-descriptor)
+ )
+ ..parse-generic
+ (<>.after (<t>.this ..array-prefix)
+ recur)
+ )))))
+
(def: #export (method args return exceptions)
(-> (List Type) (Maybe Type) (List Generic) Method)
{#args args #return return #exceptions exceptions})
diff --git a/stdlib/source/lux/time/date.lux b/stdlib/source/lux/time/date.lux
index 3a1df14c1..45121339a 100644
--- a/stdlib/source/lux/time/date.lux
+++ b/stdlib/source/lux/time/date.lux
@@ -152,14 +152,10 @@
#month month
#day (.nat (.dec utc-day))})))
-(def: (decode input)
- (-> Text (Error Date))
- (l.run input ..lex-date))
-
(structure: #export codec
{#.doc (doc "Based on ISO 8601."
"For example: 2017-01-15")}
(Codec Text Date)
(def: encode ..encode)
- (def: decode ..decode))
+ (def: decode (l.run ..lex-date)))
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 28d4ff07c..91581c37b 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -164,7 +164,7 @@
## TODO: Get rid of this template block and use the definition in
## lux/host.jvm.lux ASAP
(template [<name> <class>]
- [(type: #export <name> (.primitive <class>))]
+ [(def: #export <name> .Type (#.Primitive <class> #.Nil))]
## Boxes
[Boolean "java.lang.Boolean"]
@@ -368,9 +368,6 @@
(#.Primitive name _)
(////@wrap name)
- (#.Named name unnamed)
- (check-jvm unnamed)
-
(^template [<tag>]
(<tag> id)
(////@wrap "java.lang.Object"))
@@ -402,6 +399,12 @@
(/////analysis.throw ..primitives-are-not-objects [name])
(////@wrap name))))
+(def: (check-return type)
+ (-> .Type (Operation Text))
+ (if (is? .Any type)
+ (////@wrap "void")
+ (check-jvm type)))
+
(def: (read-primitive-array-handler lux-type jvm-type)
(-> .Type Type Handler)
(function (_ extension-name analyse args)
@@ -759,7 +762,12 @@
class-name (java/lang/Class::getName java-type)]
(////@wrap (case (array.size (java/lang/Class::getTypeParameters java-type))
0
- (#.Primitive class-name (list))
+ (case class-name
+ "void"
+ Any
+
+ _
+ (#.Primitive class-name (list)))
arity
(|> (list.indices arity)
@@ -796,7 +804,7 @@
_)
## else
- (/////analysis.throw cannot-convert-to-a-lux-type java-type)))
+ (/////analysis.throw ..cannot-convert-to-a-lux-type java-type)))
(def: (correspond-type-params class type)
(-> (java/lang/Class java/lang/Object) .Type (Operation Mapping))
@@ -1127,28 +1135,34 @@
[parameters (|> (Method::getGenericParameterTypes method)
array.to-list
(monad.map @ java-type-to-parameter))
- #let [modifiers (Method::getModifiers method)]]
- (wrap (and (java/lang/Object::equals class (Method::getDeclaringClass method))
- (text@= method-name (Method::getName method))
- (case #Static
- #Special
- (Modifier::isStatic modifiers)
-
- _
- #1)
- (case method-style
- #Special
- (not (or (Modifier::isInterface (java/lang/Class::getModifiers class))
- (Modifier::isAbstract modifiers)))
-
- _
- #1)
- (n/= (list.size arg-classes) (list.size parameters))
- (list@fold (function (_ [expectedJC actualJC] prev)
- (and prev
- (text@= expectedJC actualJC)))
- #1
- (list.zip2 arg-classes parameters))))))
+ #let [modifiers (Method::getModifiers method)]
+ #let [correct-class? (java/lang/Object::equals class (Method::getDeclaringClass method))
+ correct-method? (text@= method-name (Method::getName method))
+ static-matches? (case method-style
+ #Static
+ (Modifier::isStatic modifiers)
+
+ _
+ #1)
+ special-matches? (case method-style
+ #Special
+ (not (or (Modifier::isInterface (java/lang/Class::getModifiers class))
+ (Modifier::isAbstract modifiers)))
+
+ _
+ #1)
+ arity-matches? (n/= (list.size arg-classes) (list.size parameters))
+ inputs-match? (list@fold (function (_ [expectedJC actualJC] prev)
+ (and prev
+ (text@= expectedJC actualJC)))
+ #1
+ (list.zip2 arg-classes parameters))]]
+ (wrap (and correct-class?
+ correct-method?
+ static-matches?
+ special-matches?
+ arity-matches?
+ inputs-match?))))
(def: (check-constructor class arg-classes constructor)
(-> (java/lang/Class java/lang/Object) (List Text) (Constructor java/lang/Object) (Operation Bit))
@@ -1330,7 +1344,7 @@
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Static argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))
- outputJC (check-jvm outputT)]
+ outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
(/////analysis.text method)
(/////analysis.text outputJC)
@@ -1350,7 +1364,7 @@
_
(undefined))]
- outputJC (check-jvm outputT)]
+ outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
(/////analysis.text method)
(/////analysis.text outputJC)
@@ -1365,7 +1379,7 @@
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Special argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
- outputJC (check-jvm outputT)]
+ outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
(/////analysis.text method)
(/////analysis.text outputJC)
@@ -1382,7 +1396,7 @@
(Modifier::isInterface (java/lang/Class::getModifiers class)))
[methodT exceptionsT] (method-candidate class-name method #Interface argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
- outputJC (check-jvm outputT)]
+ outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name
(list& (/////analysis.text class-name)
(/////analysis.text method)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-15 23:16:17 +0000