diff options
Diffstat (limited to '')
| -rw-r--r-- | stdlib/source/lux/control/concurrency/atom.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/control/concurrency/process.lux | 2 | ||||
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 354 | ||||
| -rw-r--r-- | stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux | 400 |
4 files changed, 486 insertions, 272 deletions
diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index cb252066a..599545498 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -48,7 +48,7 @@ (java/util/concurrent/atomic/AtomicReference::get (:representation atom))}))) (def: #export (compare-and-swap current new atom) - {#.doc (doc "Only mutates an atom if you can present it's current value." + {#.doc (doc "Only mutates an atom if you can present its current value." "That guarantees that atom was not updated since you last read from it.")} (All [a] (-> a a (Atom a) (IO Bit))) (io (for {(~~ (static @.old)) diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index 6d432f48d..3a6b2cda7 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -82,7 +82,7 @@ (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism)) (~~ (static @.jvm)) - (java/util/concurrent/ScheduledThreadPoolExecutor::new (:coerce host.Long ..parallelism))} + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))} ## Default (: (Atom (List Process)) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux index 5345d221f..fa0979cb1 100644 --- a/stdlib/source/lux/host.jvm.lux +++ b/stdlib/source/lux/host.jvm.lux @@ -134,8 +134,6 @@ (def: constructor-method-name "<init>") (def: member-separator "::") -(type: JVM-Code Text) - (type: BoundKind #UpperBound #LowerBound) @@ -223,6 +221,7 @@ (#VirtualMethod [Bit Bit (List Type-Paramameter) + Text (List ArgDecl) GenericType Code @@ -230,6 +229,7 @@ (#OverridenMethod [Bit Class-Declaration (List Type-Paramameter) + Text (List ArgDecl) GenericType Code @@ -698,8 +698,8 @@ (#StaticMethod strict? type-vars args return-type return-expr exs) (make-static-method-parser params class-name method-name args) - (^or (#VirtualMethod final? strict? type-vars args return-type return-expr exs) - (#OverridenMethod strict? owner-class type-vars args return-type return-expr exs)) + (^or (#VirtualMethod final? strict? type-vars self-name args return-type return-expr exs) + (#OverridenMethod strict? owner-class type-vars self-name args return-type return-expr exs)) (make-special-method-parser params class-name method-name args) (#AbstractMethod type-vars args return-type exs) @@ -942,8 +942,10 @@ final? (s.this? (' #final)) method-vars (p.default (list) (type-params^ imports)) #let [total-vars (list@compose class-vars method-vars)] - [name arg-decls] (s.form (p.and s.local-identifier - (arg-decls^ imports total-vars))) + [name self-name arg-decls] (s.form ($_ p.and + s.local-identifier + s.local-identifier + (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) @@ -951,7 +953,7 @@ (wrap [{#member-name name #member-privacy pm #member-anns annotations} - (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) + (#VirtualMethod final? strict-fp? method-vars self-name arg-decls return-type body exs)])))) (def: (overriden-method-def^ imports) (-> Class-Imports (Parser [Member-Declaration Method-Definition])) @@ -960,8 +962,10 @@ owner-class (class-decl^ imports) method-vars (p.default (list) (type-params^ imports)) #let [total-vars (list@compose (product.right owner-class) method-vars)] - [name arg-decls] (s.form (p.and s.local-identifier - (arg-decls^ imports total-vars))) + [name self-name arg-decls] (s.form ($_ p.and + s.local-identifier + s.local-identifier + (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) exs (throws-decl^ imports total-vars) annotations (annotations^ imports) @@ -969,7 +973,7 @@ (wrap [{#member-name name #member-privacy #PublicPM #member-anns annotations} - (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) + (#OverridenMethod strict-fp? owner-class method-vars self-name arg-decls return-type body exs)])))) (def: (static-method-def^ imports) (-> Class-Imports (Parser [Member-Declaration Method-Definition])) @@ -1130,158 +1134,141 @@ #import-field-type gtype})))) )) -(def: with-parens - (-> JVM-Code JVM-Code) - (text.enclose ["(" ")"])) - -(def: with-brackets - (-> JVM-Code JVM-Code) - (text.enclose ["[" "]"])) - -(def: spaced - (-> (List JVM-Code) JVM-Code) - (text.join-with " ")) - (def: (privacy-modifier$ pm) - (-> PrivacyModifier JVM-Code) + (-> PrivacyModifier Code) (case pm - #PublicPM "public" - #PrivatePM "private" - #ProtectedPM "protected" - #DefaultPM "default")) + #PublicPM (' "public") + #PrivatePM (' "private") + #ProtectedPM (' "protected") + #DefaultPM (' "default"))) (def: (inheritance-modifier$ im) - (-> InheritanceModifier JVM-Code) + (-> InheritanceModifier Code) (case im - #FinalIM "final" - #AbstractIM "abstract" - #DefaultIM "default")) + #FinalIM (' "final") + #AbstractIM (' "abstract") + #DefaultIM (' "default"))) (def: (annotation-param$ [name value]) - (-> AnnotationParam JVM-Code) - (format name "=" (code.to-text value))) + (-> AnnotationParam Code) + (` [(~ (code.text name)) (~ value)])) (def: (annotation$ [name params]) - (-> Annotation JVM-Code) - (format "(" name " " "{" (text.join-with text.tab (list@map annotation-param$ params)) "}" ")")) + (-> Annotation Code) + (` ((~ (code.text name)) (~+ (list@map annotation-param$ params))))) (def: (bound-kind$ kind) - (-> BoundKind JVM-Code) + (-> BoundKind Code) (case kind - #UpperBound "<" - #LowerBound ">")) + #UpperBound (' "<") + #LowerBound (' ">"))) (def: (generic-type$ gtype) - (-> GenericType JVM-Code) + (-> GenericType Code) (case gtype (#GenericTypeVar name) - name + (code.text name) (#GenericClass name params) - (format "(" (sanitize name) " " (spaced (list@map generic-type$ params)) ")") + (` ((~ (code.text (sanitize name))) (~+ (list@map generic-type$ params)))) (#GenericArray param) - (format "(" array.type-name " " (generic-type$ param) ")") + (` [(~ (generic-type$ param))]) (#GenericWildcard #.None) - "?" + (code.text "?") (#GenericWildcard (#.Some [bound-kind bound])) - (format (bound-kind$ bound-kind) (generic-type$ bound)))) + (` [(~ (bound-kind$ bound-kind)) (~ (generic-type$ bound))]))) (def: (type-param$ [name bounds]) - (-> Type-Paramameter JVM-Code) - (format "(" name " " (spaced (list@map generic-type$ bounds)) ")")) + (-> Type-Paramameter Code) + (` [(~ (code.text name)) (~+ (list@map generic-type$ bounds))])) (def: (class-decl$ (^open ".")) - (-> Class-Declaration JVM-Code) - (format "(" (sanitize class-name) " " (spaced (list@map type-param$ class-params)) ")")) + (-> Class-Declaration Code) + (` ((~ (code.text (sanitize class-name))) + (~+ (list@map type-param$ class-params))))) (def: (super-class-decl$ (^slots [#super-class-name #super-class-params])) - (-> Super-Class-Decl JVM-Code) - (format "(" (sanitize super-class-name) " " (spaced (list@map generic-type$ super-class-params)) ")")) + (-> Super-Class-Decl Code) + (` ((~ (code.text (sanitize super-class-name))) + (~+ (list@map generic-type$ super-class-params))))) (def: (method-decl$ [[name pm anns] method-decl]) - (-> [Member-Declaration MethodDecl] JVM-Code) + (-> [Member-Declaration MethodDecl] Code) (let [(^slots [#method-tvars #method-inputs #method-output #method-exs]) method-decl] - (with-parens - (spaced (list name - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ method-tvars))) - (with-brackets (spaced (list@map generic-type$ method-exs))) - (with-brackets (spaced (list@map generic-type$ method-inputs))) - (generic-type$ method-output)) - )))) + (` ((~ (code.text name)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ method-tvars))] + [(~+ (list@map generic-type$ method-exs))] + [(~+ (list@map generic-type$ method-inputs))] + (~ (generic-type$ method-output)))))) (def: (state-modifier$ sm) - (-> StateModifier JVM-Code) + (-> StateModifier Code) (case sm - #VolatileSM "volatile" - #FinalSM "final" - #DefaultSM "default")) + #VolatileSM (' "volatile") + #FinalSM (' "final") + #DefaultSM (' "default"))) (def: (field-decl$ [[name pm anns] field]) - (-> [Member-Declaration FieldDecl] JVM-Code) + (-> [Member-Declaration FieldDecl] Code) (case field (#ConstantField class value) - (with-parens - (spaced (list "constant" name - (with-brackets (spaced (list@map annotation$ anns))) - (generic-type$ class) - (code.to-text value)) - )) + (` ("constant" (~ (code.text name)) + [(~+ (list@map annotation$ anns))] + (~ (generic-type$ class)) + (~ value) + )) (#VariableField sm class) - (with-parens - (spaced (list "variable" name - (privacy-modifier$ pm) - (state-modifier$ sm) - (with-brackets (spaced (list@map annotation$ anns))) - (generic-type$ class)) - )) + (` ("variable" (~ (code.text name)) + (~ (privacy-modifier$ pm)) + (~ (state-modifier$ sm)) + [(~+ (list@map annotation$ anns))] + (~ (generic-type$ class)) + )) )) (def: (arg-decl$ [name type]) - (-> ArgDecl JVM-Code) - (with-parens - (spaced (list name (generic-type$ type))))) + (-> ArgDecl Code) + (` [(~ (code.text name)) (~ (generic-type$ type))])) (def: (constructor-arg$ [class term]) - (-> ConstructorArg JVM-Code) - (with-brackets - (spaced (list (generic-type$ class) (code.to-text term))))) + (-> ConstructorArg Code) + (` [(~ (generic-type$ class)) (~ term)])) (def: (method-def$ replacer super-class [[name pm anns] method-def]) - (-> (-> Code Code) Super-Class-Decl [Member-Declaration Method-Definition] JVM-Code) + (-> (-> Code Code) Super-Class-Decl [Member-Declaration Method-Definition] Code) (case method-def (#ConstructorMethod strict-fp? type-vars arg-decls constructor-args body exs) - (with-parens - (spaced (list "init" - (privacy-modifier$ pm) - (bit@encode strict-fp?) - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ type-vars))) - (with-brackets (spaced (list@map generic-type$ exs))) - (with-brackets (spaced (list@map arg-decl$ arg-decls))) - (with-brackets (spaced (list@map constructor-arg$ constructor-args))) - (code.to-text (pre-walk-replace replacer body)) - ))) + (` ("init" + (~ (privacy-modifier$ pm)) + (~ (code.bit strict-fp?)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ type-vars))] + [(~+ (list@map generic-type$ exs))] + [(~+ (list@map arg-decl$ arg-decls))] + [(~+ (list@map constructor-arg$ constructor-args))] + (~ (pre-walk-replace replacer body)) + )) - (#VirtualMethod final? strict-fp? type-vars arg-decls return-type body exs) - (with-parens - (spaced (list "virtual" - name - (privacy-modifier$ pm) - (bit@encode final?) - (bit@encode strict-fp?) - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ type-vars))) - (with-brackets (spaced (list@map generic-type$ exs))) - (with-brackets (spaced (list@map arg-decl$ arg-decls))) - (generic-type$ return-type) - (code.to-text (pre-walk-replace replacer body))))) + (#VirtualMethod final? strict-fp? type-vars self-name arg-decls return-type body exs) + (` ("virtual" + (~ (code.text name)) + (~ (privacy-modifier$ pm)) + (~ (code.bit final?)) + (~ (code.bit strict-fp?)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ type-vars))] + (~ (code.text self-name)) + [(~+ (list@map arg-decl$ arg-decls))] + (~ (generic-type$ return-type)) + [(~+ (list@map generic-type$ exs))] + (~ (pre-walk-replace replacer body)))) - (#OverridenMethod strict-fp? class-decl type-vars arg-decls return-type body exs) + (#OverridenMethod strict-fp? class-decl type-vars self-name arg-decls return-type body exs) (let [super-replacer (parser->replacer (s.form (do p.monad [_ (s.this (' ::super!)) args (s.tuple (p.exactly (list.size arg-decls) s.any)) @@ -1295,56 +1282,52 @@ (~+ (|> args (list.zip2 arg-decls') (list@map ..decorate-input)))))))))] - (with-parens - (spaced (list "override" - (class-decl$ class-decl) - name - (bit@encode strict-fp?) - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ type-vars))) - (with-brackets (spaced (list@map generic-type$ exs))) - (with-brackets (spaced (list@map arg-decl$ arg-decls))) - (generic-type$ return-type) - (|> body - (pre-walk-replace replacer) - (pre-walk-replace super-replacer) - (code.to-text)) - )))) + (` ("override" + (~ (class-decl$ class-decl)) + (~ (code.text name)) + (~ (code.bit strict-fp?)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ type-vars))] + (~ (code.text self-name)) + [(~+ (list@map arg-decl$ arg-decls))] + (~ (generic-type$ return-type)) + [(~+ (list@map generic-type$ exs))] + (~ (|> body + (pre-walk-replace replacer) + (pre-walk-replace super-replacer))) + ))) (#StaticMethod strict-fp? type-vars arg-decls return-type body exs) - (with-parens - (spaced (list "static" - name - (privacy-modifier$ pm) - (bit@encode strict-fp?) - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ type-vars))) - (with-brackets (spaced (list@map generic-type$ exs))) - (with-brackets (spaced (list@map arg-decl$ arg-decls))) - (generic-type$ return-type) - (code.to-text (pre-walk-replace replacer body))))) + (` ("static" + (~ (code.text name)) + (~ (privacy-modifier$ pm)) + (~ (code.bit strict-fp?)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ type-vars))] + [(~+ (list@map generic-type$ exs))] + [(~+ (list@map arg-decl$ arg-decls))] + (~ (generic-type$ return-type)) + (~ (pre-walk-replace replacer body)))) (#AbstractMethod type-vars arg-decls return-type exs) - (with-parens - (spaced (list "abstract" - name - (privacy-modifier$ pm) - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ type-vars))) - (with-brackets (spaced (list@map generic-type$ exs))) - (with-brackets (spaced (list@map arg-decl$ arg-decls))) - (generic-type$ return-type)))) + (` ("abstract" + (~ (code.text name)) + (~ (privacy-modifier$ pm)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ type-vars))] + [(~+ (list@map generic-type$ exs))] + [(~+ (list@map arg-decl$ arg-decls))] + (~ (generic-type$ return-type)))) (#NativeMethod type-vars arg-decls return-type exs) - (with-parens - (spaced (list "native" - name - (privacy-modifier$ pm) - (with-brackets (spaced (list@map annotation$ anns))) - (with-brackets (spaced (list@map type-param$ type-vars))) - (with-brackets (spaced (list@map generic-type$ exs))) - (with-brackets (spaced (list@map arg-decl$ arg-decls))) - (generic-type$ return-type)))) + (` ("native" + (~ (code.text name)) + (~ (privacy-modifier$ pm)) + [(~+ (list@map annotation$ anns))] + [(~+ (list@map type-param$ type-vars))] + [(~+ (list@map generic-type$ exs))] + [(~+ (list@map arg-decl$ arg-decls))] + (~ (generic-type$ return-type)))) )) (def: (complete-call$ g!obj [method args]) @@ -1408,16 +1391,15 @@ method-parsers (list@map (method->parser (product.right class-decl) fully-qualified-class-name) methods) replacer (parser->replacer (list@fold p.either (p.fail "") - (list@compose field-parsers method-parsers))) - def-code (format "jvm class:" - (spaced (list (class-decl$ class-decl) - (super-class-decl$ super) - (with-brackets (spaced (list@map super-class-decl$ interfaces))) - (inheritance-modifier$ im) - (with-brackets (spaced (list@map annotation$ annotations))) - (with-brackets (spaced (list@map field-decl$ fields))) - (with-brackets (spaced (list@map (method-def$ replacer super) methods))))))]] - (wrap (list (` ((~ (code.text def-code)))))))) + (list@compose field-parsers method-parsers)))]] + (wrap (list (` ("jvm class" + (~ (class-decl$ class-decl)) + (~ (super-class-decl$ super)) + [(~+ (list@map super-class-decl$ interfaces))] + (~ (inheritance-modifier$ im)) + [(~+ (list@map annotation$ annotations))] + [(~+ (list@map field-decl$ fields))] + [(~+ (list@map (method-def$ replacer super) methods))])))))) (syntax: #export (interface: {#let [imports (class-imports *compiler*)]} @@ -1433,13 +1415,11 @@ {#.doc (doc "Allows defining JVM interfaces." (interface: TestInterface ([] foo [boolean String] void #throws [Exception])))} - (let [def-code (format "jvm interface:" - (spaced (list (class-decl$ class-decl) - (with-brackets (spaced (list@map super-class-decl$ supers))) - (with-brackets (spaced (list@map annotation$ annotations))) - (spaced (list@map method-decl$ members)))))] - (wrap (list (` ((~ (code.text def-code)))))) - )) + (wrap (list (` ("jvm class interface" + (~ (class-decl$ class-decl)) + [(~+ (list@map super-class-decl$ supers))] + [(~+ (list@map annotation$ annotations))] + (~+ (list@map method-decl$ members))))))) (syntax: #export (object {#let [imports (class-imports *compiler*)]} @@ -1461,12 +1441,11 @@ (exec (do-something some-value) []))) )} - (let [def-code (format "jvm anon-class:" - (spaced (list (super-class-decl$ super) - (with-brackets (spaced (list@map super-class-decl$ interfaces))) - (with-brackets (spaced (list@map constructor-arg$ constructor-args))) - (with-brackets (spaced (list@map (method-def$ function.identity super) methods))))))] - (wrap (list (` ((~ (code.text def-code)))))))) + (wrap (list (` ("jvm class anonymous" + (~ (super-class-decl$ super)) + [(~+ (list@map super-class-decl$ interfaces))] + [(~+ (list@map constructor-arg$ constructor-args))] + [(~+ (list@map (method-def$ function.identity super) methods))]))))) (syntax: #export (null) {#.doc (doc "Null object reference." @@ -1713,6 +1692,17 @@ (-> Code Code) (` ((~' ~) (~ quoted)))) +(def: (jvm-input [unboxed raw]) + (-> [Text Code] [Text Code]) + [unboxed (case unboxed + "byte" (` (.:coerce (.primitive "java.lang.Long") (.: .Int (~ raw)))) + "short" (` (.:coerce (.primitive "java.lang.Long") (.: .Int (~ raw)))) + "int" (` (.:coerce (.primitive "java.lang.Long") (.: .Int (~ raw)))) + "long" (` (.:coerce (.primitive "java.lang.Long") (.: .Int (~ raw)))) + "float" (` (.:coerce (.primitive "java.lang.Double") (.: .Frac (~ raw)))) + "double" (` (.:coerce (.primitive "java.lang.Double") (.: .Frac (~ raw)))) + _ (` ("jvm object cast" (~ raw))))]) + (def: (jvm-invoke-inputs mode classes inputs) (-> Primitive-Mode (List Text) (List [Bit Code]) (List Code)) (|> inputs @@ -1721,7 +1711,7 @@ (` ((~! !!!) (~ (un-quote input)))) (un-quote input)))) (list.zip2 classes) - (list@map (auto-convert-input mode)))) + (list@map (|>> jvm-input (auto-convert-input mode))))) (def: (with-class-type class expression) (-> Text Code Code) @@ -1796,7 +1786,8 @@ (` ((~ (code.text jvm-op)) (~ (code.text full-name)) (~ (code.text import-method-name)) - (~+ (list@map un-quote object-ast)) + (~+ (list@map (|>> un-quote ~ "jvm object cast" `) + object-ast)) (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs) (list.zip2 arg-classes) (list@map ..decorate-input)))))] @@ -1844,8 +1835,9 @@ (let [setter-call (if import-field-static? (` ((~ setter-name) (~ g!value))) (` ((~ setter-name) (~ g!value) (~ g!obj)))) - setter-value (auto-convert-input import-field-mode - [(simple-class$ (list) import-field-type) (un-quote g!value)]) + setter-value (|> [(simple-class$ (list) import-field-type) (un-quote g!value)] + ..jvm-input + (auto-convert-input import-field-mode)) setter-value (if import-field-maybe? (` ((~! !!!) (~ setter-value))) setter-value) @@ -1975,7 +1967,7 @@ ["char" "jvm cnewarray"]) _ - (wrap (list (` ("jvm anewarray" (~ (code.text (generic-type$ type))) (~ size))))))) + (wrap (list (` ("jvm anewarray" (~ (generic-type$ type)) (~ size))))))) (syntax: #export (array-length array) {#.doc (doc "Gives the length of an array." 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 5040438b5..1c7dfdee7 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/jvm.lux @@ -26,16 +26,23 @@ ["_." type]]]] ["." // #_ ["#." common] - ["#/" // + ["/#" // ["#." bundle] - ["#/" // ("#@." monad) + ["/#" // ("#@." monad) [analysis [".A" type] - [".A" inference]] - ["#/" // #_ + [".A" inference] + ["." scope]] + ["/#" // #_ ["#." analysis (#+ Analysis Operation Phase Handler Bundle)] ["#." synthesis]]]]]) +(def: inheritance-relationship-type-name "_jvm_inheritance") +(def: (inheritance-relationship-type class super-class super-interfaces) + (-> Type Type (List Type) Type) + (#.Primitive ..inheritance-relationship-type-name + (list& class super-class super-interfaces))) + (def: (custom [syntax handler]) (All [s] (-> [(Parser s) @@ -123,6 +130,12 @@ [too-many-candidates] ) +(exception: #export (cannot-cast {from Type} {to Type} {value Code}) + (exception.report + ["From" (%type from)] + ["To" (%type to)] + ["Value" (%code value)])) + (template [<name>] [(exception: #export (<name> {message Text}) message)] @@ -131,8 +144,6 @@ [mistaken-field-owner] - [cannot-cast] - [cannot-possibly-be-an-instance] [unknown-type-var] @@ -350,8 +361,11 @@ (#.Named name unnamed) (check-jvm unnamed) - (#.Var id) - (////@wrap "java.lang.Object") + (^template [<tag>] + (<tag> id) + (////@wrap "java.lang.Object")) + ([#.Var] + [#.Ex]) (^template [<tag>] (<tag> env unquantified) @@ -547,8 +561,8 @@ _ (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) -(import: java/lang/Object - (equals [Object] boolean)) +(import: #long java/lang/Object + (equals [java/lang/Object] boolean)) (import: java/lang/ClassLoader) @@ -574,14 +588,14 @@ (#static isAbstract [int] boolean)) (import: java/lang/reflect/Field - (getDeclaringClass [] (java/lang/Class Object)) + (getDeclaringClass [] (java/lang/Class java/lang/Object)) (getModifiers [] int) (getGenericType [] java/lang/reflect/Type)) (import: java/lang/reflect/Method (getName [] String) (getModifiers [] int) - (getDeclaringClass [] (Class Object)) + (getDeclaringClass [] (java/lang/Class java/lang/Object)) (getTypeParameters [] (Array (TypeVariable Method))) (getGenericParameterTypes [] (Array java/lang/reflect/Type)) (getGenericReturnType [] java/lang/reflect/Type) @@ -589,28 +603,28 @@ (import: (java/lang/reflect/Constructor c) (getModifiers [] int) - (getDeclaringClass [] (Class c)) + (getDeclaringClass [] (java/lang/Class c)) (getTypeParameters [] (Array (TypeVariable (Constructor c)))) (getGenericParameterTypes [] (Array java/lang/reflect/Type)) (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) -(import: (java/lang/Class c) +(import: #long (java/lang/Class c) (getName [] String) (getModifiers [] int) - (#static forName [String] #try (Class Object)) - (isAssignableFrom [(Class Object)] boolean) - (getTypeParameters [] (Array (TypeVariable (Class c)))) + (#static forName [String] #try (java/lang/Class java/lang/Object)) + (isAssignableFrom [(java/lang/Class java/lang/Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (java/lang/Class c)))) (getGenericInterfaces [] (Array java/lang/reflect/Type)) - (getGenericSuperclass [] java/lang/reflect/Type) + (getGenericSuperclass [] #? java/lang/reflect/Type) (getDeclaredField [String] #try Field) - (getConstructors [] (Array (Constructor Object))) + (getConstructors [] (Array (Constructor java/lang/Object))) (getDeclaredMethods [] (Array Method))) (def: (load-class name) - (-> Text (Operation (Class Object))) + (-> Text (Operation (java/lang/Class java/lang/Object))) (do ////.monad [] - (case (Class::forName name) + (case (java/lang/Class::forName name) (#error.Success [class]) (wrap class) @@ -622,7 +636,7 @@ (do ////.monad [super (load-class super) sub (load-class sub)] - (wrap (Class::isAssignableFrom sub super)))) + (wrap (java/lang/Class::isAssignableFrom sub super)))) (def: object::throw Handler @@ -687,9 +701,9 @@ (def: (java-type-to-class jvm-type) (-> java/lang/reflect/Type (Operation Text)) - (<| (case (host.check Class jvm-type) + (<| (case (host.check java/lang/Class jvm-type) (#.Some jvm-type) - (////@wrap (Class::getName jvm-type)) + (////@wrap (java/lang/Class::getName jvm-type)) _) (case (host.check ParameterizedType jvm-type) @@ -729,11 +743,11 @@ (////@wrap Any)) _) - (case (host.check Class java-type) + (case (host.check java/lang/Class java-type) (#.Some java-type) - (let [java-type (:coerce (Class Object) java-type) - class-name (Class::getName java-type)] - (////@wrap (case (array.size (Class::getTypeParameters java-type)) + (let [java-type (:coerce (java/lang/Class java/lang/Object) java-type) + class-name (java/lang/Class::getName java-type)] + (////@wrap (case (array.size (java/lang/Class::getTypeParameters java-type)) 0 (#.Primitive class-name (list)) @@ -748,14 +762,14 @@ (case (host.check ParameterizedType java-type) (#.Some java-type) (let [raw (ParameterizedType::getRawType java-type)] - (case (host.check Class raw) + (case (host.check java/lang/Class raw) (#.Some raw) (do ////.monad [paramsT (|> java-type ParameterizedType::getActualTypeArguments array.to-list (monad.map @ (java-type-to-lux-type mappings)))] - (////@wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) + (////@wrap (#.Primitive (java/lang/Class::getName (:coerce (java/lang/Class java/lang/Object) raw)) paramsT))) _ @@ -775,11 +789,11 @@ (/////analysis.throw cannot-convert-to-a-lux-type java-type))) (def: (correspond-type-params class type) - (-> (Class Object) Type (Operation Mappings)) + (-> (java/lang/Class java/lang/Object) Type (Operation Mappings)) (case type (#.Primitive name params) - (let [class-name (Class::getName class) - class-params (array.to-list (Class::getTypeParameters class)) + (let [class-name (java/lang/Class::getName class) + class-params (array.to-list (java/lang/Class::getTypeParameters class)) num-class-params (list.size class-params) num-type-params (list.size params)] (cond (not (text@= class-name name)) @@ -803,25 +817,58 @@ _ (/////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]))) + (do ////.monad + [from-class (load-class from-name) + mapping (correspond-type-params from-class fromT)] + (monad.map @ + (function (_ superJT) + (do @ + [super-name (java-type-to-class superJT) + super-class (load-class super-name) + superT (java-type-to-lux-type mapping superJT)] + (wrap [[super-name superT] (java/lang/Class::isAssignableFrom super-class to-class)]))) + (case (java/lang/Class::getGenericSuperclass from-class) + (#.Some super) + (list& super (array.to-list (java/lang/Class::getGenericInterfaces from-class))) + + #.None + (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]))) + (case fromT + (^ (#.Primitive _ (list& self-classT super-classT super-interfacesT+))) + (monad.map ////.monad + (function (_ superT) + (do ////.monad + [super-name (check-jvm superT) + super-class (load-class super-name)] + (wrap [[super-name superT] + (java/lang/Class::isAssignableFrom super-class to-class)]))) + (list& super-classT super-interfacesT+)) + + _ + (/////analysis.throw cannot-cast [fromT toT fromC]))) + (def: object::cast Handler (function (_ extension-name analyse args) (case args - (^ (list valueC)) + (^ (list fromC)) (do ////.monad [toT (///.lift macro.expected-type) to-name (check-jvm toT) - [valueT valueA] (typeA.with-inference - (analyse valueC)) - from-name (check-jvm valueT) + [fromT fromA] (typeA.with-inference + (analyse fromC)) + from-name (check-jvm fromT) can-cast? (: (Operation Bit) (case [from-name to-name] (^template [<primitive> <object>] (^or [<primitive> <object>] [<object> <primitive>]) - (do @ - [_ (typeA.infer (#.Primitive to-name (list)))] - (wrap #1))) + (wrap #1)) (["boolean" "java.lang.Boolean"] ["byte" "java.lang.Byte"] ["short" "java.lang.Short"] @@ -837,47 +884,35 @@ (not (dictionary.contains? from-name boxes))) _ (////.assert ..primitives-are-not-objects [to-name] (not (dictionary.contains? to-name boxes))) - to-class (load-class to-name)] - (loop [[current-name currentT] [from-name valueT]] + to-class (load-class to-name) + _ (if (text@= ..inheritance-relationship-type-name from-name) + (wrap []) + (do @ + [from-class (load-class from-name)] + (////.assert cannot-cast [fromT toT fromC] + (java/lang/Class::isAssignableFrom from-class to-class))))] + (loop [[current-name currentT] [from-name fromT]] (if (text@= to-name current-name) + (wrap #1) (do @ - [_ (typeA.infer toT)] - (wrap #1)) - (do @ - [current-class (load-class current-name) - _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line) - (Class::isAssignableFrom current-class to-class)) - candiate-parents (monad.map @ - (function (_ java-type) - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [[class-name java-type] (Class::isAssignableFrom class to-class)]))) - (list& (Class::getGenericSuperclass current-class) - (array.to-list (Class::getGenericInterfaces current-class))))] + [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)))] (case (|> candiate-parents (list.filter product.right) (list@map product.left)) - (#.Cons [next-name nextJT] _) - (do @ - [mapping (correspond-type-params current-class currentT) - nextT (java-type-to-lux-type mapping nextJT)] - (recur [next-name nextT])) + (#.Cons [next-name nextT] _) + (recur [next-name nextT]) #.Nil - (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line))) + (/////analysis.throw cannot-cast [fromT toT fromC])) ))))))] (if can-cast? (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name) (/////analysis.text to-name) - valueA))) - (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line)))) + fromA))) + (/////analysis.throw cannot-cast [fromT toT fromC]))) _ (/////analysis.throw ///.invalid-syntax [extension-name %code args])))) @@ -896,17 +931,17 @@ ))) (def: (find-field class-name field-name) - (-> Text Text (Operation [(Class Object) Field])) + (-> Text Text (Operation [(java/lang/Class java/lang/Object) Field])) (do ////.monad [class (load-class class-name)] - (case (Class::getDeclaredField field-name class) + (case (java/lang/Class::getDeclaredField field-name class) (#error.Success field) (let [owner (Field::getDeclaringClass field)] (if (is? owner class) (wrap [class field]) (/////analysis.throw mistaken-field-owner (format " Field: " field-name text.new-line - " Owner Class: " (Class::getName owner) text.new-line + " Owner Class: " (java/lang/Class::getName owner) text.new-line "Target Class: " class-name text.new-line)))) (#error.Failure _) @@ -968,7 +1003,7 @@ (do @ [#let [fieldJT (Field::getGenericType fieldJ) var-names (|> class - Class::getTypeParameters + java/lang/Class::getTypeParameters array.to-list (list@map (|>> TypeVariable::getName)))] mappings (: (Operation Mappings) @@ -1038,9 +1073,9 @@ (def: (java-type-to-parameter type) (-> java/lang/reflect/Type (Operation Text)) - (<| (case (host.check Class type) + (<| (case (host.check java/lang/Class type) (#.Some type) - (////@wrap (Class::getName type)) + (////@wrap (java/lang/Class::getName type)) _) (case (host.check ParameterizedType type) @@ -1077,13 +1112,13 @@ #Interface) (def: (check-method class method-name method-style arg-classes method) - (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) + (-> (java/lang/Class java/lang/Object) Text Method-Style (List Text) Method (Operation Bit)) (do ////.monad [parameters (|> (Method::getGenericParameterTypes method) array.to-list (monad.map @ java-type-to-parameter)) #let [modifiers (Method::getModifiers method)]] - (wrap (and (Object::equals class (Method::getDeclaringClass method)) + (wrap (and (java/lang/Object::equals class (Method::getDeclaringClass method)) (text@= method-name (Method::getName method)) (case #Static #Special @@ -1093,7 +1128,7 @@ #1) (case method-style #Special - (not (or (Modifier::isInterface (Class::getModifiers class)) + (not (or (Modifier::isInterface (java/lang/Class::getModifiers class)) (Modifier::isAbstract modifiers))) _ @@ -1106,12 +1141,12 @@ (list.zip2 arg-classes parameters)))))) (def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) + (-> (java/lang/Class java/lang/Object) (List Text) (Constructor java/lang/Object) (Operation Bit)) (do ////.monad [parameters (|> (Constructor::getGenericParameterTypes constructor) array.to-list (monad.map @ java-type-to-parameter))] - (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) + (wrap (and (java/lang/Object::equals class (Constructor::getDeclaringClass constructor)) (n/= (list.size arg-classes) (list.size parameters)) (list@fold (function (_ [expectedJC actualJC] prev) (and prev @@ -1145,7 +1180,7 @@ (list) _ - (|> (Class::getTypeParameters owner) + (|> (java/lang/Class::getTypeParameters owner) array.to-list (list@map (|>> TypeVariable::getName)))) method-tvars (|> (Method::getTypeParameters method) @@ -1166,15 +1201,15 @@ inputsT _ - (list& (#.Primitive (Class::getName owner) owner-tvarsT) + (list& (#.Primitive (java/lang/Class::getName owner) owner-tvarsT) inputsT))) outputT)]] (wrap [methodT exceptionsT])))) (def: (constructor-signature constructor) - (-> (Constructor Object) (Operation Method-Signature)) + (-> (Constructor java/lang/Object) (Operation Method-Signature)) (let [owner (Constructor::getDeclaringClass constructor) - owner-tvars (|> (Class::getTypeParameters owner) + owner-tvars (|> (java/lang/Class::getTypeParameters owner) array.to-list (list@map (|>> TypeVariable::getName))) method-tvars (|> (Constructor::getTypeParameters constructor) @@ -1188,7 +1223,7 @@ exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) array.to-list (monad.map @ (java-type-to-lux-type mappings))) - #let [objectT (#.Primitive (Class::getName owner) owner-tvarsT) + #let [objectT (#.Primitive (java/lang/Class::getName owner) owner-tvarsT) constructorT (<| (type.univ-q (dictionary.size mappings)) (type.function inputsT) objectT)]] @@ -1217,7 +1252,7 @@ (do ////.monad [class (load-class class-name) candidates (|> class - Class::getDeclaredMethods + java/lang/Class::getDeclaredMethods array.to-list (monad.map @ (: (-> Method (Operation Evaluation)) (function (_ method) @@ -1248,7 +1283,7 @@ (do ////.monad [class (load-class class-name) candidates (|> class - Class::getConstructors + java/lang/Class::getConstructors array.to-list (monad.map @ (function (_ constructor) (do @ @@ -1334,7 +1369,7 @@ [#let [argsT (list@map product.left argsTC)] class (load-class class-name) _ (////.assert non-interface class-name - (Modifier::isInterface (Class::getModifiers class))) + (Modifier::isInterface (java/lang/Class::getModifiers class))) [methodT exceptionsT] (method-candidate class-name method #Interface argsT) [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) outputJC (check-jvm outputT)] @@ -1376,6 +1411,192 @@ ))) ))) +(type: #rec JVM-Type + [Text (List JVM-Type)]) + +(def: (lux-type [name parameters]) + (-> JVM-Type Type) + (case [name parameters] + ["void" #.Nil] + Any + + [_ #.Nil] + (case (dictionary.get name boxes) + (#.Some box) + (#.Primitive box #.Nil) + + #.None + (#.Primitive name #.Nil)) + + _ + (#.Primitive name (list@map lux-type parameters)))) + +(def: jvm-type + (Parser JVM-Type) + (p.rec + (function (_ jvm-type) + (s.form (p.and s.text (p.some jvm-type)))))) + +(def: constructor-arg + (Parser [JVM-Type Code]) + (s.tuple (p.and ..jvm-type s.any))) + +(type: (Annotation-Parameter a) + [Text a]) + +(def: annotation-parameter + (Parser (Annotation-Parameter Code)) + (s.tuple (p.and s.text s.any))) + +(type: (Annotation a) + [Text (List (Annotation-Parameter a))]) + +(def: annotation + (Parser (Annotation Code)) + (s.form (p.and s.text (p.some ..annotation-parameter)))) + +(type: Type-Parameter Text) + +(def: type-parameter + (Parser Type-Parameter) + s.text) + +(type: Argument + [Text JVM-Type]) + +(def: argument + (Parser Argument) + (s.tuple (p.and s.text ..jvm-type))) + +(type: Overriden-Method + [JVM-Type Text Bit (List (Annotation Code)) (List Type-Parameter) Text (List Argument) JVM-Type (List JVM-Type) Code]) + +(type: Method-Definition + (#Overriden-Method Overriden-Method)) + +(def: overriden-method-definition + (Parser Overriden-Method) + (<| s.form + (p.after (s.this (` "override"))) + ($_ p.and + ..jvm-type + s.text + s.bit + (s.tuple (p.some ..annotation)) + (s.tuple (p.some ..type-parameter)) + s.text + (s.tuple (p.some ..argument)) + ..jvm-type + (s.tuple (p.some ..jvm-type)) + s.any + ))) + +(def: (jvm-type-analysis [name parameters]) + (-> JVM-Type Analysis) + (/////analysis.tuple (list& (/////analysis.text name) + (list@map jvm-type-analysis parameters)))) + +(def: (annotation-parameter-analysis [name value]) + (-> (Annotation-Parameter Analysis) Analysis) + (/////analysis.tuple (list (/////analysis.text name) value))) + +(def: (annotation-analysis [name parameters]) + (-> (Annotation Analysis) Analysis) + (/////analysis.tuple (list& (/////analysis.text name) + (list@map annotation-parameter-analysis parameters)))) + +(def: type-parameter-analysis + (-> Type-Parameter Analysis) + /////analysis.text) + +(def: (constructor-arg-analysis [type term]) + (-> [JVM-Type Analysis] Analysis) + (/////analysis.tuple (list (jvm-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)) + (s.tuple (p.some ..overriden-method-definition))) + (function (_ extension-name analyse [super-class + super-interfaces + constructor-args + methods]) + (do ////.monad + [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) + ..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 + 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) + methodsA (monad.map @ (function (_ [parent-type method-name + strict-fp? annotations type-parameters + self-name arguments return-type exceptions + body]) + + (do @ + [annotationsA (monad.map @ (function (_ [name parameters]) + (do @ + [parametersA (monad.map @ (function (_ [name value]) + (do @ + [valueA (analyse value)] + (wrap [name valueA]))) + parameters)] + (wrap [name parametersA]))) + annotations) + [scope bodyA] (|> arguments + (list@map (function (_ [name jvmT]) + [name (lux-type jvmT)])) + (#.Cons [self-name selfT]) + list.reverse + (list@fold scope.with-local (analyse body)) + (typeA.with-type (lux-type return-type)) + /////analysis.with-scope)] + (wrap (/////analysis.tuple (list (jvm-type-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)) + (jvm-type-analysis return-type) + (/////analysis.tuple (list@map jvm-type-analysis + exceptions)) + (#/////analysis.Function + (scope.environment scope) + bodyA) + ))))) + methods) + _ (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)) + (/////analysis.tuple methodsA))))))])) + +(def: bundle::class + Bundle + (<| (///bundle.prefix "class") + (|> ///bundle.empty + (///bundle.install "anonymous" class::anonymous) + ))) + (def: #export bundle Bundle (<| (///bundle.prefix "jvm") @@ -1389,4 +1610,5 @@ (dictionary.merge bundle::array) (dictionary.merge bundle::object) (dictionary.merge bundle::member) + (dictionary.merge bundle::class) ))) |