aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorEduardo Julian2019-09-08 21:17:40 -0400
committerEduardo Julian2019-09-08 21:17:40 -0400
commitfb7a90d4c56d5e4e726f1e83dc951fa46d36ffdb (patch)
tree31767c55747bdb92ab88400441cbc2d143b0552f
parent0e2121dbec4f61dc1d9404deb9dd2b3f401ba4df (diff)
Some fixes.
Diffstat
-rw-r--r--new-luxc/source/luxc/lang/host/jvm/inst.lux12
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux191
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/runtime.lux4
-rw-r--r--stdlib/source/lux/host.jvm.lux1126
-rw-r--r--stdlib/source/lux/target/jvm/encoding/name.lux11
-rw-r--r--stdlib/source/lux/target/jvm/type.lux9
-rw-r--r--stdlib/source/lux/target/jvm/type/alias.lux6
-rw-r--r--stdlib/source/lux/target/jvm/type/lux.lux6
-rw-r--r--stdlib/source/lux/target/jvm/type/parser.lux49
-rw-r--r--stdlib/source/lux/target/jvm/type/signature.lux11
-rw-r--r--stdlib/source/lux/tool/compiler/analysis.lux6
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux290
12 files changed, 904 insertions, 817 deletions
diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux
index 4c9346d64..d5d7cb1fb 100644
--- a/new-luxc/source/luxc/lang/host/jvm/inst.lux
+++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux
@@ -374,14 +374,14 @@
(do-to visitor
(org/objectweb/asm/MethodVisitor::visitLabel @label))))
-(def: #export (array type)
+(def: #export (array elementT)
(-> (Type Value) Inst)
- (case (type.primitive? type)
- (#.Left object)
- (ANEWARRAY object)
+ (case (type.primitive? elementT)
+ (#.Left elementT)
+ (ANEWARRAY elementT)
- (#.Right primitive)
- (NEWARRAY primitive)))
+ (#.Right elementT)
+ (NEWARRAY elementT)))
(template [<name> <boolean> <byte> <short> <int> <long> <float> <double> <char>]
[(def: (<name> type)
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 b01056479..ca6e31bfd 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -55,6 +55,38 @@
["#." reference]
["#." function]]])
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<t>.embed <parser> <s>.text))]
+
+ [var Var parser.var]
+ [class Class parser.class]
+ [object Object parser.object]
+ [value Value parser.value]
+ [return Return parser.return]
+ )
+
+(exception: #export (not-an-object-array {arrayJT (Type Array)})
+ (exception.report
+ ["JVM Type" (|> arrayJT type.signature signature.signature)]))
+
+(def: #export object-array
+ (Parser (Type Object))
+ (do <>.monad
+ [arrayJT (<t>.embed parser.array <s>.text)]
+ (case (parser.array? arrayJT)
+ (#.Some elementJT)
+ (case (parser.object? elementJT)
+ (#.Some elementJT)
+ (wrap elementJT)
+
+ #.None
+ (<>.fail (exception.construct ..not-an-object-array arrayJT)))
+
+ #.None
+ (undefined))))
+
(template [<name> <inst>]
[(def: <name>
Inst
@@ -296,27 +328,6 @@
(bundle.install "<" (binary char::<))
)))
-(def: (array-java-type nesting elem-class)
- (-> Nat Text (Type Object))
- (type.array (case nesting
- 0 (undefined)
- 1 (`` (cond (~~ (template [<type>]
- [(text@= (reflection.reflection (type.reflection <type>))
- elem-class)
- <type>]
-
- [type.boolean]
- [type.byte]
- [type.short]
- [type.int]
- [type.long]
- [type.float]
- [type.double]
- [type.char]))
- ## else
- (type.class elem-class (list))))
- _ (array-java-type (dec nesting) elem-class))))
-
(def: (primitive-array-length-handler jvm-primitive)
(-> (Type Primitive) Handler)
(..custom
@@ -328,20 +339,16 @@
(_.CHECKCAST (type.array jvm-primitive))
_.ARRAYLENGTH))))]))
-(def: (array::length::object extension-name generate inputs)
+(def: array::length::object
Handler
- (case inputs
- (^ (list (synthesis.i64 nesting)
- (synthesis.text elem-class)
- arrayS))
- (do phase.monad
- [arrayI (generate arrayS)]
- (wrap (|>> arrayI
- (_.CHECKCAST (array-java-type (.nat nesting) elem-class))
- _.ARRAYLENGTH)))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+ (..custom
+ [($_ <>.and ..object-array <s>.any)
+ (function (_ extension-name generate [elementJT arrayS])
+ (do phase.monad
+ [arrayI (generate arrayS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ _.ARRAYLENGTH))))]))
(def: (new-primitive-array-handler jvm-primitive)
(-> (Type Primitive) Handler)
@@ -356,19 +363,15 @@
_
(phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
-(def: (array::new::object extension-name generate inputs)
+(def: array::new::object
Handler
- (case inputs
- (^ (list (synthesis.i64 nesting)
- (synthesis.text elem-class)
- lengthS))
- (do phase.monad
- [lengthI (generate lengthS)]
- (wrap (|>> lengthI
- (_.array (array-java-type (.nat nesting) elem-class)))))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+ (..custom
+ [($_ <>.and ..object <s>.any)
+ (function (_ extension-name generate [objectJT lengthS])
+ (do phase.monad
+ [lengthI (generate lengthS)]
+ (wrap (|>> lengthI
+ (_.ANEWARRAY objectJT)))))]))
(def: (read-primitive-array-handler jvm-primitive loadI)
(-> (Type Primitive) Inst Handler)
@@ -386,23 +389,18 @@
_
(phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
-(def: (array::read::object extension-name generate inputs)
+(def: array::read::object
Handler
- (case inputs
- (^ (list (synthesis.i64 nesting)
- (synthesis.text elem-class)
- idxS
- arrayS))
- (do phase.monad
- [arrayI (generate arrayS)
- idxI (generate idxS)]
- (wrap (|>> arrayI
- (_.CHECKCAST (array-java-type (.nat nesting) elem-class))
- idxI
- _.AALOAD)))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any)
+ (function (_ extension-name generate [elementJT idxS arrayS])
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ idxI
+ _.AALOAD))))]))
(def: (write-primitive-array-handler jvm-primitive storeI)
(-> (Type Primitive) Inst Handler)
@@ -423,27 +421,21 @@
_
(phase.throw extension.invalid-syntax [extension-name %synthesis inputs]))))
-(def: (array::write::object extension-name generate inputs)
+(def: array::write::object
Handler
- (case inputs
- (^ (list (synthesis.i64 nesting)
- (synthesis.text elem-class)
- idxS
- valueS
- arrayS))
- (do phase.monad
- [arrayI (generate arrayS)
- idxI (generate idxS)
- valueI (generate valueS)]
- (wrap (|>> arrayI
- (_.CHECKCAST (array-java-type (.nat nesting) elem-class))
- _.DUP
- idxI
- valueI
- _.AASTORE)))
-
- _
- (phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
+ (..custom
+ [($_ <>.and ..object-array <s>.any <s>.any <s>.any)
+ (function (_ extension-name generate [elementJT idxS valueS arrayS])
+ (do phase.monad
+ [arrayI (generate arrayS)
+ idxI (generate idxS)
+ valueI (generate valueS)]
+ (wrap (|>> arrayI
+ (_.CHECKCAST (type.array elementJT))
+ _.DUP
+ idxI
+ valueI
+ _.AASTORE))))]))
(def: array
Bundle
@@ -583,7 +575,7 @@
_
(phase.throw extension.invalid-syntax [extension-name %synthesis inputs])))
-(def: object
+(def: object-bundle
Bundle
(<| (bundle.prefix "object")
(|> (: Bundle bundle.empty)
@@ -608,7 +600,7 @@
[(reflection.reflection reflection.char) type.char])
(dictionary.from-list text.hash)))
-(def: static::get
+(def: get::static
Handler
(..custom
[($_ <>.and <s>.text <s>.text <s>.text)
@@ -622,7 +614,7 @@
#.None
(wrap (_.GETSTATIC (type.class class (list)) field (type.class unboxed (list)))))))]))
-(def: static::put
+(def: put::static
Handler
(..custom
[($_ <>.and <s>.text <s>.text <s>.text <s>.any)
@@ -642,7 +634,7 @@
(_.PUTSTATIC $class field $class)
(_.string synthesis.unit))))))]))
-(def: virtual::get
+(def: get::virtual
Handler
(..custom
[($_ <>.and <s>.text <s>.text <s>.text <s>.any)
@@ -660,7 +652,7 @@
(_.CHECKCAST $class)
getI))))]))
-(def: virtual::put
+(def: put::virtual
Handler
(..custom
[($_ <>.and <s>.text <s>.text <s>.text <s>.any <s>.any)
@@ -683,17 +675,6 @@
valueI
putI))))]))
-(template [<name> <category> <parser>]
- [(def: #export <name>
- (Parser (Type <category>))
- (<t>.embed <parser> <s>.text))]
-
- [var Var parser.var]
- [class Class parser.class]
- [value Value parser.value]
- [return Return parser.return]
- )
-
(type: Input (Typed Synthesis))
(def: input
@@ -774,14 +755,14 @@
Bundle
(<| (bundle.prefix "member")
(|> (: Bundle bundle.empty)
- (dictionary.merge (<| (bundle.prefix "static")
+ (dictionary.merge (<| (bundle.prefix "get")
(|> (: Bundle bundle.empty)
- (bundle.install "get" static::get)
- (bundle.install "put" static::put))))
- (dictionary.merge (<| (bundle.prefix "virtual")
+ (bundle.install "static" get::static)
+ (bundle.install "virtual" get::virtual))))
+ (dictionary.merge (<| (bundle.prefix "put")
(|> (: Bundle bundle.empty)
- (bundle.install "get" virtual::get)
- (bundle.install "put" virtual::put))))
+ (bundle.install "static" put::static)
+ (bundle.install "virtual" put::virtual))))
(dictionary.merge (<| (bundle.prefix "invoke")
(|> (: Bundle bundle.empty)
(bundle.install "static" invoke::static)
@@ -1051,7 +1032,7 @@
(dictionary.merge ..double)
(dictionary.merge ..char)
(dictionary.merge ..array)
- (dictionary.merge ..object)
+ (dictionary.merge ..object-bundle)
(dictionary.merge ..member)
(dictionary.merge ..bundle::class)
)))
diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
index 4297090b6..11f8870eb 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.lux
@@ -117,7 +117,7 @@
(|>> ($d.method #$.Public $.staticM "variant_make"
(type.method [(list $Tag $Flag $Value) //.$Variant (list)])
(|>> (_.int +3)
- (_.array //.$Variant)
+ (_.ANEWARRAY $Value)
store-tagI
store-flagI
store-valueI
@@ -174,7 +174,7 @@
_.ATHROW))
($d.method #$.Public $.staticM "pm_push" (type.method [(list $Stack $Value) $Stack (list)])
(|>> (_.int +2)
- (_.ANEWARRAY $Stack)
+ (_.ANEWARRAY $Value)
_.DUP
(_.int +1)
(_.ALOAD 0)
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index 1daa2ded1..69a156504 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -1,6 +1,6 @@
(.module:
[lux (#- Type type int char)
- ["." type ("#@." equivalence)]
+ ["lux-." type ("#@." equivalence)]
[abstract
["." monad (#+ Monad do)]
["." enum]]
@@ -8,8 +8,8 @@
["." function]
["." io]
["." try (#+ Try)]
- ["p" parser ("#@." monad)
- ["s" code (#+ Parser)]]]
+ ["<>" parser ("#@." monad)
+ ["<c>" code (#+ Parser)]]]
[data
["." maybe]
["." product]
@@ -18,7 +18,7 @@
["." text ("#@." equivalence monoid)
["%" format (#+ format)]]
[collection
- ["." array (#+ Array)]
+ ["." array]
["." list ("#@." monad fold monoid)]
["." dictionary (#+ Dictionary)]]]
["." macro (#+ with-gensyms)
@@ -26,15 +26,24 @@
["." code]
["." template]]
[target
- ["." jvm #_
- ["#" type (#+ Primitive Var Bound Class Generic Type Argument Return Typed)
+ [jvm
+ [encoding
+ ["." name (#+ External)]]
+ ["." type (#+ Type Argument Typed)
+ ["." category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
["." box]
- ["." reflection]]]]])
+ ["." signature]
+ ["." reflection]
+ ["." parser]]]]])
+
+(type: Variable Text)
+
+(def: signature (|>> type.signature signature.signature))
+(def: reflection (|>> type.reflection reflection.reflection))
(template [<name> <class>]
[(def: #export <name> .Type (#.Primitive <class> #.Nil))]
- ## Boxes
[Boolean box.boolean]
[Byte box.byte]
[Short box.short]
@@ -43,6 +52,10 @@
[Float box.float]
[Double box.double]
[Character box.char]
+ )
+
+(template [<name> <class>]
+ [(def: #export <name> .Type (#.Primitive (reflection.reflection <class>) #.Nil))]
## Primitives
[boolean reflection.boolean]
@@ -57,45 +70,33 @@
(def: (get-static-field class field)
(-> Text Text Code)
- (` ("jvm member static get"
+ (` ("jvm member get static"
(~ (code.text class))
(~ (code.text field)))))
(def: (get-virtual-field class field object)
(-> Text Text Code Code)
- (` ("jvm member virtual get"
+ (` ("jvm member get virtual"
(~ (code.text class))
(~ (code.text field))
(~ object))))
(def: boxes
- (Dictionary Text Text)
- (|> (list [jvm.boolean-descriptor box.boolean]
- [jvm.byte-descriptor box.byte]
- [jvm.short-descriptor box.short]
- [jvm.int-descriptor box.int]
- [jvm.long-descriptor box.long]
- [jvm.float-descriptor box.float]
- [jvm.double-descriptor box.double]
- [jvm.char-descriptor box.char])
- (dictionary.from-list text.hash)))
-
-(def: reflections
- (Dictionary Text Text)
- (|> (list [jvm.boolean-descriptor reflection.boolean]
- [jvm.byte-descriptor reflection.byte]
- [jvm.short-descriptor reflection.short]
- [jvm.int-descriptor reflection.int]
- [jvm.long-descriptor reflection.long]
- [jvm.float-descriptor reflection.float]
- [jvm.double-descriptor reflection.double]
- [jvm.char-descriptor reflection.char])
- (dictionary.from-list text.hash)))
+ (Dictionary (Type Value) Text)
+ (|> (list [type.boolean box.boolean]
+ [type.byte box.byte]
+ [type.short box.short]
+ [type.int box.int]
+ [type.long box.long]
+ [type.float box.float]
+ [type.double box.double]
+ [type.char box.char])
+ (dictionary.from-list type.hash)))
(template [<name> <pre> <post>]
[(def: (<name> unboxed boxed raw)
- (-> Text Text Code Code)
- (let [unboxed (|> reflections (dictionary.get unboxed) (maybe.default unboxed))]
+ (-> (Type Value) Text Code Code)
+ (let [unboxed (..reflection unboxed)]
(` (|> (~ raw)
(: (primitive (~ (code.text <pre>))))
"jvm object cast"
@@ -155,11 +156,11 @@
#ManualPrM
#AutoPrM)
-(type: PrivacyModifier
- #PublicPM
- #PrivatePM
- #ProtectedPM
- #DefaultPM)
+(type: Privacy
+ #PublicP
+ #PrivateP
+ #ProtectedP
+ #DefaultP)
(type: StateModifier
#VolatileSM
@@ -177,10 +178,10 @@
(type: Class-Declaration
{#class-name Text
- #class-params (List Var)})
+ #class-params (List (Type Var))})
(type: StackFrame (primitive "java/lang/StackTraceElement"))
-(type: StackTrace (Array StackFrame))
+(type: StackTrace (array.Array StackFrame))
(type: AnnotationParam
[Text Code])
@@ -191,7 +192,7 @@
(type: Member-Declaration
{#member-name Text
- #member-privacy PrivacyModifier
+ #member-privacy Privacy
#member-anns (List Annotation)})
(type: FieldDecl
@@ -199,14 +200,14 @@
(#VariableField StateModifier Type))
(type: MethodDecl
- {#method-tvars (List Var)
+ {#method-tvars (List Variable)
#method-inputs (List Type)
#method-output Return
#method-exs (List Class)})
(type: Method-Definition
(#ConstructorMethod [Bit
- (List Var)
+ (List Variable)
Text
(List Argument)
(List (Typed Code))
@@ -214,7 +215,7 @@
(List Class)])
(#VirtualMethod [Bit
Bit
- (List Var)
+ (List Variable)
Text
(List Argument)
Return
@@ -222,23 +223,23 @@
(List Class)])
(#OverridenMethod [Bit
Class-Declaration
- (List Var)
+ (List Variable)
Text
(List Argument)
Return
Code
(List Class)])
(#StaticMethod [Bit
- (List Var)
+ (List Variable)
(List Argument)
Return
Code
(List Class)])
- (#AbstractMethod [(List Var)
+ (#AbstractMethod [(List Variable)
(List Argument)
Return
(List Class)])
- (#NativeMethod [(List Var)
+ (#NativeMethod [(List Variable)
(List Argument)
Return
(List Class)]))
@@ -255,7 +256,7 @@
{#import-member-mode Primitive-Mode
#import-member-alias Text
#import-member-kind ImportMethodKind
- #import-member-tvars (List Var)
+ #import-member-tvars (List Variable)
#import-member-args (List [Bit Type])
#import-member-maybe? Bit
#import-member-try? Bit
@@ -285,92 +286,94 @@
(type: Class-Imports
(List [Text Text]))
-(def: binary-class-separator "/")
-(def: syntax-class-separator ".")
-
(def: (short-class-name name)
(-> Text Text)
- (case (list.reverse (text.split-all-with ..binary-class-separator name))
+ (case (list.reverse (text.split-all-with name.internal-separator name))
(#.Cons short-name _)
short-name
#.Nil
name))
-(def: sanitize
- (-> Text Text)
- (text.replace-all ..binary-class-separator ..syntax-class-separator))
-
-(def: (generic-type generic)
- (-> Generic Code)
- (case generic
- (#jvm.Var name)
- (code.identifier ["" name])
-
- (#jvm.Wildcard wilcard)
- (case wilcard
- (^or #.None (#.Some [#jvm.Lower _]))
- (` .Any)
-
- (#.Some [#jvm.Upper bound])
- (generic-type bound))
+(def: (primitive-type mode type)
+ (-> Primitive-Mode (Type Primitive) Code)
+ (case mode
+ #ManualPrM
+ (cond (:: type.equivalence = type.boolean type) (` ..Boolean)
+ (:: type.equivalence = type.byte type) (` ..Byte)
+ (:: type.equivalence = type.short type) (` ..Short)
+ (:: type.equivalence = type.int type) (` ..Integer)
+ (:: type.equivalence = type.long type) (` ..Long)
+ (:: type.equivalence = type.float type) (` ..Float)
+ (:: type.equivalence = type.double type) (` ..Double)
+ (:: type.equivalence = type.char type) (` ..Character)
+ ## else
+ (undefined))
- (#jvm.Class [name params])
- (` (.primitive (~ (code.text (sanitize name)))
- [(~+ (list@map generic-type params))]))))
+ #AutoPrM
+ (cond (:: type.equivalence = type.boolean type)
+ (` .Bit)
+
+ (or (:: type.equivalence = type.short type)
+ (:: type.equivalence = type.byte type)
+ (:: type.equivalence = type.int type)
+ (:: type.equivalence = type.long type))
+ (` .Int)
+
+ (or (:: type.equivalence = type.float type)
+ (:: type.equivalence = type.double type))
+ (` .Frac)
+
+ (:: type.equivalence = type.char type)
+ (` .Nat)
-(def: (jvm-type mode type)
- (-> Primitive-Mode Type Code)
- (case type
- (#jvm.Primitive primitive)
- (case mode
- #ManualPrM
- (case primitive
- #jvm.Boolean (` ..Boolean)
- #jvm.Byte (` ..Byte)
- #jvm.Short (` ..Short)
- #jvm.Int (` ..Integer)
- #jvm.Long (` ..Long)
- #jvm.Float (` ..Float)
- #jvm.Double (` ..Double)
- #jvm.Char (` ..Character))
-
- #AutoPrM
- (case primitive
- #jvm.Boolean (` .Bit)
- #jvm.Byte (` .Int)
- #jvm.Short (` .Int)
- #jvm.Int (` .Int)
- #jvm.Long (` .Int)
- #jvm.Float (` .Frac)
- #jvm.Double (` .Frac)
- #jvm.Char (` .Nat)))
-
- (#jvm.Generic generic)
- (generic-type generic)
-
- (#jvm.Array elementT)
- (case elementT
- (#jvm.Primitive primitive)
- (let [array-type-name (jvm.descriptor (jvm.array 1 (case primitive
- #jvm.Boolean jvm.boolean
- #jvm.Byte jvm.byte
- #jvm.Short jvm.short
- #jvm.Int jvm.int
- #jvm.Long jvm.long
- #jvm.Float jvm.float
- #jvm.Double jvm.double
- #jvm.Char jvm.char)))]
- (` (#.Primitive (~ (code.text array-type-name)) #.Nil)))
+ ## else
+ (undefined))))
+
+(def: (parameter-type type)
+ (-> (Type Parameter) Code)
+ (`` (<| (~~ (template [<when> <binding> <then>]
+ [(case (<when> type)
+ (#.Some <binding>)
+ <then>
+
+ #.None)]
+
+ [parser.var? name (code.identifier ["" name])]
+ [parser.wildcard? bound (` .Any)]
+ [parser.lower? bound (` .Any)]
+ [parser.upper? bound (parameter-type bound)]
+ [parser.class? [name parameters]
+ (` (.primitive (~ (code.text name))
+ [(~+ (list@map parameter-type parameters))]))]))
+ ## else
+ (undefined)
+ )))
- _
- (` (#.Primitive (~ (code.text array.type-name))
- (#.Cons (~ (jvm-type mode elementT)) #.Nil))))
- ))
+(def: (value-type mode type)
+ (-> Primitive-Mode (Type Value) Code)
+ (`` (<| (~~ (template [<when> <binding> <then>]
+ [(case (<when> type)
+ (#.Some <binding>)
+ <then>
+
+ #.None)]
+
+ [parser.parameter? type (parameter-type type)]
+ [parser.primitive? type (primitive-type mode type)]
+ [parser.array? elementT (case (parser.primitive? elementT)
+ (#.Some elementT)
+ (` (#.Primitive (~ (code.text (..reflection (type.array elementT)))) #.Nil))
+
+ #.None
+ (` (#.Primitive (~ (code.text array.type-name))
+ (#.Cons (~ (value-type mode elementT)) #.Nil))))]))
+ (undefined)
+ )))
(def: (declaration-type$ (^slots [#class-name #class-params]))
(-> Class-Declaration Code)
- (` (primitive (~ (code.text (sanitize class-name)))
+ (` (primitive (~ (code.text class-name))
[(~+ (list@map code.local-identifier class-params))])))
(def: empty-imports
@@ -418,24 +421,24 @@
(def: (make-get-const-parser class-name field-name)
(-> Text Text (Parser Code))
- (do p.monad
+ (do <>.monad
[#let [dotted-name (format "::" field-name)]
- _ (s.this! (code.identifier ["" dotted-name]))]
+ _ (<c>.this! (code.identifier ["" dotted-name]))]
(wrap (get-static-field class-name field-name))))
(def: (make-get-var-parser class-name field-name)
(-> Text Text (Parser Code))
- (do p.monad
+ (do <>.monad
[#let [dotted-name (format "::" field-name)]
- _ (s.this! (code.identifier ["" dotted-name]))]
+ _ (<c>.this! (code.identifier ["" dotted-name]))]
(wrap (get-virtual-field class-name field-name (' _jvm_this)))))
(def: (make-put-var-parser class-name field-name)
(-> Text Text (Parser Code))
- (do p.monad
+ (do <>.monad
[#let [dotted-name (format "::" field-name)]
[_ _ value] (: (Parser [Any Any Code])
- (s.form ($_ p.and (s.this! (' :=)) (s.this! (code.identifier ["" dotted-name])) s.any)))]
+ (<c>.form ($_ <>.and (<c>.this! (' :=)) (<c>.this! (code.identifier ["" dotted-name])) <c>.any)))]
(wrap (`' ((~ (code.text (format "jvm putfield" ":" class-name ":" field-name))) _jvm_this (~ value))))))
(def: (pre-walk-replace f input)
@@ -458,7 +461,7 @@
(def: (parser->replacer p ast)
(-> (Parser Code) (-> Code Code))
- (case (p.run p (list ast))
+ (case (<>.run p (list ast))
(#.Right [#.Nil ast'])
ast'
@@ -473,8 +476,8 @@
(make-get-const-parser class-name field-name)
(#VariableField _)
- (p.either (make-get-var-parser class-name field-name)
- (make-put-var-parser class-name field-name))))
+ (<>.either (make-get-var-parser class-name field-name)
+ (make-put-var-parser class-name field-name))))
(def: (decorate-input [class value])
(-> [Text Code] Code)
@@ -482,42 +485,39 @@
(def: (make-constructor-parser class-name arguments)
(-> Text (List Argument) (Parser Code))
- (do p.monad
+ (do <>.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)]]
+ (<c>.form (<>.after (<c>.this! (' ::new!))
+ (<c>.tuple (<>.exactly (list.size arguments) <c>.any)))))]
(wrap (` ("jvm member invoke constructor" (~ (code.text class-name))
(~+ (|> args
- (list.zip2 arguments')
+ (list.zip2 (list@map (|>> product.right ..signature) arguments))
(list@map ..decorate-input))))))))
(def: (make-static-method-parser class-name method-name arguments)
(-> Text Text (List Argument) (Parser Code))
- (do p.monad
+ (do <>.monad
[#let [dotted-name (format "::" method-name "!")]
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)]]
+ (<c>.form (<>.after (<c>.this! (code.identifier ["" dotted-name]))
+ (<c>.tuple (<>.exactly (list.size arguments) <c>.any)))))]
(wrap (` ("jvm member invoke static" (~ (code.text class-name)) (~ (code.text method-name))
(~+ (|> args
- (list.zip2 arguments')
+ (list.zip2 (list@map (|>> product.right ..signature) arguments))
(list@map ..decorate-input))))))))
(template [<name> <jvm-op>]
[(def: (<name> class-name method-name arguments)
(-> Text Text (List Argument) (Parser Code))
- (do p.monad
+ (do <>.monad
[#let [dotted-name (format "::" method-name "!")]
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)]]
+ (<c>.form (<>.after (<c>.this! (code.identifier ["" dotted-name]))
+ (<c>.tuple (<>.exactly (list.size arguments) <c>.any)))))]
(wrap (` (<jvm-op> (~ (code.text class-name)) (~ (code.text method-name))
(~' _jvm_this)
(~+ (|> args
- (list.zip2 arguments')
+ (list.zip2 (list@map (|>> product.right ..signature) arguments))
(list@map ..decorate-input))))))))]
[make-special-method-parser "jvm member invoke special"]
@@ -545,325 +545,355 @@
(def: (full-class-name^ imports)
(-> Class-Imports (Parser Text))
- (do p.monad
- [name s.local-identifier]
+ (do <>.monad
+ [name <c>.local-identifier]
(wrap (qualify imports name))))
(def: privacy-modifier^
- (Parser PrivacyModifier)
- (let [(^open ".") p.monad]
- ($_ p.or
- (s.this! (' #public))
- (s.this! (' #private))
- (s.this! (' #protected))
+ (Parser Privacy)
+ (let [(^open ".") <>.monad]
+ ($_ <>.or
+ (<c>.this! (' #public))
+ (<c>.this! (' #private))
+ (<c>.this! (' #protected))
(wrap []))))
(def: inheritance-modifier^
(Parser InheritanceModifier)
- (let [(^open ".") p.monad]
- ($_ p.or
- (s.this! (' #final))
- (s.this! (' #abstract))
+ (let [(^open ".") <>.monad]
+ ($_ <>.or
+ (<c>.this! (' #final))
+ (<c>.this! (' #abstract))
(wrap []))))
-(def: bound^
- (Parser Bound)
- (p.or (s.this! (' >))
- (s.this! (' <))))
-
(def: (assert-valid-class-name type-vars name)
- (-> (List Var) Text (Parser Any))
- (do p.monad
- [_ (p.assert "Names in class declarations cannot contain periods."
- (not (text.contains? ..syntax-class-separator name)))]
- (p.assert (format name " cannot be a type-var!")
- (not (list.member? text.equivalence type-vars name)))))
+ (-> (List Variable) Text (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)))))
(def: (valid-class-name imports type-vars)
- (-> Class-Imports (List Var) (Parser Text))
- (do p.monad
+ (-> Class-Imports (List Variable) (Parser Text))
+ (do <>.monad
[name (full-class-name^ imports)
_ (assert-valid-class-name type-vars name)]
(wrap name)))
-(def: (class^' generic^ imports type-vars)
- (-> (-> Class-Imports (List Var) (Parser Generic))
- (-> Class-Imports (List Var) (Parser Class)))
- ($_ p.either
- (p.and (valid-class-name imports type-vars)
- (p@wrap (list)))
- (s.form (p.and (full-class-name^ imports)
- (p.some (generic^ imports type-vars))))
- ))
+(def: (class^' parameter^ imports type-vars)
+ (-> (-> Class-Imports (List Variable) (Parser (Type Parameter)))
+ (-> Class-Imports (List Variable) (Parser (Type Class))))
+ (do <>.monad
+ [[name parameters] (: (Parser [External (List (Type Parameter))])
+ ($_ <>.either
+ (<>.and (valid-class-name imports type-vars)
+ (<>@wrap (list)))
+ (<c>.form (<>.and (full-class-name^ imports)
+ (<>.some (parameter^ imports type-vars))))))]
+ (wrap (type.class name parameters))))
+
+(def: (variable^ imports type-vars)
+ (-> Class-Imports (List Variable) (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))]
+ (wrap (type.var name))))
+
+(def: wildcard^
+ (Parser (Type Parameter))
+ (do <>.monad
+ [_ (<c>.this! (' ?))]
+ (wrap type.wildcard)))
+
+(template [<name> <comparison> <constructor>]
+ [(def: <name>
+ (-> (Parser (Type Class)) (Parser (Type Parameter)))
+ (|>> (<>.after (<c>.this! (' <comparison>)))
+ (<>.after ..wildcard^)
+ <c>.tuple
+ (:: <>.monad map <constructor>)))]
+
+ [upper^ < type.upper]
+ [lower^ > type.lower]
+ )
-(def: (generic^ imports type-vars)
- (-> Class-Imports (List Var) (Parser Generic))
- (p.rec
+(def: (parameter^ imports type-vars)
+ (-> Class-Imports (List Variable) (Parser (Type Parameter)))
+ (<>.rec
(function (_ recur^)
- ($_ p.or
- (do p.monad
- [name (full-class-name^ imports)
- _ (p.assert "Var name must ne one of the expected type-vars."
- (list.member? text.equivalence type-vars name))]
- (wrap name))
- (p.or (s.this! (' ?))
- (s.tuple (p.after (s.this! (' ?))
- (p.and ..bound^
- recur^))))
- (class^' generic^ imports type-vars)
- ))))
+ (let [class^ (..class^' parameter^ imports type-vars)]
+ ($_ <>.either
+ (..variable^ imports type-vars)
+ ..wildcard^
+ (upper^ class^)
+ (lower^ class^)
+ class^
+ )))))
+
+(def: (itself^ type)
+ (All [a] (-> (Type a) (Parser (Type a))))
+ (do <>.monad
+ [_ (<c>.identifier! ["" (..reflection type)])]
+ (wrap type)))
(def: primitive^
- (Parser Primitive)
- ($_ p.or
- (s.identifier! ["" reflection.boolean])
- (s.identifier! ["" reflection.byte])
- (s.identifier! ["" reflection.short])
- (s.identifier! ["" reflection.int])
- (s.identifier! ["" reflection.long])
- (s.identifier! ["" reflection.float])
- (s.identifier! ["" reflection.double])
- (s.identifier! ["" reflection.char])
+ (Parser (Type Primitive))
+ ($_ <>.either
+ (itself^ type.boolean)
+ (itself^ type.byte)
+ (itself^ type.short)
+ (itself^ type.int)
+ (itself^ type.long)
+ (itself^ type.float)
+ (itself^ type.double)
+ (itself^ type.char)
))
+(def: array^
+ (-> (Parser (Type Value)) (Parser (Type Array)))
+ (|>> <c>.tuple
+ (:: <>.monad map type.array)))
+
(def: (type^ imports type-vars)
- (-> Class-Imports (List Var) (Parser Type))
- (p.rec
- (function (_ recur^)
- ($_ p.or
+ (-> Class-Imports (List Variable) (Parser (Type Value)))
+ (<>.rec
+ (function (_ type^)
+ ($_ <>.either
..primitive^
- (generic^ imports type-vars)
- (s.tuple recur^)
+ (..parameter^ imports type-vars)
+ (..array^ type^)
))))
(def: (return^ imports type-vars)
- (-> Class-Imports (List Var) (Parser Return))
- (p.or (s.identifier! ["" "void"])
- (..type^ imports type-vars)))
+ (-> Class-Imports (List Variable) (Parser (Type Return)))
+ (<>.either (itself^ type.void)
+ (..type^ imports type-vars)))
(def: var^
- (Parser Var)
- s.local-identifier)
+ (Parser (Type Var))
+ (:: <>.monad map type.var <c>.local-identifier))
(def: vars^
- (Parser (List Var))
- (s.tuple (p.some var^)))
+ (Parser (List (Type Var)))
+ (<c>.tuple (<>.some var^)))
(def: (declaration^ imports)
(-> Class-Imports (Parser Class-Declaration))
- (p.either (p.and (valid-class-name imports (list))
- (p@wrap (list)))
- (s.form (p.and (valid-class-name imports (list))
- (p.some var^)))
- ))
+ (<>.either (<>.and (valid-class-name imports (list))
+ (<>@wrap (list)))
+ (<c>.form (<>.and (valid-class-name imports (list))
+ (<>.some var^)))
+ ))
(def: (class^ imports type-vars)
- (-> Class-Imports (List Var) (Parser Class))
- (class^' generic^ imports type-vars))
+ (-> Class-Imports (List Variable) (Parser Class))
+ (class^' parameter^ imports type-vars))
(def: annotation-params^
(Parser (List AnnotationParam))
- (s.record (p.some (p.and s.local-tag s.any))))
+ (<c>.record (<>.some (<>.and <c>.local-tag <c>.any))))
(def: (annotation^ imports)
(-> Class-Imports (Parser Annotation))
- (p.either (do p.monad
- [ann-name (full-class-name^ imports)]
- (wrap [ann-name (list)]))
- (s.form (p.and (full-class-name^ imports)
- annotation-params^))))
+ (<>.either (do <>.monad
+ [ann-name (full-class-name^ imports)]
+ (wrap [ann-name (list)]))
+ (<c>.form (<>.and (full-class-name^ imports)
+ annotation-params^))))
(def: (annotations^' imports)
(-> Class-Imports (Parser (List Annotation)))
- (do p.monad
- [_ (s.this! (' #ann))]
- (s.tuple (p.some (annotation^ imports)))))
+ (do <>.monad
+ [_ (<c>.this! (' #ann))]
+ (<c>.tuple (<>.some (annotation^ imports)))))
(def: (annotations^ imports)
(-> Class-Imports (Parser (List Annotation)))
- (do p.monad
- [anns?? (p.maybe (annotations^' imports))]
+ (do <>.monad
+ [anns?? (<>.maybe (annotations^' imports))]
(wrap (maybe.default (list) anns??))))
(def: (throws-decl^ imports type-vars)
- (-> Class-Imports (List Var) (Parser (List Class)))
- (<| (p.default (list))
- (do p.monad
- [_ (s.this! (' #throws))]
- (s.tuple (p.some (..class^ imports type-vars))))))
+ (-> Class-Imports (List Variable) (Parser (List Class)))
+ (<| (<>.default (list))
+ (do <>.monad
+ [_ (<c>.this! (' #throws))]
+ (<c>.tuple (<>.some (..class^ imports type-vars))))))
(def: (method-decl^ imports type-vars)
- (-> Class-Imports (List Var) (Parser [Member-Declaration MethodDecl]))
- (s.form (do p.monad
- [tvars (p.default (list) ..vars^)
- name s.local-identifier
- anns (annotations^ imports)
- inputs (s.tuple (p.some (..type^ imports type-vars)))
- output (..return^ imports type-vars)
- exs (throws-decl^ imports type-vars)]
- (wrap [[name #PublicPM anns] {#method-tvars tvars
- #method-inputs inputs
- #method-output output
- #method-exs exs}]))))
+ (-> Class-Imports (List Variable) (Parser [Member-Declaration MethodDecl]))
+ (<c>.form (do <>.monad
+ [tvars (<>.default (list) ..vars^)
+ name <c>.local-identifier
+ anns (annotations^ imports)
+ inputs (<c>.tuple (<>.some (..type^ imports type-vars)))
+ output (..return^ imports type-vars)
+ exs (throws-decl^ imports type-vars)]
+ (wrap [[name #PublicP anns] {#method-tvars tvars
+ #method-inputs inputs
+ #method-output output
+ #method-exs exs}]))))
(def: state-modifier^
(Parser StateModifier)
- ($_ p.or
- (s.this! (' #volatile))
- (s.this! (' #final))
- (:: p.monad wrap [])))
+ ($_ <>.or
+ (<c>.this! (' #volatile))
+ (<c>.this! (' #final))
+ (:: <>.monad wrap [])))
(def: (field-decl^ imports type-vars)
- (-> Class-Imports (List Var) (Parser [Member-Declaration FieldDecl]))
- (p.either (s.form (do p.monad
- [_ (s.this! (' #const))
- name s.local-identifier
- anns (annotations^ imports)
- type (..type^ imports type-vars)
- body s.any]
- (wrap [[name #PublicPM anns] (#ConstantField [type body])])))
- (s.form (do p.monad
- [pm privacy-modifier^
- sm state-modifier^
- name s.local-identifier
- anns (annotations^ imports)
- type (..type^ imports type-vars)]
- (wrap [[name pm anns] (#VariableField [sm type])])))))
+ (-> Class-Imports (List Variable) (Parser [Member-Declaration FieldDecl]))
+ (<>.either (<c>.form (do <>.monad
+ [_ (<c>.this! (' #const))
+ name <c>.local-identifier
+ anns (annotations^ imports)
+ type (..type^ imports type-vars)
+ body <c>.any]
+ (wrap [[name #PublicP anns] (#ConstantField [type body])])))
+ (<c>.form (do <>.monad
+ [pm privacy-modifier^
+ sm state-modifier^
+ name <c>.local-identifier
+ anns (annotations^ imports)
+ type (..type^ imports type-vars)]
+ (wrap [[name pm anns] (#VariableField [sm type])])))))
(def: (argument^ imports type-vars)
- (-> Class-Imports (List Var) (Parser Argument))
- (s.record (p.and s.local-identifier
- (..type^ imports type-vars))))
+ (-> Class-Imports (List Variable) (Parser Argument))
+ (<c>.record (<>.and <c>.local-identifier
+ (..type^ imports type-vars))))
(def: (arguments^ imports type-vars)
- (-> Class-Imports (List Var) (Parser (List Argument)))
- (p.some (argument^ imports type-vars)))
+ (-> Class-Imports (List Variable) (Parser (List Argument)))
+ (<>.some (argument^ imports type-vars)))
(def: (constructor-arg^ imports type-vars)
- (-> Class-Imports (List Var) (Parser (Typed Code)))
- (s.record (p.and (..type^ imports type-vars) s.any)))
+ (-> Class-Imports (List Variable) (Parser (Typed Code)))
+ (<c>.record (<>.and (..type^ imports type-vars) <c>.any)))
(def: (constructor-args^ imports type-vars)
- (-> Class-Imports (List Var) (Parser (List (Typed Code))))
- (s.tuple (p.some (constructor-arg^ imports type-vars))))
+ (-> Class-Imports (List Variable) (Parser (List (Typed Code))))
+ (<c>.tuple (<>.some (constructor-arg^ imports type-vars))))
(def: (constructor-method^ imports class-vars)
- (-> Class-Imports (List Var) (Parser [Member-Declaration Method-Definition]))
- (s.form (do p.monad
- [pm privacy-modifier^
- strict-fp? (p.parses? (s.this! (' #strict)))
- method-vars (p.default (list) ..vars^)
- #let [total-vars (list@compose class-vars method-vars)]
- [_ self-name arguments] (s.form ($_ p.and
- (s.this! (' new))
- s.local-identifier
- (arguments^ imports total-vars)))
- constructor-args (constructor-args^ imports total-vars)
- exs (throws-decl^ imports total-vars)
- annotations (annotations^ imports)
- body s.any]
- (wrap [{#member-name constructor-method-name
- #member-privacy pm
- #member-anns annotations}
- (#ConstructorMethod strict-fp? method-vars self-name arguments constructor-args body exs)]))))
+ (-> Class-Imports (List Variable) (Parser [Member-Declaration Method-Definition]))
+ (<c>.form (do <>.monad
+ [pm privacy-modifier^
+ strict-fp? (<>.parses? (<c>.this! (' #strict)))
+ method-vars (<>.default (list) ..vars^)
+ #let [total-vars (list@compose class-vars method-vars)]
+ [_ self-name arguments] (<c>.form ($_ <>.and
+ (<c>.this! (' new))
+ <c>.local-identifier
+ (arguments^ imports total-vars)))
+ constructor-args (constructor-args^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body <c>.any]
+ (wrap [{#member-name constructor-method-name
+ #member-privacy pm
+ #member-anns annotations}
+ (#ConstructorMethod strict-fp? method-vars self-name arguments constructor-args body exs)]))))
(def: (virtual-method-def^ imports class-vars)
- (-> Class-Imports (List Var) (Parser [Member-Declaration Method-Definition]))
- (s.form (do p.monad
- [pm privacy-modifier^
- strict-fp? (p.parses? (s.this! (' #strict)))
- final? (p.parses? (s.this! (' #final)))
- method-vars (p.default (list) ..vars^)
- #let [total-vars (list@compose class-vars method-vars)]
- [name self-name arguments] (s.form ($_ p.and
- s.local-identifier
- s.local-identifier
- (arguments^ imports total-vars)))
- return-type (..return^ imports total-vars)
- exs (throws-decl^ imports total-vars)
- annotations (annotations^ imports)
- body s.any]
- (wrap [{#member-name name
- #member-privacy pm
- #member-anns annotations}
- (#VirtualMethod final? strict-fp? method-vars self-name arguments return-type body exs)]))))
+ (-> Class-Imports (List Variable) (Parser [Member-Declaration Method-Definition]))
+ (<c>.form (do <>.monad
+ [pm privacy-modifier^
+ strict-fp? (<>.parses? (<c>.this! (' #strict)))
+ final? (<>.parses? (<c>.this! (' #final)))
+ method-vars (<>.default (list) ..vars^)
+ #let [total-vars (list@compose class-vars method-vars)]
+ [name self-name arguments] (<c>.form ($_ <>.and
+ <c>.local-identifier
+ <c>.local-identifier
+ (arguments^ imports total-vars)))
+ return-type (..return^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body <c>.any]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#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]))
- (s.form (do p.monad
- [strict-fp? (p.parses? (s.this! (' #strict)))
- owner-class (declaration^ imports)
- method-vars (p.default (list) ..vars^)
- #let [total-vars (list@compose (product.right owner-class) method-vars)]
- [name self-name arguments] (s.form ($_ p.and
- s.local-identifier
- s.local-identifier
- (arguments^ imports total-vars)))
- return-type (..return^ imports total-vars)
- exs (throws-decl^ imports total-vars)
- annotations (annotations^ imports)
- body s.any]
- (wrap [{#member-name name
- #member-privacy #PublicPM
- #member-anns annotations}
- (#OverridenMethod strict-fp? owner-class method-vars self-name arguments return-type body exs)]))))
+ (<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)]
+ [name self-name arguments] (<c>.form ($_ <>.and
+ <c>.local-identifier
+ <c>.local-identifier
+ (arguments^ imports total-vars)))
+ return-type (..return^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body <c>.any]
+ (wrap [{#member-name name
+ #member-privacy #PublicP
+ #member-anns annotations}
+ (#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]))
- (s.form (do p.monad
- [pm privacy-modifier^
- strict-fp? (p.parses? (s.this! (' #strict)))
- _ (s.this! (' #static))
- method-vars (p.default (list) ..vars^)
- #let [total-vars method-vars]
- [name arguments] (s.form (p.and s.local-identifier
- (arguments^ imports total-vars)))
- return-type (..return^ imports total-vars)
- exs (throws-decl^ imports total-vars)
- annotations (annotations^ imports)
- body s.any]
- (wrap [{#member-name name
- #member-privacy pm
- #member-anns annotations}
- (#StaticMethod strict-fp? method-vars arguments return-type body exs)]))))
+ (<c>.form (do <>.monad
+ [pm privacy-modifier^
+ strict-fp? (<>.parses? (<c>.this! (' #strict)))
+ _ (<c>.this! (' #static))
+ method-vars (<>.default (list) ..vars^)
+ #let [total-vars method-vars]
+ [name arguments] (<c>.form (<>.and <c>.local-identifier
+ (arguments^ imports total-vars)))
+ return-type (..return^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)
+ body <c>.any]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#StaticMethod strict-fp? method-vars arguments return-type body exs)]))))
(def: (abstract-method-def^ imports)
(-> Class-Imports (Parser [Member-Declaration Method-Definition]))
- (s.form (do p.monad
- [pm privacy-modifier^
- _ (s.this! (' #abstract))
- method-vars (p.default (list) ..vars^)
- #let [total-vars method-vars]
- [name arguments] (s.form (p.and s.local-identifier
- (arguments^ imports total-vars)))
- return-type (..return^ imports total-vars)
- exs (throws-decl^ imports total-vars)
- annotations (annotations^ imports)]
- (wrap [{#member-name name
- #member-privacy pm
- #member-anns annotations}
- (#AbstractMethod method-vars arguments return-type exs)]))))
+ (<c>.form (do <>.monad
+ [pm privacy-modifier^
+ _ (<c>.this! (' #abstract))
+ method-vars (<>.default (list) ..vars^)
+ #let [total-vars method-vars]
+ [name arguments] (<c>.form (<>.and <c>.local-identifier
+ (arguments^ imports total-vars)))
+ return-type (..return^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#AbstractMethod method-vars arguments return-type exs)]))))
(def: (native-method-def^ imports)
(-> Class-Imports (Parser [Member-Declaration Method-Definition]))
- (s.form (do p.monad
- [pm privacy-modifier^
- _ (s.this! (' #native))
- method-vars (p.default (list) ..vars^)
- #let [total-vars method-vars]
- [name arguments] (s.form (p.and s.local-identifier
- (arguments^ imports total-vars)))
- return-type (..return^ imports total-vars)
- exs (throws-decl^ imports total-vars)
- annotations (annotations^ imports)]
- (wrap [{#member-name name
- #member-privacy pm
- #member-anns annotations}
- (#NativeMethod method-vars arguments return-type exs)]))))
+ (<c>.form (do <>.monad
+ [pm privacy-modifier^
+ _ (<c>.this! (' #native))
+ method-vars (<>.default (list) ..vars^)
+ #let [total-vars method-vars]
+ [name arguments] (<c>.form (<>.and <c>.local-identifier
+ (arguments^ imports total-vars)))
+ return-type (..return^ imports total-vars)
+ exs (throws-decl^ imports total-vars)
+ annotations (annotations^ imports)]
+ (wrap [{#member-name name
+ #member-privacy pm
+ #member-anns annotations}
+ (#NativeMethod method-vars arguments return-type exs)]))))
(def: (method-def^ imports class-vars)
- (-> Class-Imports (List Var) (Parser [Member-Declaration Method-Definition]))
- ($_ p.either
+ (-> Class-Imports (List Variable) (Parser [Member-Declaration Method-Definition]))
+ ($_ <>.either
(constructor-method^ imports class-vars)
(virtual-method-def^ imports class-vars)
(overriden-method-def^ imports)
@@ -873,107 +903,110 @@
(def: partial-call^
(Parser Partial-Call)
- (s.form (p.and s.identifier (p.some s.any))))
+ (<c>.form (<>.and <c>.identifier (<>.some <c>.any))))
(def: class-kind^
(Parser Class-Kind)
- (p.either (do p.monad
- [_ (s.this! (' #class))]
- (wrap #Class))
- (do p.monad
- [_ (s.this! (' #interface))]
- (wrap #Interface))
- ))
+ (<>.either (do <>.monad
+ [_ (<c>.this! (' #class))]
+ (wrap #Class))
+ (do <>.monad
+ [_ (<c>.this! (' #interface))]
+ (wrap #Interface))
+ ))
(def: import-member-alias^
(Parser (Maybe Text))
- (p.maybe (do p.monad
- [_ (s.this! (' #as))]
- s.local-identifier)))
+ (<>.maybe (do <>.monad
+ [_ (<c>.this! (' #as))]
+ <c>.local-identifier)))
(def: (import-member-args^ imports type-vars)
- (-> Class-Imports (List Var) (Parser (List [Bit Type])))
- (s.tuple (p.some (p.and (p.parses? (s.tag! ["" "?"]))
- (..type^ imports type-vars)))))
+ (-> Class-Imports (List Variable) (Parser (List [Bit Type])))
+ (<c>.tuple (<>.some (<>.and (<>.parses? (<c>.tag! ["" "?"]))
+ (..type^ imports type-vars)))))
(def: import-member-return-flags^
(Parser [Bit Bit Bit])
- ($_ p.and (p.parses? (s.this! (' #io))) (p.parses? (s.this! (' #try))) (p.parses? (s.this! (' #?)))))
+ ($_ <>.and
+ (<>.parses? (<c>.this! (' #io)))
+ (<>.parses? (<c>.this! (' #try)))
+ (<>.parses? (<c>.this! (' #?)))))
(def: primitive-mode^
(Parser Primitive-Mode)
- (p.or (s.tag! ["" "manual"])
- (s.tag! ["" "auto"])))
+ (<>.or (<c>.tag! ["" "manual"])
+ (<c>.tag! ["" "auto"])))
(def: (import-member-decl^ imports owner-vars)
- (-> Class-Imports (List Var) (Parser Import-Member-Declaration))
- ($_ p.either
- (s.form (do p.monad
- [_ (s.this! (' #enum))
- enum-members (p.some s.local-identifier)]
- (wrap (#EnumDecl enum-members))))
- (s.form (do p.monad
- [tvars (p.default (list) ..vars^)
- _ (s.identifier! ["" "new"])
- ?alias import-member-alias^
- #let [total-vars (list@compose owner-vars tvars)]
- ?prim-mode (p.maybe primitive-mode^)
- args (import-member-args^ imports total-vars)
- [io? try? maybe?] import-member-return-flags^]
- (wrap (#ConstructorDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode)
- #import-member-alias (maybe.default "new" ?alias)
- #import-member-kind #VirtualIMK
- #import-member-tvars tvars
- #import-member-args args
- #import-member-maybe? maybe?
- #import-member-try? try?
- #import-member-io? io?}
- {}]))
- ))
- (s.form (do p.monad
- [kind (: (Parser ImportMethodKind)
- (p.or (s.tag! ["" "static"])
- (wrap [])))
- tvars (p.default (list) ..vars^)
- name s.local-identifier
- ?alias import-member-alias^
- #let [total-vars (list@compose owner-vars tvars)]
- ?prim-mode (p.maybe primitive-mode^)
- args (import-member-args^ imports total-vars)
- [io? try? maybe?] import-member-return-flags^
- return (..return^ imports total-vars)]
- (wrap (#MethodDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode)
- #import-member-alias (maybe.default name ?alias)
- #import-member-kind kind
- #import-member-tvars tvars
- #import-member-args args
- #import-member-maybe? maybe?
- #import-member-try? try?
- #import-member-io? io?}
- {#import-method-name name
- #import-method-return return}]))))
- (s.form (do p.monad
- [static? (p.parses? (s.this! (' #static)))
- name s.local-identifier
- ?prim-mode (p.maybe primitive-mode^)
- gtype (..type^ imports owner-vars)
- maybe? (p.parses? (s.this! (' #?)))
- setter? (p.parses? (s.this! (' #!)))]
- (wrap (#FieldAccessDecl {#import-field-mode (maybe.default #AutoPrM ?prim-mode)
- #import-field-name name
- #import-field-static? static?
- #import-field-maybe? maybe?
- #import-field-setter? setter?
- #import-field-type gtype}))))
+ (-> Class-Imports (List Variable) (Parser Import-Member-Declaration))
+ ($_ <>.either
+ (<c>.form (do <>.monad
+ [_ (<c>.this! (' #enum))
+ enum-members (<>.some <c>.local-identifier)]
+ (wrap (#EnumDecl enum-members))))
+ (<c>.form (do <>.monad
+ [tvars (<>.default (list) ..vars^)
+ _ (<c>.identifier! ["" "new"])
+ ?alias import-member-alias^
+ #let [total-vars (list@compose owner-vars tvars)]
+ ?prim-mode (<>.maybe primitive-mode^)
+ args (import-member-args^ imports total-vars)
+ [io? try? maybe?] import-member-return-flags^]
+ (wrap (#ConstructorDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode)
+ #import-member-alias (maybe.default "new" ?alias)
+ #import-member-kind #VirtualIMK
+ #import-member-tvars tvars
+ #import-member-args args
+ #import-member-maybe? maybe?
+ #import-member-try? try?
+ #import-member-io? io?}
+ {}]))
+ ))
+ (<c>.form (do <>.monad
+ [kind (: (Parser ImportMethodKind)
+ (<>.or (<c>.tag! ["" "static"])
+ (wrap [])))
+ tvars (<>.default (list) ..vars^)
+ name <c>.local-identifier
+ ?alias import-member-alias^
+ #let [total-vars (list@compose owner-vars tvars)]
+ ?prim-mode (<>.maybe primitive-mode^)
+ args (import-member-args^ imports total-vars)
+ [io? try? maybe?] import-member-return-flags^
+ return (..return^ imports total-vars)]
+ (wrap (#MethodDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode)
+ #import-member-alias (maybe.default name ?alias)
+ #import-member-kind kind
+ #import-member-tvars tvars
+ #import-member-args args
+ #import-member-maybe? maybe?
+ #import-member-try? try?
+ #import-member-io? io?}
+ {#import-method-name name
+ #import-method-return return}]))))
+ (<c>.form (do <>.monad
+ [static? (<>.parses? (<c>.this! (' #static)))
+ name <c>.local-identifier
+ ?prim-mode (<>.maybe primitive-mode^)
+ gtype (..type^ imports owner-vars)
+ maybe? (<>.parses? (<c>.this! (' #?)))
+ setter? (<>.parses? (<c>.this! (' #!)))]
+ (wrap (#FieldAccessDecl {#import-field-mode (maybe.default #AutoPrM ?prim-mode)
+ #import-field-name name
+ #import-field-static? static?
+ #import-field-maybe? maybe?
+ #import-field-setter? setter?
+ #import-field-type gtype}))))
))
(def: (privacy-modifier$ pm)
- (-> PrivacyModifier Code)
+ (-> Privacy Code)
(case pm
- #PublicPM (' "public")
- #PrivatePM (' "private")
- #ProtectedPM (' "protected")
- #DefaultPM (' "default")))
+ #PublicP (' "public")
+ #PrivateP (' "private")
+ #ProtectedP (' "protected")
+ #DefaultP (' "default")))
(def: (inheritance-modifier$ im)
(-> InheritanceModifier Code)
@@ -997,7 +1030,7 @@
#jvm.Upper (code.local-identifier "<")))
(def: var$
- (-> Var Code)
+ (-> Variable Code)
code.text)
(def: (generic$ generic)
@@ -1007,7 +1040,7 @@
(var$ var)
(#jvm.Class name params)
- (` ((~ (code.text (sanitize name))) (~+ (list@map generic$ params))))
+ (` ((~ (code.text name)) (~+ (list@map generic$ params))))
(#jvm.Wildcard wilcard)
(case wilcard
@@ -1048,12 +1081,12 @@
(def: (declaration$ (^open "."))
(-> Class-Declaration Code)
- (` ((~ (code.text (sanitize class-name)))
+ (` ((~ (code.text class-name))
(~+ (list@map var$ class-params)))))
(def: (class$ [name params])
(-> Class Code)
- (` ((~ (code.text (sanitize name)))
+ (` ((~ (code.text name))
(~+ (list@map generic$ params)))))
(def: (method-decl$ [[name pm anns] method-decl])
@@ -1131,17 +1164,17 @@
(~ (pre-walk-replace replacer body))))
(#OverridenMethod strict-fp? declaration type-vars self-name arguments return-type body exs)
- (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)]]
- (wrap (` ("jvm member invoke special"
- (~ (code.text (product.left super-class)))
- (~ (code.text name))
- (~' _jvm_this)
- (~+ (|> args
- (list.zip2 arguments')
- (list@map ..decorate-input)))))))))]
+ (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)]]
+ (wrap (` ("jvm member invoke special"
+ (~ (code.text (product.left super-class)))
+ (~ (code.text name))
+ (~' _jvm_this)
+ (~+ (|> args
+ (list.zip2 arguments')
+ (list@map ..decorate-input)))))))))]
(` ("override"
(~ (declaration$ declaration))
(~ (code.text name))
@@ -1206,13 +1239,13 @@
imports (add-import [(short-class-name full-class-name) full-class-name]
(class-imports *compiler*))]}
{#let [class-vars (product.right declaration)]}
- {super (p.default object-class
- (class^ imports class-vars))}
- {interfaces (p.default (list)
- (s.tuple (p.some (class^ imports class-vars))))}
+ {super (<>.default object-class
+ (class^ imports class-vars))}
+ {interfaces (<>.default (list)
+ (<c>.tuple (<>.some (class^ imports class-vars))))}
{annotations (annotations^ imports)}
- {fields (p.some (field-decl^ imports class-vars))}
- {methods (p.some (method-def^ imports class-vars))})
+ {fields (<>.some (field-decl^ imports class-vars))}
+ {methods (<>.some (method-def^ imports class-vars))})
{#.doc (doc "Allows defining JVM classes in Lux code."
"For example:"
(class: #final (TestClass A) [Runnable]
@@ -1245,19 +1278,14 @@
)}
(do macro.monad
[current-module macro.current-module-name
- #let [fully-qualified-class-name (format (sanitize current-module) ..syntax-class-separator full-class-name)
+ #let [fully-qualified-class-name (name.qualify current-module full-class-name)
field-parsers (list@map (field->parser fully-qualified-class-name) fields)
method-parsers (list@map (method->parser fully-qualified-class-name) methods)
- replacer (parser->replacer (list@fold p.either
- (p.fail "")
+ replacer (parser->replacer (list@fold <>.either
+ (<>.fail "")
(list@compose field-parsers method-parsers)))]]
(wrap (list (` ("jvm class"
- (~ (declaration$ (update@ #class-name
- (|>> (format (text.replace-all ..binary-class-separator
- ..syntax-class-separator
- current-module)
- ..syntax-class-separator))
- declaration)))
+ (~ (declaration$ (update@ #class-name (name.qualify current-module) declaration)))
(~ (class$ super))
[(~+ (list@map class$ interfaces))]
(~ (inheritance-modifier$ im))
@@ -1272,10 +1300,10 @@
imports (add-import [(short-class-name full-class-name) full-class-name]
(class-imports *compiler*))]}
{#let [class-vars (product.right declaration)]}
- {supers (p.default (list)
- (s.tuple (p.some (class^ imports class-vars))))}
+ {supers (<>.default (list)
+ (<c>.tuple (<>.some (class^ imports class-vars))))}
{annotations (annotations^ imports)}
- {members (p.some (method-decl^ imports class-vars))})
+ {members (<>.some (method-decl^ imports class-vars))})
{#.doc (doc "Allows defining JVM interfaces."
(interface: TestInterface
([] foo [boolean String] void #throws [Exception])))}
@@ -1288,12 +1316,12 @@
(syntax: #export (object
{#let [imports (class-imports *compiler*)]}
{class-vars ..vars^}
- {super (p.default object-class
- (class^ imports class-vars))}
- {interfaces (p.default (list)
- (s.tuple (p.some (class^ imports class-vars))))}
+ {super (<>.default object-class
+ (class^ imports class-vars))}
+ {interfaces (<>.default (list)
+ (<c>.tuple (<>.some (class^ imports class-vars))))}
{constructor-args (constructor-args^ imports class-vars)}
- {methods (p.some (overriden-method-def^ imports))})
+ {methods (<>.some (overriden-method-def^ imports))})
{#.doc (doc "Allows defining anonymous classes."
"The 1st tuple corresponds to class-level type-variables."
"The 2nd tuple corresponds to parent interfaces."
@@ -1366,7 +1394,7 @@
(syntax: #export (check {#let [imports (class-imports *compiler*)]}
{class (..type^ imports (list))}
- {unchecked (p.maybe s.any)})
+ {unchecked (<>.maybe <c>.any)})
{#.doc (doc "Checks whether an object is an instance of a particular class."
"Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes."
(case (check String "YOLO")
@@ -1400,7 +1428,7 @@
(finish-the-computation ___))))}
(wrap (list (` ("jvm object synchronized" (~ lock) (~ body))))))
-(syntax: #export (do-to obj {methods (p.some partial-call^)})
+(syntax: #export (do-to obj {methods (<>.some partial-call^)})
{#.doc (doc "Call a variety of methods on an object. Then, return the object."
(do-to object
(ClassName::method1 arg0 arg1 arg2)
@@ -1420,11 +1448,11 @@
{#..jvm-class (~ (code.text full-name))}
.Type
(All [(~+ params')]
- (primitive (~ (code.text (sanitize full-name)))
+ (primitive (~ (code.text full-name))
[(~+ params')]))))))
(def: (member-type-vars class-tvars member)
- (-> (List Var) Import-Member-Declaration (List Var))
+ (-> (List Variable) Import-Member-Declaration (List Variable))
(case member
(#ConstructorDecl [commons _])
(list@compose class-tvars (get@ #import-member-tvars commons))
@@ -1441,7 +1469,7 @@
class-tvars))
(def: (member-def-arg-bindings vars class member)
- (-> (List Var) Class-Declaration Import-Member-Declaration (Meta [(List [Bit Code]) (List Text) (List Code)]))
+ (-> (List Variable) Class-Declaration Import-Member-Declaration (Meta [(List [Bit Code]) (List Text) (List Code)]))
(case member
(^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _]))
(let [(^slots [#import-member-tvars #import-member-args]) commons]
@@ -1452,10 +1480,10 @@
(with-gensyms [arg-name]
(wrap [maybe? arg-name]))))
import-member-args)
- #let [arg-classes (list@map (|>> product.right jvm.descriptor) import-member-args)
+ #let [arg-classes (list@map (|>> product.right type.descriptor) import-member-args)
arg-types (list@map (: (-> [Bit Type] Code)
(function (_ [maybe? arg])
- (let [arg-type (jvm-type (get@ #import-member-mode commons) arg)]
+ (let [arg-type (value-type (get@ #import-member-mode commons) arg)]
(if maybe?
(` (Maybe (~ arg-type)))
arg-type))))
@@ -1504,12 +1532,12 @@
)
(def: var->type-arg
- (-> Var Code)
+ (-> Variable Code)
code.local-identifier)
(template [<jvm> <class> <descriptor>]
[(def: <class> <jvm>)
- (def: <descriptor> (jvm.signature (jvm.class <jvm> (list))))]
+ (def: <descriptor> (type.signature (type.class <jvm> (list))))]
["java.lang.String" string-class string-descriptor]
[box.boolean boolean-box-class boolean-box-descriptor]
@@ -1546,7 +1574,7 @@
(` ("jvm object cast" (~ raw)))
raw)
(list)]))))
- unboxed/boxed (case (dictionary.get unboxed boxes)
+ unboxed/boxed (case (dictionary.get unboxed ..boxes)
(#.Some boxed)
(<unbox/box> unboxed boxed refined)
@@ -1560,25 +1588,25 @@
(` (.|> (~ unboxed/boxed) (~+ post))))))]
[#1 auto-convert-input ..unbox
- [[jvm.boolean-descriptor jvm.boolean-descriptor (list (` (.: .Bit)) (` (.:coerce (.primitive (~ (code.text box.boolean)))))) []]
- [jvm.byte-descriptor jvm.byte-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-byte)) []]
- [jvm.short-descriptor jvm.short-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-short)) []]
- [jvm.int-descriptor jvm.int-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long))))) (` ..long-to-int)) []]
- [jvm.long-descriptor jvm.long-descriptor (list (` (.: .Int)) (` (.:coerce (.primitive (~ (code.text box.long)))))) []]
- [jvm.float-descriptor jvm.float-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double))))) (` ..double-to-float)) []]
- [jvm.double-descriptor jvm.double-descriptor (list (` (.: .Frac)) (` (.:coerce (.primitive (~ (code.text box.double)))))) []]
+ [[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)))))) []]]]
[#0 auto-convert-output ..box
- [[jvm.boolean-descriptor jvm.boolean-descriptor (list) [(` (.: (.primitive (~ (code.text box.boolean))))) (` (.:coerce .Bit))]]
- [jvm.byte-descriptor jvm.long-descriptor (list (` "jvm conversion byte-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [jvm.short-descriptor jvm.long-descriptor (list (` "jvm conversion short-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [jvm.int-descriptor jvm.long-descriptor (list (` "jvm conversion int-to-long")) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [jvm.long-descriptor jvm.long-descriptor (list) [(` (.: (.primitive (~ (code.text box.long))))) (` (.:coerce .Int))]]
- [jvm.float-descriptor jvm.double-descriptor (list (` "jvm conversion float-to-double")) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]
- [jvm.double-descriptor jvm.double-descriptor (list) [(` (.: (.primitive (~ (code.text box.double))))) (` (.:coerce .Frac))]]
+ [[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))]]
@@ -1604,9 +1632,8 @@
(` (.: (.primitive (~ (code.text class))) (~ expression))))
(def: (member-def-interop vars kind class [arg-function-inputs arg-classes arg-types] member method-prefix)
- (-> (List Var) Class-Kind Class-Declaration [(List [Bit Code]) (List Text) (List Code)] Import-Member-Declaration Text (Meta (List Code)))
+ (-> (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
- full-name (sanitize full-name)
all-params (list@map var->type-arg (member-type-vars class-tvars member))]
(case member
(#EnumDecl enum-members)
@@ -1630,7 +1657,7 @@
(#ConstructorDecl [commons _])
(do macro.monad
[#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))])
- jvm-interop (|> [(jvm.signature (jvm.class full-name (list)))
+ jvm-interop (|> [(type.signature (type.class full-name (list)))
(` ("jvm member invoke constructor"
(~ (code.text full-name))
(~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)
@@ -1667,17 +1694,17 @@
)))
method-return-class (case (get@ #import-method-return method)
#.None
- jvm.void-descriptor
+ type.void-descriptor
(#.Some return)
- (jvm.signature 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 (jvm.signature (jvm.class full-name (list)))))
+ (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)
@@ -1692,7 +1719,7 @@
(#FieldAccessDecl fad)
(do macro.monad
[#let [(^open ".") fad
- base-gtype (jvm-type import-field-mode import-field-type)
+ base-gtype (value-type import-field-mode import-field-type)
classC (declaration-type$ class)
typeC (if import-field-maybe?
(` (Maybe (~ base-gtype)))
@@ -1705,7 +1732,7 @@
(` ((~ getter-name)))
(` ((~ getter-name) (~ g!obj))))
getter-body (<| (auto-convert-output import-field-mode)
- [(jvm.signature import-field-type)
+ [(type.signature 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)))])
@@ -1723,7 +1750,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 (|> [(type.signature import-field-type) (un-quote g!value)]
(auto-convert-input import-field-mode))
setter-value (if import-field-maybe?
(` ((~! !!!) (~ setter-value)))
@@ -1741,7 +1768,7 @@
)))
(def: (member-import$ vars long-name? kind class member)
- (-> (List Var) Bit Class-Kind Class-Declaration Import-Member-Declaration (Meta (List Code)))
+ (-> (List Variable) Bit Class-Kind Class-Declaration Import-Member-Declaration (Meta (List Code)))
(let [[full-name _] class
method-prefix (if long-name?
full-name
@@ -1766,24 +1793,23 @@
(def: (class-kind [class-name _])
(-> Class-Declaration (Meta Class-Kind))
- (let [class-name (sanitize class-name)]
- (case (load-class class-name)
- (#.Right class)
- (:: macro.monad wrap (if (interface? class)
- #Interface
- #Class))
+ (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*)]}
- {long-name? (p.parses? (s.this! (' #long)))}
+ {long-name? (<>.parses? (<c>.this! (' #long)))}
{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*))]}
- {members (p.some (import-member-decl^ imports (product.right declaration)))})
+ {members (<>.some (import-member-decl^ imports (product.right declaration)))})
{#.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."
@@ -1859,21 +1885,21 @@
[#jvm.Char "jvm array new char"])
_
- (wrap (list (` (: (~ (jvm-type #ManualPrM (jvm.array 1 type)))
+ (wrap (list (` (: (~ (value-type #ManualPrM (type.array 1 type)))
("jvm array new object" (~ g!size)))))))))
(def: (type->class-name type)
(-> .Type (Meta Text))
- (if (type@= Any type)
+ (if (lux-type@= Any type)
(:: macro.monad wrap "java.lang.Object")
(case type
(#.Primitive name params)
(:: macro.monad wrap name)
(#.Apply A F)
- (case (type.apply (list A) F)
+ (case (lux-type.apply (list A) F)
#.None
- (macro.fail (format "Cannot apply type: " (type.to-text F) " to " (type.to-text A)))
+ (macro.fail (format "Cannot apply type: " (%.type F) " to " (%.type A)))
(#.Some type')
(type->class-name type'))
@@ -1882,7 +1908,7 @@
(type->class-name type')
_
- (macro.fail (format "Cannot convert to JVM type: " (type.to-text type))))))
+ (macro.fail (format "Cannot convert to JVM type: " (%.type type))))))
(syntax: #export (array-length array)
{#.doc (doc "Gives the length of an array."
@@ -2009,4 +2035,4 @@
(syntax: #export (type {#let [imports (class-imports *compiler*)]}
{type (..type^ imports (list))})
- (wrap (list (jvm-type #ManualPrM type))))
+ (wrap (list (value-type #ManualPrM type))))
diff --git a/stdlib/source/lux/target/jvm/encoding/name.lux b/stdlib/source/lux/target/jvm/encoding/name.lux
index 7f2119bc0..1ba56573a 100644
--- a/stdlib/source/lux/target/jvm/encoding/name.lux
+++ b/stdlib/source/lux/target/jvm/encoding/name.lux
@@ -1,7 +1,8 @@
(.module:
[lux #*
[data
- ["." text]]
+ ["." text
+ ["%" format (#+ format)]]]
[type
abstract]])
@@ -30,3 +31,11 @@
(|>> :representation
(text.replace-all ..internal-separator
..external-separator))))
+
+(def: #export sanitize
+ (-> Text External)
+ (|>> ..internal ..external))
+
+(def: #export (qualify package class)
+ (-> Text External External)
+ (format (..sanitize package) ..external-separator class))
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index d8b21a829..890c459b6 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -1,7 +1,8 @@
(.module:
[lux (#- Type int char)
[abstract
- [equivalence (#+ Equivalence)]]
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
[data
["." maybe]
["." text]
@@ -125,6 +126,12 @@
(..signature parameter)
(..signature subject))))
+ (structure: #export hash
+ (All [category] (Hash (Type category)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> ..signature (:: /signature.hash hash))))
+
(def: #export (primitive? type)
(-> (Type Value) (Either (Type Object)
(Type Primitive)))
diff --git a/stdlib/source/lux/target/jvm/type/alias.lux b/stdlib/source/lux/target/jvm/type/alias.lux
index dfa1e4356..9d92d7b6a 100644
--- a/stdlib/source/lux/target/jvm/type/alias.lux
+++ b/stdlib/source/lux/target/jvm/type/alias.lux
@@ -44,13 +44,11 @@
(def: (class parameter)
(-> (Parser (Type Parameter)) (Parser (Type Class)))
(|> (do <>.monad
- [_ (<t>.this //descriptor.class-prefix)
- name //parser.class-name
+ [name //parser.class-name
parameters (|> (<>.some parameter)
(<>.after (<t>.this //signature.parameters-start))
(<>.before (<t>.this //signature.parameters-end))
- (<>.default (list)))
- _ (<t>.this //descriptor.class-suffix)]
+ (<>.default (list)))]
(wrap (//.class name parameters)))
(<>.after (<t>.this //descriptor.class-prefix))
(<>.before (<t>.this //descriptor.class-suffix))))
diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux
index 56203d32b..59ead2071 100644
--- a/stdlib/source/lux/target/jvm/type/lux.lux
+++ b/stdlib/source/lux/target/jvm/type/lux.lux
@@ -98,13 +98,11 @@
(def: (class' parameter)
(-> (Parser (Check Type)) (Parser (Check Type)))
(|> (do <>.monad
- [_ (<t>.this //descriptor.class-prefix)
- name //parser.class-name
+ [name //parser.class-name
parameters (|> (<>.some parameter)
(<>.after (<t>.this //signature.parameters-start))
(<>.before (<t>.this //signature.parameters-end))
- (<>.default (list)))
- _ (<t>.this //descriptor.class-suffix)]
+ (<>.default (list)))]
(wrap (do check.monad
[parameters (monad.seq @ parameters)]
(wrap (#.Primitive name parameters)))))
diff --git a/stdlib/source/lux/target/jvm/type/parser.lux b/stdlib/source/lux/target/jvm/type/parser.lux
index fd29e4856..2ed9b89c5 100644
--- a/stdlib/source/lux/target/jvm/type/parser.lux
+++ b/stdlib/source/lux/target/jvm/type/parser.lux
@@ -10,7 +10,9 @@
[data
["." product]
[text
- ["%" format (#+ format)]]]]
+ ["%" format (#+ format)]]
+ [collection
+ ["." list]]]]
["." // (#+ Type)
[category (#+ Void Value Return Method Primitive Object Class Array Var Parameter)]
["#." signature (#+ Signature)]
@@ -114,13 +116,11 @@
(def: (class'' parameter)
(-> (Parser (Type Parameter)) (Parser [External (List (Type Parameter))]))
(|> (do <>.monad
- [_ (<t>.this //descriptor.class-prefix)
- name ..class-name
+ [name ..class-name
parameters (|> (<>.some parameter)
(<>.after (<t>.this //signature.parameters-start))
(<>.before (<t>.this //signature.parameters-end))
- (<>.default (list)))
- _ (<t>.this //descriptor.class-suffix)]
+ (<>.default (list)))]
(wrap [name parameters]))
(<>.after (<t>.this //descriptor.class-prefix))
(<>.before (<t>.this //descriptor.class-suffix))))
@@ -152,6 +152,18 @@
(Parser (Type Class))
(..class' ..parameter))
+(template [<name> <prefix> <constructor>]
+ [(def: #export <name>
+ (-> (Type Value) (Maybe (Type Class)))
+ (|>> //.signature
+ //signature.signature
+ (<t>.run (<>.after (<t>.this <prefix>) ..class))
+ try.maybe))]
+
+ [lower? //signature.lower-prefix //.lower]
+ [upper? //signature.upper-prefix //.upper]
+ )
+
(def: #export read-class
(-> (Type Class) [External (List (Type Parameter))])
(|>> //.signature
@@ -173,6 +185,12 @@
(Parser (Type Array))
(..array' ..value))
+(def: #export object
+ (Parser (Type Object))
+ ($_ <>.either
+ ..class
+ ..array))
+
(def: #export return
(Parser (Type Return))
(<>.either ..void
@@ -193,3 +211,24 @@
return ..return
exceptions (<>.some exception)]
(wrap (//.method [parameters return exceptions])))))
+
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (-> (Type Value) (Maybe <category>))
+ (|>> //.signature
+ //signature.signature
+ (<t>.run <parser>)
+ try.maybe))]
+
+ [array? (Type Value)
+ (do <>.monad
+ [_ (<t>.this //descriptor.array-prefix)]
+ ..value)]
+ [class? [External (List (Type Parameter))]
+ (..class'' ..parameter)]
+
+ [primitive? (Type Primitive) ..primitive]
+ [wildcard? (Type Parameter) ..wildcard]
+ [parameter? (Type Parameter) ..parameter]
+ [object? (Type Object) ..object]
+ )
diff --git a/stdlib/source/lux/target/jvm/type/signature.lux b/stdlib/source/lux/target/jvm/type/signature.lux
index 56fb04da6..5a2256417 100644
--- a/stdlib/source/lux/target/jvm/type/signature.lux
+++ b/stdlib/source/lux/target/jvm/type/signature.lux
@@ -1,9 +1,10 @@
(.module:
[lux (#- int char)
[abstract
- [equivalence (#+ Equivalence)]]
+ [equivalence (#+ Equivalence)]
+ [hash (#+ Hash)]]
[data
- ["." text ("#@." equivalence)
+ ["." text ("#@." hash)
["%" format (#+ format)]]
[collection
["." list ("#@." functor)]]]
@@ -117,4 +118,10 @@
(def: (= parameter subject)
(text@= (:representation parameter)
(:representation subject))))
+
+ (structure: #export hash
+ (All [category] (Hash (Signature category)))
+
+ (def: &equivalence ..equivalence)
+ (def: hash (|>> :representation text@hash)))
)
diff --git a/stdlib/source/lux/tool/compiler/analysis.lux b/stdlib/source/lux/tool/compiler/analysis.lux
index ffefb48f7..e59397ed9 100644
--- a/stdlib/source/lux/tool/compiler/analysis.lux
+++ b/stdlib/source/lux/tool/compiler/analysis.lux
@@ -320,6 +320,12 @@
(All [e] (-> (Exception e) e Operation))
(..fail (exception.construct exception parameters)))
+(def: #export (assert exception parameters condition)
+ (All [e] (-> (Exception e) e Bit (Operation Any)))
+ (if condition
+ (:: phase.monad wrap [])
+ (..throw exception parameters)))
+
(def: #export (fail' error)
(-> Text (phase.Operation Lux))
(function (_ state)
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 98f09019e..1d5b1218d 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -5,12 +5,12 @@
[abstract
["." monad (#+ do)]]
[control
+ pipe
["." try (#+ Try) ("#@." monad)]
+ ["." exception (#+ exception:)]
["<>" parser
["<c>" code (#+ Parser)]
- ["<t>" text]]
- ["." exception (#+ exception:)]
- pipe]
+ ["<t>" text]]]
[data
["." maybe]
["." product]
@@ -20,7 +20,7 @@
["%" format (#+ format)]]
[collection
["." list ("#@." fold monad monoid)]
- ["." array (#+ Array)]
+ ["." array]
["." dictionary (#+ Dictionary)]]]
["." type
["." check (#+ Check) ("#@." monad)]]
@@ -29,7 +29,7 @@
[".!" reflection]
[encoding
[name (#+ External)]]
- ["#" type (#+ Type Argument Typed)
+ ["#" type (#+ Type Argument Typed) ("#@." equivalence)
["." category (#+ Void Value Return Primitive Object Class Array Var Parameter Method)]
["." box]
["." reflection]
@@ -91,7 +91,7 @@
)
(type: Member
- {#class Text
+ {#class External
#member Text})
(def: member
@@ -110,6 +110,7 @@
[non-object]
[non-array]
[non-parameter]
+ [non-jvm-type]
)
(template [<name>]
@@ -130,12 +131,12 @@
(template [<name>]
[(exception: #export (<name> {class Text}
{method Text}
- {arg-classes (List Text)}
+ {inputsJT (List (Type Value))}
{hints (List Method-Signature)})
(exception.report
["Class" class]
["Method" method]
- ["Arguments" (exception.enumerate %.text arg-classes)]
+ ["Arguments" (exception.enumerate ..signature inputsJT)]
["Hints" (exception.enumerate %.type (list@map product.left hints))]))]
[no-candidates]
@@ -239,52 +240,74 @@
)))
(def: #export boxes
- (Dictionary Text Text)
- (|> (list [(reflection.reflection reflection.boolean) box.boolean]
- [(reflection.reflection reflection.byte) box.byte]
- [(reflection.reflection reflection.short) box.short]
- [(reflection.reflection reflection.int) box.int]
- [(reflection.reflection reflection.long) box.long]
- [(reflection.reflection reflection.float) box.float]
- [(reflection.reflection reflection.double) box.double]
- [(reflection.reflection reflection.char) box.char])
+ (Dictionary Text [Text (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]]
+ [(reflection.reflection reflection.int) [box.int jvm.int]]
+ [(reflection.reflection reflection.long) [box.long jvm.long]]
+ [(reflection.reflection reflection.float) [box.float jvm.float]]
+ [(reflection.reflection reflection.double) [box.double jvm.double]]
+ [(reflection.reflection reflection.char) [box.char jvm.char]])
(dictionary.from-list text.hash)))
-(def: (array-type-info allow-primitives? arrayT)
- (-> Bit .Type (Operation [Nat Text]))
- (loop [level 0
- currentT arrayT]
- (case currentT
- (#.Named name anonymous)
- (recur level anonymous)
-
- (#.Apply inputT abstractionT)
- (case (type.apply (list inputT) abstractionT)
- (#.Some outputT)
- (recur level outputT)
-
- #.None
- (/////analysis.throw ..non-array arrayT))
-
- (^ (#.Primitive (static array.type-name) (list elemT)))
- (recur (inc level) elemT)
-
- (#.Primitive class #.Nil)
- (if (and (dictionary.contains? class boxes)
- (not allow-primitives?))
- (/////analysis.throw ..primitives-are-not-objects [class])
- (////@wrap [level class]))
-
- (#.Primitive class _)
- (if (dictionary.contains? class boxes)
- (/////analysis.throw ..primitives-cannot-have-type-parameters class)
- (////@wrap [level class]))
-
- (#.Ex _)
- (////@wrap [level ..object-class])
-
- _
- (/////analysis.throw ..non-array arrayT))))
+(def: (jvm-type luxT)
+ (-> .Type (Operation (Type Value)))
+ (case luxT
+ (#.Named name anonymousT)
+ (jvm-type anonymousT)
+
+ (#.Apply inputT abstractionT)
+ (case (type.apply (list inputT) abstractionT)
+ (#.Some outputT)
+ (jvm-type outputT)
+
+ #.None
+ (/////analysis.throw ..non-jvm-type luxT))
+
+ (^ (#.Primitive (static array.type-name) (list elemT)))
+ (////@map jvm.array (jvm-type elemT))
+
+ (#.Primitive class parametersT)
+ (case (dictionary.get class ..boxes)
+ (#.Some [_ primitive-type])
+ (case parametersT
+ #.Nil
+ (////@wrap primitive-type)
+
+ _
+ (/////analysis.throw ..primitives-cannot-have-type-parameters class))
+
+ #.None
+ (do ////.monad
+ [parametersJT (: (Operation (List (Type Parameter)))
+ (monad.map @
+ (function (_ parameterT)
+ (do ////.monad
+ [parameterJT (jvm-type parameterT)]
+ (case (jvm-parser.parameter? parameterJT)
+ (#.Some parameterJT)
+ (wrap parameterJT)
+
+ #.None
+ (/////analysis.throw ..non-parameter parameterT))))
+ parametersT))]
+ (wrap (jvm.class class parametersJT))))
+
+ (#.Ex _)
+ (////@wrap (jvm.class ..object-class (list)))
+
+ _
+ (/////analysis.throw ..non-jvm-type luxT)))
+
+(def: (jvm-array-type objectT)
+ (-> .Type (Operation (Type Array)))
+ (do ////.monad
+ [objectJ (jvm-type objectT)]
+ (|> objectJ
+ ..signature
+ (<t>.run jvm-parser.array)
+ ////.lift)))
(def: (primitive-array-length-handler primitive-type)
(-> (Type Primitive) Handler)
@@ -309,12 +332,11 @@
(do ////.monad
[_ (typeA.infer ..int)
[var-id varT] (typeA.with-env check.var)
- arrayA (typeA.with-type (.type (Array varT))
+ arrayA (typeA.with-type (.type (array.Array varT))
(analyse arrayC))
varT (typeA.with-env (check.clean varT))
- [array-nesting elem-class] (array-type-info true (.type (Array varT)))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat array-nesting)
- (/////analysis.text elem-class)
+ arrayJT (jvm-array-type (.type (array.Array varT)))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text (..signature arrayJT))
arrayA))))
_
@@ -344,12 +366,14 @@
[lengthA (typeA.with-type ..int
(analyse lengthC))
expectedT (///.lift macro.expected-type)
- [level elem-class] (array-type-info false expectedT)
- _ (if (n.> 0 level)
- (wrap [])
- (/////analysis.throw ..non-array expectedT))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (dec level))
- (/////analysis.text elem-class)
+ expectedJT (jvm-array-type expectedT)
+ elementJT (case (jvm-parser.array? expectedJT)
+ (#.Some elementJT)
+ (wrap elementJT)
+
+ #.None
+ (/////analysis.throw ..non-array expectedT))]
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text (..signature elementJT))
lengthA))))
_
@@ -503,15 +527,14 @@
(do ////.monad
[[var-id varT] (typeA.with-env check.var)
_ (typeA.infer varT)
- arrayA (typeA.with-type (.type (Array varT))
+ arrayA (typeA.with-type (.type (array.Array varT))
(analyse arrayC))
varT (typeA.with-env
(check.clean varT))
- [nesting elem-class] (array-type-info false (.type (Array varT)))
+ arrayJT (jvm-array-type (.type (array.Array varT)))
idxA (typeA.with-type ..int
(analyse idxC))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat nesting)
- (/////analysis.text elem-class)
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text (..signature arrayJT))
idxA
arrayA))))
@@ -547,18 +570,17 @@
(^ (list idxC valueC arrayC))
(do ////.monad
[[var-id varT] (typeA.with-env check.var)
- _ (typeA.infer (.type (Array varT)))
- arrayA (typeA.with-type (.type (Array varT))
+ _ (typeA.infer (.type (array.Array varT)))
+ arrayA (typeA.with-type (.type (array.Array varT))
(analyse arrayC))
varT (typeA.with-env
(check.clean varT))
- [nesting elem-class] (array-type-info false (.type (Array varT)))
+ arrayJT (jvm-array-type (.type (array.Array varT)))
idxA (typeA.with-type ..int
(analyse idxC))
valueA (typeA.with-type varT
(analyse valueC))]
- (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat nesting)
- (/////analysis.text elem-class)
+ (wrap (#/////analysis.Extension extension-name (list (/////analysis.text (..signature arrayJT))
idxA
valueA
arrayA))))
@@ -849,9 +871,9 @@
## else
(do @
[_ (////.assert ..primitives-are-not-objects [from-name]
- (not (dictionary.contains? from-name boxes)))
+ (not (dictionary.contains? from-name ..boxes)))
_ (////.assert ..primitives-are-not-objects [to-name]
- (not (dictionary.contains? to-name boxes)))
+ (not (dictionary.contains? to-name ..boxes)))
to-class (////.lift (reflection!.load to-name))
_ (if (text@= ..inheritance-relationship-type-name from-name)
(wrap [])
@@ -898,7 +920,7 @@
(///bundle.install "cast" object::cast)
)))
-(def: static::get
+(def: get::static
Handler
(..custom
[..member
@@ -915,7 +937,7 @@
(/////analysis.text field)
(/////analysis.text (|> fieldJT ..reflection)))))))]))
-(def: static::put
+(def: put::static
Handler
(..custom
[($_ <>.and ..member <c>.any)
@@ -936,7 +958,7 @@
(/////analysis.text field)
valueA)))))]))
-(def: virtual::get
+(def: get::virtual
Handler
(..custom
[($_ <>.and ..member <c>.any)
@@ -957,7 +979,7 @@
(/////analysis.text field)
objectA)))))]))
-(def: virtual::put
+(def: put::virtual
Handler
(..custom
[($_ <>.and ..member <c>.any <c>.any)
@@ -990,13 +1012,12 @@
#Special
#Interface)
-(def: (check-method class method-name method-style arg-classes method)
- (-> (java/lang/Class java/lang/Object) Text Method-Style (List Text) java/lang/reflect/Method (Operation Bit))
+(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))
(do ////.monad
[parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method)
array.to-list
(monad.map try.monad reflection!.type)
- (:: try.monad map (list@map ..reflection))
////.lift)
#let [modifiers (java/lang/reflect/Method::getModifiers method)
correct-class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method))
@@ -1014,12 +1035,12 @@
_
#1)
- arity-matches? (n.= (list.size arg-classes) (list.size parameters))
+ arity-matches? (n.= (list.size inputsJT) (list.size parameters))
inputs-match? (list@fold (function (_ [expectedJC actualJC] prev)
(and prev
- (text@= expectedJC actualJC)))
+ (jvm@= expectedJC actualJC)))
#1
- (list.zip2 arg-classes parameters))]]
+ (list.zip2 inputsJT parameters))]]
(wrap (and correct-class?
correct-method?
static-matches?
@@ -1027,21 +1048,20 @@
arity-matches?
inputs-match?))))
-(def: (check-constructor class arg-classes constructor)
- (-> (java/lang/Class java/lang/Object) (List Text) (java/lang/reflect/Constructor java/lang/Object) (Operation Bit))
+(def: (check-constructor class inputsJT constructor)
+ (-> (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
(monad.map try.monad reflection!.type)
- (:: try.monad map (list@map ..reflection))
////.lift)]
(wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor))
- (n.= (list.size arg-classes) (list.size parameters))
+ (n.= (list.size inputsJT) (list.size parameters))
(list@fold (function (_ [expectedJC actualJC] prev)
(and prev
- (text@= expectedJC actualJC)))
+ (jvm@= expectedJC actualJC)))
#1
- (list.zip2 arg-classes parameters))))))
+ (list.zip2 inputsJT parameters))))))
(def: idx-to-parameter
(-> Nat .Type)
@@ -1148,8 +1168,8 @@
[hint! #Hint]
)
-(def: (method-candidate class-name method-name method-style arg-classes)
- (-> Text Text Method-Style (List Text) (Operation Method-Signature))
+(def: (method-candidate class-name method-name method-style inputsJT)
+ (-> Text Text Method-Style (List (Type Value)) (Operation Method-Signature))
(do ////.monad
[class (////.lift (reflection!.load class-name))
candidates (|> class
@@ -1159,7 +1179,7 @@
(monad.map @ (: (-> java/lang/reflect/Method (Operation Evaluation))
(function (_ method)
(do @
- [passes? (check-method class method-name method-style arg-classes method)]
+ [passes? (check-method class method-name method-style inputsJT method)]
(:: @ map (if passes?
(|>> #Pass)
(|>> #Hint))
@@ -1169,15 +1189,15 @@
(wrap method)
#.Nil
- (/////analysis.throw ..no-candidates [class-name method-name arg-classes (list.search-all hint! candidates)])
+ (/////analysis.throw ..no-candidates [class-name method-name inputsJT (list.search-all hint! candidates)])
candidates
- (/////analysis.throw ..too-many-candidates [class-name method-name arg-classes candidates]))))
+ (/////analysis.throw ..too-many-candidates [class-name method-name inputsJT candidates]))))
(def: constructor-method "<init>")
-(def: (constructor-candidate class-name arg-classes)
- (-> Text (List Text) (Operation Method-Signature))
+(def: (constructor-candidate class-name inputsJT)
+ (-> Text (List (Type Value)) (Operation Method-Signature))
(do ////.monad
[class (////.lift (reflection!.load class-name))
candidates (|> class
@@ -1185,7 +1205,7 @@
array.to-list
(monad.map @ (function (_ constructor)
(do @
- [passes? (check-constructor class arg-classes constructor)]
+ [passes? (check-constructor class inputsJT constructor)]
(:: @ map
(if passes? (|>> #Pass) (|>> #Hint))
(constructor-signature constructor))))))]
@@ -1194,33 +1214,44 @@
(wrap constructor)
#.Nil
- (/////analysis.throw ..no-candidates [class-name ..constructor-method arg-classes (list.search-all hint! candidates)])
+ (/////analysis.throw ..no-candidates [class-name ..constructor-method inputsJT (list.search-all hint! candidates)])
candidates
- (/////analysis.throw ..too-many-candidates [class-name ..constructor-method arg-classes candidates]))))
+ (/////analysis.throw ..too-many-candidates [class-name ..constructor-method inputsJT candidates]))))
-(def: typed-input
- (Parser [Text Code])
- (<c>.tuple (<>.and <c>.text <c>.any)))
+(template [<name> <category> <parser>]
+ [(def: #export <name>
+ (Parser (Type <category>))
+ (<t>.embed <parser> <c>.text))]
+
+ [var Var jvm-parser.var]
+ [class Class jvm-parser.class]
+ [type Value jvm-parser.value]
+ [return Return jvm-parser.return]
+ )
+
+(def: input
+ (Parser (Typed Code))
+ (<c>.tuple (<>.and ..type <c>.any)))
(def: (decorate-inputs typesT inputsA)
- (-> (List Text) (List Analysis) (List Analysis))
+ (-> (List (Type Value)) (List Analysis) (List Analysis))
(|> inputsA
- (list.zip2 (list@map (|>> /////analysis.text) typesT))
+ (list.zip2 (list@map (|>> ..signature /////analysis.text) typesT))
(list@map (function (_ [type value])
(/////analysis.tuple (list type value))))))
(def: invoke::static
Handler
(..custom
- [($_ <>.and ..member (<>.some ..typed-input))
+ [($_ <>.and ..member (<>.some ..input))
(function (_ extension-name analyse [[class method] argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Static argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))
outputJC (check-return outputT)]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
(/////analysis.text method)
(/////analysis.text (..signature outputJC))
(decorate-inputs argsT argsA))))))]))
@@ -1228,7 +1259,7 @@
(def: invoke::virtual
Handler
(..custom
- [($_ <>.and ..member <c>.any (<>.some ..typed-input))
+ [($_ <>.and ..member <c>.any (<>.some ..input))
(function (_ extension-name analyse [[class method] objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
@@ -1241,7 +1272,7 @@
_
(undefined))]
outputJC (check-return outputT)]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
(/////analysis.text method)
(/////analysis.text (..signature outputJC))
objectA
@@ -1250,14 +1281,14 @@
(def: invoke::special
Handler
(..custom
- [($_ <>.and ..member <c>.any (<>.some ..typed-input))
+ [($_ <>.and ..member <c>.any (<>.some ..input))
(function (_ extension-name analyse [[class method] objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (method-candidate class method #Special argsT)
[outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC)))
outputJC (check-return outputT)]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
(/////analysis.text method)
(/////analysis.text (..signature outputJC))
(decorate-inputs argsT argsA))))))]))
@@ -1265,7 +1296,7 @@
(def: invoke::interface
Handler
(..custom
- [($_ <>.and ..member <c>.any (<>.some ..typed-input))
+ [($_ <>.and ..member <c>.any (<>.some ..input))
(function (_ extension-name analyse [[class-name method] objectC argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
@@ -1282,7 +1313,7 @@
(undefined))]
outputJC (check-return outputT)]
(wrap (#/////analysis.Extension extension-name
- (list& (/////analysis.text class-name)
+ (list& (/////analysis.text (..signature (jvm.class class-name (list))))
(/////analysis.text method)
(/////analysis.text (..signature outputJC))
objectA
@@ -1290,27 +1321,27 @@
(def: invoke::constructor
(..custom
- [($_ <>.and <c>.text (<>.some ..typed-input))
+ [($_ <>.and <c>.text (<>.some ..input))
(function (_ extension-name analyse [class argsTC])
(do ////.monad
[#let [argsT (list@map product.left argsTC)]
[methodT exceptionsT] (constructor-candidate class argsT)
[outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))]
- (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class)
+ (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text (..signature (jvm.class class (list))))
(decorate-inputs argsT argsA))))))]))
(def: bundle::member
Bundle
(<| (///bundle.prefix "member")
(|> ///bundle.empty
- (dictionary.merge (<| (///bundle.prefix "static")
+ (dictionary.merge (<| (///bundle.prefix "get")
(|> ///bundle.empty
- (///bundle.install "get" static::get)
- (///bundle.install "put" static::put))))
- (dictionary.merge (<| (///bundle.prefix "virtual")
+ (///bundle.install "static" get::static)
+ (///bundle.install "virtual" get::virtual))))
+ (dictionary.merge (<| (///bundle.prefix "put")
(|> ///bundle.empty
- (///bundle.install "get" virtual::get)
- (///bundle.install "put" virtual::put))))
+ (///bundle.install "static" put::static)
+ (///bundle.install "virtual" put::virtual))))
(dictionary.merge (<| (///bundle.prefix "invoke")
(|> ///bundle.empty
(///bundle.install "static" invoke::static)
@@ -1321,21 +1352,6 @@
)))
)))
-(template [<name> <category> <parser>]
- [(def: #export <name>
- (Parser (Type <category>))
- (<t>.embed <parser> <c>.text))]
-
- [var Var jvm-parser.var]
- [class Class jvm-parser.class]
- [type Value jvm-parser.value]
- [return Return jvm-parser.return]
- )
-
-(def: #export typed
- (Parser (Typed Code))
- (<c>.tuple (<>.and ..type <c>.any)))
-
(type: #export (Annotation-Parameter a)
[Text a])
@@ -1491,7 +1507,7 @@
(<c>.tuple (<>.some ..class))
<c>.text
(<c>.tuple (<>.some ..argument))
- (<c>.tuple (<>.some ..typed))
+ (<c>.tuple (<>.some ..input))
<c>.any)))
(def: #export (analyse-constructor-method analyse selfT mapping method)
@@ -1825,7 +1841,7 @@
(<c>.tuple (<>.some ..var))
..class
(<c>.tuple (<>.some ..class))
- (<c>.tuple (<>.some ..typed))
+ (<c>.tuple (<>.some ..input))
(<c>.tuple (<>.some ..overriden-method-definition)))
(function (_ extension-name analyse [parameters
super-class
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 09:31:57 +0000