aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux87
-rw-r--r--stdlib/source/lux/target/jvm/type.lux21
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux465
3 files changed, 399 insertions, 174 deletions
diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
index dfcbd8f84..b3d6281c8 100644
--- a/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
+++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/host.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- Type int char)
+ [lux (#- Type primitive int char)
[abstract
["." monad (#+ do)]]
[control
@@ -21,7 +21,7 @@
["." set]]]
[target
[jvm
- ["_t" type (#+ Primitive Type Method)]]]
+ ["_t" type (#+ Primitive Bound Generic Class Type Method Var Typed Argument Return)]]]
[tool
[compiler
[analysis (#+ Environment)]
@@ -831,14 +831,58 @@
(#error.Failure error)
(phase.throw extension.invalid-syntax [extension-name %synthesis input]))))
+(def: var
+ (<s>.Parser Var)
+ <s>.text)
+
+(def: bound
+ (<s>.Parser Bound)
+ (<>.or (<s>.constant! ["" ">"])
+ (<s>.constant! ["" "<"])))
+
+(def: (class' generic)
+ (-> (<s>.Parser Generic) (<s>.Parser Class))
+ (<s>.tuple (<>.and <s>.text (<>.some generic))))
+
+(def: generic
+ (<s>.Parser Generic)
+ (<>.rec
+ (function (_ generic)
+ (let [wildcard (<>.or (<s>.constant! ["" "?"])
+ (<s>.tuple (<>.and ..bound generic)))]
+ ($_ <>.or
+ ..var
+ wildcard
+ (class' generic))))))
+
+(def: class
+ (<s>.Parser Class)
+ (class' ..generic))
+
+(def: primitive
+ (<s>.Parser Primitive)
+ ($_ <>.or
+ (<s>.constant! ["" "boolean"])
+ (<s>.constant! ["" "byte"])
+ (<s>.constant! ["" "short"])
+ (<s>.constant! ["" "int"])
+ (<s>.constant! ["" "long"])
+ (<s>.constant! ["" "float"])
+ (<s>.constant! ["" "double"])
+ (<s>.constant! ["" "char"])
+ ))
+
(def: jvm-type
- (<s>.Parser /.JVM-Type)
+ (<s>.Parser Type)
(<>.rec
(function (_ jvm-type)
- (<s>.tuple (<>.and <s>.text (<>.some jvm-type))))))
+ ($_ <>.or
+ ..primitive
+ ..generic
+ (<s>.tuple jvm-type)))))
(def: constructor-arg
- (<s>.Parser (/.Constructor-Argument Synthesis))
+ (<s>.Parser (Typed Synthesis))
(<s>.tuple (<>.and ..jvm-type <s>.any)))
(def: annotation-parameter
@@ -849,31 +893,32 @@
(<s>.Parser (/.Annotation Synthesis))
(<s>.tuple (<>.and <s>.text (<>.some ..annotation-parameter))))
-(def: type-parameter
- (<s>.Parser /.Type-Parameter)
- <s>.text)
-
(def: argument
- (<s>.Parser /.Argument)
+ (<s>.Parser Argument)
(<s>.tuple (<>.and <s>.text ..jvm-type)))
+(def: return
+ (<s>.Parser Return)
+ (<>.or (<s>.constant! ["" "void"])
+ ..jvm-type))
+
(def: overriden-method-definition
(<s>.Parser [Environment (/.Overriden-Method Synthesis)])
(<s>.tuple (do <>.monad
- [ownerT ..jvm-type
+ [ownerT ..class
name <s>.text
strict-fp? <s>.bit
annotations (<s>.tuple (<>.some ..annotation))
- type-parameters (<s>.tuple (<>.some ..type-parameter))
+ vars (<s>.tuple (<>.some ..var))
self-name <s>.text
arguments (<s>.tuple (<>.some ..argument))
- returnT ..jvm-type
- exceptionsT (<s>.tuple (<>.some ..jvm-type))
+ returnT ..return
+ exceptionsT (<s>.tuple (<>.some ..class))
[environment body] (<s>.function 1
(<s>.tuple <s>.any))]
(wrap [environment
[ownerT name
- strict-fp? annotations type-parameters
+ strict-fp? annotations vars
self-name arguments returnT exceptionsT
body]]))))
@@ -955,8 +1000,8 @@
(..custom
[($_ <>.and
<s>.text
- ..jvm-type
- (<s>.tuple (<>.some ..jvm-type))
+ ..class
+ (<s>.tuple (<>.some ..class))
(<s>.tuple (<>.some ..constructor-arg))
(<s>.tuple (<>.some ..overriden-method-definition)))
(function (_ extension-name generate [class-name
@@ -979,7 +1024,7 @@
(dictionary.from-list reference.hash))
normalized-methods (list@map (function (_ [environment
[ownerT name
- strict-fp? annotations type-parameters
+ strict-fp? annotations vars
self-name arguments returnT exceptionsT
body]])
(let [local-mapping (|> environment
@@ -991,7 +1036,7 @@
maybe.assume)]))
(dictionary.from-list reference.hash))]
[ownerT name
- strict-fp? annotations type-parameters
+ strict-fp? annotations vars
self-name arguments returnT exceptionsT
(normalize-method-body local-mapping body)]))
overriden-methods)]
@@ -1004,7 +1049,7 @@
_ (phase.throw extension.invalid-syntax ["YOLO-TRON" %synthesis (list)])]
(wrap _.DUP)))]))
-(def: class
+(def: bundle::class
Bundle
(<| (bundle.prefix "class")
(|> (: Bundle bundle.empty)
@@ -1023,5 +1068,5 @@
(dictionary.merge ..array)
(dictionary.merge ..object)
(dictionary.merge ..member)
- (dictionary.merge ..class)
+ (dictionary.merge ..bundle::class)
)))
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index 23925e468..e6532fe0d 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -22,8 +22,8 @@
(def: object-class "java.lang.Object")
(type: #export Bound
- #Upper
- #Lower)
+ #Lower
+ #Upper)
(type: #export Primitive
#Boolean
@@ -35,10 +35,12 @@
#Double
#Char)
+(type: #export Var Text)
+
(type: #export #rec Generic
- (#Var Text)
+ (#Var Var)
(#Wildcard (Maybe [Bound Generic]))
- (#Class Text (List Generic)))
+ (#Class [Text (List Generic)]))
(type: #export Class
[Text (List Generic)])
@@ -51,11 +53,20 @@
(#Generic Generic)
(#Array Type))
+(type: #export Argument
+ [Text Type])
+
+(type: #export Return
+ (Maybe Type))
+
(type: #export Method
{#args (List Type)
- #return (Maybe Type)
+ #return Return
#exceptions (List Generic)})
+(type: #export (Typed a)
+ [Type a])
+
(template [<name> <primitive>]
[(def: #export <name> Type (#Primitive <primitive>))]
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 a9417050a..69e80d89f 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -1,5 +1,5 @@
(.module:
- [lux (#- char int)
+ [lux (#- Type primitive type char int)
["." host (#+ import:)]
["." macro]
[abstract
@@ -20,10 +20,10 @@
["." array (#+ Array)]
["." dictionary (#+ Dictionary)]]]
["." type
- ["." check]]
+ ["." check (#+ Check) ("#@." monad)]]
[target
[jvm
- ["_." type]]]]
+ ["_." type (#+ Var Bound Primitive Generic Class Type Argument Return Typed)]]]]
["." // #_
["#." common]
["/#" //
@@ -39,10 +39,20 @@
(def: inheritance-relationship-type-name "_jvm_inheritance")
(def: (inheritance-relationship-type class super-class super-interfaces)
- (-> Type Type (List Type) Type)
+ (-> .Type .Type (List .Type) .Type)
(#.Primitive ..inheritance-relationship-type-name
(list& class super-class super-interfaces)))
+(template [<label> <constant> <function>]
+ [(def: <constant> <label>)
+ (def: (<function> class)
+ (-> .Type .Type)
+ (#.Primitive <constant> (list class)))]
+
+ ["_jvm_lower" lower-relationship-name lower-relationship-type]
+ ["_jvm_upper" upper-relationship-name upper-relationship-type]
+ )
+
(def: (custom [syntax handler])
(All [s]
(-> [(Parser s)
@@ -65,8 +75,8 @@
($_ p.and s.text s.text))
(type: Method-Signature
- {#method Type
- #exceptions (List Type)})
+ {#method .Type
+ #exceptions (List .Type)})
(import: #long java/lang/reflect/Type
(getTypeName [] String))
@@ -83,7 +93,7 @@
)
(template [<name>]
- [(exception: #export (<name> {type Type})
+ [(exception: #export (<name> {type .Type})
(exception.report
["Type" (%type type)]))]
@@ -130,7 +140,7 @@
[too-many-candidates]
)
-(exception: #export (cannot-cast {from Type} {to Type} {value Code})
+(exception: #export (cannot-cast {from .Type} {to .Type} {value Code})
(exception.report
["From" (%type from)]
["To" (%type to)]
@@ -154,7 +164,7 @@
## TODO: Get rid of this template block and use the definition in
## lux/host.jvm.lux ASAP
(template [<name> <class>]
- [(type: #export <name> (primitive <class>))]
+ [(type: #export <name> (.primitive <class>))]
## Boxes
[Boolean "java.lang.Boolean"]
@@ -270,7 +280,7 @@
(dictionary.from-list text.hash)))
(def: (array-type-info allow-primitives? arrayT)
- (-> Bit Type (Operation [Nat Text]))
+ (-> Bit .Type (Operation [Nat Text]))
(loop [level 0
currentT arrayT]
(case currentT
@@ -307,10 +317,10 @@
(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 varT))
(analyse arrayC))
varT (typeA.with-env (check.clean varT))
- [array-nesting elem-class] (array-type-info true (type (Array 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)
arrayA))))
@@ -319,7 +329,7 @@
(/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
(def: (new-primitive-array-handler primitive-type)
- (-> _type.Type Handler)
+ (-> Type Handler)
(function (_ extension-name analyse args)
(case args
(^ (list lengthC))
@@ -353,7 +363,7 @@
(/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)]))))
(def: (check-jvm objectT)
- (-> Type (Operation Text))
+ (-> .Type (Operation Text))
(case objectT
(#.Primitive name _)
(////@wrap name)
@@ -385,7 +395,7 @@
(/////analysis.throw non-object objectT)))
(def: (check-object objectT)
- (-> Type (Operation Text))
+ (-> .Type (Operation Text))
(do ////.monad
[name (check-jvm objectT)]
(if (dictionary.contains? name boxes)
@@ -393,7 +403,7 @@
(////@wrap name))))
(def: (read-primitive-array-handler lux-type jvm-type)
- (-> Type _type.Type Handler)
+ (-> .Type Type Handler)
(function (_ extension-name analyse args)
(case args
(^ (list idxC arrayC))
@@ -416,7 +426,7 @@
(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 varT))
(analyse arrayC))
varT (typeA.with-env
(check.clean varT))
@@ -432,7 +442,7 @@
(/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))
(def: (write-primitive-array-handler lux-type jvm-type)
- (-> Type _type.Type Handler)
+ (-> .Type Type Handler)
(let [array-type (#.Primitive (_type.descriptor (_type.array 1 jvm-type)) (list))]
(function (_ extension-name analyse args)
(case args
@@ -459,8 +469,8 @@
(^ (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 varT)))
+ arrayA (typeA.with-type (.type (Array varT))
(analyse arrayC))
varT (typeA.with-env
(check.clean varT))
@@ -714,17 +724,17 @@
## else
(/////analysis.throw cannot-convert-to-a-class jvm-type)))
-(type: Mappings
- (Dictionary Text Type))
+(type: Mapping
+ (Dictionary Var .Type))
-(def: fresh-mappings Mappings (dictionary.new text.hash))
+(def: fresh-mapping Mapping (dictionary.new text.hash))
-(def: (java-type-to-lux-type mappings java-type)
- (-> Mappings java/lang/reflect/Type (Operation Type))
+(def: (java-type-to-lux-type mapping java-type)
+ (-> Mapping java/lang/reflect/Type (Operation .Type))
(<| (case (host.check TypeVariable java-type)
(#.Some java-type)
(let [var-name (TypeVariable::getName java-type)]
- (case (dictionary.get var-name mappings)
+ (case (dictionary.get var-name mapping)
(#.Some var-type)
(////@wrap var-type)
@@ -737,7 +747,7 @@
(case [(array.read 0 (WildcardType::getUpperBounds java-type))
(array.read 0 (WildcardType::getLowerBounds java-type))]
(^or [(#.Some bound) _] [_ (#.Some bound)])
- (java-type-to-lux-type mappings bound)
+ (java-type-to-lux-type mapping bound)
_
(////@wrap Any))
@@ -768,7 +778,7 @@
[paramsT (|> java-type
ParameterizedType::getActualTypeArguments
array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))]
+ (monad.map @ (java-type-to-lux-type mapping)))]
(////@wrap (#.Primitive (java/lang/Class::getName (:coerce (java/lang/Class java/lang/Object) raw))
paramsT)))
@@ -781,7 +791,7 @@
(do ////.monad
[innerT (|> java-type
GenericArrayType::getGenericComponentType
- (java-type-to-lux-type mappings))]
+ (java-type-to-lux-type mapping))]
(wrap (#.Primitive array.type-name (list innerT))))
_)
@@ -789,7 +799,7 @@
(/////analysis.throw cannot-convert-to-a-lux-type java-type)))
(def: (correspond-type-params class type)
- (-> (java/lang/Class java/lang/Object) Type (Operation Mappings))
+ (-> (java/lang/Class java/lang/Object) .Type (Operation Mapping))
(case type
(#.Primitive name params)
(let [class-name (java/lang/Class::getName class)
@@ -818,7 +828,7 @@
(/////analysis.throw non-jvm-type type)))
(def: (class-candiate-parents from-name fromT to-name to-class)
- (-> Text Type Text (java/lang/Class java/lang/Object) (Operation (List [[Text Type] Bit])))
+ (-> Text .Type Text (java/lang/Class java/lang/Object) (Operation (List [[Text .Type] Bit])))
(do ////.monad
[from-class (load-class from-name)
mapping (correspond-type-params from-class fromT)]
@@ -837,7 +847,7 @@
(array.to-list (java/lang/Class::getGenericInterfaces from-class))))))
(def: (inheritance-candiate-parents fromT to-class toT fromC)
- (-> Type (java/lang/Class java/lang/Object) Type Code (Operation (List [[Text Type] Bit])))
+ (-> .Type (java/lang/Class java/lang/Object) .Type Code (Operation (List [[Text .Type] Bit])))
(case fromT
(^ (#.Primitive _ (list& self-classT super-classT super-interfacesT+)))
(monad.map ////.monad
@@ -895,7 +905,7 @@
(if (text@= to-name current-name)
(wrap #1)
(do @
- [candiate-parents (: (Operation (List [[Text Type] Bit]))
+ [candiate-parents (: (Operation (List [[Text .Type] Bit]))
(if (text@= ..inheritance-relationship-type-name current-name)
(inheritance-candiate-parents currentT to-class toT fromC)
(class-candiate-parents current-name currentT to-name to-class)))]
@@ -948,14 +958,14 @@
(/////analysis.throw unknown-field [class-name field-name]))))
(def: (static-field class-name field-name)
- (-> Text Text (Operation [Type Text Bit]))
+ (-> Text Text (Operation [.Type Text Bit]))
(do ////.monad
[[class fieldJ] (find-field class-name field-name)
#let [modifiers (Field::getModifiers fieldJ)]]
(if (Modifier::isStatic modifiers)
(let [fieldJT (Field::getGenericType fieldJ)]
(do @
- [fieldT (java-type-to-lux-type fresh-mappings fieldJT)
+ [fieldT (java-type-to-lux-type fresh-mapping fieldJT)
unboxed (java-type-to-class fieldJT)]
(wrap [fieldT unboxed (Modifier::isFinal modifiers)])))
(/////analysis.throw ..not-a-static-field [class-name field-name]))))
@@ -995,7 +1005,7 @@
(/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)]))))
(def: (virtual-field class-name field-name objectT)
- (-> Text Text Type (Operation [Type Bit]))
+ (-> Text Text .Type (Operation [.Type Bit]))
(do ////.monad
[[class fieldJ] (find-field class-name field-name)
#let [modifiers (Field::getModifiers fieldJ)]]
@@ -1006,24 +1016,24 @@
java/lang/Class::getTypeParameters
array.to-list
(list@map (|>> TypeVariable::getName)))]
- mappings (: (Operation Mappings)
- (case objectT
- (#.Primitive _class-name _class-params)
- (do @
- [#let [num-params (list.size _class-params)
- num-vars (list.size var-names)]
- _ (////.assert type-parameter-mismatch
- (format "Expected: " (%i (.int num-params)) text.new-line
- " Actual: " (%i (.int num-vars)) text.new-line
- " Class: " _class-name text.new-line
- " Type: " (%type objectT))
- (n/= num-params num-vars))]
- (wrap (|> (list.zip2 var-names _class-params)
- (dictionary.from-list text.hash))))
-
- _
- (/////analysis.throw non-object objectT)))
- fieldT (java-type-to-lux-type mappings fieldJT)]
+ mapping (: (Operation Mapping)
+ (case objectT
+ (#.Primitive _class-name _class-params)
+ (do @
+ [#let [num-params (list.size _class-params)
+ num-vars (list.size var-names)]
+ _ (////.assert type-parameter-mismatch
+ (format "Expected: " (%i (.int num-params)) text.new-line
+ " Actual: " (%i (.int num-vars)) text.new-line
+ " Class: " _class-name text.new-line
+ " Type: " (%type objectT))
+ (n/= num-params num-vars))]
+ (wrap (|> (list.zip2 var-names _class-params)
+ (dictionary.from-list text.hash))))
+
+ _
+ (/////analysis.throw non-object objectT)))
+ fieldT (java-type-to-lux-type mapping fieldJT)]
(wrap [fieldT (Modifier::isFinal modifiers)]))
(/////analysis.throw not-a-virtual-field [class-name field-name]))))
@@ -1155,11 +1165,11 @@
(list.zip2 arg-classes parameters))))))
(def: idx-to-parameter
- (-> Nat Type)
+ (-> Nat .Type)
(|>> (n/* 2) inc #.Parameter))
-(def: (jvm-type-var-mappings owner-tvars method-tvars)
- (-> (List Text) (List Text) [(List Type) Mappings])
+(def: (jvm-type-var-mapping owner-tvars method-tvars)
+ (-> (List Text) (List Text) [(List .Type) Mapping])
(let [jvm-tvars (list@compose owner-tvars method-tvars)
lux-tvars (|> jvm-tvars
list.reverse
@@ -1169,8 +1179,8 @@
list.reverse)
num-owner-tvars (list.size owner-tvars)
owner-tvarsT (|> lux-tvars (list.take num-owner-tvars) (list@map product.right))
- mappings (dictionary.from-list text.hash lux-tvars)]
- [owner-tvarsT mappings]))
+ mapping (dictionary.from-list text.hash lux-tvars)]
+ [owner-tvarsT mapping]))
(def: (method-signature method-style method)
(-> Method-Style Method (Operation Method-Signature))
@@ -1186,16 +1196,16 @@
method-tvars (|> (Method::getTypeParameters method)
array.to-list
(list@map (|>> TypeVariable::getName)))
- [owner-tvarsT mappings] (jvm-type-var-mappings owner-tvars method-tvars)]
+ [owner-tvarsT mapping] (jvm-type-var-mapping owner-tvars method-tvars)]
(do ////.monad
[inputsT (|> (Method::getGenericParameterTypes method)
array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
- outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method))
+ (monad.map @ (java-type-to-lux-type mapping)))
+ outputT (java-type-to-lux-type mapping (Method::getGenericReturnType method))
exceptionsT (|> (Method::getGenericExceptionTypes method)
array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
- #let [methodT (<| (type.univ-q (dictionary.size mappings))
+ (monad.map @ (java-type-to-lux-type mapping)))
+ #let [methodT (<| (type.univ-q (dictionary.size mapping))
(type.function (case method-style
#Static
inputsT
@@ -1215,16 +1225,16 @@
method-tvars (|> (Constructor::getTypeParameters constructor)
array.to-list
(list@map (|>> TypeVariable::getName)))
- [owner-tvarsT mappings] (jvm-type-var-mappings owner-tvars method-tvars)]
+ [owner-tvarsT mapping] (jvm-type-var-mapping owner-tvars method-tvars)]
(do ////.monad
[inputsT (|> (Constructor::getGenericParameterTypes constructor)
array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
+ (monad.map @ (java-type-to-lux-type mapping)))
exceptionsT (|> (Constructor::getGenericExceptionTypes constructor)
array.to-list
- (monad.map @ (java-type-to-lux-type mappings)))
+ (monad.map @ (java-type-to-lux-type mapping)))
#let [objectT (#.Primitive (java/lang/Class::getName owner) owner-tvarsT)
- constructorT (<| (type.univ-q (dictionary.size mappings))
+ constructorT (<| (type.univ-q (dictionary.size mapping))
(type.function inputsT)
objectT)]]
(wrap [constructorT exceptionsT]))))
@@ -1411,38 +1421,137 @@
)))
)))
-(type: #export #rec JVM-Type
- [Text (List JVM-Type)])
+(def: var
+ (Parser Var)
+ s.text)
-(def: (lux-type [name parameters])
- (-> JVM-Type Type)
- (case [name parameters]
- ["void" #.Nil]
- Any
+(def: bound
+ (Parser Bound)
+ (p.or (s.identifier! ["" ">"])
+ (s.identifier! ["" "<"])))
- [_ #.Nil]
- (case (dictionary.get name boxes)
- (#.Some box)
- (#.Primitive box #.Nil)
+(def: generic
+ (Parser Generic)
+ (p.rec
+ (function (_ generic)
+ (let [wildcard (: (Parser (Maybe [Bound Generic]))
+ (p.or (s.identifier! ["" "?"])
+ (s.form (p.and ..bound generic))))
+ class (: (Parser Class)
+ (s.form (p.and s.text (p.some generic))))]
+ ($_ p.or
+ ..var
+ wildcard
+ class)))))
+
+(def: class
+ (Parser Class)
+ (s.form (p.and s.text (p.some ..generic))))
+
+(exception: #export (unknown-jvm-type-var {var Var})
+ (exception.report
+ ["Var" (%t var)]))
+(def: (generic-type mapping generic)
+ (-> Mapping Generic (Check .Type))
+ (case generic
+ (#_type.Var var)
+ (case (dictionary.get var mapping)
+ #.None
+ (check.throw unknown-jvm-type-var var)
+
+ (#.Some type)
+ (check@wrap type))
+
+ (#_type.Wildcard wildcard)
+ (case wildcard
#.None
- (#.Primitive name #.Nil))
+ (do check.monad
+ [[id type] check.existential]
+ (wrap type))
+
+ (#.Some [bound limit])
+ (do check.monad
+ [limitT (generic-type mapping limit)]
+ (case bound
+ #_type.Lower
+ (wrap (lower-relationship-type limitT))
+
+ #_type.Upper
+ (wrap (upper-relationship-type limitT)))))
- _
- (#.Primitive name (list@map lux-type parameters))))
+ (#_type.Class name parameters)
+ (do check.monad
+ [parametersT+ (monad.map @ (generic-type mapping) parameters)]
+ (wrap (#.Primitive name parametersT+)))))
+
+(def: (class-type mapping [name parameters])
+ (-> Mapping Class (Check .Type))
+ (do check.monad
+ [parametersT+ (monad.map @ (generic-type mapping) parameters)]
+ (wrap (#.Primitive name parametersT+))))
+
+(def: (jvm-type mapping type)
+ (-> Mapping Type (Check .Type))
+ (case type
+ (#_type.Primitive primitive)
+ (check@wrap (case primitive
+ #_type.Boolean ..boolean
+ #_type.Byte ..byte
+ #_type.Short ..short
+ #_type.Int ..int
+ #_type.Long ..long
+ #_type.Float ..float
+ #_type.Double ..double
+ #_type.Char ..char))
+
+ (#_type.Generic generic)
+ (generic-type mapping generic)
+
+ (#_type.Array type)
+ (case type
+ (#_type.Primitive primitive)
+ (check@wrap (#.Primitive (_type.descriptor (_type.array 1 type)) (list)))
-(def: jvm-type
- (Parser JVM-Type)
- (p.rec
- (function (_ jvm-type)
- (s.form (p.and s.text (p.some jvm-type))))))
+ _
+ (do check.monad
+ [elementT (jvm-type mapping type)]
+ (wrap (.type (Array elementT)))))))
-(type: #export (Constructor-Argument a)
- [JVM-Type a])
+(def: (return-type mapping type)
+ (-> Mapping Return (Check .Type))
+ (case type
+ #.None
+ (check@wrap Any)
+
+ (#.Some type)
+ (jvm-type mapping type)))
+
+(def: primitive
+ (Parser Primitive)
+ ($_ p.or
+ (s.identifier! ["" "boolean"])
+ (s.identifier! ["" "byte"])
+ (s.identifier! ["" "short"])
+ (s.identifier! ["" "int"])
+ (s.identifier! ["" "long"])
+ (s.identifier! ["" "float"])
+ (s.identifier! ["" "double"])
+ (s.identifier! ["" "char"])
+ ))
+
+(def: type
+ (Parser Type)
+ (p.rec
+ (function (_ type)
+ ($_ p.or
+ ..primitive
+ ..generic
+ (s.tuple type)))))
-(def: constructor-arg
- (Parser (Constructor-Argument Code))
- (s.tuple (p.and ..jvm-type s.any)))
+(def: typed
+ (Parser (Typed Code))
+ (s.tuple (p.and ..type s.any)))
(type: #export (Annotation-Parameter a)
[Text a])
@@ -1458,29 +1567,25 @@
(Parser (Annotation Code))
(s.form (p.and s.text (p.some ..annotation-parameter))))
-(type: #export Type-Parameter Text)
-
-(def: type-parameter
- (Parser Type-Parameter)
- s.text)
-
-(type: #export Argument
- [Text JVM-Type])
-
(def: argument
(Parser Argument)
- (s.tuple (p.and s.text ..jvm-type)))
+ (s.tuple (p.and s.text ..type)))
+
+(def: return
+ (Parser Return)
+ (p.or (s.identifier! ["" "void"])
+ ..type))
(type: #export (Overriden-Method a)
- [JVM-Type
+ [Class
Text
Bit
(List (Annotation a))
- (List Type-Parameter)
+ (List Var)
Text
(List Argument)
- JVM-Type
- (List JVM-Type)
+ Return
+ (List Class)
a])
(type: #export (Method-Definition a)
@@ -1489,24 +1594,48 @@
(def: overriden-method-definition
(Parser (Overriden-Method Code))
(<| s.form
- (p.after (s.this (` "override")))
+ (p.after (s.text! "override"))
($_ p.and
- ..jvm-type
+ ..class
s.text
s.bit
(s.tuple (p.some ..annotation))
- (s.tuple (p.some ..type-parameter))
+ (s.tuple (p.some ..var))
s.text
(s.tuple (p.some ..argument))
- ..jvm-type
- (s.tuple (p.some ..jvm-type))
+ ..return
+ (s.tuple (p.some ..class))
s.any
)))
-(def: (jvm-type-analysis [name parameters])
- (-> JVM-Type Analysis)
+(def: (generic-analysis generic)
+ (-> Generic Analysis)
+ (case generic
+ (#_type.Var var)
+ (/////analysis.text var)
+
+ (#_type.Wildcard wildcard)
+ (case wildcard
+ #.None
+ (/////analysis.constant ["" "?"])
+
+ (#.Some [bound limit])
+ (/////analysis.tuple (list (case bound
+ #_type.Lower
+ (/////analysis.constant ["" ">"])
+
+ #_type.Upper
+ (/////analysis.constant ["" "<"]))
+ (generic-analysis limit))))
+
+ (#_type.Class name parameters)
+ (/////analysis.tuple (list& (/////analysis.text name)
+ (list@map generic-analysis parameters)))))
+
+(def: (class-analysis [name parameters])
+ (-> Class Analysis)
(/////analysis.tuple (list& (/////analysis.text name)
- (list@map jvm-type-analysis parameters))))
+ (list@map generic-analysis parameters))))
(def: (annotation-parameter-analysis [name value])
(-> (Annotation-Parameter Analysis) Analysis)
@@ -1517,23 +1646,51 @@
(/////analysis.tuple (list& (/////analysis.text name)
(list@map annotation-parameter-analysis parameters))))
-(def: type-parameter-analysis
- (-> Type-Parameter Analysis)
+(def: var-analysis
+ (-> Var Analysis)
/////analysis.text)
-(def: (constructor-arg-analysis [type term])
- (-> (Constructor-Argument Analysis) Analysis)
- (/////analysis.tuple (list (jvm-type-analysis type) term)))
+(def: (type-analysis type)
+ (-> Type Analysis)
+ (case type
+ (#_type.Primitive primitive)
+ (case primitive
+ #_type.Boolean (/////analysis.constant ["" "boolean"])
+ #_type.Byte (/////analysis.constant ["" "byte"])
+ #_type.Short (/////analysis.constant ["" "short"])
+ #_type.Int (/////analysis.constant ["" "int"])
+ #_type.Long (/////analysis.constant ["" "long"])
+ #_type.Float (/////analysis.constant ["" "float"])
+ #_type.Double (/////analysis.constant ["" "double"])
+ #_type.Char (/////analysis.constant ["" "char"]))
+
+ (#_type.Generic generic)
+ (generic-analysis generic)
+
+ (#_type.Array type)
+ (/////analysis.tuple (list (type-analysis type)))))
+
+(def: (return-analysis return)
+ (-> Return Analysis)
+ (case return
+ #.None
+ (/////analysis.constant ["" "void"])
+
+ (#.Some type)
+ (type-analysis type)))
+
+(def: (typed-analysis [type term])
+ (-> (Typed Analysis) Analysis)
+ (/////analysis.tuple (list (type-analysis type) term)))
-(def: lux-module-separator "/")
(def: jvm-package-separator ".")
(def: class::anonymous
Handler
(..custom [($_ p.and
- jvm-type
- (s.tuple (p.some jvm-type))
- (s.tuple (p.some ..constructor-arg))
+ ..class
+ (s.tuple (p.some ..class))
+ (s.tuple (p.some ..typed))
(s.tuple (p.some ..overriden-method-definition)))
(function (_ extension-name analyse [super-class
super-interfaces
@@ -1543,23 +1700,29 @@
[name (///.lift (do macro.monad
[where macro.current-module-name
id macro.count]
- (wrap (format (text.replace-all ..lux-module-separator ..jvm-package-separator where)
+ (wrap (format (text.replace-all .module-separator ..jvm-package-separator where)
..jvm-package-separator
"anonymous-class" (%n id)))))
- #let [super-classT (lux-type super-class)
- super-interfaceT+ (list@map lux-type super-interfaces)
- selfT (inheritance-relationship-type (#.Primitive name (list))
+ super-classT (typeA.with-env
+ (class-type fresh-mapping super-class))
+ super-interfaceT+ (typeA.with-env
+ (monad.map check.monad
+ (class-type fresh-mapping)
+ super-interfaces))
+ #let [selfT (inheritance-relationship-type (#.Primitive name (list))
super-classT
super-interfaceT+)]
- constructor-argsA (monad.map @ (function (_ [jvm-type term])
- (do @
- [termA (typeA.with-type (lux-type jvm-type)
- (analyse term))]
- (wrap [jvm-type termA])))
- constructor-args)
+ constructor-argsA+ (monad.map @ (function (_ [type term])
+ (do @
+ [argT (typeA.with-env
+ (jvm-type fresh-mapping type))
+ termA (typeA.with-type argT
+ (analyse term))]
+ (wrap [type termA])))
+ constructor-args)
methodsA (monad.map @ (function (_ [parent-type method-name
- strict-fp? annotations type-parameters
- self-name arguments return-type exceptions
+ strict-fp? annotations vars
+ self-name arguments return exceptions
body])
(do @
@@ -1572,27 +1735,34 @@
parameters)]
(wrap [name parametersA])))
annotations)
- [scope bodyA] (|> arguments
- (list@map (function (_ [name jvmT])
- [name (lux-type jvmT)]))
+ returnT (typeA.with-env
+ (return-type fresh-mapping return))
+ arguments' (typeA.with-env
+ (monad.map check.monad
+ (function (_ [name jvmT])
+ (do check.monad
+ [luxT (jvm-type fresh-mapping jvmT)]
+ (wrap [name luxT])))
+ arguments))
+ [scope bodyA] (|> arguments'
(#.Cons [self-name selfT])
list.reverse
(list@fold scope.with-local (analyse body))
- (typeA.with-type (lux-type return-type))
+ (typeA.with-type returnT)
/////analysis.with-scope)]
- (wrap (/////analysis.tuple (list (jvm-type-analysis parent-type)
+ (wrap (/////analysis.tuple (list (class-analysis parent-type)
(/////analysis.text method-name)
(/////analysis.bit strict-fp?)
(/////analysis.tuple (list@map annotation-analysis annotationsA))
- (/////analysis.tuple (list@map type-parameter-analysis type-parameters))
+ (/////analysis.tuple (list@map var-analysis vars))
(/////analysis.text self-name)
(/////analysis.tuple (list@map (function (_ [argument argumentJT])
(/////analysis.tuple
(list (/////analysis.text argument)
- (jvm-type-analysis argumentJT))))
+ (type-analysis argumentJT))))
arguments))
- (jvm-type-analysis return-type)
- (/////analysis.tuple (list@map jvm-type-analysis
+ (return-analysis return)
+ (/////analysis.tuple (list@map class-analysis
exceptions))
(#/////analysis.Function
(scope.environment scope)
@@ -1602,10 +1772,9 @@
_ (typeA.infer selfT)]
(wrap (#/////analysis.Extension extension-name
(list (/////analysis.text name)
- (jvm-type-analysis super-class)
- (/////analysis.tuple (list@map jvm-type-analysis super-interfaces))
- (/////analysis.tuple (list@map constructor-arg-analysis
- constructor-argsA))
+ (class-analysis super-class)
+ (/////analysis.tuple (list@map class-analysis super-interfaces))
+ (/////analysis.tuple (list@map typed-analysis constructor-argsA+))
(/////analysis.tuple methodsA))))))]))
(def: bundle::class