aboutsummaryrefslogtreecommitdiff
path: root/stdlib
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/data/collection/list.lux4
-rw-r--r--stdlib/source/lux/data/product.lux12
-rw-r--r--stdlib/source/lux/host.jvm.lux2
-rw-r--r--stdlib/source/lux/target/jvm/reflection.lux22
-rw-r--r--stdlib/source/lux/target/jvm/type.lux84
-rw-r--r--stdlib/source/lux/target/jvm/type/lux.lux4
-rw-r--r--stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux109
7 files changed, 195 insertions, 42 deletions
diff --git a/stdlib/source/lux/data/collection/list.lux b/stdlib/source/lux/data/collection/list.lux
index ff6739076..f03b2bf2e 100644
--- a/stdlib/source/lux/data/collection/list.lux
+++ b/stdlib/source/lux/data/collection/list.lux
@@ -356,8 +356,8 @@
(def: #export (empty? xs)
(All [a] (Predicate (List a)))
(case xs
- #.Nil #1
- _ #0))
+ #.Nil true
+ _ false))
(def: #export (member? eq xs x)
(All [a] (-> (Equivalence a) (List a) a Bit))
diff --git a/stdlib/source/lux/data/product.lux b/stdlib/source/lux/data/product.lux
index bb3191e24..64b84cb3e 100644
--- a/stdlib/source/lux/data/product.lux
+++ b/stdlib/source/lux/data/product.lux
@@ -1,6 +1,8 @@
(.module:
{#.doc "Functionality for working with tuples (particularly 2-tuples)."}
- lux)
+ [lux #*
+ [abstract
+ [equivalence (#+ Equivalence)]]])
(template [<name> <type> <output>]
[(def: #export (<name> xy)
@@ -43,3 +45,11 @@
(-> a [l r])))
(function (_ x)
[(f x) (g x)]))
+
+(structure: #export (equivalence l@= r@=)
+ (All [l r]
+ (-> (Equivalence l) (Equivalence r)
+ (Equivalence [l r])))
+ (def: (= [lP rP] [lS rS])
+ (and (l@= lP lS)
+ (r@= rP rS))))
diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux
index e1735cf8e..6daaf4869 100644
--- a/stdlib/source/lux/host.jvm.lux
+++ b/stdlib/source/lux/host.jvm.lux
@@ -1438,7 +1438,7 @@
(with-gensyms [arg-name]
(wrap [maybe? arg-name]))))
import-member-args)
- #let [arg-classes (list@map (|>> product.right jvm.signature) import-member-args)
+ #let [arg-classes (list@map (|>> product.right jvm.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)]
diff --git a/stdlib/source/lux/target/jvm/reflection.lux b/stdlib/source/lux/target/jvm/reflection.lux
index e65b6061f..afea0b0c2 100644
--- a/stdlib/source/lux/target/jvm/reflection.lux
+++ b/stdlib/source/lux/target/jvm/reflection.lux
@@ -23,7 +23,8 @@
(import: #long java/lang/String)
(import: #long java/lang/Object
- (toString [] java/lang/String))
+ (toString [] java/lang/String)
+ (getClass [] (java/lang/Class java/lang/Object)))
(import: #long java/lang/reflect/Type
(getTypeName [] java/lang/String))
@@ -89,10 +90,10 @@
(template [<name>]
[(exception: #export (<name> {jvm-type java/lang/reflect/Type})
(exception.report
- ["Type" (java/lang/reflect/Type::getTypeName jvm-type)]))]
+ ["Type" (java/lang/reflect/Type::getTypeName jvm-type)]
+ ["Class" (|> jvm-type java/lang/Object::getClass java/lang/Object::toString)]))]
[not-a-class]
- [cannot-convert-to-a-parameter]
[cannot-convert-to-a-lux-type]
)
@@ -120,13 +121,22 @@
_)
(case (host.check java/lang/reflect/WildcardType reflection)
(#.Some reflection)
+ ## TODO: Instead of having single lower/upper bounds, should
+ ## allow for multiple ones.
(case [(array.read 0 (java/lang/reflect/WildcardType::getLowerBounds reflection))
(array.read 0 (java/lang/reflect/WildcardType::getUpperBounds reflection))]
(^template [<pattern> <kind>]
<pattern>
- (do error.monad
- [bound (generic bound)]
- (wrap (#/.Wildcard (#.Some [<kind> bound])))))
+ (case (host.check java/lang/reflect/GenericArrayType bound)
+ (#.Some _)
+ ## TODO: Array bounds should not be "erased" as they
+ ## are right now.
+ (#error.Success (#/.Wildcard #.None))
+
+ _
+ (:: error.monad map
+ (|>> [<kind>] #.Some #/.Wildcard)
+ (generic bound))))
([[_ (#.Some bound)] #/.Upper]
[[(#.Some bound) _] #/.Lower])
diff --git a/stdlib/source/lux/target/jvm/type.lux b/stdlib/source/lux/target/jvm/type.lux
index 4b62f33a7..2c3b2b1e2 100644
--- a/stdlib/source/lux/target/jvm/type.lux
+++ b/stdlib/source/lux/target/jvm/type.lux
@@ -1,12 +1,15 @@
(.module:
[lux (#- Type int char)
+ [abstract
+ [equivalence (#+ Equivalence)]]
[control
["<>" parser
["<t>" text (#+ Parser)]]]
[data
[error (#+ Error)]
+ ["." product]
["." maybe ("#@." functor)]
- ["." text
+ ["." text ("#@." equivalence)
format]
[collection
["." list ("#@." functor)]]]])
@@ -56,6 +59,20 @@
#Lower
#Upper)
+## TODO: Replace with polytypism.
+(structure: #export bound-equivalence
+ (Equivalence Bound)
+ (def: (= parameter subject)
+ (case [parameter subject]
+ (^template [<tag>]
+ [<tag> <tag>]
+ true)
+ ([#Lower]
+ [#Upper])
+
+ _
+ false)))
+
(type: #export Primitive
#Boolean
#Byte
@@ -66,6 +83,26 @@
#Double
#Char)
+## TODO: Replace with polytypism.
+(structure: #export primitive-equivalence
+ (Equivalence Primitive)
+ (def: (= parameter subject)
+ (case [parameter subject]
+ (^template [<tag>]
+ [<tag> <tag>]
+ true)
+ ([#Boolean]
+ [#Byte]
+ [#Short]
+ [#Int]
+ [#Long]
+ [#Float]
+ [#Double]
+ [#Char])
+
+ _
+ false)))
+
(type: #export Var Text)
(with-expansions [<Class> (as-is [Text (List Generic)])]
@@ -78,6 +115,24 @@
<Class>)
)
+(structure: #export generic-equivalence
+ (Equivalence Generic)
+ (def: (= parameter subject)
+ (case [parameter subject]
+ [(#Var parameter) (#Var subject)]
+ (text@= parameter subject)
+
+ [(#Wildcard parameter) (#Wildcard subject)]
+ (:: (maybe.equivalence (product.equivalence bound-equivalence =))
+ = parameter subject)
+
+ [(#Class [nameP paramsP]) (#Class [nameS paramsS])]
+ (and (text@= nameP nameS)
+ (:: (list.equivalence =) = paramsP paramsS))
+
+ _
+ false)))
+
(type: #export Parameter
[Text Class (List Class)])
@@ -86,17 +141,44 @@
(#Generic Generic)
(#Array Type))
+(structure: #export type-equivalence
+ (Equivalence Type)
+ (def: (= parameter subject)
+ (case [parameter subject]
+ [(#Primitive parameter) (#Primitive subject)]
+ (:: ..primitive-equivalence = parameter subject)
+
+ [(#Generic parameter) (#Generic subject)]
+ (:: ..generic-equivalence = parameter subject)
+
+ [(#Array parameter) (#Array subject)]
+ (= parameter subject)
+
+ _
+ false)))
+
(type: #export Argument
[Text Type])
(type: #export Return
(Maybe Type))
+(def: #export return-equivalence
+ (Equivalence Return)
+ (maybe.equivalence ..type-equivalence))
+
(type: #export Method
{#args (List Type)
#return Return
#exceptions (List Generic)})
+(structure: #export method-equivalence
+ (Equivalence Method)
+ (def: (= [argsP returnP exceptionsP] [argsS returnS exceptionsS])
+ (and (:: (list.equivalence ..type-equivalence) = argsP argsS)
+ (:: ..return-equivalence = returnP returnS)
+ (:: (list.equivalence ..generic-equivalence) = exceptionsP exceptionsS))))
+
(type: #export (Typed a)
[Type a])
diff --git a/stdlib/source/lux/target/jvm/type/lux.lux b/stdlib/source/lux/target/jvm/type/lux.lux
index 92bc05091..2e1529ba6 100644
--- a/stdlib/source/lux/target/jvm/type/lux.lux
+++ b/stdlib/source/lux/target/jvm/type/lux.lux
@@ -92,11 +92,11 @@
(#//.Array elementT)
(case elementT
(#//.Primitive primitive)
- (check@wrap (#.Primitive (//.descriptor (//.array 1 input)) #.Nil))
+ (check@wrap (#.Primitive (//.descriptor input) #.Nil))
_
(do check.monad
- [elementT (type mapping input)]
+ [elementT (type mapping elementT)]
(wrap (.type (Array elementT)))))))
(def: #export (return mapping input)
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 8679135f1..e14a528b2 100644
--- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
+++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux
@@ -26,6 +26,7 @@
["." jvm #_
[".!" reflection]
["#" type (#+ Var Bound Primitive Generic Class Type Argument Return Method Typed)
+ ("method@." method-equivalence)
["." box]
["." reflection]
[".T" lux (#+ Mapping)]]]]]
@@ -928,7 +929,7 @@
[parameters (|> (java/lang/reflect/Method::getGenericParameterTypes method)
array.to-list
(monad.map error.monad reflection!.type)
- (:: error.monad map (list@map jvm.signature))
+ (:: error.monad map (list@map jvm.descriptor))
////.lift)
#let [modifiers (java/lang/reflect/Method::getModifiers method)
correct-class? (java/lang/Object::equals class (java/lang/reflect/Method::getDeclaringClass method))
@@ -965,7 +966,7 @@
[parameters (|> (java/lang/reflect/Constructor::getGenericParameterTypes constructor)
array.to-list
(monad.map error.monad reflection!.type)
- (:: error.monad map (list@map jvm.signature))
+ (:: error.monad map (list@map jvm.descriptor))
////.lift)]
(wrap (and (java/lang/Object::equals class (java/lang/reflect/Constructor::getDeclaringClass constructor))
(n/= (list.size arg-classes) (list.size parameters))
@@ -1431,35 +1432,54 @@
(-> (Typed Analysis) Analysis)
(/////analysis.tuple (list (type-analysis type) term)))
-(def: abstract-methods
- (-> (java/lang/Class java/lang/Object)
- (Error (List [Text Method])))
- (|>> java/lang/Class::getDeclaredMethods
- array.to-list
- (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))
- (monad.map error.monad
- (function (_ method)
- (do error.monad
- [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method)
- array.to-list
- (monad.map @ reflection!.type))
- return (|> method
- java/lang/reflect/Method::getGenericReturnType
- reflection!.return)
- exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
- array.to-list
- (monad.map @ reflection!.generic))]
- (wrap [(java/lang/reflect/Method::getName method)
- (jvm.method inputs return exceptions)]))))))
+(template [<name> <filter>]
+ [(def: <name>
+ (-> (java/lang/Class java/lang/Object)
+ (Error (List [Text Method])))
+ (|>> java/lang/Class::getDeclaredMethods
+ array.to-list
+ <filter>
+ (monad.map error.monad
+ (function (_ method)
+ (do error.monad
+ [inputs (|> (java/lang/reflect/Method::getGenericParameterTypes method)
+ array.to-list
+ (monad.map @ reflection!.type))
+ return (|> method
+ java/lang/reflect/Method::getGenericReturnType
+ reflection!.return)
+ exceptions (|> (java/lang/reflect/Method::getGenericExceptionTypes method)
+ array.to-list
+ (monad.map @ reflection!.generic))]
+ (wrap [(java/lang/reflect/Method::getName method)
+ (jvm.method inputs return exceptions)]))))))]
+
+ [abstract-methods (list.filter (|>> java/lang/reflect/Method::getModifiers java/lang/reflect/Modifier::isAbstract))]
+ [methods (<|)]
+ )
(def: jvm-package-separator ".")
-(def: all-abstract-methods
- (-> (List Class) (Error (List [Text Method])))
- (|>> (monad.map error.monad (|>> product.left reflection!.load))
- (error@map (monad.map error.monad ..abstract-methods))
- error@join
- (error@map list@join)))
+(template [<name> <methods>]
+ [(def: <name>
+ (-> (List Class) (Error (List [Text Method])))
+ (|>> (monad.map error.monad (|>> product.left reflection!.load))
+ (error@map (monad.map error.monad <methods>))
+ error@join
+ (error@map list@join)))]
+
+ [all-abstract-methods ..abstract-methods]
+ [all-methods ..methods]
+ )
+
+(template [<name>]
+ [(exception: #export (<name> {methods (List Text)})
+ (exception.report
+ ["Methods" (exception.enumerate %t methods)]))]
+
+ [missing-abstract-methods]
+ [invalid-overriden-methods]
+ )
(def: class::anonymous
Handler
@@ -1546,7 +1566,38 @@
)))))
methods)
required-abstract-methods (////.lift (all-abstract-methods (list& super-class super-interfaces)))
- _ (typeA.infer selfT)]
+ 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)]
+ _ (typeA.infer selfT)
+ _ (////.assert ..missing-abstract-methods (list@map product.left missing-abstract-methods)
+ (list.empty? missing-abstract-methods))
+ _ (////.assert ..invalid-overriden-methods (list@map product.left invalid-overriden-methods)
+ (list.empty? invalid-overriden-methods))]
(wrap (#/////analysis.Extension extension-name
(list (/////analysis.text name)
(class-analysis super-class)
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-06 08:08:16 +0000