aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--stdlib/source/lux/control/concurrency/atom.lux35
-rw-r--r--stdlib/source/lux/control/concurrency/process.lux62
-rw-r--r--stdlib/source/lux/host.jvm.lux2087
-rw-r--r--stdlib/source/lux/host.old.lux253
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."