aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
authorEduardo Julian2019-09-14 23:42:56 -0400
committerEduardo Julian2019-09-14 23:42:56 -0400
commit7027b09b68a5ad8f7a4eb2f9edd913d43d2f1730 (patch)
tree93226f666a0ee75d1ef19186a7bead3e770075d8 /stdlib
parentfb7a90d4c56d5e4e726f1e83dc951fa46d36ffdb (diff)
More fixes.
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/parser/text.lux27
-rw-r--r--stdlib/source/lux/data/text.lux2
-rw-r--r--stdlib/source/lux/host.jvm.lux935
-rw-r--r--stdlib/source/lux/math.lux4
-rw-r--r--stdlib/source/lux/target/jvm/type.lux16
-rw-r--r--stdlib/source/lux/target/jvm/type/category.lux2
-rw-r--r--stdlib/source/lux/target/jvm/type/descriptor.lux10
-rw-r--r--stdlib/source/lux/target/jvm/type/parser.lux19
-rw-r--r--stdlib/source/lux/target/jvm/type/reflection.lux50
-rw-r--r--stdlib/source/lux/target/jvm/type/signature.lux10
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux187
11 files changed, 725 insertions, 537 deletions
diff --git a/stdlib/source/lux/control/parser/text.lux b/stdlib/source/lux/control/parser/text.lux
index 44d568eaf..5a7c2bb10 100644
--- a/stdlib/source/lux/control/parser/text.lux
+++ b/stdlib/source/lux/control/parser/text.lux
@@ -109,19 +109,20 @@
[not! Slice ..any!]
)
-(def: #export (this reference)
- {#.doc "Lex a text if it matches the given sample."}
- (-> Text (Parser Any))
- (function (_ [offset tape])
- (case (/.index-of' reference offset tape)
- (#.Some where)
- (if (n.= offset where)
- (#try.Success [[("lux i64 +" (/.size reference) offset) tape]
- []])
- (#try.Failure ($_ /@compose "Could not match: " (/.encode reference) " @ " (maybe.assume (/.clip' offset tape)))))
-
- _
- (#try.Failure ($_ /@compose "Could not match: " (/.encode reference))))))
+(with-expansions [<failure> (as-is (#try.Failure ($_ /@compose "Could not match: " (/.encode reference) " @ " (maybe.assume (/.clip' offset tape)))))]
+ (def: #export (this reference)
+ {#.doc "Lex a text if it matches the given sample."}
+ (-> Text (Parser Any))
+ (function (_ [offset tape])
+ (case (/.index-of' reference offset tape)
+ (#.Some where)
+ (if (n.= offset where)
+ (#try.Success [[("lux i64 +" (/.size reference) offset) tape]
+ []])
+ <failure>)
+
+ _
+ <failure>))))
(def: #export (this? reference)
{#.doc "Lex a text if it matches the given sample."}
diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux
index dce88022b..99cf151b1 100644
--- a/stdlib/source/lux/data/text.lux
+++ b/stdlib/source/lux/data/text.lux
@@ -198,7 +198,7 @@
(~~ (static @.jvm))
(|> input
(:coerce (primitive "java.lang.String"))
- ("jvm member invoke virtual" "java.lang.String" "hashCode")
+ ("jvm member invoke virtual" [] "java.lang.String" "hashCode" [])
"jvm conversion int-to-long"
"jvm object cast"
(: (primitive "java.lang.Long"))
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index 69a156504..c668431c8 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -8,7 +8,9 @@
["." function]
["." io]
["." try (#+ Try)]
+ ["." exception (#+ Exception exception:)]
["<>" parser ("#@." monad)
+ ["<t>" text]
["<c>" code (#+ Parser)]]]
[data
["." maybe]
@@ -30,13 +32,17 @@
[encoding
["." name (#+ External)]]
["." type (#+ Type Argument Typed)
- ["." category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ ["." category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
["." box]
+ ["." descriptor]
["." signature]
["." reflection]
["." parser]]]]])
-(type: Variable Text)
+(def: internal
+ (-> External Text)
+ (|>> name.internal
+ name.read))
(def: signature (|>> type.signature signature.signature))
(def: reflection (|>> type.reflection reflection.reflection))
@@ -176,19 +182,15 @@
#Class
#Interface)
-(type: Class-Declaration
- {#class-name Text
- #class-params (List (Type Var))})
-
(type: StackFrame (primitive "java/lang/StackTraceElement"))
(type: StackTrace (array.Array StackFrame))
-(type: AnnotationParam
+(type: Annotation-Parameter
[Text Code])
(type: Annotation
{#ann-name Text
- #ann-params (List AnnotationParam)})
+ #ann-params (List Annotation-Parameter)})
(type: Member-Declaration
{#member-name Text
@@ -196,53 +198,53 @@
#member-anns (List Annotation)})
(type: FieldDecl
- (#ConstantField Type Code)
- (#VariableField StateModifier Type))
+ (#ConstantField (Type Value) Code)
+ (#VariableField StateModifier (Type Value)))
(type: MethodDecl
- {#method-tvars (List Variable)
- #method-inputs (List Type)
- #method-output Return
- #method-exs (List Class)})
+ {#method-tvars (List (Type Var))
+ #method-inputs (List (Type Value))
+ #method-output (Type Return)
+ #method-exs (List (Type Class))})
(type: Method-Definition
(#ConstructorMethod [Bit
- (List Variable)
+ (List (Type Var))
Text
(List Argument)
(List (Typed Code))
Code
- (List Class)])
+ (List (Type Class))])
(#VirtualMethod [Bit
Bit
- (List Variable)
+ (List (Type Var))
Text
(List Argument)
- Return
+ (Type Return)
Code
- (List Class)])
+ (List (Type Class))])
(#OverridenMethod [Bit
- Class-Declaration
- (List Variable)
+ (Type Declaration)
+ (List (Type Var))
Text
(List Argument)
- Return
+ (Type Return)
Code
- (List Class)])
+ (List (Type Class))])
(#StaticMethod [Bit
- (List Variable)
+ (List (Type Var))
(List Argument)
- Return
+ (Type Return)
Code
- (List Class)])
- (#AbstractMethod [(List Variable)
+ (List (Type Class))])
+ (#AbstractMethod [(List (Type Var))
(List Argument)
- Return
- (List Class)])
- (#NativeMethod [(List Variable)
+ (Type Return)
+ (List (Type Class))])
+ (#NativeMethod [(List (Type Var))
(List Argument)
- Return
- (List Class)]))
+ (Type Return)
+ (List (Type Class))]))
(type: Partial-Call
{#pc-method Name
@@ -256,8 +258,8 @@
{#import-member-mode Primitive-Mode
#import-member-alias Text
#import-member-kind ImportMethodKind
- #import-member-tvars (List Variable)
- #import-member-args (List [Bit Type])
+ #import-member-tvars (List (Type Var))
+ #import-member-args (List [Bit (Type Value)])
#import-member-maybe? Bit
#import-member-try? Bit
#import-member-io? Bit})
@@ -267,7 +269,7 @@
(type: ImportMethodDecl
{#import-method-name Text
- #import-method-return Return})
+ #import-method-return (Type Return)})
(type: ImportFieldDecl
{#import-field-mode Primitive-Mode
@@ -275,7 +277,7 @@
#import-field-static? Bit
#import-field-maybe? Bit
#import-field-setter? Bit
- #import-field-type Type})
+ #import-field-type (Type Value)})
(type: Import-Member-Declaration
(#EnumDecl (List Text))
@@ -283,7 +285,7 @@
(#MethodDecl [ImportMethodCommons ImportMethodDecl])
(#FieldAccessDecl ImportFieldDecl))
-(type: Class-Imports
+(type: Context
(List [Text Text]))
(def: (short-class-name name)
@@ -340,9 +342,9 @@
#.None)]
[parser.var? name (code.identifier ["" name])]
- [parser.wildcard? bound (` .Any)]
- [parser.lower? bound (` .Any)]
- [parser.upper? bound (parameter-type bound)]
+ [parser.wildcard? _ (` .Any)]
+ [parser.lower? _ (` .Any)]
+ [parser.upper? limit (parameter-type limit)]
[parser.class? [name parameters]
(` (.primitive (~ (code.text name))
[(~+ (list@map parameter-type parameters))]))]))
@@ -371,33 +373,32 @@
(undefined)
)))
-(def: (declaration-type$ (^slots [#class-name #class-params]))
- (-> Class-Declaration Code)
- (` (primitive (~ (code.text class-name))
- [(~+ (list@map code.local-identifier class-params))])))
+(def: declaration-type$
+ (-> (Type Declaration) Code)
+ (|>> ..signature code.text))
-(def: empty-imports
- Class-Imports
+(def: fresh
+ Context
(list))
(def: (get-import name imports)
- (-> Text Class-Imports (Maybe Text))
+ (-> Text Context (Maybe Text))
(:: maybe.functor map product.right
(list.find (|>> product.left (text@= name))
imports)))
(def: (add-import short+full imports)
- (-> [Text Text] Class-Imports Class-Imports)
+ (-> [Text Text] Context Context)
(#.Cons short+full imports))
-(def: (class-imports compiler)
- (-> Lux Class-Imports)
+(def: (context compiler)
+ (-> Lux Context)
(case (macro.run compiler
- (: (Meta Class-Imports)
+ (: (Meta Context)
(do macro.monad
[current-module macro.current-module-name
definitions (macro.definitions current-module)]
- (wrap (list@fold (: (-> [Text Global] Class-Imports Class-Imports)
+ (wrap (list@fold (: (-> [Text Global] Context Context)
(function (_ [short-name constant] imports)
(case constant
(#.Left _)
@@ -410,13 +411,13 @@
_
imports))))
- empty-imports
+ ..fresh
definitions)))))
(#.Left _) (list)
(#.Right imports) imports))
(def: (qualify imports name)
- (-> Class-Imports Text Text)
+ (-> Context Text Text)
(|> imports (get-import name) (maybe.default name)))
(def: (make-get-const-parser class-name field-name)
@@ -480,8 +481,8 @@
(make-put-var-parser class-name field-name))))
(def: (decorate-input [class value])
- (-> [Text Code] Code)
- (` [(~ (code.text class)) (~ value)]))
+ (-> [(Type Value) Code] Code)
+ (` [(~ (code.text (..signature class))) (~ value)]))
(def: (make-constructor-parser class-name arguments)
(-> Text (List Argument) (Parser Code))
@@ -491,7 +492,7 @@
(<c>.tuple (<>.exactly (list.size arguments) <c>.any)))))]
(wrap (` ("jvm member invoke constructor" (~ (code.text class-name))
(~+ (|> args
- (list.zip2 (list@map (|>> product.right ..signature) arguments))
+ (list.zip2 (list@map product.right arguments))
(list@map ..decorate-input))))))))
(def: (make-static-method-parser class-name method-name arguments)
@@ -503,7 +504,7 @@
(<c>.tuple (<>.exactly (list.size arguments) <c>.any)))))]
(wrap (` ("jvm member invoke static" (~ (code.text class-name)) (~ (code.text method-name))
(~+ (|> args
- (list.zip2 (list@map (|>> product.right ..signature) arguments))
+ (list.zip2 (list@map product.right arguments))
(list@map ..decorate-input))))))))
(template [<name> <jvm-op>]
@@ -517,7 +518,7 @@
(wrap (` (<jvm-op> (~ (code.text class-name)) (~ (code.text method-name))
(~' _jvm_this)
(~+ (|> args
- (list.zip2 (list@map (|>> product.right ..signature) arguments))
+ (list.zip2 (list@map product.right arguments))
(list@map ..decorate-input))))))))]
[make-special-method-parser "jvm member invoke special"]
@@ -544,7 +545,7 @@
(make-virtual-method-parser class-name method-name args)))
(def: (full-class-name^ imports)
- (-> Class-Imports (Parser Text))
+ (-> Context (Parser Text))
(do <>.monad
[name <c>.local-identifier]
(wrap (qualify imports name))))
@@ -566,24 +567,41 @@
(<c>.this! (' #abstract))
(wrap []))))
+(exception: #export (class-names-cannot-contain-periods {name Text})
+ (exception.report
+ ["Name" (%.text name)]))
+
+(exception: #export (class-name-cannot-be-a-type-variable {name Text}
+ {type-vars (List (Type Var))})
+ (exception.report
+ ["Name" (%.text name)]
+ ["Type Variables" (exception.enumerate parser.name type-vars)]))
+
+(def: (assert exception payload test)
+ (All [e] (-> (Exception e) e Bit (Parser Any)))
+ (<>.assert (exception.construct exception payload)
+ test))
+
(def: (assert-valid-class-name type-vars name)
- (-> (List Variable) Text (Parser Any))
+ (-> (List (Type Var)) External (Parser Any))
(do <>.monad
- [_ (<>.assert "Names in class declarations cannot contain periods."
- (not (text.contains? name.external-separator name)))]
- (<>.assert (format name " cannot be a type-var!")
- (not (list.member? text.equivalence type-vars name)))))
+ [_ (..assert ..class-names-cannot-contain-periods [name]
+ (not (text.contains? name.external-separator name)))]
+ (..assert ..class-name-cannot-be-a-type-variable [name type-vars]
+ (not (list.member? text.equivalence
+ (list@map parser.name type-vars)
+ name)))))
(def: (valid-class-name imports type-vars)
- (-> Class-Imports (List Variable) (Parser Text))
+ (-> Context (List (Type Var)) (Parser External))
(do <>.monad
[name (full-class-name^ imports)
_ (assert-valid-class-name type-vars name)]
(wrap name)))
(def: (class^' parameter^ imports type-vars)
- (-> (-> Class-Imports (List Variable) (Parser (Type Parameter)))
- (-> Class-Imports (List Variable) (Parser (Type Class))))
+ (-> (-> Context (List (Type Var)) (Parser (Type Parameter)))
+ (-> Context (List (Type Var)) (Parser (Type Class))))
(do <>.monad
[[name parameters] (: (Parser [External (List (Type Parameter))])
($_ <>.either
@@ -593,12 +611,18 @@
(<>.some (parameter^ imports type-vars))))))]
(wrap (type.class name parameters))))
+(exception: #export (unexpected-type-variable {name Text}
+ {type-vars (List (Type Var))})
+ (exception.report
+ ["Unexpected Type Variable" (%.text name)]
+ ["Expected Type Variables" (exception.enumerate parser.name type-vars)]))
+
(def: (variable^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (Type Parameter)))
+ (-> Context (List (Type Var)) (Parser (Type Parameter)))
(do <>.monad
[name (full-class-name^ imports)
- _ (<>.assert "Variable name must ne one of the expected type-variables."
- (list.member? text.equivalence type-vars name))]
+ _ (..assert ..unexpected-type-variable [name type-vars]
+ (list.member? text.equivalence (list@map parser.name type-vars) name))]
(wrap (type.var name))))
(def: wildcard^
@@ -620,7 +644,7 @@
)
(def: (parameter^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (Type Parameter)))
+ (-> Context (List (Type Var)) (Parser (Type Parameter)))
(<>.rec
(function (_ recur^)
(let [class^ (..class^' parameter^ imports type-vars)]
@@ -657,7 +681,7 @@
(:: <>.monad map type.array)))
(def: (type^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (Type Value)))
+ (-> Context (List (Type Var)) (Parser (Type Value)))
(<>.rec
(function (_ type^)
($_ <>.either
@@ -667,7 +691,7 @@
))))
(def: (return^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (Type Return)))
+ (-> Context (List (Type Var)) (Parser (Type Return)))
(<>.either (itself^ type.void)
(..type^ imports type-vars)))
@@ -680,50 +704,53 @@
(<c>.tuple (<>.some var^)))
(def: (declaration^ imports)
- (-> Class-Imports (Parser Class-Declaration))
- (<>.either (<>.and (valid-class-name imports (list))
- (<>@wrap (list)))
- (<c>.form (<>.and (valid-class-name imports (list))
- (<>.some var^)))
- ))
+ (-> Context (Parser (Type Declaration)))
+ (do <>.monad
+ [[name variables] (: (Parser [External (List (Type Var))])
+ (<>.either (<>.and (valid-class-name imports (list))
+ (<>@wrap (list)))
+ (<c>.form (<>.and (valid-class-name imports (list))
+ (<>.some var^)))
+ ))]
+ (wrap (type.declaration name variables))))
(def: (class^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser Class))
+ (-> Context (List (Type Var)) (Parser (Type Class)))
(class^' parameter^ imports type-vars))
-(def: annotation-params^
- (Parser (List AnnotationParam))
+(def: annotation-parameters^
+ (Parser (List Annotation-Parameter))
(<c>.record (<>.some (<>.and <c>.local-tag <c>.any))))
(def: (annotation^ imports)
- (-> Class-Imports (Parser Annotation))
+ (-> Context (Parser Annotation))
(<>.either (do <>.monad
[ann-name (full-class-name^ imports)]
(wrap [ann-name (list)]))
(<c>.form (<>.and (full-class-name^ imports)
- annotation-params^))))
+ annotation-parameters^))))
(def: (annotations^' imports)
- (-> Class-Imports (Parser (List Annotation)))
+ (-> Context (Parser (List Annotation)))
(do <>.monad
[_ (<c>.this! (' #ann))]
(<c>.tuple (<>.some (annotation^ imports)))))
(def: (annotations^ imports)
- (-> Class-Imports (Parser (List Annotation)))
+ (-> Context (Parser (List Annotation)))
(do <>.monad
[anns?? (<>.maybe (annotations^' imports))]
(wrap (maybe.default (list) anns??))))
(def: (throws-decl^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (List Class)))
+ (-> Context (List (Type Var)) (Parser (List (Type Class))))
(<| (<>.default (list))
(do <>.monad
[_ (<c>.this! (' #throws))]
(<c>.tuple (<>.some (..class^ imports type-vars))))))
(def: (method-decl^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser [Member-Declaration MethodDecl]))
+ (-> Context (List (Type Var)) (Parser [Member-Declaration MethodDecl]))
(<c>.form (do <>.monad
[tvars (<>.default (list) ..vars^)
name <c>.local-identifier
@@ -744,7 +771,7 @@
(:: <>.monad wrap [])))
(def: (field-decl^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser [Member-Declaration FieldDecl]))
+ (-> Context (List (Type Var)) (Parser [Member-Declaration FieldDecl]))
(<>.either (<c>.form (do <>.monad
[_ (<c>.this! (' #const))
name <c>.local-identifier
@@ -761,24 +788,24 @@
(wrap [[name pm anns] (#VariableField [sm type])])))))
(def: (argument^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser Argument))
+ (-> Context (List (Type Var)) (Parser Argument))
(<c>.record (<>.and <c>.local-identifier
(..type^ imports type-vars))))
(def: (arguments^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (List Argument)))
+ (-> Context (List (Type Var)) (Parser (List Argument)))
(<>.some (argument^ imports type-vars)))
(def: (constructor-arg^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (Typed Code)))
+ (-> Context (List (Type Var)) (Parser (Typed Code)))
(<c>.record (<>.and (..type^ imports type-vars) <c>.any)))
(def: (constructor-args^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (List (Typed Code))))
+ (-> Context (List (Type Var)) (Parser (List (Typed Code))))
(<c>.tuple (<>.some (constructor-arg^ imports type-vars))))
(def: (constructor-method^ imports class-vars)
- (-> Class-Imports (List Variable) (Parser [Member-Declaration Method-Definition]))
+ (-> Context (List (Type Var)) (Parser [Member-Declaration Method-Definition]))
(<c>.form (do <>.monad
[pm privacy-modifier^
strict-fp? (<>.parses? (<c>.this! (' #strict)))
@@ -798,7 +825,7 @@
(#ConstructorMethod strict-fp? method-vars self-name arguments constructor-args body exs)]))))
(def: (virtual-method-def^ imports class-vars)
- (-> Class-Imports (List Variable) (Parser [Member-Declaration Method-Definition]))
+ (-> Context (List (Type Var)) (Parser [Member-Declaration Method-Definition]))
(<c>.form (do <>.monad
[pm privacy-modifier^
strict-fp? (<>.parses? (<c>.this! (' #strict)))
@@ -819,12 +846,13 @@
(#VirtualMethod final? strict-fp? method-vars self-name arguments return-type body exs)]))))
(def: (overriden-method-def^ imports)
- (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
+ (-> Context (Parser [Member-Declaration Method-Definition]))
(<c>.form (do <>.monad
[strict-fp? (<>.parses? (<c>.this! (' #strict)))
owner-class (declaration^ imports)
method-vars (<>.default (list) ..vars^)
- #let [total-vars (list@compose (product.right owner-class) method-vars)]
+ #let [total-vars (list@compose (product.right (parser.declaration owner-class))
+ method-vars)]
[name self-name arguments] (<c>.form ($_ <>.and
<c>.local-identifier
<c>.local-identifier
@@ -839,7 +867,7 @@
(#OverridenMethod strict-fp? owner-class method-vars self-name arguments return-type body exs)]))))
(def: (static-method-def^ imports)
- (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
+ (-> Context (Parser [Member-Declaration Method-Definition]))
(<c>.form (do <>.monad
[pm privacy-modifier^
strict-fp? (<>.parses? (<c>.this! (' #strict)))
@@ -858,7 +886,7 @@
(#StaticMethod strict-fp? method-vars arguments return-type body exs)]))))
(def: (abstract-method-def^ imports)
- (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
+ (-> Context (Parser [Member-Declaration Method-Definition]))
(<c>.form (do <>.monad
[pm privacy-modifier^
_ (<c>.this! (' #abstract))
@@ -875,7 +903,7 @@
(#AbstractMethod method-vars arguments return-type exs)]))))
(def: (native-method-def^ imports)
- (-> Class-Imports (Parser [Member-Declaration Method-Definition]))
+ (-> Context (Parser [Member-Declaration Method-Definition]))
(<c>.form (do <>.monad
[pm privacy-modifier^
_ (<c>.this! (' #native))
@@ -892,7 +920,7 @@
(#NativeMethod method-vars arguments return-type exs)]))))
(def: (method-def^ imports class-vars)
- (-> Class-Imports (List Variable) (Parser [Member-Declaration Method-Definition]))
+ (-> Context (List (Type Var)) (Parser [Member-Declaration Method-Definition]))
($_ <>.either
(constructor-method^ imports class-vars)
(virtual-method-def^ imports class-vars)
@@ -922,7 +950,7 @@
<c>.local-identifier)))
(def: (import-member-args^ imports type-vars)
- (-> Class-Imports (List Variable) (Parser (List [Bit Type])))
+ (-> Context (List (Type Var)) (Parser (List [Bit (Type Value)])))
(<c>.tuple (<>.some (<>.and (<>.parses? (<c>.tag! ["" "?"]))
(..type^ imports type-vars)))))
@@ -939,7 +967,7 @@
(<c>.tag! ["" "auto"])))
(def: (import-member-decl^ imports owner-vars)
- (-> Class-Imports (List Variable) (Parser Import-Member-Declaration))
+ (-> Context (List (Type Var)) (Parser Import-Member-Declaration))
($_ <>.either
(<c>.form (do <>.monad
[_ (<c>.this! (' #enum))
@@ -1003,91 +1031,42 @@
(def: (privacy-modifier$ pm)
(-> Privacy Code)
(case pm
- #PublicP (' "public")
- #PrivateP (' "private")
- #ProtectedP (' "protected")
- #DefaultP (' "default")))
+ #PublicP (code.text "public")
+ #PrivateP (code.text "private")
+ #ProtectedP (code.text "protected")
+ #DefaultP (code.text "default")))
(def: (inheritance-modifier$ im)
(-> InheritanceModifier Code)
(case im
- #FinalIM (' "final")
- #AbstractIM (' "abstract")
- #DefaultIM (' "default")))
+ #FinalIM (code.text "final")
+ #AbstractIM (code.text "abstract")
+ #DefaultIM (code.text "default")))
-(def: (annotation-param$ [name value])
- (-> AnnotationParam Code)
+(def: (annotation-parameter$ [name value])
+ (-> Annotation-Parameter Code)
(` [(~ (code.text name)) (~ value)]))
(def: (annotation$ [name params])
(-> Annotation Code)
- (` ((~ (code.text name)) (~+ (list@map annotation-param$ params)))))
-
-(def: (bound$ kind)
- (-> Bound Code)
- (case kind
- #jvm.Lower (code.local-identifier ">")
- #jvm.Upper (code.local-identifier "<")))
-
-(def: var$
- (-> Variable Code)
- code.text)
-
-(def: (generic$ generic)
- (-> Generic Code)
- (case generic
- (#jvm.Var var)
- (var$ var)
-
- (#jvm.Class name params)
- (` ((~ (code.text name)) (~+ (list@map generic$ params))))
-
- (#jvm.Wildcard wilcard)
- (case wilcard
- #.None
- (code.local-identifier "?")
-
- (#.Some [bound bound])
- (` ((~ (..bound$ bound)) (~ (generic$ bound)))))))
-
-(def: (type$ type)
- (-> Type Code)
- (case type
- (#jvm.Primitive primitive)
- (case primitive
- #jvm.Boolean (code.local-identifier reflection.boolean)
- #jvm.Byte (code.local-identifier reflection.byte)
- #jvm.Short (code.local-identifier reflection.short)
- #jvm.Int (code.local-identifier reflection.int)
- #jvm.Long (code.local-identifier reflection.long)
- #jvm.Float (code.local-identifier reflection.float)
- #jvm.Double (code.local-identifier reflection.double)
- #jvm.Char (code.local-identifier reflection.char))
-
- (#jvm.Generic generic)
- (generic$ generic)
-
- (#jvm.Array elementT)
- (` [(~ (type$ elementT))])))
-
-(def: (return$ return)
- (-> Return Code)
- (case return
- #.None
- (code.local-identifier "void")
-
- (#.Some type)
- (type$ type)))
+ (` ((~ (code.text name)) (~+ (list@map annotation-parameter$ params)))))
-(def: (declaration$ (^open "."))
- (-> Class-Declaration Code)
- (` ((~ (code.text class-name))
- (~+ (list@map var$ class-params)))))
+(template [<name> <category>]
+ [(def: <name>
+ (-> (Type <category>) Code)
+ (|>> ..signature code.text))]
+
+ [var$ Var]
+ [parameter$ Parameter]
+ [value$ Value]
+ [return$ Return]
+ [declaration$ Declaration]
+ [class$ Class]
+ )
-(def: (class$ [name params])
- (-> Class Code)
- (` ((~ (code.text name))
- (~+ (list@map generic$ params)))))
+(def: var$'
+ (-> (Type Var) Code)
+ (|>> ..signature code.local-identifier))
(def: (method-decl$ [[name pm anns] method-decl])
(-> [Member-Declaration MethodDecl] Code)
@@ -1096,7 +1075,7 @@
[(~+ (list@map annotation$ anns))]
[(~+ (list@map var$ method-tvars))]
[(~+ (list@map class$ method-exs))]
- [(~+ (list@map type$ method-inputs))]
+ [(~+ (list@map value$ method-inputs))]
(~ (return$ method-output))))))
(def: (state-modifier$ sm)
@@ -1112,7 +1091,7 @@
(#ConstantField class value)
(` ("constant" (~ (code.text name))
[(~+ (list@map annotation$ anns))]
- (~ (type$ class))
+ (~ (value$ class))
(~ value)
))
@@ -1121,20 +1100,20 @@
(~ (privacy-modifier$ pm))
(~ (state-modifier$ sm))
[(~+ (list@map annotation$ anns))]
- (~ (type$ class))
+ (~ (value$ class))
))
))
(def: (argument$ [name type])
(-> Argument Code)
- (` [(~ (code.text name)) (~ (type$ type))]))
+ (` [(~ (code.text name)) (~ (value$ type))]))
(def: (constructor-arg$ [class term])
(-> (Typed Code) Code)
- (` [(~ (type$ class)) (~ term)]))
+ (` [(~ (value$ class)) (~ term)]))
(def: (method-def$ replacer super-class [[name pm anns] method-def])
- (-> (-> Code Code) Class [Member-Declaration Method-Definition] Code)
+ (-> (-> Code Code) (Type Class) [Member-Declaration Method-Definition] Code)
(case method-def
(#ConstructorMethod strict-fp? type-vars self-name arguments constructor-args body exs)
(` ("init"
@@ -1166,14 +1145,13 @@
(#OverridenMethod strict-fp? declaration type-vars self-name arguments return-type body exs)
(let [super-replacer (parser->replacer (<c>.form (do <>.monad
[_ (<c>.this! (' ::super!))
- args (<c>.tuple (<>.exactly (list.size arguments) <c>.any))
- #let [arguments' (list@map (|>> product.right type.signature) arguments)]]
+ args (<c>.tuple (<>.exactly (list.size arguments) <c>.any))]
(wrap (` ("jvm member invoke special"
- (~ (code.text (product.left super-class)))
+ (~ (code.text (product.left (parser.read-class super-class))))
(~ (code.text name))
(~' _jvm_this)
(~+ (|> args
- (list.zip2 arguments')
+ (list.zip2 (list@map product.right arguments))
(list@map ..decorate-input)))))))))]
(` ("override"
(~ (declaration$ declaration))
@@ -1227,19 +1205,17 @@
(-> Code Partial-Call Code)
(` ((~ (code.identifier method)) (~+ args) (~ g!obj))))
-(def: object-class
- Class
- ["java/lang/Object" (list)])
+(def: $Object
+ (Type Class)
+ (type.class "java.lang.Object" (list)))
(syntax: #export (class:
- {#let [imports (class-imports *compiler*)]}
+ {#let [imports (..context *compiler*)]}
{im inheritance-modifier^}
- {declaration (declaration^ imports)}
- {#let [full-class-name (product.left declaration)
- imports (add-import [(short-class-name full-class-name) full-class-name]
- (class-imports *compiler*))]}
- {#let [class-vars (product.right declaration)]}
- {super (<>.default object-class
+ {[full-class-name class-vars] (:: @ map parser.declaration (declaration^ imports))}
+ {#let [imports (add-import [(short-class-name full-class-name) full-class-name]
+ (..context *compiler*))]}
+ {super (<>.default $Object
(class^ imports class-vars))}
{interfaces (<>.default (list)
(<c>.tuple (<>.some (class^ imports class-vars))))}
@@ -1276,7 +1252,7 @@
"(::new! []) for calling the class's constructor."
"(::resolve! container [value]) for calling the 'resolve' method."
)}
- (do macro.monad
+ (do @
[current-module macro.current-module-name
#let [fully-qualified-class-name (name.qualify current-module full-class-name)
field-parsers (list@map (field->parser fully-qualified-class-name) fields)
@@ -1285,7 +1261,7 @@
(<>.fail "")
(list@compose field-parsers method-parsers)))]]
(wrap (list (` ("jvm class"
- (~ (declaration$ (update@ #class-name (name.qualify current-module) declaration)))
+ (~ (declaration$ (type.declaration (name.qualify current-module full-class-name) class-vars)))
(~ (class$ super))
[(~+ (list@map class$ interfaces))]
(~ (inheritance-modifier$ im))
@@ -1294,12 +1270,10 @@
[(~+ (list@map (method-def$ replacer super) methods))]))))))
(syntax: #export (interface:
- {#let [imports (class-imports *compiler*)]}
- {declaration (declaration^ imports)}
- {#let [full-class-name (product.left declaration)
- imports (add-import [(short-class-name full-class-name) full-class-name]
- (class-imports *compiler*))]}
- {#let [class-vars (product.right declaration)]}
+ {#let [imports (..context *compiler*)]}
+ {[full-class-name class-vars] (:: @ map parser.declaration (declaration^ imports))}
+ {#let [imports (add-import [(short-class-name full-class-name) full-class-name]
+ (..context *compiler*))]}
{supers (<>.default (list)
(<c>.tuple (<>.some (class^ imports class-vars))))}
{annotations (annotations^ imports)}
@@ -1307,16 +1281,18 @@
{#.doc (doc "Allows defining JVM interfaces."
(interface: TestInterface
([] foo [boolean String] void #throws [Exception])))}
- (wrap (list (` ("jvm class interface"
- (~ (declaration$ declaration))
- [(~+ (list@map class$ supers))]
- [(~+ (list@map annotation$ annotations))]
- (~+ (list@map method-decl$ members)))))))
+ (do @
+ [current-module macro.current-module-name]
+ (wrap (list (` ("jvm class interface"
+ (~ (declaration$ (type.declaration (name.qualify current-module full-class-name) class-vars)))
+ [(~+ (list@map class$ supers))]
+ [(~+ (list@map annotation$ annotations))]
+ (~+ (list@map method-decl$ members))))))))
(syntax: #export (object
- {#let [imports (class-imports *compiler*)]}
+ {#let [imports (..context *compiler*)]}
{class-vars ..vars^}
- {super (<>.default object-class
+ {super (<>.default $Object
(class^ imports class-vars))}
{interfaces (<>.default (list)
(<c>.tuple (<>.some (class^ imports class-vars))))}
@@ -1392,7 +1368,7 @@
(wrap (list (` ("lux try" ((~! io.label) (.function ((~ g!_) (~ g!_))
(~ expression)))))))))
-(syntax: #export (check {#let [imports (class-imports *compiler*)]}
+(syntax: #export (check {#let [imports (..context *compiler*)]}
{class (..type^ imports (list))}
{unchecked (<>.maybe <c>.any)})
{#.doc (doc "Checks whether an object is an instance of a particular class."
@@ -1401,7 +1377,7 @@
(#.Some value-as-string)
#.None))}
(with-gensyms [g!_ g!unchecked]
- (let [class-name (reflection.class class)
+ (let [class-name (..reflection class)
class-type (` (.primitive (~ (code.text class-name))))
check-type (` (.Maybe (~ class-type)))
check-code (` (if ("jvm object instance?" (~ (code.text class-name)) (~ g!unchecked))
@@ -1438,21 +1414,22 @@
(exec (~+ (list@map (complete-call$ g!obj) methods))
(~ g!obj))))))))
-(def: (class-import$ long-name? [full-name params])
- (-> Bit Class-Declaration Code)
- (let [def-name (if long-name?
- full-name
- (short-class-name full-name))
- params' (list@map code.local-identifier params)]
+(def: (class-import$ long-name? declaration)
+ (-> Bit (Type Declaration) Code)
+ (let [[full-name params] (parser.declaration declaration)
+ def-name (..internal (if long-name?
+ full-name
+ (short-class-name full-name)))
+ params' (list@map ..var$' params)]
(` (def: (~ (code.identifier ["" def-name]))
- {#..jvm-class (~ (code.text full-name))}
+ {#..jvm-class (~ (code.text (..internal full-name)))}
.Type
(All [(~+ params')]
(primitive (~ (code.text full-name))
[(~+ params')]))))))
(def: (member-type-vars class-tvars member)
- (-> (List Variable) Import-Member-Declaration (List Variable))
+ (-> (List (Type Var)) Import-Member-Declaration (List (Type Var)))
(case member
(#ConstructorDecl [commons _])
(list@compose class-tvars (get@ #import-member-tvars commons))
@@ -1468,33 +1445,33 @@
_
class-tvars))
-(def: (member-def-arg-bindings vars class member)
- (-> (List Variable) Class-Declaration Import-Member-Declaration (Meta [(List [Bit Code]) (List Text) (List Code)]))
+(def: (member-def-arg-bindings vars member)
+ (-> (List (Type Var)) Import-Member-Declaration (Meta [(List [Bit Code]) (List (Type Value)) (List Code)]))
(case member
(^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
(let [(^slots [#import-member-tvars #import-member-args]) commons]
(do macro.monad
[arg-inputs (monad.map @
- (: (-> [Bit Type] (Meta [Bit Code]))
+ (: (-> [Bit (Type Value)] (Meta [Bit Code]))
(function (_ [maybe? _])
(with-gensyms [arg-name]
(wrap [maybe? arg-name]))))
import-member-args)
- #let [arg-classes (list@map (|>> product.right type.descriptor) import-member-args)
- arg-types (list@map (: (-> [Bit Type] Code)
+ #let [input-jvm-types (list@map product.right import-member-args)
+ arg-types (list@map (: (-> [Bit (Type Value)] Code)
(function (_ [maybe? arg])
(let [arg-type (value-type (get@ #import-member-mode commons) arg)]
(if maybe?
(` (Maybe (~ arg-type)))
arg-type))))
import-member-args)]]
- (wrap [arg-inputs arg-classes arg-types])))
+ (wrap [arg-inputs input-jvm-types arg-types])))
_
(:: macro.monad wrap [(list) (list) (list)])))
(def: (decorate-return-maybe member never-null? unboxed return-term)
- (-> Import-Member-Declaration Bit Text Code Code)
+ (-> Import-Member-Declaration Bit (Type Value) Code Code)
(case member
(^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
(cond (or never-null?
@@ -1531,49 +1508,33 @@
[decorate-return-io #import-member-io? (` ((~! io.io) (~ return-term)))]
)
-(def: var->type-arg
- (-> Variable Code)
- code.local-identifier)
-
-(template [<jvm> <class> <descriptor>]
- [(def: <class> <jvm>)
- (def: <descriptor> (type.signature (type.class <jvm> (list))))]
-
- ["java.lang.String" string-class string-descriptor]
- [box.boolean boolean-box-class boolean-box-descriptor]
- [box.byte byte-box-class byte-box-descriptor]
- [box.short short-box-class short-box-descriptor]
- [box.int int-box-class int-box-descriptor]
- [box.long long-box-class long-box-descriptor]
- [box.float float-box-class float-box-descriptor]
- [box.double double-box-class double-box-descriptor]
- [box.char char-box-class char-box-descriptor]
- )
+(def: $String (type.class "java.lang.String" (list)))
(template [<input?> <name> <unbox/box> <special+>]
[(def: (<name> mode [unboxed raw])
- (-> Primitive-Mode [Text Code] Code)
- (let [[unboxed refined post] (: [Text Code (List Code)]
+ (-> Primitive-Mode [(Type Value) Code] Code)
+ (let [[unboxed refined post] (: [(Type Value) Code (List Code)]
(case mode
#ManualPrM
[unboxed raw (list)]
#AutoPrM
- (`` (case unboxed
- (^template [<old> <new> <pre> <post>]
- (^ (static <old>))
- (with-expansions [<post>' (template.splice <post>)]
- [<new>
- (` (.|> (~ raw) (~+ <pre>)))
- (list <post>')]))
- ((~~ (template.splice <special+>)))
-
- _
- [unboxed
- (if <input?>
- (` ("jvm object cast" (~ raw)))
- raw)
- (list)]))))
+ (with-expansions [<special+>' (template.splice <special+>)
+ <cond-cases> (template [<old> <new> <pre> <post>]
+ [(:: type.equivalence = <old> unboxed)
+ (with-expansions [<post>' (template.splice <post>)]
+ [<new>
+ (` (.|> (~ raw) (~+ <pre>)))
+ (list <post>')])]
+
+ <special+>')]
+ (cond <cond-cases>
+ ## else
+ [unboxed
+ (if <input?>
+ (` ("jvm object cast" (~ raw)))
+ raw)
+ (list)]))))
unboxed/boxed (case (dictionary.get unboxed ..boxes)
(#.Some boxed)
(<unbox/box> unboxed boxed refined)
@@ -1588,29 +1549,29 @@
(` (.|> (~ unboxed/boxed) (~+ post))))))]
[#1 auto-convert-input ..unbox
- [[type.boolean-descriptor type.boolean-descriptor (list (` (.: .Bit)) (` (.:coerce (.primitive (~ (code.text box.boolean)))))) []]
- [type.byte-descriptor type.byte-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-byte)) []]
- [type.short-descriptor type.short-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-short)) []]
- [type.int-descriptor type.int-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-int)) []]
- [type.long-descriptor type.long-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long)))))) []]
- [type.float-descriptor type.float-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double))))) (` ..double-to-float)) []]
- [type.double-descriptor type.double-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double)))))) []]
- [..string-descriptor ..string-descriptor (list (` (.: .Text)) (` (.:coerce (.primitive (~ (code.text ..string-class)))))) []]
- [..boolean-box-descriptor ..boolean-box-descriptor (list (` (.: .Bit)) (` (.:coerce (.primitive (~ (code.text ..boolean-box-class)))))) []]
- [..long-box-descriptor ..long-box-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text ..long-box-class)))))) []]
- [..double-box-descriptor ..double-box-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text ..double-box-class)))))) []]]]
+ [[type.boolean type.boolean (list (` (.: .Bit)) (` (.:coerce (.primitive (~ (code.text box.boolean)))))) []]
+ [type.byte type.byte (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-byte)) []]
+ [type.short type.short (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-short)) []]
+ [type.int type.int (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-int)) []]
+ [type.long type.long (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long)))))) []]
+ [type.float type.float (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double))))) (` ..double-to-float)) []]
+ [type.double type.double (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double)))))) []]
+ [..$String ..$String (list (` (.: .Text)) (` (.:coerce (.primitive (~ (code.text (..reflection ..$String))))))) []]
+ [(type.class box.boolean (list)) (type.class box.boolean (list)) (list (` (.: .Bit)) (` (.:coerce (.primitive (~ (code.text box.boolean)))))) []]
+ [(type.class box.long (list)) (type.class box.long (list)) (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long)))))) []]
+ [(type.class box.double (list)) (type.class box.double (list)) (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double)))))) []]]]
[#0 auto-convert-output ..box
- [[type.boolean-descriptor type.boolean-descriptor (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:coerce .Bit))]]
- [type.byte-descriptor type.long-descriptor (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [type.short-descriptor type.long-descriptor (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [type.int-descriptor type.long-descriptor (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [type.long-descriptor type.long-descriptor (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [type.float-descriptor type.double-descriptor (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]
- [type.double-descriptor type.double-descriptor (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]
- [..string-descriptor ..string-descriptor (list) [(` (.: (.primitive (~ (code.text ..string-class))))) (` (.:coerce .Text))]]
- [..boolean-box-descriptor ..boolean-box-descriptor (list) [(` (.: (.primitive (~ (code.text ..boolean-box-class))))) (` (.:coerce .Bit))]]
- [..long-box-descriptor ..long-box-descriptor (list) [(` (.: (.primitive (~ (code.text ..long-box-class))))) (` (.:coerce .Int))]]
- [..double-box-descriptor ..double-box-descriptor (list) [(` (.: (.primitive (~ (code.text ..double-box-class))))) (` (.:coerce .Frac))]]]]
+ [[type.boolean type.boolean (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:coerce .Bit))]]
+ [type.byte type.long (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
+ [type.short type.long (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
+ [type.int type.long (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
+ [type.long type.long (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
+ [type.float type.double (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]
+ [type.double type.double (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]
+ [..$String ..$String (list) [(` (.: (.primitive (~ (code.text (..reflection ..$String)))))) (` (.:coerce .Text))]]
+ [(type.class box.boolean (list)) (type.class box.boolean (list)) (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:coerce .Bit))]]
+ [(type.class box.long (list)) (type.class box.long (list)) (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
+ [(type.class box.double (list)) (type.class box.double (list)) (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]]]
)
(def: (un-quote quoted)
@@ -1618,7 +1579,7 @@
(` ((~' ~) (~ quoted))))
(def: (jvm-invoke-inputs mode classes inputs)
- (-> Primitive-Mode (List Text) (List [Bit Code]) (List Code))
+ (-> Primitive-Mode (List (Type Value)) (List [Bit Code]) (List Code))
(|> inputs
(list@map (function (_ [maybe? input])
(if maybe?
@@ -1627,14 +1588,9 @@
(list.zip2 classes)
(list@map (auto-convert-input mode))))
-(def: (with-class-type class expression)
- (-> Text Code Code)
- (` (.: (.primitive (~ (code.text class))) (~ expression))))
-
-(def: (member-def-interop vars kind class [arg-function-inputs arg-classes arg-types] member method-prefix)
- (-> (List Variable) Class-Kind Class-Declaration [(List [Bit Code]) (List Text) (List Code)] Import-Member-Declaration Text (Meta (List Code)))
- (let [[full-name class-tvars] class
- all-params (list@map var->type-arg (member-type-vars class-tvars member))]
+(def: (member-def-interop vars kind class [arg-function-inputs input-jvm-types arg-types] member method-prefix)
+ (-> (List (Type Var)) Class-Kind (Type Declaration) [(List [Bit Code]) (List (Type Value)) (List Code)] Import-Member-Declaration Text (Meta (List Code)))
+ (let [[full-name class-tvars] (parser.declaration class)]
(case member
(#EnumDecl enum-members)
(do macro.monad
@@ -1644,7 +1600,7 @@
(` (primitive (~ (code.text full-name))))
_
- (let [=class-tvars (list@map var->type-arg class-tvars)]
+ (let [=class-tvars (list@map ..var$' class-tvars)]
(` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)]))))))
getter-interop (: (-> Text Code)
(function (_ name)
@@ -1656,15 +1612,18 @@
(#ConstructorDecl [commons _])
(do macro.monad
- [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
- jvm-interop (|> [(type.signature (type.class full-name (list)))
+ [#let [classT (type.class full-name (list))
+ def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
+ jvm-interop (|> [classT
(` ("jvm member invoke constructor"
+ [(~+ (list@map ..var$ class-tvars))]
(~ (code.text full-name))
- (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)
- (list.zip2 arg-classes)
+ [(~+ (list@map ..var$ (get@ #import-member-tvars commons)))]
+ (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) input-jvm-types arg-function-inputs)
+ (list.zip2 input-jvm-types)
(list@map ..decorate-input)))))]
(auto-convert-output (get@ #import-member-mode commons))
- (decorate-return-maybe member true full-name)
+ (decorate-return-maybe member true classT)
(decorate-return-try member)
(decorate-return-io member))]]
(wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs)))
@@ -1692,39 +1651,41 @@
["jvm member invoke interface"
(list g!obj)]
)))
- method-return-class (case (get@ #import-method-return method)
- #.None
- type.void-descriptor
-
- (#.Some return)
- (type.signature return))
- jvm-interop (|> [method-return-class
- (` ((~ (code.text jvm-op))
- (~ (code.text full-name))
- (~ (code.text import-method-name))
- (~+ (|> object-ast
- (list@map ..un-quote)
- (list.zip2 (list (type.signature (type.class full-name (list)))))
- (list@map (auto-convert-input (get@ #import-member-mode commons)))))
- (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)
- (list.zip2 arg-classes)
- (list@map ..decorate-input)))))]
- (auto-convert-output (get@ #import-member-mode commons))
- (decorate-return-maybe member false method-return-class)
- (decorate-return-try member)
- (decorate-return-io member))]]
+ method-return (get@ #import-method-return method)
+ callC (: Code
+ (` ((~ (code.text jvm-op))
+ [(~+ (list@map ..var$ class-tvars))]
+ (~ (code.text full-name))
+ (~ (code.text import-method-name))
+ [(~+ (list@map ..var$ (get@ #import-member-tvars commons)))]
+ (~+ (|> object-ast
+ (list@map ..un-quote)
+ (list.zip2 (list (type.class full-name (list))))
+ (list@map (auto-convert-input (get@ #import-member-mode commons)))))
+ (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) input-jvm-types arg-function-inputs)
+ (list.zip2 input-jvm-types)
+ (list@map ..decorate-input))))))
+ jvm-interop (: Code
+ (case (type.void? method-return)
+ (#.Left method-return)
+ (|> [method-return
+ callC]
+ (auto-convert-output (get@ #import-member-mode commons))
+ (decorate-return-maybe member false method-return)
+ (decorate-return-try member)
+ (decorate-return-io member))
+
+
+ (#.Right method-return)
+ (|> callC
+ (decorate-return-try member)
+ (decorate-return-io member))))]]
(wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs)) (~+ object-ast))
((~' wrap) (.list (.` (~ jvm-interop))))))))))
(#FieldAccessDecl fad)
(do macro.monad
[#let [(^open ".") fad
- base-gtype (value-type import-field-mode import-field-type)
- classC (declaration-type$ class)
- typeC (if import-field-maybe?
- (` (Maybe (~ base-gtype)))
- base-gtype)
- tvar-asts (list@map var->type-arg class-tvars)
getter-name (code.identifier ["" (format method-prefix member-separator import-field-name)])
setter-name (code.identifier ["" (format method-prefix member-separator import-field-name "!")])]
getter-interop (with-gensyms [g!obj]
@@ -1732,7 +1693,7 @@
(` ((~ getter-name)))
(` ((~ getter-name) (~ g!obj))))
getter-body (<| (auto-convert-output import-field-mode)
- [(type.signature import-field-type)
+ [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)))])
@@ -1750,7 +1711,7 @@
(let [setter-call (if import-field-static?
(` ((~ setter-name) (~ g!value)))
(` ((~ setter-name) (~ g!value) (~ g!obj))))
- setter-value (|> [(type.signature import-field-type) (un-quote g!value)]
+ setter-value (|> [import-field-type (un-quote g!value)]
(auto-convert-input import-field-mode))
setter-value (if import-field-maybe?
(` ((~! !!!) (~ setter-value)))
@@ -1768,48 +1729,50 @@
)))
(def: (member-import$ vars long-name? kind class member)
- (-> (List Variable) Bit Class-Kind Class-Declaration Import-Member-Declaration (Meta (List Code)))
- (let [[full-name _] class
- method-prefix (if long-name?
- full-name
- (short-class-name full-name))]
+ (-> (List (Type Var)) Bit Class-Kind (Type Declaration) Import-Member-Declaration (Meta (List Code)))
+ (let [[full-name _] (parser.declaration class)
+ method-prefix (..internal (if long-name?
+ full-name
+ (short-class-name full-name)))]
(do macro.monad
- [=args (member-def-arg-bindings vars class member)]
+ [=args (member-def-arg-bindings vars member)]
(member-def-interop vars kind class =args member method-prefix))))
(def: interface?
(All [a] (-> (primitive "java.lang.Class" [a]) Bit))
- (|>> ("jvm member invoke virtual" "java.lang.Class" "isInterface")
+ (|>> ("jvm member invoke virtual" [] "java.lang.Class" "isInterface" [])
"jvm object cast"
(: ..Boolean)
(:coerce Bit)))
(def: load-class
- (-> Text (Try (primitive "java.lang.Class" [Any])))
+ (-> External (Try (primitive "java.lang.Class" [Any])))
(|>> (:coerce (primitive "java.lang.String"))
["Ljava/lang/String;"]
- ("jvm member invoke static" "java.lang.Class" "forName")
- try))
+ ("jvm member invoke static" [] "java.lang.Class" "forName" [])
+ ..try))
-(def: (class-kind [class-name _])
- (-> Class-Declaration (Meta Class-Kind))
- (case (load-class class-name)
- (#.Right class)
- (:: macro.monad wrap (if (interface? class)
- #Interface
- #Class))
+(def: (class-kind declaration)
+ (-> (Type Declaration) (Meta Class-Kind))
+ (let [[class-name _] (parser.declaration declaration)]
+ (case (load-class class-name)
+ (#.Right class)
+ (:: macro.monad wrap (if (interface? class)
+ #Interface
+ #Class))
- (#.Left _)
- (macro.fail (format "Unknown class: " class-name))))
+ (#.Left _)
+ (macro.fail (format "Unknown class: " class-name)))))
(syntax: #export (import:
- {#let [imports (class-imports *compiler*)]}
+ {#let [imports (..context *compiler*)]}
{long-name? (<>.parses? (<c>.this! (' #long)))}
{declaration (declaration^ imports)}
- {#let [full-class-name (product.left declaration)
+ {#let [[full-class-name class-type-vars] (parser.declaration declaration)
+ full-class-name (..internal full-class-name)
imports (add-import [(short-class-name full-class-name) full-class-name]
- (class-imports *compiler*))]}
- {members (<>.some (import-member-decl^ imports (product.right declaration)))})
+ (..context *compiler*))]}
+ {members (<>.some (import-member-decl^ imports class-type-vars))})
{#.doc (doc "Allows importing JVM classes, and using them as types."
"Their methods, fields and enum options can also be imported."
"Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes."
@@ -1858,10 +1821,10 @@
)}
(do macro.monad
[kind (class-kind declaration)
- =members (monad.map @ (member-import$ (product.right declaration) long-name? kind declaration) members)]
+ =members (monad.map @ (member-import$ class-type-vars long-name? kind declaration) members)]
(wrap (list& (class-import$ long-name? declaration) (list@join =members)))))
-(syntax: #export (array {#let [imports (class-imports *compiler*)]}
+(syntax: #export (array {#let [imports (..context *compiler*)]}
{type (..type^ imports (list))}
size)
{#.doc (doc "Create an array of the given type, with the given size."
@@ -1871,44 +1834,116 @@
(.:coerce (.primitive (~ (code.text box.long))))
"jvm object cast"
"jvm conversion long-to-int"))]
- (case type
- (^template [<primitive> <array-op>]
- (^ (#jvm.Primitive <primitive>))
- (wrap (list (` (<array-op> (~ g!size))))))
- ([#jvm.Boolean "jvm array new boolean"]
- [#jvm.Byte "jvm array new byte"]
- [#jvm.Short "jvm array new short"]
- [#jvm.Int "jvm array new int"]
- [#jvm.Long "jvm array new long"]
- [#jvm.Float "jvm array new float"]
- [#jvm.Double "jvm array new double"]
- [#jvm.Char "jvm array new char"])
+ (`` (cond (~~ (template [<primitive> <array-op>]
+ [(:: type.equivalence = <primitive> type)
+ (wrap (list (` (<array-op> (~ g!size)))))]
+
+ [type.boolean "jvm array new boolean"]
+ [type.byte "jvm array new byte"]
+ [type.short "jvm array new short"]
+ [type.int "jvm array new int"]
+ [type.long "jvm array new long"]
+ [type.float "jvm array new float"]
+ [type.double "jvm array new double"]
+ [type.char "jvm array new char"]))
+ ## else
+ (wrap (list (` (: (~ (value-type #ManualPrM (type.array type)))
+ ("jvm array new object" (~ g!size))))))))))
+
+(exception: #export (cannot-convert-to-jvm-type {type .Type})
+ (exception.report
+ ["Lux Type" (%.type type)]))
+
+(with-expansions [<failure> (as-is (macro.fail (exception.construct ..cannot-convert-to-jvm-type [type])))]
+ (def: (lux-type->jvm-type type)
+ (-> .Type (Meta (Type Value)))
+ (if (lux-type@= Any type)
+ (:: macro.monad wrap $Object)
+ (case type
+ (#.Primitive name params)
+ (`` (cond (~~ (template [<type>]
+ [(text@= (..reflection <type>) name)
+ (case params
+ #.Nil
+ (:: macro.monad wrap <type>)
+
+ _
+ <failure>)]
+
+ [type.boolean]
+ [type.byte]
+ [type.short]
+ [type.int]
+ [type.long]
+ [type.float]
+ [type.double]
+ [type.char]))
+
+ (~~ (template [<type>]
+ [(text@= (..reflection (type.array <type>)) name)
+ (case params
+ #.Nil
+ (:: macro.monad wrap (type.array <type>))
+
+ _
+ <failure>)]
+
+ [type.boolean]
+ [type.byte]
+ [type.short]
+ [type.int]
+ [type.long]
+ [type.float]
+ [type.double]
+ [type.char]))
+
+ (text@= array.type-name name)
+ (case params
+ (#.Cons elementLT #.Nil)
+ (:: macro.monad map type.array
+ (lux-type->jvm-type elementLT))
+
+ _
+ <failure>)
+
+ (text.starts-with? descriptor.array-prefix name)
+ (case params
+ #.Nil
+ (let [[_ unprefixed] (maybe.assume (text.split-with descriptor.array-prefix name))]
+ (:: macro.monad map type.array
+ (lux-type->jvm-type (#.Primitive unprefixed (list)))))
+
+ _
+ <failure>)
+
+ ## else
+ (:: macro.monad map (type.class name)
+ (: (Meta (List (Type Parameter)))
+ (monad.map macro.monad
+ (function (_ paramLT)
+ (do macro.monad
+ [paramJT (lux-type->jvm-type paramLT)]
+ (case (parser.parameter? paramJT)
+ (#.Some paramJT)
+ (wrap paramJT)
- _
- (wrap (list (` (: (~ (value-type #ManualPrM (type.array 1 type)))
- ("jvm array new object" (~ g!size)))))))))
-
-(def: (type->class-name type)
- (-> .Type (Meta Text))
- (if (lux-type@= Any type)
- (:: macro.monad wrap "java.lang.Object")
- (case type
- (#.Primitive name params)
- (:: macro.monad wrap name)
-
- (#.Apply A F)
- (case (lux-type.apply (list A) F)
- #.None
- (macro.fail (format "Cannot apply type: " (%.type F) " to " (%.type A)))
+ #.None
+ <failure>)))
+ params)))))
- (#.Some type')
- (type->class-name type'))
-
- (#.Named _ type')
- (type->class-name type')
+ (#.Apply A F)
+ (case (lux-type.apply (list A) F)
+ #.None
+ <failure>
- _
- (macro.fail (format "Cannot convert to JVM type: " (%.type type))))))
+ (#.Some type')
+ (lux-type->jvm-type type'))
+
+ (#.Named _ type')
+ (lux-type->jvm-type type')
+
+ _
+ <failure>))))
(syntax: #export (array-length array)
{#.doc (doc "Gives the length of an array."
@@ -1917,17 +1952,24 @@
[_ (#.Identifier array-name)]
(do macro.monad
[array-type (macro.find-type array-name)
- array-jvm-type (type->class-name array-type)
- #let [g!extension (code.text (case array-jvm-type
- "[Z" "jvm array length boolean"
- "[B" "jvm array length byte"
- "[S" "jvm array length short"
- "[I" "jvm array length int"
- "[J" "jvm array length long"
- "[F" "jvm array length float"
- "[D" "jvm array length double"
- "[C" "jvm array length char"
- _ "jvm array length object"))]]
+ array-jvm-type (lux-type->jvm-type array-type)
+ #let [g!extension (code.text (`` (cond (~~ (template [<primitive> <extension>]
+ [(:: type.equivalence =
+ (type.array <primitive>)
+ array-jvm-type)
+ <extension>]
+
+ [type.boolean "jvm array length boolean"]
+ [type.byte "jvm array length byte"]
+ [type.short "jvm array length short"]
+ [type.int "jvm array length int"]
+ [type.long "jvm array length long"]
+ [type.float "jvm array length float"]
+ [type.double "jvm array length double"]
+ [type.char "jvm array length char"]))
+
+ ## else
+ "jvm array length object")))]]
(wrap (list (` (.|> ((~ g!extension) (~ array))
"jvm conversion int-to-long"
"jvm object cast"
@@ -1946,29 +1988,31 @@
[_ (#.Identifier array-name)]
(do macro.monad
[array-type (macro.find-type array-name)
- array-jvm-type (type->class-name array-type)
+ array-jvm-type (lux-type->jvm-type array-type)
#let [g!idx (` (.|> (~ idx)
(.: .Nat)
(.:coerce (.primitive (~ (code.text box.long))))
"jvm object cast"
"jvm conversion long-to-int"))]]
- (case array-jvm-type
- (^template [<type> <array-op> <box>]
- <type>
- (wrap (list (` (.|> (<array-op> (~ g!idx) (~ array))
- "jvm object cast"
- (.: (.primitive (~ (code.text <box>)))))))))
- (["[Z" "jvm array read boolean" box.boolean]
- ["[B" "jvm array read byte" box.byte]
- ["[S" "jvm array read short" box.short]
- ["[I" "jvm array read int" box.int]
- ["[J" "jvm array read long" box.long]
- ["[F" "jvm array read float" box.float]
- ["[D" "jvm array read double" box.double]
- ["[C" "jvm array read char" box.char])
-
- _
- (wrap (list (` ("jvm array read object" (~ g!idx) (~ array)))))))
+ (`` (cond (~~ (template [<primitive> <extension> <box>]
+ [(:: type.equivalence =
+ (type.array <primitive>)
+ array-jvm-type)
+ (wrap (list (` (.|> (<extension> (~ g!idx) (~ array))
+ "jvm object cast"
+ (.: (.primitive (~ (code.text <box>))))))))]
+
+ [type.boolean "jvm array read boolean" box.boolean]
+ [type.byte "jvm array read byte" box.byte]
+ [type.short "jvm array read short" box.short]
+ [type.int "jvm array read int" box.int]
+ [type.long "jvm array read long" box.long]
+ [type.float "jvm array read float" box.float]
+ [type.double "jvm array read double" box.double]
+ [type.char "jvm array read char" box.char]))
+
+ ## else
+ (wrap (list (` ("jvm array read object" (~ g!idx) (~ array))))))))
_
(with-gensyms [g!array]
@@ -1982,41 +2026,42 @@
[_ (#.Identifier array-name)]
(do macro.monad
[array-type (macro.find-type array-name)
- array-jvm-type (type->class-name array-type)
+ array-jvm-type (lux-type->jvm-type array-type)
#let [g!idx (` (.|> (~ idx)
(.: .Nat)
(.:coerce (.primitive (~ (code.text box.long))))
"jvm object cast"
"jvm conversion long-to-int"))]]
- (case array-jvm-type
- (^template [<type> <array-op> <box>]
- <type>
- (let [g!value (` (.|> (~ value)
- (.:coerce (.primitive (~ (code.text <box>))))
- "jvm object cast"))]
- (wrap (list (` (<array-op> (~ g!idx) (~ g!value) (~ array)))))))
- (["[Z" "jvm array write boolean" box.boolean]
- ["[B" "jvm array write byte" box.byte]
- ["[S" "jvm array write short" box.short]
- ["[I" "jvm array write int" box.int]
- ["[J" "jvm array write long" box.long]
- ["[F" "jvm array write float" box.float]
- ["[D" "jvm array write double" box.double]
- ["[C" "jvm array write char" box.char])
-
- _
- (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array)))))))
+ (`` (cond (~~ (template [<primitive> <extension> <box>]
+ [(:: type.equivalence =
+ (type.array <primitive>)
+ array-jvm-type)
+ (let [g!value (` (.|> (~ value)
+ (.:coerce (.primitive (~ (code.text <box>))))
+ "jvm object cast"))]
+ (wrap (list (` (<extension> (~ g!idx) (~ g!value) (~ array))))))]
+
+ [type.boolean "jvm array write boolean" box.boolean]
+ [type.byte "jvm array write byte" box.byte]
+ [type.short "jvm array write short" box.short]
+ [type.int "jvm array write int" box.int]
+ [type.long "jvm array write long" box.long]
+ [type.float "jvm array write float" box.float]
+ [type.double "jvm array write double" box.double]
+ [type.char "jvm array write char" box.char]))
+
+ ## else
+ (wrap (list (` ("jvm array write object" (~ g!idx) (~ value) (~ array))))))))
_
(with-gensyms [g!array]
(wrap (list (` (let [(~ g!array) (~ array)]
(..array-write (~ idx) (~ value) (~ g!array)))))))))
-(syntax: #export (class-for {#let [imports (class-imports *compiler*)]}
- {type (..type^ imports (list))})
+(syntax: #export (class-for {type (..type^ (..context *compiler*) (list))})
{#.doc (doc "Loads the class as a java.lang.Class object."
(class-for java/lang/String))}
- (wrap (list (` ("jvm object class" (~ (code.text (reflection.class type))))))))
+ (wrap (list (` ("jvm object class" (~ (code.text (..reflection type))))))))
(def: get-compiler
(Meta Lux)
@@ -2028,11 +2073,11 @@
(resolve "String")
=>
"java.lang.String")}
- (-> Text (Meta Text))
+ (-> External (Meta External))
(do macro.monad
[*compiler* get-compiler]
- (wrap (qualify (class-imports *compiler*) class))))
+ (wrap (qualify (..context *compiler*) class))))
-(syntax: #export (type {#let [imports (class-imports *compiler*)]}
+(syntax: #export (type {#let [imports (..context *compiler*)]}
{type (..type^ imports (list))})
(wrap (list (value-type #ManualPrM type))))
diff --git a/stdlib/source/lux/math.lux b/stdlib/source/lux/math.lux
index b030746a0..6f3448f7d 100644
--- a/stdlib/source/lux/math.lux
+++ b/stdlib/source/lux/math.lux
@@ -48,7 +48,7 @@
(-> Frac Frac)
(|>> !double
["D"]
- ("jvm member invoke static" "java.lang.Math" <method>)
+ ("jvm member invoke static" [] "java.lang.Math" <method> [])
!frac))]
[cos "cos"]
@@ -67,7 +67,7 @@
)
(def: #export (pow param subject)
(-> Frac Frac Frac)
- (|> ("jvm member invoke static" "java.lang.Math" "pow"
+ (|> ("jvm member invoke static" [] "java.lang.Math" "pow" []
["D" (!double subject)] ["D" (!double param)])
!frac)))
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index 890c459b6..e5190429b 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -16,7 +16,7 @@
[encoding
["#." name (#+ External)]]]
["." / #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
["#." signature (#+ Signature)]
["#." descriptor (#+ Descriptor)]
["#." reflection (#+ Reflection)]])
@@ -78,6 +78,20 @@
(/descriptor.class name)
(/reflection.class name)]))
+ (def: #export (declaration name variables)
+ (-> External (List (Type Var)) (Type Declaration))
+ (:abstraction
+ [(/signature.declaration name (list@map ..signature variables))
+ (/descriptor.declaration name)
+ (/reflection.declaration name)]))
+
+ (def: #export (as-class type)
+ (-> (Type Declaration) (Type Class))
+ (:abstraction
+ [(/signature.as-class (..signature type))
+ (/descriptor.as-class (..descriptor type))
+ (/reflection.as-class (..reflection type))]))
+
(def: #export wildcard
(Type Parameter)
(:abstraction
diff --git a/stdlib/source/lux/target/jvm/type/category.lux b/stdlib/source/lux/target/jvm/type/category.lux
index cbeaa53ef..f635d3e86 100644
--- a/stdlib/source/lux/target/jvm/type/category.lux
+++ b/stdlib/source/lux/target/jvm/type/category.lux
@@ -31,3 +31,5 @@
[[Object' Parameter'] Class]
[[Object'] Array]
)
+
+(abstract: #export Declaration {} Any)
diff --git a/stdlib/source/lux/target/jvm/type/descriptor.lux b/stdlib/source/lux/target/jvm/type/descriptor.lux
index 367f3338d..53d7eb1b8 100644
--- a/stdlib/source/lux/target/jvm/type/descriptor.lux
+++ b/stdlib/source/lux/target/jvm/type/descriptor.lux
@@ -13,7 +13,7 @@
[type
abstract]]
["." // #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
["/#" // #_
[encoding
["#." name (#+ Internal External)]]]])
@@ -53,6 +53,14 @@
(text.enclose [..class-prefix ..class-suffix])
:abstraction))
+ (def: #export (declaration name)
+ (-> External (Descriptor Declaration))
+ (:transmutation (..class name)))
+
+ (def: #export as-class
+ (-> (Descriptor Declaration) (Descriptor Class))
+ (|>> :transmutation))
+
(template [<name> <category>]
[(def: #export <name>
(Descriptor <category>)
diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux
index 2ed9b89c5..99f4a57ee 100644
--- a/stdlib/source/lux/target/jvm/type/parser.lux
+++ b/stdlib/source/lux/target/jvm/type/parser.lux
@@ -14,7 +14,7 @@
[collection
["." list]]]]
["." // (#+ Type)
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
["#." signature (#+ Signature)]
["#." descriptor (#+ Descriptor)]
["#." reflection (#+ Reflection)]
@@ -90,7 +90,7 @@
(<>@map //.var ..var'))
(def: #export var?
- (-> (Type Parameter) (Maybe Text))
+ (-> (Type Value) (Maybe Text))
(|>> //.signature
//signature.signature
(<t>.run ..var')
@@ -232,3 +232,18 @@
[parameter? (Type Parameter) ..parameter]
[object? (Type Object) ..object]
)
+
+(def: #export declaration
+ (-> (Type Declaration) [External (List (Type Var))])
+ (let [declaration' (: (Parser [External (List (Type Var))])
+ (|> (<>.and ..class-name
+ (|> (<>.some ..var)
+ (<>.after (<t>.this //signature.parameters-start))
+ (<>.before (<t>.this //signature.parameters-end))
+ (<>.default (list))))
+ (<>.after (<t>.this //descriptor.class-prefix))
+ (<>.before (<t>.this //descriptor.class-suffix))))]
+ (|>> //.signature
+ //signature.signature
+ (<t>.run declaration')
+ try.assume)))
diff --git a/stdlib/source/lux/target/jvm/type/reflection.lux b/stdlib/source/lux/target/jvm/type/reflection.lux
index ffc26fb8b..1d6162838 100644
--- a/stdlib/source/lux/target/jvm/type/reflection.lux
+++ b/stdlib/source/lux/target/jvm/type/reflection.lux
@@ -1,12 +1,14 @@
(.module:
[lux (#- int char)
+ [abstract
+ [equivalence (#+ Equivalence)]]
[data
- [text
+ ["." text ("#@." equivalence)
["%" format (#+ format)]]]
[type
abstract]]
["." // #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
["#." descriptor]
[//
[encoding
@@ -21,6 +23,12 @@
(-> (Reflection Any) Text)
(|>> :representation))
+ (structure: #export equivalence
+ (All [category] (Equivalence (Reflection category)))
+
+ (def: (= parameter subject)
+ (text@= (:representation parameter) (:representation subject))))
+
(template [<category> <name> <reflection>]
[(def: #export <name>
(Reflection <category>)
@@ -41,11 +49,41 @@
(-> External (Reflection Class))
(|>> :abstraction))
- (def: #export array
+ (def: #export (declaration name)
+ (-> External (Reflection Declaration))
+ (:transmutation (..class name)))
+
+ (def: #export as-class
+ (-> (Reflection Declaration) (Reflection Class))
+ (|>> :transmutation))
+
+ (def: #export (array element)
(-> (Reflection Value) (Reflection Array))
- (|>> :representation
- (format //descriptor.array-prefix)
- :abstraction))
+ (let [element' (:representation element)
+ elementR (`` (cond (text.starts-with? //descriptor.array-prefix element')
+ element'
+
+ (~~ (template [<primitive> <descriptor>]
+ [(:: ..equivalence = <primitive> element)
+ (//descriptor.descriptor <descriptor>)]
+
+ [..boolean //descriptor.boolean]
+ [..byte //descriptor.byte]
+ [..short //descriptor.short]
+ [..int //descriptor.int]
+ [..long //descriptor.long]
+ [..float //descriptor.float]
+ [..double //descriptor.double]
+ [..char //descriptor.char]))
+
+ (|> element'
+ //descriptor.class
+ //descriptor.descriptor
+ (text.replace-all //name.internal-separator
+ //name.external-separator))))]
+ (|> elementR
+ (format //descriptor.array-prefix)
+ :abstraction)))
(template [<name> <category>]
[(def: #export <name>
diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux
index 5a2256417..b88d3f610 100644
--- a/stdlib/source/lux/target/jvm/type/signature.lux
+++ b/stdlib/source/lux/target/jvm/type/signature.lux
@@ -11,7 +11,7 @@
[type
abstract]]
["." // #_
- [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
+ [category (#+ Void Value Return Method Primitive Object Class Array Var Parameter Declaration)]
["#." descriptor]
["/#" // #_
[encoding
@@ -91,6 +91,14 @@
..parameters-end))
//descriptor.class-suffix)))
+ (def: #export (declaration name variables)
+ (-> External (List (Signature Var)) (Signature Declaration))
+ (:transmutation (..class name variables)))
+
+ (def: #export as-class
+ (-> (Signature Declaration) (Signature Class))
+ (|>> :transmutation))
+
(def: #export arguments-start "(")
(def: #export arguments-end ")")
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 1d5b1218d..769646ad0 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -114,7 +114,7 @@
)
(template [<name>]
- [(exception: #export (<name> {class Text})
+ [(exception: #export (<name> {class External})
(exception.report
["Class/type" (%.text class)]))]
@@ -123,13 +123,13 @@
[primitives-are-not-objects]
)
-(exception: #export (cannot-set-a-final-field {field Text} {class Text})
+(exception: #export (cannot-set-a-final-field {field Text} {class External})
(exception.report
["Field" (%.text field)]
["Class" (%.text class)]))
(template [<name>]
- [(exception: #export (<name> {class Text}
+ [(exception: #export (<name> {class External}
{method Text}
{inputsJT (List (Type Value))}
{hints (List Method-Signature)})
@@ -240,7 +240,7 @@
)))
(def: #export boxes
- (Dictionary Text [Text (Type Primitive)])
+ (Dictionary External [External (Type Primitive)])
(|> (list [(reflection.reflection reflection.boolean) [box.boolean jvm.boolean]]
[(reflection.reflection reflection.byte) [box.byte jvm.byte]]
[(reflection.reflection reflection.short) [box.short jvm.short]]
@@ -387,21 +387,18 @@
(/////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)
+ (`` (cond (or (~~ (template [<type>]
+ [(text@= (..reflection <type>) name)]
+
+ [jvm.boolean]
+ [jvm.byte]
+ [jvm.short]
+ [jvm.int]
+ [jvm.long]
+ [jvm.float]
+ [jvm.double]
+ [jvm.char]))
+ (text.starts-with? descriptor.array-prefix name))
(/////analysis.throw ..non-parameter objectT)
## else
@@ -437,22 +434,36 @@
(-> .Type (Operation (Type Value)))
(case objectT
(#.Primitive name #.Nil)
- (`` (cond (~~ (template [<reflection> <type>]
- [(text@= (reflection.reflection <reflection>)
- name)
+ (`` (cond (~~ (template [<type>]
+ [(text@= (..reflection <type>) 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]))
+ [jvm.boolean]
+ [jvm.byte]
+ [jvm.short]
+ [jvm.int]
+ [jvm.long]
+ [jvm.float]
+ [jvm.double]
+ [jvm.char]))
+
+ (~~ (template [<type>]
+ [(text@= (..reflection (jvm.array <type>)) name)
+ (////@wrap (jvm.array <type>))]
+
+ [jvm.boolean]
+ [jvm.byte]
+ [jvm.short]
+ [jvm.int]
+ [jvm.long]
+ [jvm.float]
+ [jvm.double]
+ [jvm.char]))
(text.starts-with? descriptor.array-prefix name)
- (////.lift (<t>.run jvm-parser.value name))
+ (let [[_ unprefixed] (maybe.assume (text.split-with descriptor.array-prefix name))]
+ (:: ////.monad map jvm.array
+ (check-jvm (#.Primitive unprefixed (list)))))
## else
(////@wrap (jvm.class name (list)))))
@@ -800,7 +811,7 @@
(////.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])))
+ (-> External .Type External (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit])))
(do ////.monad
[from-class (////.lift (reflection!.load from-name))
mapping (////.lift (reflection!.correspond from-class fromT))]
@@ -1012,8 +1023,8 @@
#Special
#Interface)
-(def: (check-method class method-name method-style inputsJT method)
- (-> (java/lang/Class java/lang/Object) Text Method-Style (List (Type Value)) java/lang/reflect/Method (Operation Bit))
+(def: (check-method aliasing class method-name method-style inputsJT method)
+ (-> Aliasing (java/lang/Class java/lang/Object) Text Method-Style (List (Type Value)) java/lang/reflect/Method (Operation Bit))
(do ////.monad
[parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method)
array.to-list
@@ -1027,20 +1038,29 @@
(java/lang/reflect/Modifier::isStatic modifiers)
_
- #1)
+ true)
special-matches? (case method-style
#Special
(not (or (java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class))
(java/lang/reflect/Modifier::isAbstract modifiers)))
_
- #1)
+ true)
arity-matches? (n.= (list.size inputsJT) (list.size parameters))
inputs-match? (list@fold (function (_ [expectedJC actualJC] prev)
(and prev
- (jvm@= expectedJC actualJC)))
- #1
- (list.zip2 inputsJT parameters))]]
+ (jvm@= expectedJC (: (Type Value)
+ (case (jvm-parser.var? actualJC)
+ (#.Some name)
+ (|> aliasing
+ (dictionary.get name)
+ (maybe.default name)
+ jvm.var)
+
+ #.None
+ actualJC)))))
+ true
+ (list.zip2 parameters inputsJT))]]
(wrap (and correct-class?
correct-method?
static-matches?
@@ -1048,8 +1068,8 @@
arity-matches?
inputs-match?))))
-(def: (check-constructor class inputsJT constructor)
- (-> (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit))
+(def: (check-constructor aliasing class inputsJT constructor)
+ (-> Aliasing (java/lang/Class java/lang/Object) (List (Type Value)) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit))
(do ////.monad
[parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
array.to-list
@@ -1059,9 +1079,18 @@
(n.= (list.size inputsJT) (list.size parameters))
(list@fold (function (_ [expectedJC actualJC] prev)
(and prev
- (jvm@= expectedJC actualJC)))
- #1
- (list.zip2 inputsJT parameters))))))
+ (jvm@= expectedJC (: (Type Value)
+ (case (jvm-parser.var? actualJC)
+ (#.Some name)
+ (|> aliasing
+ (dictionary.get name)
+ (maybe.default name)
+ jvm.var)
+
+ #.None
+ actualJC)))))
+ true
+ (list.zip2 parameters inputsJT))))))
(def: idx-to-parameter
(-> Nat .Type)
@@ -1168,10 +1197,29 @@
[hint! #Hint]
)
-(def: (method-candidate class-name method-name method-style inputsJT)
- (-> Text Text Method-Style (List (Type Value)) (Operation Method-Signature))
+(template [<name> <type> <method>]
+ [(def: <name>
+ (-> <type> (List (Type Var)))
+ (|>> <method>
+ array.to-list
+ (list@map (|>> java/lang/reflect/TypeVariable::getName jvm.var))))]
+
+ [class-type-variables (java/lang/Class java/lang/Object) java/lang/Class::getTypeParameters]
+ [constructor-type-variables (java/lang/reflect/Constructor java/lang/Object) java/lang/reflect/Constructor::getTypeParameters]
+ [method-type-variables java/lang/reflect/Method java/lang/reflect/Method::getTypeParameters]
+ )
+
+(def: (aliasing expected actual)
+ (-> (List (Type Var)) (List (Type Var)) Aliasing)
+ (|> (list.zip2 (list@map jvm-parser.name actual)
+ (list@map jvm-parser.name expected))
+ (dictionary.from-list text.hash)))
+
+(def: (method-candidate actual-class-tvars class-name actual-method-tvars method-name method-style inputsJT)
+ (-> (List (Type Var)) External (List (Type Var)) Text Method-Style (List (Type Value)) (Operation Method-Signature))
(do ////.monad
[class (////.lift (reflection!.load class-name))
+ #let [expected-class-tvars (class-type-variables class)]
candidates (|> class
java/lang/Class::getDeclaredMethods
array.to-list
@@ -1179,7 +1227,10 @@
(monad.map @ (: (-> java/lang/reflect/Method (Operation Evaluation))
(function (_ method)
(do @
- [passes? (check-method class method-name method-style inputsJT method)]
+ [#let [expected-method-tvars (method-type-variables method)
+ aliasing (dictionary.merge (..aliasing expected-class-tvars actual-class-tvars)
+ (..aliasing expected-method-tvars actual-method-tvars))]
+ passes? (check-method aliasing class method-name method-style inputsJT method)]
(:: @ map (if passes?
(|>> #Pass)
(|>> #Hint))
@@ -1196,16 +1247,20 @@
(def: constructor-method "<init>")
-(def: (constructor-candidate class-name inputsJT)
- (-> Text (List (Type Value)) (Operation Method-Signature))
+(def: (constructor-candidate actual-class-tvars class-name actual-method-tvars inputsJT)
+ (-> (List (Type Var)) External (List (Type Var)) (List (Type Value)) (Operation Method-Signature))
(do ////.monad
[class (////.lift (reflection!.load class-name))
+ #let [expected-class-tvars (class-type-variables class)]
candidates (|> class
java/lang/Class::getConstructors
array.to-list
(monad.map @ (function (_ constructor)
(do @
- [passes? (check-constructor class inputsJT constructor)]
+ [#let [expected-method-tvars (constructor-type-variables constructor)
+ aliasing (dictionary.merge (..aliasing expected-class-tvars actual-class-tvars)
+ (..aliasing expected-method-tvars actual-method-tvars))]
+ passes? (check-constructor aliasing class inputsJT constructor)]
(:: @ map
(if passes? (|>> #Pass) (|>> #Hint))
(constructor-signature constructor))))))]
@@ -1241,14 +1296,16 @@
(list@map (function (_ [type value])
(/////analysis.tuple (list type value))))))
+(def: type-vars (<c>.tuple (<>.some ..var)))
+
(def: invoke::static
Handler
(..custom
- [($_ <>.and ..member (<>.some ..input))
- (function (_ extension-name analyse [[class method] argsTC])
+ [($_ <>.and ..type-vars ..member ..type-vars (<>.some ..input))
+ (function (_ extension-name analyse [class-tvars [class method] method-tvars argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
- [methodT exceptionsT] (method-candidate class method #Static argsT)
+ [methodT exceptionsT] (method-candidate class-tvars class method-tvars method #Static argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))
outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
@@ -1259,11 +1316,11 @@
(def: invoke::virtual
Handler
(..custom
- [($_ <>.and ..member <c>.any (<>.some ..input))
- (function (_ extension-name analyse [[class method] objectC argsTC])
+ [($_ <>.and ..type-vars ..member ..type-vars <c>.any (<>.some ..input))
+ (function (_ extension-name analyse [class-tvars [class method] method-tvars objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
- [methodT exceptionsT] (method-candidate class method #Virtual argsT)
+ [methodT exceptionsT] (method-candidate class-tvars class method-tvars method #Virtual argsT)
[outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
#let [[objectA argsA] (case allA
(#.Cons objectA argsA)
@@ -1281,11 +1338,11 @@
(def: invoke::special
Handler
(..custom
- [($_ <>.and ..member <c>.any (<>.some ..input))
- (function (_ extension-name analyse [[class method] objectC argsTC])
+ [($_ <>.and ..type-vars ..member ..type-vars <c>.any (<>.some ..input))
+ (function (_ extension-name analyse [class-tvars [class method] method-tvars objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
- [methodT exceptionsT] (method-candidate class method #Special argsT)
+ [methodT exceptionsT] (method-candidate class-tvars class method-tvars method #Special argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
@@ -1296,14 +1353,14 @@
(def: invoke::interface
Handler
(..custom
- [($_ <>.and ..member <c>.any (<>.some ..input))
- (function (_ extension-name analyse [[class-name method] objectC argsTC])
+ [($_ <>.and ..type-vars ..member ..type-vars <c>.any (<>.some ..input))
+ (function (_ extension-name analyse [class-tvars [class-name method] method-tvars objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
class (////.lift (reflection!.load class-name))
_ (////.assert non-interface class-name
(java/lang/reflect/Modifier::isInterface (java/lang/Class::getModifiers class)))
- [methodT exceptionsT] (method-candidate class-name method #Interface argsT)
+ [methodT exceptionsT] (method-candidate class-tvars class-name method-tvars method #Interface argsT)
[outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
#let [[objectA argsA] (case allA
(#.Cons objectA argsA)
@@ -1321,11 +1378,11 @@
(def: invoke::constructor
(..custom
- [($_ <>.and <c>.text (<>.some ..input))
- (function (_ extension-name analyse [class argsTC])
+ [($_ <>.and ..type-vars <c>.text ..type-vars (<>.some ..input))
+ (function (_ extension-name analyse [class-tvars class method-tvars argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
- [methodT exceptionsT] (constructor-candidate class argsT)
+ [methodT exceptionsT] (constructor-candidate class-tvars class method-tvars argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))]
(wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
(decorate-inputs argsT argsA))))))]))