aboutsummaryrefslogtreecommitdiff
path: root/stdlib/source
diff options
context:
space:
mode:
Diffstat (limited to 'stdlib/source')
-rw-r--r--stdlib/source/lux/host.jvm.lux1
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux164
2 files changed, 129 insertions, 36 deletions
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index 0c15560c0..d4eb214e7 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -1306,6 +1306,7 @@
[])))
)}
(wrap (list (` ("jvm class anonymous"
+ [(~+ (list@map var$ class-vars))]
(~ (class$ super))
[(~+ (list@map class$ interfaces))]
[(~+ (list@map constructor-arg$ constructor-args))]
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 a013c564e..94aec9628 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -1439,9 +1439,12 @@
)
(template [<name>]
- [(exception: #export (<name> {methods (List Text)})
+ [(exception: #export (<name> {methods (List [Text Method])})
(exception.report
- ["Methods" (exception.enumerate %t methods)]))]
+ ["Methods" (exception.enumerate
+ (function (_ [name method])
+ (format (%t name) " " (jvm.method-signature method)))
+ methods)]))]
[missing-abstract-methods]
[invalid-overriden-methods]
@@ -1811,30 +1814,132 @@
(type: #export (Method-Definition a)
(#Overriden-Method (Overriden-Method a)))
+(def: #export parameter-types
+ (-> (List Var) (Check (List [Var .Type])))
+ (monad.map check.monad
+ (function (_ parameterJ)
+ (do check.monad
+ [[_ parameterT] check.existential]
+ (wrap [parameterJ parameterT])))))
+
+(def: (mismatched-methods super-set sub-set)
+ (-> (List [Text Method]) (List [Text Method]) (List [Text Method]))
+ (list.filter (function (_ [sub-name subJT])
+ (|> super-set
+ (list.filter (function (_ [super-name superJT])
+ (and (text@= super-name sub-name)
+ (method@= superJT subJT))))
+ list.size
+ (n/= 1)
+ not))
+ sub-set))
+
+(exception: #export (class-parameter-mismatch {expected (List Text)}
+ {actual (List jvm.Generic)})
+ (exception.report
+ ["Expected (amount)" (%n (list.size expected))]
+ ["Expected (parameters)" (exception.enumerate %t expected)]
+ ["Actual (amount)" (%n (list.size actual))]
+ ["Actual (parameters)" (exception.enumerate (|>> #jvm.Generic jvm.signature) actual)]))
+
+(type: Renamer (Dictionary Text Text))
+
+(def: (re-map-super [name actual-parameters])
+ (-> Class (Operation Renamer))
+ (do ////.monad
+ [class (////.lift (reflection!.load name))
+ #let [expected-parameters (|> (java/lang/Class::getTypeParameters class)
+ array.to-list
+ (list@map (|>> java/lang/reflect/TypeVariable::getName)))]
+ _ (////.assert ..class-parameter-mismatch [expected-parameters actual-parameters]
+ (n/= (list.size expected-parameters)
+ (list.size actual-parameters)))]
+ (wrap (|> (list.zip2 expected-parameters actual-parameters)
+ (list@fold (function (_ [expected actual] mapping)
+ (case actual
+ (#jvm.Var actual)
+ (dictionary.put actual expected mapping)
+
+ _
+ mapping))
+ (dictionary.new text.hash))))))
+
+(def: (re-map-generic mapping generic)
+ (-> Renamer jvm.Generic jvm.Generic)
+ (case generic
+ (#jvm.Var var)
+ (#jvm.Var (|> mapping (dictionary.get var) (maybe.default var)))
+
+ (#jvm.Wildcard wildcard)
+ (case wildcard
+ #.None
+ generic
+
+ (#.Some [bound limit])
+ (#jvm.Wildcard (#.Some [bound (re-map-generic mapping limit)])))
+
+ (#jvm.Class name parameters)
+ (#jvm.Class name (list@map (re-map-generic mapping) parameters))))
+
+(def: (re-map-type mapping type)
+ (-> Renamer jvm.Type jvm.Type)
+ (case type
+ (#jvm.Primitive primitive)
+ type
+
+ (#jvm.Generic generic)
+ (#jvm.Generic (re-map-generic mapping generic))
+
+ (#jvm.Array type)
+ (#jvm.Array (re-map-type mapping type))))
+
+(def: (re-map-return mapping return)
+ (-> Renamer jvm.Return jvm.Return)
+ (case return
+ #.None
+ return
+
+ (#.Some return)
+ (#.Some (re-map-type mapping return))))
+
+(def: (re-map-method mapping [inputs output exceptions])
+ (-> Renamer jvm.Method jvm.Method)
+ [(list@map (re-map-type mapping) inputs)
+ (re-map-return mapping output)
+ (list@map (re-map-generic mapping) exceptions)])
+
(def: class::anonymous
Handler
(..custom
[($_ <>.and
+ (<c>.tuple (<>.some ..var))
..class
(<c>.tuple (<>.some ..class))
(<c>.tuple (<>.some ..typed))
(<c>.tuple (<>.some ..overriden-method-definition)))
- (function (_ extension-name analyse [super-class
+ (function (_ extension-name analyse [parameters
+ super-class
super-interfaces
constructor-args
methods])
(do ////.monad
- [name (///.lift (do macro.monad
+ [parameters (typeA.with-env
+ (..parameter-types parameters))
+ #let [mapping (list@fold (function (_ [parameterJ parameterT] mapping)
+ (dictionary.put parameterJ parameterT mapping))
+ luxT.fresh
+ parameters)]
+ name (///.lift (do macro.monad
[where macro.current-module-name
id macro.count]
(wrap (format (text.replace-all .module-separator ..jvm-package-separator where)
..jvm-package-separator
"anonymous-class" (%n id)))))
super-classT (typeA.with-env
- (luxT.class luxT.fresh super-class))
+ (luxT.class mapping super-class))
super-interfaceT+ (typeA.with-env
(monad.map check.monad
- (luxT.class luxT.fresh)
+ (luxT.class mapping)
super-interfaces))
#let [selfT (inheritance-relationship-type (#.Primitive name (list))
super-classT
@@ -1842,44 +1947,31 @@
constructor-argsA+ (monad.map @ (function (_ [type term])
(do @
[argT (typeA.with-env
- (luxT.type luxT.fresh type))
+ (luxT.type mapping type))
termA (typeA.with-type argT
(analyse term))]
(wrap [type termA])))
constructor-args)
- methodsA (monad.map @ (analyse-overriden-method analyse selfT luxT.fresh) methods)
+ methodsA (monad.map @ (analyse-overriden-method analyse selfT mapping) methods)
required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces)))
available-methods (////.lift (all-methods (list& super-class super-interfaces)))
- #let [overriden-methods (list@map (function (_ [parent-type method-name
- strict-fp? annotations vars
- self-name arguments return exceptions
- body])
- [method-name (jvm.method (list@map product.right arguments)
- return
- (list@map (|>> #jvm.Class) exceptions))])
- methods)
- missing-abstract-methods (list.filter (function (_ [abstract-method-name abstract-methodJT])
- (|> overriden-methods
- (list.filter (function (_ [method-name methodJT])
- (and (text@= method-name abstract-method-name)
- (method@= abstract-methodJT methodJT))))
- list.size
- (n/= 1)
- not))
- required-abstract-methods)
- invalid-overriden-methods (list.filter (function (_ [method-name methodJT])
- (|> available-methods
- (list.filter (function (_ [abstract-method-name abstract-methodJT])
- (and (text@= method-name abstract-method-name)
- (method@= abstract-methodJT methodJT))))
- list.size
- (n/= 1)
- not))
- overriden-methods)]
+ overriden-methods (monad.map @ (function (_ [parent-type method-name
+ strict-fp? annotations vars
+ self-name arguments return exceptions
+ body])
+ (do @
+ [re-mapping (re-map-super parent-type)]
+ (wrap [method-name (re-map-method re-mapping
+ (jvm.method (list@map product.right arguments)
+ return
+ (list@map (|>> #jvm.Class) exceptions)))])))
+ methods)
+ #let [missing-abstract-methods (mismatched-methods overriden-methods required-abstract-methods)
+ invalid-overriden-methods (mismatched-methods available-methods overriden-methods)]
_ (typeA.infer selfT)
- _ (////.assert ..missing-abstract-methods (list@map product.left missing-abstract-methods)
+ _ (////.assert ..missing-abstract-methods missing-abstract-methods
(list.empty? missing-abstract-methods))
- _ (////.assert ..invalid-overriden-methods (list@map product.left invalid-overriden-methods)
+ _ (////.assert ..invalid-overriden-methods invalid-overriden-methods
(list.empty? invalid-overriden-methods))]
(wrap (#/////analysis.Extension extension-name
(list (/////analysis.text name)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-09 08:34:54 +0000