diff options
Diffstat (limited to '')
| -rw-r--r-- | luxc/src/lux/host.clj | 18 | ||||
| -rw-r--r-- | stdlib/source/lux/data/collection/list.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/data/product.lux | 12 | ||||
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/reflection.lux | 22 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/type.lux | 84 | ||||
| -rw-r--r-- | stdlib/source/lux/target/jvm/type/lux.lux | 4 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 109 |
8 files changed, 207 insertions, 48 deletions
diff --git a/luxc/src/lux/host.clj b/luxc/src/lux/host.clj index 5b93f5b49..562d582f6 100644 --- a/luxc/src/lux/host.clj +++ b/luxc/src/lux/host.clj @@ -27,8 +27,9 @@ (def ->package ->module-class) -(defn unfold-array [type] +(defn unfold-array "(-> Type (, Int Type))" + [type] (|case type (&/$Primitive "#Array" (&/$Cons param (&/$Nil))) (|let [[count inner] (unfold-array param)] @@ -39,8 +40,9 @@ (let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] - (defn ->java-sig [^objects type] + (defn ->java-sig "(-> Type (Lux Text))" + [^objects type] (|case type (&/$Primitive ?name params) (cond (= &host-type/array-data-tag ?name) (|do [:let [[level base] (unfold-array type)] @@ -145,8 +147,9 @@ (return (&/T [exs gvars gargs]))) (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str)))))) -(defn abstract-methods [class-loader super-class] +(defn abstract-methods "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" + [class-loader super-class] (|let [[super-name super-params] super-class] (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader)) :when (Modifier/isAbstract (.getModifiers =method))] @@ -362,8 +365,9 @@ (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) )) -(defn privacy-modifier->flag [privacy-modifier] +(defn privacy-modifier->flag "(-> PrivacyModifier Int)" + [privacy-modifier] (|case privacy-modifier (&/$PublicPM) Opcodes/ACC_PUBLIC (&/$PrivatePM) Opcodes/ACC_PRIVATE @@ -371,15 +375,17 @@ (&/$DefaultPM) 0 )) -(defn state-modifier->flag [state-modifier] +(defn state-modifier->flag "(-> StateModifier Int)" + [state-modifier] (|case state-modifier (&/$DefaultSM) 0 (&/$VolatileSM) Opcodes/ACC_VOLATILE (&/$FinalSM) Opcodes/ACC_FINAL)) -(defn inheritance-modifier->flag [inheritance-modifier] +(defn inheritance-modifier->flag "(-> InheritanceModifier Int)" + [inheritance-modifier] (|case inheritance-modifier (&/$DefaultIM) 0 (&/$AbstractIM) Opcodes/ACC_ABSTRACT 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) |