diff options
| author | Eduardo Julian | 2019-04-18 23:36:08 -0400 |
|---|---|---|
| committer | Eduardo Julian | 2019-04-18 23:36:08 -0400 |
| commit | c339a123ea6a9c9baaaed92281af471002f89321 (patch) | |
| tree | 3d3a74a139d2ab6f807931973235a9057d0c7d53 | |
| parent | f59327398a0350a42b640b247ea3d392011b4e94 (diff) | |
WIP: Host interop for the new JVM compiler.
| -rw-r--r-- | stdlib/source/lux/control/concurrency/atom.lux | 35 | ||||
| -rw-r--r-- | stdlib/source/lux/control/concurrency/process.lux | 62 | ||||
| -rw-r--r-- | stdlib/source/lux/host.jvm.lux | 2087 | ||||
| -rw-r--r-- | stdlib/source/lux/host.old.lux | 253 |
4 files changed, 2279 insertions, 158 deletions
diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index 0b5c4fc3f..4de104212 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -9,10 +9,16 @@ abstract] [tool [compiler - ["." host]]] + ["@" host]]] [host (#+ import:)]]) -(`` (for {(~~ (static host.old)) +(`` (for {(~~ (static @.old)) + (import: #long (java/util/concurrent/atomic/AtomicReference a) + (new [a]) + (get [] a) + (compareAndSet [a a] boolean)) + + (~~ (static @.jvm)) (import: #long (java/util/concurrent/atomic/AtomicReference a) (new [a]) (get [] a) @@ -21,24 +27,41 @@ (`` (abstract: #export (Atom a) {#.doc "Atomic references that are safe to mutate concurrently."} - (for {(~~ (static host.old)) + (for {(~~ (static @.old)) + (java/util/concurrent/atomic/AtomicReference a) + + (~~ (static @.jvm)) (java/util/concurrent/atomic/AtomicReference a)}) (def: #export (atom value) (All [a] (-> a (Atom a))) - (:abstraction (for {(~~ (static host.old)) + (:abstraction (for {(~~ (static @.old)) + (java/util/concurrent/atomic/AtomicReference::new value) + + (~~ (static @.jvm)) (java/util/concurrent/atomic/AtomicReference::new value)}))) (def: #export (read atom) (All [a] (-> (Atom a) (IO a))) - (io (for {(~~ (static host.old)) + (io (for {(~~ (static @.old)) + (java/util/concurrent/atomic/AtomicReference::get (:representation atom)) + + (~~ (static @.jvm)) (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." "That guarantees that atom was not updated since you last read from it.")} (All [a] (-> a a (Atom a) (IO Bit))) - (io (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)))) + (io (for {(~~ (static @.old)) + (java/util/concurrent/atomic/AtomicReference::compareAndSet current new (:representation atom)) + + (~~ (static @.jvm)) + (|> (:representation atom) + (java/util/concurrent/atomic/AtomicReference::compareAndSet current new) + "jvm object cast" + (: (primitive "java.lang.Boolean")) + (:coerce Bit))}))) )) (def: #export (update f atom) diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index 322300a17..074ea96ac 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -10,12 +10,33 @@ ["." list]]] [tool [compiler - ["." host]]] - [host (#+ import: object)]] + ["@" host]]] + ["." host (#+ import: object)]] [// ["." atom (#+ Atom)]]) -(`` (for {(~~ (static host.old)) +(`` (for {(~~ (static @.old)) + (as-is (import: #long java/lang/Object) + + (import: #long java/lang/Runtime + (#static getRuntime [] java/lang/Runtime) + (availableProcessors [] int)) + + (import: #long java/lang/Runnable) + + (import: #long java/util/concurrent/TimeUnit + (#enum MILLISECONDS)) + + (import: #long java/util/concurrent/Executor + (execute [java/lang/Runnable] #io void)) + + (import: #long (java/util/concurrent/ScheduledFuture a)) + + (import: #long java/util/concurrent/ScheduledThreadPoolExecutor + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object)))) + + (~~ (static @.jvm)) (as-is (import: #long java/lang/Object) (import: #long java/lang/Runtime @@ -45,17 +66,25 @@ (def: #export parallelism Nat - (`` (for {(~~ (static host.old)) + (`` (for {(~~ (static @.old)) + (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) + .nat) + + (~~ (static @.jvm)) (|> (java/lang/Runtime::getRuntime) (java/lang/Runtime::availableProcessors) - .nat)} + (:coerce Nat))} ## Default 1))) (def: runner - (`` (for {(~~ (static host.old)) - (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))} + (`` (for {(~~ (static @.old)) + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism)) + + (~~ (static @.jvm)) + (java/util/concurrent/ScheduledThreadPoolExecutor::new (:coerce host.Long ..parallelism))} ## Default (: (Atom (List Process)) @@ -63,7 +92,17 @@ (def: #export (schedule milli-seconds action) (-> Nat (IO Any) (IO Any)) - (`` (for {(~~ (static host.old)) + (`` (for {(~~ (static @.old)) + (let [runnable (object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run) void + (io.run action)))] + (case milli-seconds + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner))) + + (~~ (static @.jvm)) (let [runnable (object [] [java/lang/Runnable] [] (java/lang/Runnable [] (run) void @@ -79,11 +118,14 @@ #action action})) runner)))) -(`` (for {(~~ (static host.old)) +(`` (for {(~~ (static @.old)) + (as-is) + + (~~ (static @.jvm)) (as-is)} ## Default - (as-is (exception: #export (cannot-continue-running-processes) "") + (as-is (exception: #export cannot-continue-running-processes) (def: #export run! (IO Any) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux new file mode 100644 index 000000000..b7775b395 --- /dev/null +++ b/stdlib/source/lux/host.jvm.lux @@ -0,0 +1,2087 @@ +(.module: + [lux (#- type int char) + [abstract + ["." monad (#+ Monad do)] + ["." enum]] + [control + ["p" parser] + ["." function] + ["." io]] + [data + ["." maybe] + ["." product] + ["." error (#+ Error)] + ["." bit ("#@." codec)] + number + ["." text ("#@." equivalence monoid) + format] + [collection + ["." array (#+ Array)] + ["." list ("#@." monad fold monoid)] + ["." dictionary (#+ Dictionary)]]] + ["." type ("#@." equivalence)] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax: Syntax)]]]) + +(template [<name> <class>] + [(type: #export <name> (primitive <class>))] + + ## Boxes + [Boolean "java.lang.Boolean"] + [Byte "java.lang.Byte"] + [Short "java.lang.Short"] + [Integer "java.lang.Integer"] + [Long "java.lang.Long"] + [Float "java.lang.Float"] + [Double "java.lang.Double"] + [Character "java.lang.Character"] + + ## Primitives + [boolean "boolean"] + [byte "byte"] + [short "short"] + [int "int"] + [long "long"] + [float "float"] + [double "double"] + [char "char"] + ) + +(def: (get-static-field class field) + (-> Text Text Code) + (` ("jvm member static get" + (~ (code.text class)) + (~ (code.text field))))) + +(def: (get-virtual-field class field object) + (-> Text Text Code Code) + (` ("jvm member virtual get" + (~ (code.text class)) + (~ (code.text field)) + (~ object)))) + +(def: boxes + (Dictionary Text Text) + (|> (list ["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + (dictionary.from-list text.hash))) + +(def: (unbox unboxed boxed raw) + (-> Text Text Code Code) + (` (|> (~ raw) + (: (primitive (~ (code.text boxed)))) + "jvm object cast" + (: (primitive (~ (code.text unboxed))))))) + +(def: (box unboxed boxed raw) + (-> Text Text Code Code) + (` (|> (~ raw) + (: (primitive (~ (code.text unboxed)))) + "jvm object cast" + (: (primitive (~ (code.text boxed))))))) + +(template [<name> <op> <from> <to>] + [(template: #export (<name> value) + {#.doc (doc "Type converter." + (: <to> + (<name> (: <from> foo))))} + (|> value + (: <from>) + "jvm object cast" + <op> + "jvm object cast" + (: <to>)))] + + [byte-to-long "jvm conversion byte-to-long" ..Byte ..Long] + + [short-to-long "jvm conversion short-to-long" ..Short ..Long] + + [double-to-int "jvm conversion double-to-int" ..Double ..Integer] + [double-to-long "jvm conversion double-to-long" ..Double ..Long] + [double-to-float "jvm conversion double-to-float" ..Double ..Float] + + [float-to-int "jvm conversion float-to-int" ..Float ..Integer] + [float-to-long "jvm conversion float-to-long" ..Float ..Long] + [float-to-double "jvm conversion float-to-double" ..Float ..Double] + + [int-to-byte "jvm conversion int-to-byte" ..Integer ..Byte] + [int-to-short "jvm conversion int-to-short" ..Integer ..Short] + [int-to-long "jvm conversion int-to-long" ..Integer ..Long] + [int-to-float "jvm conversion int-to-float" ..Integer ..Float] + [int-to-double "jvm conversion int-to-double" ..Integer ..Double] + [int-to-char "jvm conversion int-to-char" ..Integer ..Character] + + [long-to-byte "jvm conversion long-to-byte" ..Long ..Byte] + [long-to-short "jvm conversion long-to-short" ..Long ..Short] + [long-to-int "jvm conversion long-to-int" ..Long ..Integer] + [long-to-float "jvm conversion long-to-float" ..Long ..Float] + [long-to-double "jvm conversion long-to-double" ..Long ..Double] + + [char-to-byte "jvm conversion char-to-byte" ..Character ..Byte] + [char-to-short "jvm conversion char-to-short" ..Character ..Short] + [char-to-int "jvm conversion char-to-int" ..Character ..Integer] + [char-to-long "jvm conversion char-to-long" ..Character ..Long] + ) + +(def: constructor-method-name "<init>") +(def: member-separator "::") + +(type: JVM-Code Text) + +(type: BoundKind + #UpperBound + #LowerBound) + +(type: #rec GenericType + (#GenericTypeVar Text) + (#GenericClass [Text (List GenericType)]) + (#GenericArray GenericType) + (#GenericWildcard (Maybe [BoundKind GenericType]))) + +(type: Type-Paramameter + [Text (List GenericType)]) + +(type: Primitive-Mode + #ManualPrM + #AutoPrM) + +(type: PrivacyModifier + #PublicPM + #PrivatePM + #ProtectedPM + #DefaultPM) + +(type: StateModifier + #VolatileSM + #FinalSM + #DefaultSM) + +(type: InheritanceModifier + #FinalIM + #AbstractIM + #DefaultIM) + +(type: Class-Kind + #Class + #Interface) + +(type: Class-Declaration + {#class-name Text + #class-params (List Type-Paramameter)}) + +(type: StackFrame (primitive "java/lang/StackTraceElement")) +(type: StackTrace (Array StackFrame)) + +(type: Super-Class-Decl + {#super-class-name Text + #super-class-params (List GenericType)}) + +(type: AnnotationParam + [Text Code]) + +(type: Annotation + {#ann-name Text + #ann-params (List AnnotationParam)}) + +(type: Member-Declaration + {#member-name Text + #member-privacy PrivacyModifier + #member-anns (List Annotation)}) + +(type: FieldDecl + (#ConstantField GenericType Code) + (#VariableField StateModifier GenericType)) + +(type: MethodDecl + {#method-tvars (List Type-Paramameter) + #method-inputs (List GenericType) + #method-output GenericType + #method-exs (List GenericType)}) + +(type: ArgDecl + {#arg-name Text + #arg-type GenericType}) + +(type: ConstructorArg + [GenericType Code]) + +(type: Method-Definition + (#ConstructorMethod [Bit + (List Type-Paramameter) + (List ArgDecl) + (List ConstructorArg) + Code + (List GenericType)]) + (#VirtualMethod [Bit + Bit + (List Type-Paramameter) + (List ArgDecl) + GenericType + Code + (List GenericType)]) + (#OverridenMethod [Bit + Class-Declaration + (List Type-Paramameter) + (List ArgDecl) + GenericType + Code + (List GenericType)]) + (#StaticMethod [Bit + (List Type-Paramameter) + (List ArgDecl) + GenericType + Code + (List GenericType)]) + (#AbstractMethod [(List Type-Paramameter) + (List ArgDecl) + GenericType + (List GenericType)]) + (#NativeMethod [(List Type-Paramameter) + (List ArgDecl) + GenericType + (List GenericType)])) + +(type: Partial-Call + {#pc-method Name + #pc-args (List Code)}) + +(type: ImportMethodKind + #StaticIMK + #VirtualIMK) + +(type: ImportMethodCommons + {#import-member-mode Primitive-Mode + #import-member-alias Text + #import-member-kind ImportMethodKind + #import-member-tvars (List Type-Paramameter) + #import-member-args (List [Bit GenericType]) + #import-member-maybe? Bit + #import-member-try? Bit + #import-member-io? Bit}) + +(type: ImportConstructorDecl + {}) + +(type: ImportMethodDecl + {#import-method-name Text + #import-method-return GenericType}) + +(type: ImportFieldDecl + {#import-field-mode Primitive-Mode + #import-field-name Text + #import-field-static? Bit + #import-field-maybe? Bit + #import-field-setter? Bit + #import-field-type GenericType}) + +(type: Import-Member-Declaration + (#EnumDecl (List Text)) + (#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]) + (#MethodDecl [ImportMethodCommons ImportMethodDecl]) + (#FieldAccessDecl ImportFieldDecl)) + +(type: Class-Imports + (List [Text Text])) + +(def: (short-class-name name) + (-> Text Text) + (case (list.reverse (text.split-all-with "/" name)) + (#.Cons short-name _) + short-name + + #.Nil + name)) + +(def: (manual-primitive-to-type class) + (-> Text (Maybe Code)) + (case class + (^template [<prim> <type>] + <prim> + (#.Some (' <type>))) + (["boolean" (primitive "java.lang.Boolean")] + ["byte" (primitive "java.lang.Byte")] + ["short" (primitive "java.lang.Short")] + ["int" (primitive "java.lang.Integer")] + ["long" (primitive "java.lang.Long")] + ["float" (primitive "java.lang.Float")] + ["double" (primitive "java.lang.Double")] + ["char" (primitive "java.lang.Character")] + ["void" .Any]) + + _ + #.None)) + +(def: (auto-primitive-to-type class) + (-> Text (Maybe Code)) + (case class + (^template [<prim> <type>] + <prim> + (#.Some (' <type>))) + (["boolean" .Bit] + ["byte" .Int] + ["short" .Int] + ["int" .Int] + ["long" .Int] + ["float" .Frac] + ["double" .Frac] + ["void" .Any]) + + _ + #.None)) + +(def: sanitize + (-> Text Text) + (text.replace-all "/" ".")) + +(def: (generic-class->type' mode type-params in-array? name+params + class->type') + (-> Primitive-Mode (List Type-Paramameter) Bit [Text (List GenericType)] + (-> Primitive-Mode (List Type-Paramameter) Bit GenericType Code) + Code) + (case [name+params mode in-array?] + (^multi [[prim #.Nil] #ManualPrM #0] + [(manual-primitive-to-type prim) (#.Some output)]) + output + + (^multi [[prim #.Nil] #AutoPrM #0] + [(auto-primitive-to-type prim) (#.Some output)]) + output + + [[name params] _ _] + (let [name (sanitize name) + =params (list@map (class->type' mode type-params in-array?) params)] + (` (primitive (~ (code.text name)) [(~+ =params)]))))) + +(def: (class->type' mode type-params in-array? class) + (-> Primitive-Mode (List Type-Paramameter) Bit GenericType Code) + (case class + (#GenericTypeVar name) + (case (list.find (function (_ [pname pbounds]) + (and (text@= name pname) + (not (list.empty? pbounds)))) + type-params) + #.None + (code.identifier ["" name]) + + (#.Some [pname pbounds]) + (class->type' mode type-params in-array? (maybe.assume (list.head pbounds)))) + + (#GenericClass name+params) + (generic-class->type' mode type-params in-array? name+params + class->type') + + (#GenericArray param) + (let [=param (class->type' mode type-params #1 param)] + (` ((~! array.Array) (~ =param)))) + + (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) + (' (.Ex [*] *)) + + (#GenericWildcard (#.Some [#UpperBound upper-bound])) + (class->type' mode type-params in-array? upper-bound) + )) + +(def: (class->type mode type-params class) + (-> Primitive-Mode (List Type-Paramameter) GenericType Code) + (class->type' mode type-params #0 class)) + +(def: (type-param-type$ [name bounds]) + (-> Type-Paramameter Code) + (code.identifier ["" name])) + +(def: (class-decl-type$ (^slots [#class-name #class-params])) + (-> Class-Declaration Code) + (let [=params (list@map (: (-> Type-Paramameter Code) + (function (_ [pname pbounds]) + (case pbounds + #.Nil + (code.identifier ["" pname]) + + (#.Cons bound1 _) + (class->type #ManualPrM class-params bound1)))) + class-params)] + (` (primitive (~ (code.text (sanitize class-name))) + [(~+ =params)])))) + +(def: empty-imports + Class-Imports + (list)) + +(def: (get-import name imports) + (-> Text Class-Imports (Maybe Text)) + (:: maybe.functor map product.right + (list.find (|>> product.left (text@= name)) + imports))) + +(def: (add-import short+full imports) + (-> [Text Text] Class-Imports Class-Imports) + (#.Cons short+full imports)) + +(def: (class-imports compiler) + (-> Lux Class-Imports) + (case (macro.run compiler + (: (Meta Class-Imports) + (do macro.monad + [current-module macro.current-module-name + definitions (macro.definitions current-module)] + (wrap (list@fold (: (-> [Text Definition] Class-Imports Class-Imports) + (function (_ [short-name [_ meta _]] imports) + (case (macro.get-text-ann (name-of #..jvm-class) meta) + (#.Some full-class-name) + (add-import [short-name full-class-name] imports) + + _ + imports))) + empty-imports + definitions))))) + (#.Left _) (list) + (#.Right imports) imports)) + +(def: java/lang/* + (List Text) + (list + ## Interfaces + "Appendable" + "AutoCloseable" + "CharSequence" + "Cloneable" + "Comparable" + "Iterable" + "Readable" + "Runnable" + + ## Classes + "Boolean" + "Byte" + "Character" + "Class" + "ClassLoader" + "ClassValue" + "Compiler" + "Double" + "Enum" + "Float" + "InheritableThreadLocal" + "Integer" + "Long" + "Math" + "Number" + "Object" + "Package" + "Process" + "ProcessBuilder" + "Runtime" + "RuntimePermission" + "SecurityManager" + "Short" + "StackTraceElement" + "StrictMath" + "String" + "StringBuffer" + "StringBuilder" + "System" + "Thread" + "ThreadGroup" + "ThreadLocal" + "Throwable" + "Void" + + ## Exceptions + "ArithmeticException" + "ArrayIndexOutOfBoundsException" + "ArrayStoreException" + "ClassCastException" + "ClassNotFoundException" + "CloneNotSupportedException" + "EnumConstantNotPresentException" + "Exception" + "IllegalAccessException" + "IllegalArgumentException" + "IllegalMonitorStateException" + "IllegalStateException" + "IllegalThreadStateException" + "IndexOutOfBoundsException" + "InstantiationException" + "InterruptedException" + "NegativeArraySizeException" + "NoSuchFieldException" + "NoSuchMethodException" + "NullPointerException" + "NumberFormatException" + "ReflectiveOperationException" + "RuntimeException" + "SecurityException" + "StringIndexOutOfBoundsException" + "TypeNotPresentException" + "UnsupportedOperationException" + + ## Annotations + "Deprecated" + "Override" + "SafeVarargs" + "SuppressWarnings")) + +(def: (qualify imports name) + (-> Class-Imports Text Text) + (if (list.member? text.equivalence java/lang/* name) + (format "java/lang/" name) + (maybe.default name (get-import name imports)))) + +(def: type-var-class Text "java.lang.Object") + +(def: (simple-class$ env class) + (-> (List Type-Paramameter) GenericType Text) + (case class + (#GenericTypeVar name) + (case (list.find (function (_ [pname pbounds]) + (and (text@= name pname) + (not (list.empty? pbounds)))) + env) + #.None + type-var-class + + (#.Some [pname pbounds]) + (simple-class$ env (maybe.assume (list.head pbounds)))) + + (^or (#GenericWildcard #.None) (#GenericWildcard (#.Some [#LowerBound _]))) + type-var-class + + (#GenericWildcard (#.Some [#UpperBound upper-bound])) + (simple-class$ env upper-bound) + + (#GenericClass name env) + (sanitize name) + + (#GenericArray param') + (case param' + (#GenericArray param) + (format "[" (simple-class$ env param)) + + (^template [<prim> <class>] + (#GenericClass <prim> #.Nil) + <class>) + (["boolean" "[Z"] + ["byte" "[B"] + ["short" "[S"] + ["int" "[I"] + ["long" "[J"] + ["float" "[F"] + ["double" "[D"] + ["char" "[C"]) + + param + (format "[L" (simple-class$ env param) ";")) + )) + +(def: (make-get-const-parser class-name field-name) + (-> Text Text (Syntax Code)) + (do p.monad + [#let [dotted-name (format "::" field-name)] + _ (s.this (code.identifier ["" dotted-name]))] + (wrap (get-static-field class-name field-name)))) + +(def: (make-get-var-parser class-name field-name) + (-> Text Text (Syntax Code)) + (do p.monad + [#let [dotted-name (format "::" field-name)] + _ (s.this (code.identifier ["" dotted-name]))] + (wrap (get-virtual-field class-name field-name (' _jvm_this))))) + +(def: (make-put-var-parser class-name field-name) + (-> Text Text (Syntax Code)) + (do p.monad + [#let [dotted-name (format "::" field-name)] + [_ _ value] (: (Syntax [Any Any Code]) + (s.form ($_ p.and (s.this (' :=)) (s.this (code.identifier ["" dotted-name])) s.any)))] + (wrap (`' ((~ (code.text (format "jvm putfield" ":" class-name ":" field-name))) _jvm_this (~ value)))))) + +(def: (pre-walk-replace f input) + (-> (-> Code Code) Code Code) + (case (f input) + (^template [<tag>] + [meta (<tag> parts)] + [meta (<tag> (list@map (pre-walk-replace f) parts))]) + ([#.Form] + [#.Tuple]) + + [meta (#.Record pairs)] + [meta (#.Record (list@map (: (-> [Code Code] [Code Code]) + (function (_ [key val]) + [(pre-walk-replace f key) (pre-walk-replace f val)])) + pairs))] + + ast' + ast')) + +(def: (parser->replacer p ast) + (-> (Syntax Code) (-> Code Code)) + (case (p.run (list ast) p) + (#.Right [#.Nil ast']) + ast' + + _ + ast + )) + +(def: (field->parser class-name [[field-name _ _] field]) + (-> Text [Member-Declaration FieldDecl] (Syntax Code)) + (case field + (#ConstantField _) + (make-get-const-parser class-name field-name) + + (#VariableField _) + (p.either (make-get-var-parser class-name field-name) + (make-put-var-parser class-name field-name)))) + +(def: (decorate-input [class value]) + (-> [Text Code] Code) + (` [(~ (code.text class)) (~ value)])) + +(def: (make-constructor-parser params class-name arg-decls) + (-> (List Type-Paramameter) Text (List ArgDecl) (Syntax Code)) + (do p.monad + [args (: (Syntax (List Code)) + (s.form (p.after (s.this (' ::new!)) + (s.tuple (p.exactly (list.size arg-decls) s.any))))) + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]] + (wrap (` ("jvm member invoke constructor" (~ (code.text class-name)) + (~+ (|> args + (list.zip2 arg-decls') + (list@map ..decorate-input)))))))) + +(def: (make-static-method-parser params class-name method-name arg-decls) + (-> (List Type-Paramameter) Text Text (List ArgDecl) (Syntax Code)) + (do p.monad + [#let [dotted-name (format "::" method-name "!")] + args (: (Syntax (List Code)) + (s.form (p.after (s.this (code.identifier ["" dotted-name])) + (s.tuple (p.exactly (list.size arg-decls) s.any))))) + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]] + (wrap (` ("jvm member invoke static" (~ (code.text class-name)) (~ (code.text method-name)) + (~+ (|> args + (list.zip2 arg-decls') + (list@map ..decorate-input)))))))) + +(template [<name> <jvm-op>] + [(def: (<name> params class-name method-name arg-decls) + (-> (List Type-Paramameter) Text Text (List ArgDecl) (Syntax Code)) + (do p.monad + [#let [dotted-name (format "::" method-name "!")] + args (: (Syntax (List Code)) + (s.form (p.after (s.this (code.identifier ["" dotted-name])) + (s.tuple (p.exactly (list.size arg-decls) s.any))))) + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]] + (wrap (` (<jvm-op> (~ (code.text class-name)) (~ (code.text method-name)) + (~' _jvm_this) + (~+ (|> args + (list.zip2 arg-decls') + (list@map ..decorate-input))))))))] + + [make-special-method-parser "jvm member invoke special"] + [make-virtual-method-parser "jvm member invoke virtual"] + ) + +(def: (method->parser params class-name [[method-name _ _] meth-def]) + (-> (List Type-Paramameter) Text [Member-Declaration Method-Definition] (Syntax Code)) + (case meth-def + (#ConstructorMethod strict? type-vars args constructor-args return-expr exs) + (make-constructor-parser params class-name args) + + (#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)) + (make-special-method-parser params class-name method-name args) + + (#AbstractMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args) + + (#NativeMethod type-vars args return-type exs) + (make-virtual-method-parser params class-name method-name args))) + +(def: (full-class-name^ imports) + (-> Class-Imports (Syntax Text)) + (do p.monad + [name s.local-identifier] + (wrap (qualify imports name)))) + +(def: privacy-modifier^ + (Syntax PrivacyModifier) + (let [(^open ".") p.monad] + ($_ p.or + (s.this (' #public)) + (s.this (' #private)) + (s.this (' #protected)) + (wrap [])))) + +(def: inheritance-modifier^ + (Syntax InheritanceModifier) + (let [(^open ".") p.monad] + ($_ p.or + (s.this (' #final)) + (s.this (' #abstract)) + (wrap [])))) + +(def: bound-kind^ + (Syntax BoundKind) + (p.or (s.this (' <)) + (s.this (' >)))) + +(def: (assert-no-periods name) + (-> Text (Syntax Any)) + (p.assert "Names in class declarations cannot contain periods." + (not (text.contains? "." name)))) + +(def: (generic-type^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax GenericType)) + ($_ p.either + (do p.monad + [_ (s.this (' ?))] + (wrap (#GenericWildcard #.None))) + (s.tuple (do p.monad + [_ (s.this (' ?)) + bound-kind bound-kind^ + bound (generic-type^ imports type-vars)] + (wrap (#GenericWildcard (#.Some [bound-kind bound]))))) + (do p.monad + [name (full-class-name^ imports) + _ (assert-no-periods name)] + (if (list.member? text.equivalence (list@map product.left type-vars) name) + (wrap (#GenericTypeVar name)) + (wrap (#GenericClass name (list))))) + (s.form (do p.monad + [name (s.this (' Array)) + component (generic-type^ imports type-vars)] + (case component + (^template [<class> <name>] + (#GenericClass <name> #.Nil) + (wrap (#GenericClass <class> (list)))) + (["[Z" "boolean"] + ["[B" "byte"] + ["[S" "short"] + ["[I" "int"] + ["[J" "long"] + ["[F" "float"] + ["[D" "double"] + ["[C" "char"]) + + _ + (wrap (#GenericArray component))))) + (s.form (do p.monad + [name (full-class-name^ imports) + _ (assert-no-periods name) + params (p.some (generic-type^ imports type-vars)) + _ (p.assert (format name " cannot be a type-parameter!") + (not (list.member? text.equivalence (list@map product.left type-vars) name)))] + (wrap (#GenericClass name params)))) + )) + +(def: (type-param^ imports) + (-> Class-Imports (Syntax Type-Paramameter)) + (p.either (do p.monad + [param-name s.local-identifier] + (wrap [param-name (list)])) + (s.tuple (do p.monad + [param-name s.local-identifier + _ (s.this (' <)) + bounds (p.many (generic-type^ imports (list)))] + (wrap [param-name bounds]))))) + +(def: (type-params^ imports) + (-> Class-Imports (Syntax (List Type-Paramameter))) + (s.tuple (p.some (type-param^ imports)))) + +(def: (class-decl^ imports) + (-> Class-Imports (Syntax Class-Declaration)) + (p.either (do p.monad + [name (full-class-name^ imports) + _ (assert-no-periods name)] + (wrap [name (list)])) + (s.form (do p.monad + [name (full-class-name^ imports) + _ (assert-no-periods name) + params (p.some (type-param^ imports))] + (wrap [name params]))) + )) + +(def: (super-class-decl^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax Super-Class-Decl)) + (p.either (do p.monad + [name (full-class-name^ imports) + _ (assert-no-periods name)] + (wrap [name (list)])) + (s.form (do p.monad + [name (full-class-name^ imports) + _ (assert-no-periods name) + params (p.some (generic-type^ imports type-vars))] + (wrap [name params]))))) + +(def: annotation-params^ + (Syntax (List AnnotationParam)) + (s.record (p.some (p.and s.local-tag s.any)))) + +(def: (annotation^ imports) + (-> Class-Imports (Syntax Annotation)) + (p.either (do p.monad + [ann-name (full-class-name^ imports)] + (wrap [ann-name (list)])) + (s.form (p.and (full-class-name^ imports) + annotation-params^)))) + +(def: (annotations^' imports) + (-> Class-Imports (Syntax (List Annotation))) + (do p.monad + [_ (s.this (' #ann))] + (s.tuple (p.some (annotation^ imports))))) + +(def: (annotations^ imports) + (-> Class-Imports (Syntax (List Annotation))) + (do p.monad + [anns?? (p.maybe (annotations^' imports))] + (wrap (maybe.default (list) anns??)))) + +(def: (throws-decl'^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax (List GenericType))) + (do p.monad + [_ (s.this (' #throws))] + (s.tuple (p.some (generic-type^ imports type-vars))))) + +(def: (throws-decl^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax (List GenericType))) + (do p.monad + [exs? (p.maybe (throws-decl'^ imports type-vars))] + (wrap (maybe.default (list) exs?)))) + +(def: (method-decl^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration MethodDecl])) + (s.form (do p.monad + [tvars (p.default (list) (type-params^ imports)) + name s.local-identifier + anns (annotations^ imports) + inputs (s.tuple (p.some (generic-type^ imports type-vars))) + output (generic-type^ imports type-vars) + exs (throws-decl^ imports type-vars)] + (wrap [[name #PublicPM anns] {#method-tvars tvars + #method-inputs inputs + #method-output output + #method-exs exs}])))) + +(def: state-modifier^ + (Syntax StateModifier) + ($_ p.or + (s.this (' #volatile)) + (s.this (' #final)) + (:: p.monad wrap []))) + +(def: (field-decl^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration FieldDecl])) + (p.either (s.form (do p.monad + [_ (s.this (' #const)) + name s.local-identifier + anns (annotations^ imports) + type (generic-type^ imports type-vars) + body s.any] + (wrap [[name #PublicPM anns] (#ConstantField [type body])]))) + (s.form (do p.monad + [pm privacy-modifier^ + sm state-modifier^ + name s.local-identifier + anns (annotations^ imports) + type (generic-type^ imports type-vars)] + (wrap [[name pm anns] (#VariableField [sm type])]))))) + +(def: (arg-decl^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax ArgDecl)) + (s.record (p.and s.local-identifier + (generic-type^ imports type-vars)))) + +(def: (arg-decls^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax (List ArgDecl))) + (p.some (arg-decl^ imports type-vars))) + +(def: (constructor-arg^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax ConstructorArg)) + (s.record (p.and (generic-type^ imports type-vars) s.any))) + +(def: (constructor-args^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax (List ConstructorArg))) + (s.tuple (p.some (constructor-arg^ imports type-vars)))) + +(def: (constructor-method^ imports class-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration Method-Definition])) + (s.form (do p.monad + [pm privacy-modifier^ + strict-fp? (s.this? (' #strict)) + method-vars (p.default (list) (type-params^ imports)) + #let [total-vars (list@compose class-vars method-vars)] + [_ arg-decls] (s.form (p.and (s.this (' new)) + (arg-decls^ imports total-vars))) + constructor-args (constructor-args^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s.any] + (wrap [{#member-name constructor-method-name + #member-privacy pm + #member-anns annotations} + (#ConstructorMethod strict-fp? method-vars arg-decls constructor-args body exs)])))) + +(def: (virtual-method-def^ imports class-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration Method-Definition])) + (s.form (do p.monad + [pm privacy-modifier^ + strict-fp? (s.this? (' #strict)) + 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))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s.any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#VirtualMethod final? strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (overriden-method-def^ imports) + (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) + (s.form (do p.monad + [strict-fp? (s.this? (' #strict)) + 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))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s.any] + (wrap [{#member-name name + #member-privacy #PublicPM + #member-anns annotations} + (#OverridenMethod strict-fp? owner-class method-vars arg-decls return-type body exs)])))) + +(def: (static-method-def^ imports) + (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) + (s.form (do p.monad + [pm privacy-modifier^ + strict-fp? (s.this? (' #strict)) + _ (s.this (' #static)) + method-vars (p.default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s.form (p.and s.local-identifier + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports) + body s.any] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#StaticMethod strict-fp? method-vars arg-decls return-type body exs)])))) + +(def: (abstract-method-def^ imports) + (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) + (s.form (do p.monad + [pm privacy-modifier^ + _ (s.this (' #abstract)) + method-vars (p.default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s.form (p.and s.local-identifier + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#AbstractMethod method-vars arg-decls return-type exs)])))) + +(def: (native-method-def^ imports) + (-> Class-Imports (Syntax [Member-Declaration Method-Definition])) + (s.form (do p.monad + [pm privacy-modifier^ + _ (s.this (' #native)) + method-vars (p.default (list) (type-params^ imports)) + #let [total-vars method-vars] + [name arg-decls] (s.form (p.and s.local-identifier + (arg-decls^ imports total-vars))) + return-type (generic-type^ imports total-vars) + exs (throws-decl^ imports total-vars) + annotations (annotations^ imports)] + (wrap [{#member-name name + #member-privacy pm + #member-anns annotations} + (#NativeMethod method-vars arg-decls return-type exs)])))) + +(def: (method-def^ imports class-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax [Member-Declaration Method-Definition])) + ($_ p.either + (constructor-method^ imports class-vars) + (virtual-method-def^ imports class-vars) + (overriden-method-def^ imports) + (static-method-def^ imports) + (abstract-method-def^ imports) + (native-method-def^ imports))) + +(def: partial-call^ + (Syntax Partial-Call) + (s.form (p.and s.identifier (p.some s.any)))) + +(def: class-kind^ + (Syntax Class-Kind) + (p.either (do p.monad + [_ (s.this (' #class))] + (wrap #Class)) + (do p.monad + [_ (s.this (' #interface))] + (wrap #Interface)) + )) + +(def: import-member-alias^ + (Syntax (Maybe Text)) + (p.maybe (do p.monad + [_ (s.this (' #as))] + s.local-identifier))) + +(def: (import-member-args^ imports type-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax (List [Bit GenericType]))) + (s.tuple (p.some (p.and (s.this? (' #?)) (generic-type^ imports type-vars))))) + +(def: import-member-return-flags^ + (Syntax [Bit Bit Bit]) + ($_ p.and (s.this? (' #io)) (s.this? (' #try)) (s.this? (' #?)))) + +(def: primitive-mode^ + (Syntax Primitive-Mode) + (p.or (s.this (' #manual)) + (s.this (' #auto)))) + +(def: (import-member-decl^ imports owner-vars) + (-> Class-Imports (List Type-Paramameter) (Syntax Import-Member-Declaration)) + ($_ p.either + (s.form (do p.monad + [_ (s.this (' #enum)) + enum-members (p.some s.local-identifier)] + (wrap (#EnumDecl enum-members)))) + (s.form (do p.monad + [tvars (p.default (list) (type-params^ imports)) + _ (s.this (' new)) + ?alias import-member-alias^ + #let [total-vars (list@compose owner-vars tvars)] + ?prim-mode (p.maybe primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^] + (wrap (#ConstructorDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode) + #import-member-alias (maybe.default "new" ?alias) + #import-member-kind #VirtualIMK + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {}])) + )) + (s.form (do p.monad + [kind (: (Syntax ImportMethodKind) + (p.or (s.this (' #static)) + (wrap []))) + tvars (p.default (list) (type-params^ imports)) + name s.local-identifier + ?alias import-member-alias^ + #let [total-vars (list@compose owner-vars tvars)] + ?prim-mode (p.maybe primitive-mode^) + args (import-member-args^ imports total-vars) + [io? try? maybe?] import-member-return-flags^ + return (generic-type^ imports total-vars)] + (wrap (#MethodDecl [{#import-member-mode (maybe.default #AutoPrM ?prim-mode) + #import-member-alias (maybe.default name ?alias) + #import-member-kind kind + #import-member-tvars tvars + #import-member-args args + #import-member-maybe? maybe? + #import-member-try? try? + #import-member-io? io?} + {#import-method-name name + #import-method-return return + }])))) + (s.form (do p.monad + [static? (s.this? (' #static)) + name s.local-identifier + ?prim-mode (p.maybe primitive-mode^) + gtype (generic-type^ imports owner-vars) + maybe? (s.this? (' #?)) + setter? (s.this? (' #!))] + (wrap (#FieldAccessDecl {#import-field-mode (maybe.default #AutoPrM ?prim-mode) + #import-field-name name + #import-field-static? static? + #import-field-maybe? maybe? + #import-field-setter? setter? + #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) + (case pm + #PublicPM "public" + #PrivatePM "private" + #ProtectedPM "protected" + #DefaultPM "default")) + +(def: (inheritance-modifier$ im) + (-> InheritanceModifier JVM-Code) + (case im + #FinalIM "final" + #AbstractIM "abstract" + #DefaultIM "default")) + +(def: (annotation-param$ [name value]) + (-> AnnotationParam JVM-Code) + (format name "=" (code.to-text value))) + +(def: (annotation$ [name params]) + (-> Annotation JVM-Code) + (format "(" name " " "{" (text.join-with text.tab (list@map annotation-param$ params)) "}" ")")) + +(def: (bound-kind$ kind) + (-> BoundKind JVM-Code) + (case kind + #UpperBound "<" + #LowerBound ">")) + +(def: (generic-type$ gtype) + (-> GenericType JVM-Code) + (case gtype + (#GenericTypeVar name) + name + + (#GenericClass name params) + (format "(" (sanitize name) " " (spaced (list@map generic-type$ params)) ")") + + (#GenericArray param) + (format "(" array.type-name " " (generic-type$ param) ")") + + (#GenericWildcard #.None) + "?" + + (#GenericWildcard (#.Some [bound-kind bound])) + (format (bound-kind$ bound-kind) (generic-type$ bound)))) + +(def: (type-param$ [name bounds]) + (-> Type-Paramameter JVM-Code) + (format "(" name " " (spaced (list@map generic-type$ bounds)) ")")) + +(def: (class-decl$ (^open ".")) + (-> Class-Declaration JVM-Code) + (format "(" (sanitize class-name) " " (spaced (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)) ")")) + +(def: (method-decl$ [[name pm anns] method-decl]) + (-> [Member-Declaration MethodDecl] JVM-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)) + )))) + +(def: (state-modifier$ sm) + (-> StateModifier JVM-Code) + (case sm + #VolatileSM "volatile" + #FinalSM "final" + #DefaultSM "default")) + +(def: (field-decl$ [[name pm anns] field]) + (-> [Member-Declaration FieldDecl] JVM-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)) + )) + + (#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)) + )) + )) + +(def: (arg-decl$ [name type]) + (-> ArgDecl JVM-Code) + (with-parens + (spaced (list name (generic-type$ type))))) + +(def: (constructor-arg$ [class term]) + (-> ConstructorArg JVM-Code) + (with-brackets + (spaced (list (generic-type$ class) (code.to-text term))))) + +(def: (method-def$ replacer super-class [[name pm anns] method-def]) + (-> (-> Code Code) Super-Class-Decl [Member-Declaration Method-Definition] JVM-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)) + ))) + + (#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))))) + + (#OverridenMethod strict-fp? class-decl type-vars 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)) + #let [arg-decls' (: (List Text) + (list@map (|>> product.right (simple-class$ (list))) + arg-decls))]] + (wrap (` ("jvm member invoke special" + (~ (code.text (get@ #super-class-name super-class))) + (~ (code.text name)) + (~' _jvm_this) + (~+ (|> 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)) + )))) + + (#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))))) + + (#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)))) + + (#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)))) + )) + +(def: (complete-call$ g!obj [method args]) + (-> Code Partial-Call Code) + (` ((~ (code.identifier method)) (~+ args) (~ g!obj)))) + +(def: object-super-class + Super-Class-Decl + {#super-class-name "java/lang/Object" + #super-class-params (list)}) + +(syntax: #export (class: + {#let [imports (class-imports *compiler*)]} + {im inheritance-modifier^} + {class-decl (class-decl^ imports)} + {#let [full-class-name (product.left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]} + {#let [class-vars (product.right class-decl)]} + {super (p.default object-super-class + (super-class-decl^ imports class-vars))} + {interfaces (p.default (list) + (s.tuple (p.some (super-class-decl^ imports class-vars))))} + {annotations (annotations^ imports)} + {fields (p.some (field-decl^ imports class-vars))} + {methods (p.some (method-def^ imports class-vars))}) + {#.doc (doc "Allows defining JVM classes in Lux code." + "For example:" + (class: #final (TestClass A) [Runnable] + ## Fields + (#private foo boolean) + (#private bar A) + (#private baz java/lang/Object) + ## Methods + (#public [] (new [value A]) [] + (exec (:= ::foo #1) + (:= ::bar value) + (:= ::baz "") + [])) + (#public (virtual) java/lang/Object + "") + (#public #static (static) java/lang/Object + "") + (Runnable [] (run) void + []) + ) + + "The tuple corresponds to parent interfaces." + "An optional super-class can be specified before the tuple. If not specified, java.lang.Object will be assumed." + "Fields and methods defined in the class can be used with special syntax." + "For example:" + "::resolved, for accessing the 'resolved' field." + "(:= ::resolved #1) for modifying it." + "(::new! []) for calling the class's constructor." + "(::resolve! container [value]) for calling the 'resolve' method." + )} + (do macro.monad + [current-module macro.current-module-name + #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name) + field-parsers (list@map (field->parser fully-qualified-class-name) fields) + 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)))))))) + +(syntax: #export (interface: + {#let [imports (class-imports *compiler*)]} + {class-decl (class-decl^ imports)} + {#let [full-class-name (product.left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]} + {#let [class-vars (product.right class-decl)]} + {supers (p.default (list) + (s.tuple (p.some (super-class-decl^ imports class-vars))))} + {annotations (annotations^ imports)} + {members (p.some (method-decl^ imports class-vars))}) + {#.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)))))) + )) + +(syntax: #export (object + {#let [imports (class-imports *compiler*)]} + {class-vars (s.tuple (p.some (type-param^ imports)))} + {super (p.default object-super-class + (super-class-decl^ imports class-vars))} + {interfaces (p.default (list) + (s.tuple (p.some (super-class-decl^ imports class-vars))))} + {constructor-args (constructor-args^ imports class-vars)} + {methods (p.some (overriden-method-def^ imports))}) + {#.doc (doc "Allows defining anonymous classes." + "The 1st tuple corresponds to class-level type-variables." + "The 2nd tuple corresponds to parent interfaces." + "The 3rd tuple corresponds to arguments to the super class constructor." + "An optional super-class can be specified before the 1st tuple. If not specified, java.lang.Object will be assumed." + (object [] [Runnable] + [] + (Runnable [] (run) void + (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)))))))) + +(syntax: #export (null) + {#.doc (doc "Null object reference." + (null))} + (wrap (list (` ("jvm object null"))))) + +(def: #export (null? obj) + {#.doc (doc "Test for null object reference." + (= (null? (null)) + true) + (= (null? "YOLO") + false))} + (-> (primitive "java.lang.Object") Bit) + ("jvm object null?" obj)) + +(syntax: #export (??? expr) + {#.doc (doc "Takes a (potentially null) ObjectType reference and creates a (Maybe ObjectType) for it." + (= (??? (: java/lang/String (null))) + #.None) + (= (??? "YOLO") + (#.Some "YOLO")))} + (with-gensyms [g!temp] + (wrap (list (` (let [(~ g!temp) (~ expr)] + (if ("jvm object null?" (~ g!temp)) + #.None + (#.Some (~ g!temp))))))))) + +(syntax: #export (!!! expr) + {#.doc (doc "Takes a (Maybe ObjectType) and returns a ObjectType." + "A #.None would get translated into a (null)." + (= (null) + (!!! (??? (: java/lang/Thread (null))))) + (= "foo" + (!!! (??? "foo"))))} + (with-gensyms [g!value] + (wrap (list (` ({(#.Some (~ g!value)) + (~ g!value) + + #.None + ("jvm object null")} + (~ expr))))))) + +(syntax: #export (try expression) + {#.doc (doc (case (try (risky-computation input)) + (#.Right success) + (do-something success) + + (#.Left error) + (recover-from-failure error)))} + (with-gensyms [g!_] + (wrap (list (` ("lux try" ((~! io.label) (.function ((~ g!_) (~ g!_)) + (~ expression))))))))) + +(syntax: #export (check {#let [imports (class-imports *compiler*)]} + {class (generic-type^ imports (list))} + {unchecked (p.maybe s.any)}) + {#.doc (doc "Checks whether an object is an instance of a particular class." + "Caveat emptor: Cannot check for polymorphism, so avoid using parameterized classes." + (case (check String "YOLO") + (#.Some value-as-string) + #.None))} + (with-gensyms [g!_ g!unchecked] + (let [class-name (simple-class$ (list) class) + class-type (` (.primitive (~ (code.text class-name)))) + check-type (` (.Maybe (~ class-type))) + check-code (` (if ((~ (code.text (format "jvm instanceof" ":" class-name))) (~ g!unchecked)) + (#.Some (.:coerce (~ class-type) + (~ g!unchecked))) + #.None))] + (case unchecked + (#.Some unchecked) + (wrap (list (` (: (~ check-type) + (let [(~ g!unchecked) (~ unchecked)] + (~ check-code)))))) + + #.None + (wrap (list (` (: (-> (primitive "java.lang.Object") (~ check-type)) + (function ((~ g!_) (~ g!unchecked)) + (~ check-code)))))) + )))) + +(syntax: #export (synchronized lock body) + {#.doc (doc "Evaluates body, while holding a lock on a given object." + (synchronized object-to-be-locked + (exec (do-something ___) + (do-something-else ___) + (finish-the-computation ___))))} + (wrap (list (` ("jvm object synchronized" (~ lock) (~ body)))))) + +(syntax: #export (do-to obj {methods (p.some partial-call^)}) + {#.doc (doc "Call a variety of methods on an object. Then, return the object." + (do-to object + (ClassName::method1 arg0 arg1 arg2) + (ClassName::method2 arg3 arg4 arg5)))} + (with-gensyms [g!obj] + (wrap (list (` (let [(~ g!obj) (~ obj)] + (exec (~+ (list@map (complete-call$ g!obj) methods)) + (~ g!obj)))))))) + +(def: (class-import$ long-name? [full-name params]) + (-> Bit Class-Declaration Code) + (let [def-name (if long-name? + full-name + (short-class-name full-name)) + params' (list@map (|>> product.left code.local-identifier) params)] + (` (def: (~ (code.identifier ["" def-name])) + {#.type? #1 + #..jvm-class (~ (code.text full-name))} + Type + (All [(~+ params')] + (primitive (~ (code.text (sanitize full-name))) + [(~+ params')])))))) + +(def: (member-type-vars class-tvars member) + (-> (List Type-Paramameter) Import-Member-Declaration (List Type-Paramameter)) + (case member + (#ConstructorDecl [commons _]) + (list@compose class-tvars (get@ #import-member-tvars commons)) + + (#MethodDecl [commons _]) + (case (get@ #import-member-kind commons) + #StaticIMK + (get@ #import-member-tvars commons) + + _ + (list@compose class-tvars (get@ #import-member-tvars commons))) + + _ + class-tvars)) + +(def: (member-def-arg-bindings type-params class member) + (-> (List Type-Paramameter) Class-Declaration Import-Member-Declaration (Meta [(List [Bit Code]) (List Text) (List Code)])) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (let [(^slots [#import-member-tvars #import-member-args]) commons] + (do macro.monad + [arg-inputs (monad.map @ + (: (-> [Bit GenericType] (Meta [Bit Code])) + (function (_ [maybe? _]) + (with-gensyms [arg-name] + (wrap [maybe? arg-name])))) + import-member-args) + #let [arg-classes (: (List Text) + (list@map (|>> product.right (simple-class$ (list@compose type-params import-member-tvars))) + import-member-args)) + arg-types (list@map (: (-> [Bit GenericType] Code) + (function (_ [maybe? arg]) + (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] + (if maybe? + (` (Maybe (~ arg-type))) + arg-type)))) + import-member-args)]] + (wrap [arg-inputs arg-classes arg-types]))) + + _ + (:: macro.monad wrap [(list) (list) (list)]))) + +(def: (decorate-return-maybe member never-null? unboxed return-term) + (-> Import-Member-Declaration Bit Text Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (cond (or never-null? + (dictionary.contains? unboxed ..boxes)) + return-term + + (get@ #import-member-maybe? commons) + (` (??? (~ return-term))) + + ## else + (let [g!temp (` ((~' ~') (~ (code.identifier ["" " Ω "]))))] + (` (let [(~ g!temp) (~ return-term)] + (if (not (null? (:coerce (primitive "java.lang.Object") + (~ g!temp)))) + (~ g!temp) + (error! "Cannot produce null references from method calls.")))))) + + _ + return-term)) + +(template [<name> <tag> <term-trans>] + [(def: (<name> member return-term) + (-> Import-Member-Declaration Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ <tag> commons) + <term-trans> + return-term) + + _ + return-term))] + + [decorate-return-try #import-member-try? (` (..try (~ return-term)))] + [decorate-return-io #import-member-io? (` ((~! io.io) (~ return-term)))] + ) + +(def: (free-type-param? [name bounds]) + (-> Type-Paramameter Bit) + (case bounds + #.Nil #1 + _ #0)) + +(def: (type-param->type-arg [name _]) + (-> Type-Paramameter Code) + (code.identifier ["" name])) + +(template [<name> <unbox/box> + <byte> <for-byte> + <short> <for-short> + <int> <for-int> + <float> <for-float>] + [(def: (<name> mode [unboxed raw]) + (-> Primitive-Mode [Text Code] Code) + (let [[unboxed refined] (case mode + #ManualPrM + [unboxed raw] + + #AutoPrM + (case unboxed + "byte" [<byte> (` (<for-byte> (~ raw)))] + "short" [<short> (` (<for-short> (~ raw)))] + "int" [<int> (` (<for-int> (~ raw)))] + "float" [<float> (` (<for-float> (~ raw)))] + _ [unboxed raw]))] + (case (dictionary.get unboxed boxes) + (#.Some boxed) + (<unbox/box> unboxed boxed refined) + + #.None + refined)))] + + [auto-convert-input ..unbox + "byte" ..long-to-byte + "short" ..long-to-short + "int" ..long-to-int + "float" ..double-to-float] + [auto-convert-output ..box + "long" "jvm conversion byte-to-long" + "long" "jvm conversion short-to-long" + "long" "jvm conversion int-to-long" + "double" "jvm conversion float-to-double"] + ) + +(def: (un-quote quoted) + (-> Code Code) + (` ((~' ~) (~ quoted)))) + +(def: (jvm-invoke-inputs mode classes inputs) + (-> Primitive-Mode (List Text) (List [Bit Code]) (List Code)) + (|> inputs + (list@map (function (_ [maybe? input]) + (if maybe? + (` ((~! !!!) (~ (un-quote input)))) + (un-quote input)))) + (list.zip2 classes) + (list@map (auto-convert-input mode)))) + +(def: (with-class-type class expression) + (-> Text Code Code) + (` (.: (.primitive (~ (code.text class))) (~ expression)))) + +(def: (member-def-interop type-params kind class [arg-function-inputs arg-classes arg-types] member method-prefix) + (-> (List Type-Paramameter) Class-Kind Class-Declaration [(List [Bit Code]) (List Text) (List Code)] Import-Member-Declaration Text (Meta (List Code))) + (let [[full-name class-tvars] class + full-name (sanitize full-name) + all-params (|> (member-type-vars class-tvars member) + (list.filter free-type-param?) + (list@map type-param->type-arg))] + (case member + (#EnumDecl enum-members) + (do macro.monad + [#let [enum-type (: Code + (case class-tvars + #.Nil + (` (primitive (~ (code.text full-name)))) + + _ + (let [=class-tvars (|> class-tvars + (list.filter free-type-param?) + (list@map type-param->type-arg))] + (` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)])))))) + getter-interop (: (-> Text Code) + (function (_ name) + (let [getter-name (code.identifier ["" (format method-prefix member-separator name)])] + (` (def: (~ getter-name) + (~ enum-type) + (~ (get-static-field full-name name)))))))]] + (wrap (list@map getter-interop enum-members))) + + (#ConstructorDecl [commons _]) + (do macro.monad + [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + jvm-interop (|> (` ("jvm member invoke constructor" + (~ (code.text full-name)) + (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs) + (list.zip2 arg-classes) + (list@map ..decorate-input))))) + (decorate-return-maybe member true full-name) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs))) + ((~' wrap) (.list (.` (~ jvm-interop))))))))) + + (#MethodDecl [commons method]) + (with-gensyms [g!obj] + (do @ + [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) + (^slots [#import-member-kind]) commons + (^slots [#import-method-name]) method + [jvm-op object-ast] (: [Text (List Code)] + (case import-member-kind + #StaticIMK + ["jvm member invoke static" + (list)] + + #VirtualIMK + (case kind + #Class + ["jvm member invoke virtual" + (list g!obj)] + + #Interface + ["jvm member invoke interface" + (list g!obj)] + ))) + method-return-class (simple-class$ (list) (get@ #import-method-return method)) + jvm-interop (|> [method-return-class + (` ((~ (code.text jvm-op)) + (~ (code.text full-name)) + (~ (code.text import-method-name)) + (~+ (list@map un-quote object-ast)) + (~+ (|> (jvm-invoke-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs) + (list.zip2 arg-classes) + (list@map ..decorate-input)))))] + (auto-convert-output (get@ #import-member-mode commons)) + (decorate-return-maybe member false method-return-class) + (decorate-return-try member) + (decorate-return-io member))]] + (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs)) (~+ object-ast)) + ((~' wrap) (.list (.` (~ jvm-interop)))))))))) + + (#FieldAccessDecl fad) + (do macro.monad + [#let [(^open ".") fad + base-gtype (class->type import-field-mode type-params import-field-type) + classC (class-decl-type$ class) + typeC (if import-field-maybe? + (` (Maybe (~ base-gtype))) + base-gtype) + tvar-asts (: (List Code) + (|> class-tvars + (list.filter free-type-param?) + (list@map type-param->type-arg))) + getter-name (code.identifier ["" (format method-prefix member-separator import-field-name)]) + setter-name (code.identifier ["" (format method-prefix member-separator import-field-name "!")])] + getter-interop (with-gensyms [g!obj] + (let [getter-call (if import-field-static? + (` ((~ getter-name))) + (` ((~ getter-name) (~ g!obj)))) + getter-body (<| (auto-convert-output import-field-mode) + [(simple-class$ (list) import-field-type) + (if import-field-static? + (get-static-field full-name import-field-name) + (get-virtual-field full-name import-field-name (un-quote g!obj)))]) + getter-body (if import-field-maybe? + (` ((~! ???) (~ getter-body))) + getter-body) + getter-body (if import-field-setter? + (` ((~! io.io) (~ getter-body))) + getter-body)] + (wrap (` ((~! syntax:) (~ getter-call) + ((~' wrap) (.list (.` (~ getter-body))))))))) + setter-interop (: (Meta (List Code)) + (if import-field-setter? + (with-gensyms [g!obj g!value] + (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 (if import-field-maybe? + (` ((~! !!!) (~ setter-value))) + setter-value) + setter-command (format (if import-field-static? "jvm putstatic" "jvm putfield") + ":" full-name ":" import-field-name) + g!obj+ (: (List Code) + (if import-field-static? + (list) + (list (un-quote g!obj))))] + (wrap (list (` ((~! syntax:) (~ setter-call) + ((~' wrap) (.list (.` ((~! io.io) ((~ (code.text setter-command)) (~+ g!obj+) (~ setter-value)))))))))))) + (wrap (list))))] + (wrap (list& getter-interop setter-interop))) + ))) + +(def: (member-import$ type-params long-name? kind class member) + (-> (List Type-Paramameter) Bit Class-Kind Class-Declaration Import-Member-Declaration (Meta (List Code))) + (let [[full-name _] class + method-prefix (if long-name? + full-name + (short-class-name full-name))] + (do macro.monad + [=args (member-def-arg-bindings type-params class member)] + (member-def-interop type-params kind class =args member method-prefix)))) + +(def: interface? + (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) + (|>> ("jvm member invoke virtual" "java.lang.Class" "isInterface") + "jvm object cast" + (: (primitive "java.lang.Boolean")) + (:coerce Bit))) + +(def: load-class + (-> Text (Error (primitive "java.lang.Class" [Any]))) + (|>> (:coerce (primitive "java.lang.String")) + ["java.lang.String"] + ("jvm member invoke static" "java.lang.Class" "forName") + try)) + +(def: (class-kind [class-name _]) + (-> Class-Declaration (Meta Class-Kind)) + (let [class-name (sanitize class-name)] + (case (load-class class-name) + (#.Right class) + (:: macro.monad wrap (if (interface? class) + #Interface + #Class)) + + (#.Left _) + (macro.fail (format "Unknown class: " class-name))))) + +(syntax: #export (import: + {#let [imports (class-imports *compiler*)]} + {long-name? (s.this? (' #long))} + {class-decl (class-decl^ imports)} + {#let [full-class-name (product.left class-decl) + imports (add-import [(short-class-name full-class-name) full-class-name] + (class-imports *compiler*))]} + {members (p.some (import-member-decl^ imports (product.right class-decl)))}) + {#.doc (doc "Allows importing JVM classes, and using them as types." + "Their methods, fields and enum options can also be imported." + "Also, classes which get imported into a module can also be referred-to with their short names in other macros that require JVM classes." + (import: java/lang/Object + (new []) + (equals [Object] boolean) + (wait [int] #io #try void)) + + "Special options can also be given for the return values." + "#? means that the values will be returned inside a Maybe type. That way, null becomes #.None." + "#try means that the computation might throw an exception, and the return value will be wrapped by the Error type." + "#io means the computation has side effects, and will be wrapped by the IO type." + "These options must show up in the following order [#io #try #?] (although, each option can be used independently)." + (import: java/lang/String + (new [(Array byte)]) + (#static valueOf [char] String) + (#static valueOf #as int-valueOf [int] String)) + + (import: #long (java/util/List e) + (size [] int) + (get [int] e)) + + (import: (java/util/ArrayList a) + ([T] toArray [(Array T)] (Array T))) + + "#long makes it so the class-type that is generated is of the fully-qualified name." + "In this case, it avoids a clash between the java.util.List type, and Lux's own List type." + "All enum options to be imported must be specified." + (import: java/lang/Character$UnicodeScript + (#enum ARABIC CYRILLIC LATIN)) + + "It should also be noted, the only types that may show up in method arguments or return values may be Java classes, arrays, primitives, void or type-parameters." + "Lux types, such as Maybe cannot be named (otherwise, they'd be confused for Java classes)." + (import: #long (lux/concurrency/promise/JvmPromise A) + (resolve [A] boolean) + (poll [] A) + (wasResolved [] boolean) + (waitOn [lux/Function] void) + (#static [A] make [A] (JvmPromise A))) + + "Also, the names of the imported members will look like Class::member" + (Object::new []) + (Object::equals [other-object] my-object) + (java/util/List::size [] my-list) + Character$UnicodeScript::LATIN + )} + (do macro.monad + [kind (class-kind class-decl) + =members (monad.map @ (member-import$ (product.right class-decl) long-name? kind class-decl) members)] + (wrap (list& (class-import$ long-name? class-decl) (list@join =members))))) + +(syntax: #export (array {#let [imports (class-imports *compiler*)]} + {type (generic-type^ imports (list))} + size) + {#.doc (doc "Create an array of the given type, with the given size." + (array Object 10))} + (case type + (^template [<type> <array-op>] + (^ (#GenericClass <type> (list))) + (wrap (list (` (<array-op> (~ size)))))) + (["boolean" "jvm znewarray"] + ["byte" "jvm bnewarray"] + ["short" "jvm snewarray"] + ["int" "jvm inewarray"] + ["long" "jvm lnewarray"] + ["float" "jvm fnewarray"] + ["double" "jvm dnewarray"] + ["char" "jvm cnewarray"]) + + _ + (wrap (list (` ("jvm anewarray" (~ (code.text (generic-type$ type))) (~ size))))))) + +(syntax: #export (array-length array) + {#.doc (doc "Gives the length of an array." + (array-length my-array))} + (wrap (list (` ("jvm arraylength" (~ array)))))) + +(def: (type->class-name type) + (-> Type (Meta Text)) + (if (type@= Any type) + (:: macro.monad wrap "java.lang.Object") + (case type + (#.Primitive name params) + (:: macro.monad wrap name) + + (#.Apply A F) + (case (type.apply (list A) F) + #.None + (macro.fail (format "Cannot apply type: " (type.to-text F) " to " (type.to-text A))) + + (#.Some type') + (type->class-name type')) + + (#.Named _ type') + (type->class-name type') + + _ + (macro.fail (format "Cannot convert to JvmType: " (type.to-text type)))))) + +(syntax: #export (array-read idx array) + {#.doc (doc "Loads an element from an array." + (array-read 10 my-array))} + (case array + [_ (#.Identifier array-name)] + (do macro.monad + [array-type (macro.find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [<type> <array-op>] + <type> + (wrap (list (` (<array-op> (~ array) (~ idx)))))) + (["[Z" "jvm zaload"] + ["[B" "jvm baload"] + ["[S" "jvm saload"] + ["[I" "jvm iaload"] + ["[J" "jvm jaload"] + ["[F" "jvm faload"] + ["[D" "jvm daload"] + ["[C" "jvm caload"]) + + _ + (wrap (list (` ("jvm aaload" (~ array) (~ idx))))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array-read (~ idx) (~ g!array))))))))) + +(syntax: #export (array-write idx value array) + {#.doc (doc "Stores an element into an array." + (array-write 10 my-object my-array))} + (case array + [_ (#.Identifier array-name)] + (do macro.monad + [array-type (macro.find-type array-name) + array-jvm-type (type->class-name array-type)] + (case array-jvm-type + (^template [<type> <array-op>] + <type> + (wrap (list (` (<array-op> (~ array) (~ idx) (~ value)))))) + (["[Z" "jvm zastore"] + ["[B" "jvm bastore"] + ["[S" "jvm sastore"] + ["[I" "jvm iastore"] + ["[J" "jvm jastore"] + ["[F" "jvm fastore"] + ["[D" "jvm dastore"] + ["[C" "jvm castore"]) + + _ + (wrap (list (` ("jvm aastore" (~ array) (~ idx) (~ value))))))) + + _ + (with-gensyms [g!array] + (wrap (list (` (let [(~ g!array) (~ array)] + (..array-write (~ idx) (~ value) (~ g!array))))))))) + +(syntax: #export (class-for {#let [imports (class-imports *compiler*)]} + {type (generic-type^ imports (list))}) + {#.doc (doc "Loads the class as a java.lang.Class object." + (class-for java/lang/String))} + (wrap (list (` ("jvm object class" (~ (code.text (simple-class$ (list) type)))))))) + +(def: get-compiler + (Meta Lux) + (function (_ compiler) + (#.Right [compiler compiler]))) + +(def: #export (resolve class) + {#.doc (doc "Given a potentially unqualified class name, qualifies it if necessary." + (resolve "String") + => + "java.lang.String")} + (-> Text (Meta Text)) + (do macro.monad + [*compiler* get-compiler] + (wrap (qualify (class-imports *compiler*) class)))) + +(syntax: #export (type {#let [imports (class-imports *compiler*)]} + {type (generic-type^ imports (list))}) + (wrap (list (class->type #ManualPrM (list) type)))) diff --git a/stdlib/source/lux/host.old.lux b/stdlib/source/lux/host.old.lux index 915cdc7bf..8785cb7ca 100644 --- a/stdlib/source/lux/host.old.lux +++ b/stdlib/source/lux/host.old.lux @@ -11,14 +11,14 @@ ["." maybe] ["." product] ["." error (#+ Error)] - ["." bit ("#;." codec)] + ["." bit ("#@." codec)] number - ["." text ("#;." equivalence monoid) + ["." text ("#@." equivalence monoid) format] [collection ["." array (#+ Array)] - ["." list ("#;." monad fold monoid)]]] - ["." type ("#;." equivalence)] + ["." list ("#@." monad fold monoid)]]] + ["." type ("#@." equivalence)] ["." macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]]]) @@ -291,7 +291,7 @@ [[name params] _ _] (let [name (sanitize name) - =params (list;map (class->type' mode type-params in-array?) params)] + =params (list@map (class->type' mode type-params in-array?) params)] (` (primitive (~ (code.text name)) [(~+ =params)]))))) (def: (class->type' mode type-params in-array? class) @@ -299,7 +299,7 @@ (case class (#GenericTypeVar name) (case (list.find (function (_ [pname pbounds]) - (and (text;= name pname) + (and (text@= name pname) (not (list.empty? pbounds)))) type-params) #.None @@ -333,7 +333,7 @@ (def: (class-decl-type$ (^slots [#class-name #class-params])) (-> Class-Declaration Code) - (let [=params (list;map (: (-> Type-Paramameter Code) + (let [=params (list@map (: (-> Type-Paramameter Code) (function (_ [pname pbounds]) (case pbounds #.Nil @@ -352,7 +352,7 @@ (def: (get-import name imports) (-> Text Class-Imports (Maybe Text)) (:: maybe.functor map product.right - (list.find (|>> product.left (text;= name)) + (list.find (|>> product.left (text@= name)) imports))) (def: (add-import short+full imports) @@ -366,7 +366,7 @@ (do macro.monad [current-module macro.current-module-name definitions (macro.definitions current-module)] - (wrap (list;fold (: (-> [Text Definition] Class-Imports Class-Imports) + (wrap (list@fold (: (-> [Text Definition] Class-Imports Class-Imports) (function (_ [short-name [_ meta _]] imports) (case (macro.get-text-ann (name-of #..jvm-class) meta) (#.Some full-class-name) @@ -475,7 +475,7 @@ (case class (#GenericTypeVar name) (case (list.find (function (_ [pname pbounds]) - (and (text;= name pname) + (and (text@= name pname) (not (list.empty? pbounds)))) env) #.None @@ -541,12 +541,12 @@ (case (f input) (^template [<tag>] [meta (<tag> parts)] - [meta (<tag> (list;map (pre-walk-replace f) parts))]) + [meta (<tag> (list@map (pre-walk-replace f) parts))]) ([#.Form] [#.Tuple]) [meta (#.Record pairs)] - [meta (#.Record (list;map (: (-> [Code Code] [Code Code]) + [meta (#.Record (list@map (: (-> [Code Code] [Code Code]) (function (_ [key val]) [(pre-walk-replace f key) (pre-walk-replace f val)])) pairs))] @@ -580,7 +580,7 @@ [args (: (Syntax (List Code)) (s.form (p.after (s.this (' ::new!)) (s.tuple (p.exactly (list.size arg-decls) s.any))))) - #let [arg-decls' (: (List Text) (list;map (|>> product.right (simple-class$ params)) arg-decls))]] + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls')))) (~+ args)))))) @@ -591,7 +591,7 @@ args (: (Syntax (List Code)) (s.form (p.after (s.this (code.identifier ["" dotted-name])) (s.tuple (p.exactly (list.size arg-decls) s.any))))) - #let [arg-decls' (: (List Text) (list;map (|>> product.right (simple-class$ params)) arg-decls))]] + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) (~+ args)))))) @@ -603,7 +603,7 @@ args (: (Syntax (List Code)) (s.form (p.after (s.this (code.identifier ["" dotted-name])) (s.tuple (p.exactly (list.size arg-decls) s.any))))) - #let [arg-decls' (: (List Text) (list;map (|>> product.right (simple-class$ params)) arg-decls))]] + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ params)) arg-decls))]] (wrap (`' ((~ (code.text (format <jvm-op> ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) (~' _jvm_this) (~+ args))))))] @@ -678,7 +678,7 @@ (do p.monad [name (full-class-name^ imports) _ (assert-no-periods name)] - (if (list.member? text.equivalence (list;map product.left type-vars) name) + (if (list.member? text.equivalence (list@map product.left type-vars) name) (wrap (#GenericTypeVar name)) (wrap (#GenericClass name (list))))) (s.form (do p.monad @@ -704,7 +704,7 @@ _ (assert-no-periods name) params (p.some (generic-type^ imports type-vars)) _ (p.assert (format name " cannot be a type-parameter!") - (not (list.member? text.equivalence (list;map product.left type-vars) name)))] + (not (list.member? text.equivalence (list@map product.left type-vars) name)))] (wrap (#GenericClass name params)))) )) @@ -845,7 +845,7 @@ [pm privacy-modifier^ strict-fp? (s.this? (' #strict)) method-vars (p.default (list) (type-params^ imports)) - #let [total-vars (list;compose class-vars method-vars)] + #let [total-vars (list@compose class-vars method-vars)] [_ arg-decls] (s.form (p.and (s.this (' new)) (arg-decls^ imports total-vars))) constructor-args (constructor-args^ imports total-vars) @@ -864,7 +864,7 @@ strict-fp? (s.this? (' #strict)) final? (s.this? (' #final)) method-vars (p.default (list) (type-params^ imports)) - #let [total-vars (list;compose class-vars method-vars)] + #let [total-vars (list@compose class-vars method-vars)] [name arg-decls] (s.form (p.and s.local-identifier (arg-decls^ imports total-vars))) return-type (generic-type^ imports total-vars) @@ -882,7 +882,7 @@ [strict-fp? (s.this? (' #strict)) owner-class (class-decl^ imports) method-vars (p.default (list) (type-params^ imports)) - #let [total-vars (list;compose (product.right owner-class) method-vars)] + #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))) return-type (generic-type^ imports total-vars) @@ -1001,7 +1001,7 @@ [tvars (p.default (list) (type-params^ imports)) _ (s.this (' new)) ?alias import-member-alias^ - #let [total-vars (list;compose owner-vars tvars)] + #let [total-vars (list@compose owner-vars tvars)] ?prim-mode (p.maybe primitive-mode^) args (import-member-args^ imports total-vars) [io? try? maybe?] import-member-return-flags^] @@ -1022,7 +1022,7 @@ tvars (p.default (list) (type-params^ imports)) name s.local-identifier ?alias import-member-alias^ - #let [total-vars (list;compose owner-vars tvars)] + #let [total-vars (list@compose owner-vars tvars)] ?prim-mode (p.maybe primitive-mode^) args (import-member-args^ imports total-vars) [io? try? maybe?] import-member-return-flags^ @@ -1087,7 +1087,7 @@ (def: (annotation$ [name params]) (-> Annotation JVM-Code) - (format "(" name " " "{" (text.join-with text.tab (list;map annotation-param$ params)) "}" ")")) + (format "(" name " " "{" (text.join-with text.tab (list@map annotation-param$ params)) "}" ")")) (def: (bound-kind$ kind) (-> BoundKind JVM-Code) @@ -1102,7 +1102,7 @@ name (#GenericClass name params) - (format "(" (sanitize name) " " (spaced (list;map generic-type$ params)) ")") + (format "(" (sanitize name) " " (spaced (list@map generic-type$ params)) ")") (#GenericArray param) (format "(" array.type-name " " (generic-type$ param) ")") @@ -1115,25 +1115,25 @@ (def: (type-param$ [name bounds]) (-> Type-Paramameter JVM-Code) - (format "(" name " " (spaced (list;map generic-type$ bounds)) ")")) + (format "(" name " " (spaced (list@map generic-type$ bounds)) ")")) (def: (class-decl$ (^open ".")) (-> Class-Declaration JVM-Code) - (format "(" (sanitize class-name) " " (spaced (list;map type-param$ class-params)) ")")) + (format "(" (sanitize class-name) " " (spaced (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)) ")")) + (format "(" (sanitize super-class-name) " " (spaced (list@map generic-type$ super-class-params)) ")")) (def: (method-decl$ [[name pm anns] method-decl]) (-> [Member-Declaration MethodDecl] JVM-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))) + (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)) )))) @@ -1150,7 +1150,7 @@ (#ConstantField class value) (with-parens (spaced (list "constant" name - (with-brackets (spaced (list;map annotation$ anns))) + (with-brackets (spaced (list@map annotation$ anns))) (generic-type$ class) (code.to-text value)) )) @@ -1160,7 +1160,7 @@ (spaced (list "variable" name (privacy-modifier$ pm) (state-modifier$ sm) - (with-brackets (spaced (list;map annotation$ anns))) + (with-brackets (spaced (list@map annotation$ anns))) (generic-type$ class)) )) )) @@ -1182,12 +1182,12 @@ (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))) + (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)) ))) @@ -1196,12 +1196,12 @@ (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))) + (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))))) @@ -1209,7 +1209,7 @@ (let [super-replacer (parser->replacer (s.form (do p.monad [_ (s.this (' ::super!)) args (s.tuple (p.exactly (list.size arg-decls) s.any)) - #let [arg-decls' (: (List Text) (list;map (|>> product.right (simple-class$ (list))) + #let [arg-decls' (: (List Text) (list@map (|>> product.right (simple-class$ (list))) arg-decls))]] (wrap (`' ((~ (code.text (format "jvm invokespecial" ":" (get@ #super-class-name super-class) @@ -1220,11 +1220,11 @@ (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))) + (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) @@ -1237,11 +1237,11 @@ (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))) + (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))))) @@ -1250,10 +1250,10 @@ (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))) + (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)))) (#NativeMethod type-vars arg-decls return-type exs) @@ -1261,10 +1261,10 @@ (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))) + (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)))) )) @@ -1326,19 +1326,19 @@ (do macro.monad [current-module macro.current-module-name #let [fully-qualified-class-name (format (sanitize current-module) "." full-class-name) - field-parsers (list;map (field->parser fully-qualified-class-name) fields) - method-parsers (list;map (method->parser (product.right class-decl) fully-qualified-class-name) methods) - replacer (parser->replacer (list;fold p.either + field-parsers (list@map (field->parser fully-qualified-class-name) fields) + 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))) + (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))) + (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))))))]] + (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)))))))) (syntax: #export (interface: @@ -1357,9 +1357,9 @@ ([] 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)))))] + (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)))))) )) @@ -1385,9 +1385,9 @@ )} (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))))))] + (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)))))))) (syntax: #export (null) @@ -1485,7 +1485,7 @@ (ClassName::method2 arg3 arg4 arg5)))} (with-gensyms [g!obj] (wrap (list (` (let [(~ g!obj) (~ obj)] - (exec (~+ (list;map (complete-call$ g!obj) methods)) + (exec (~+ (list@map (complete-call$ g!obj) methods)) (~ g!obj)))))))) (def: (class-import$ long-name? [full-name params]) @@ -1493,7 +1493,7 @@ (let [def-name (if long-name? full-name (short-class-name full-name)) - params' (list;map (|>> product.left code.local-identifier) params)] + params' (list@map (|>> product.left code.local-identifier) params)] (` (def: (~ (code.identifier ["" def-name])) {#.type? #1 #..jvm-class (~ (code.text full-name))} @@ -1506,7 +1506,7 @@ (-> (List Type-Paramameter) Import-Member-Declaration (List Type-Paramameter)) (case member (#ConstructorDecl [commons _]) - (list;compose class-tvars (get@ #import-member-tvars commons)) + (list@compose class-tvars (get@ #import-member-tvars commons)) (#MethodDecl [commons _]) (case (get@ #import-member-kind commons) @@ -1514,7 +1514,7 @@ (get@ #import-member-tvars commons) _ - (list;compose class-tvars (get@ #import-member-tvars commons))) + (list@compose class-tvars (get@ #import-member-tvars commons))) _ class-tvars)) @@ -1532,9 +1532,9 @@ (wrap [maybe? arg-name])))) import-member-args) #let [arg-classes (: (List Text) - (list;map (|>> product.right (simple-class$ (list;compose type-params import-member-tvars))) + (list@map (|>> product.right (simple-class$ (list@compose type-params import-member-tvars))) import-member-args)) - arg-types (list;map (: (-> [Bit GenericType] Code) + arg-types (list@map (: (-> [Bit GenericType] Code) (function (_ [maybe? arg]) (let [arg-type (class->type (get@ #import-member-mode commons) type-params arg)] (if maybe? @@ -1614,12 +1614,12 @@ (def: (jvm-extension-inputs mode classes inputs) (-> Primitive-Mode (List Text) (List [Bit Code]) (List Code)) (|> inputs - (list;map (function (_ [maybe? input]) + (list@map (function (_ [maybe? input]) (if maybe? (` ((~! !!!) (~ (un-quote input)))) (un-quote input)))) (list.zip2 classes) - (list;map (auto-convert-input mode)))) + (list@map (auto-convert-input mode)))) (def: (member-def-interop type-params kind class [arg-function-inputs arg-classes arg-types] member method-prefix) (-> (List Type-Paramameter) Class-Kind Class-Declaration [(List [Bit Code]) (List Text) (List Code)] Import-Member-Declaration Text (Meta (List Code))) @@ -1627,7 +1627,7 @@ full-name (sanitize full-name) all-params (|> (member-type-vars class-tvars member) (list.filter free-type-param?) - (list;map type-param->type-arg))] + (list@map type-param->type-arg))] (case member (#EnumDecl enum-members) (do macro.monad @@ -1639,7 +1639,7 @@ _ (let [=class-tvars (|> class-tvars (list.filter free-type-param?) - (list;map type-param->type-arg))] + (list@map type-param->type-arg))] (` (All [(~+ =class-tvars)] (primitive (~ (code.text full-name)) [(~+ =class-tvars)])))))) getter-interop (: (-> Text Code) (function (_ name) @@ -1647,7 +1647,7 @@ (` (def: (~ getter-name) (~ enum-type) ((~ (code.text (format "jvm getstatic" ":" full-name ":" name)))))))))]] - (wrap (list;map getter-interop enum-members))) + (wrap (list@map getter-interop enum-members))) (#ConstructorDecl [commons _]) (do macro.monad @@ -1658,7 +1658,7 @@ (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] - (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list;map product.right arg-function-inputs))) + (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs))) ((~' wrap) (.list (.` (~ jvm-interop))))))))) (#MethodDecl [commons method]) @@ -1667,34 +1667,31 @@ [#let [def-name (code.identifier ["" (format method-prefix member-separator (get@ #import-member-alias commons))]) (^slots [#import-member-kind]) commons (^slots [#import-method-name]) method - [jvm-op object-ast class-ast] (: [Text (List Code) (List Code)] - (case import-member-kind - #StaticIMK - ["invokestatic" - (list) - (list)] - - #VirtualIMK - (case kind - #Class - ["invokevirtual" - (list g!obj) - (list (class-decl-type$ class))] - - #Interface - ["invokeinterface" - (list g!obj) - (list (class-decl-type$ class))] - ))) + [jvm-op object-ast] (: [Text (List Code)] + (case import-member-kind + #StaticIMK + ["invokestatic" + (list)] + + #VirtualIMK + (case kind + #Class + ["invokevirtual" + (list g!obj)] + + #Interface + ["invokeinterface" + (list g!obj)] + ))) jvm-extension (code.text (format "jvm " jvm-op ":" full-name ":" import-method-name ":" (text.join-with "," arg-classes))) jvm-interop (|> [(simple-class$ (list) (get@ #import-method-return method)) - (` ((~ jvm-extension) (~+ (list;map un-quote object-ast)) + (` ((~ jvm-extension) (~+ (list@map un-quote object-ast)) (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs))))] (auto-convert-output (get@ #import-member-mode commons)) (decorate-return-maybe member) (decorate-return-try member) (decorate-return-io member))]] - (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list;map product.right arg-function-inputs)) (~+ object-ast)) + (wrap (list (` ((~! syntax:) ((~ def-name) (~+ (list@map product.right arg-function-inputs)) (~+ object-ast)) ((~' wrap) (.list (.` (~ jvm-interop)))))))))) (#FieldAccessDecl fad) @@ -1708,7 +1705,7 @@ tvar-asts (: (List Code) (|> class-tvars (list.filter free-type-param?) - (list;map type-param->type-arg))) + (list@map type-param->type-arg))) getter-name (code.identifier ["" (format method-prefix member-separator import-field-name)]) setter-name (code.identifier ["" (format method-prefix member-separator import-field-name "!")])] getter-interop (with-gensyms [g!obj] @@ -1840,7 +1837,7 @@ (do macro.monad [kind (class-kind class-decl) =members (monad.map @ (member-import$ (product.right class-decl) long-name? kind class-decl) members)] - (wrap (list& (class-import$ long-name? class-decl) (list;join =members))))) + (wrap (list& (class-import$ long-name? class-decl) (list@join =members))))) (syntax: #export (array {#let [imports (class-imports *compiler*)]} {type (generic-type^ imports (list))} @@ -1870,7 +1867,7 @@ (def: (type->class-name type) (-> Type (Meta Text)) - (if (type;= Any type) + (if (type@= Any type) (:: macro.monad wrap "java.lang.Object") (case type (#.Primitive name params) @@ -1948,34 +1945,6 @@ (wrap (list (` (let [(~ g!array) (~ array)] (..array-write (~ idx) (~ value) (~ g!array))))))))) -(def: simple-bindings^ - (Syntax (List [Text Code])) - (s.tuple (p.some (p.and s.local-identifier s.any)))) - -(syntax: #export (with-open - {bindings simple-bindings^} - body) - {#.doc (doc "Creates a local-binding with the desired resources, and runs the body (assumed to be in the IO type)." - "Afterwards, closes all resources (assumed to be subclasses of java.io.Closeable), and returns the value resulting from running the body." - (with-open [my-res1 (res1-constructor ___) - my-res2 (res1-constructor ___)] - (do io.monad - [foo (do-something my-res1) - bar (do-something-else my-res2)] - (do-one-last-thing foo bar))))} - (with-gensyms [g!output g!_] - (let [inits (list;join (list;map (function (_ [res-name res-ctor]) - (list (code.identifier ["" res-name]) res-ctor)) - bindings)) - closes (list;map (function (_ res) - (` (try ("jvm invokevirtual:java.io.Closeable:close:" (~ (code.identifier ["" (product.left res)])))))) - bindings)] - (wrap (list (` (do (~! io.monad) - [(~+ inits) - (~ g!output) (~ body) - (~' #let) [(~ g!_) (exec (~+ (list.reverse closes)) [])]] - ((~' wrap) (~ g!output))))))))) - (syntax: #export (class-for {#let [imports (class-imports *compiler*)]} {type (generic-type^ imports (list))}) {#.doc (doc "Loads the class as a java.lang.Class object." |