From 42248854f0cb5e3364e6aae25527cee65cbda3e8 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 16 Apr 2019 18:47:13 -0400 Subject: The old compiler is now identified with "old" instead of "jvm". This should help to get old JVM code and new JVM code to coexist without forcing a major rewrite of old compiler code to get it to fit the style of the new JVM compiler code. --- luxc/src/lux/compiler/io.clj | 2 +- luxc/src/lux/compiler/jvm.clj | 2 +- stdlib/source/lux/control/cli.lux | 2 +- stdlib/source/lux/control/concurrency/atom.lux | 8 +- stdlib/source/lux/control/concurrency/process.lux | 48 +- stdlib/source/lux/control/thread.lux | 2 +- stdlib/source/lux/data/collection/array.lux | 10 +- stdlib/source/lux/data/text.lux | 2 +- stdlib/source/lux/data/text/buffer.lux | 12 +- stdlib/source/lux/data/text/encoding.lux | 16 +- stdlib/source/lux/host.jvm.lux | 2002 -------------------- stdlib/source/lux/host.old.lux | 2002 ++++++++++++++++++++ stdlib/source/lux/host/jvm/loader.jvm.lux | 126 -- stdlib/source/lux/host/jvm/loader.old.lux | 126 ++ stdlib/source/lux/tool/compiler/default/init.lux | 1 + stdlib/source/lux/tool/compiler/host.lux | 3 + .../source/lux/tool/compiler/meta/io/archive.lux | 1 + .../source/lux/tool/compiler/meta/io/context.lux | 1 + .../compiler/phase/extension/analysis/host.jvm.lux | 1301 ------------- .../compiler/phase/extension/analysis/host.old.lux | 1301 +++++++++++++ .../compiler/phase/generation/scheme/case.jvm.lux | 175 -- .../tool/compiler/phase/generation/scheme/case.lux | 175 ++ .../phase/generation/scheme/extension.jvm.lux | 13 - .../compiler/phase/generation/scheme/extension.lux | 13 + .../generation/scheme/extension/common.jvm.lux | 245 --- .../phase/generation/scheme/extension/common.lux | 245 +++ .../phase/generation/scheme/function.jvm.lux | 97 - .../compiler/phase/generation/scheme/function.lux | 97 + .../compiler/phase/generation/scheme/loop.jvm.lux | 41 - .../tool/compiler/phase/generation/scheme/loop.lux | 41 + .../phase/generation/scheme/primitive.jvm.lux | 15 - .../compiler/phase/generation/scheme/primitive.lux | 15 + .../phase/generation/scheme/reference.jvm.lux | 10 - .../compiler/phase/generation/scheme/reference.lux | 10 + .../phase/generation/scheme/runtime.jvm.lux | 322 ---- .../compiler/phase/generation/scheme/runtime.lux | 322 ++++ .../phase/generation/scheme/structure.jvm.lux | 33 - .../compiler/phase/generation/scheme/structure.lux | 33 + stdlib/source/lux/world/console.lux | 2 +- stdlib/source/lux/world/db/jdbc.jvm.lux | 175 -- stdlib/source/lux/world/db/jdbc.old.lux | 175 ++ stdlib/source/lux/world/db/jdbc/input.jvm.lux | 109 -- stdlib/source/lux/world/db/jdbc/input.old.lux | 109 ++ stdlib/source/lux/world/db/jdbc/output.jvm.lux | 189 -- stdlib/source/lux/world/db/jdbc/output.old.lux | 189 ++ stdlib/source/lux/world/environment.jvm.lux | 52 - stdlib/source/lux/world/environment.old.lux | 52 + stdlib/source/lux/world/file.lux | 2 +- stdlib/source/lux/world/net/http/client.lux | 4 +- stdlib/source/lux/world/net/tcp.jvm.lux | 131 -- stdlib/source/lux/world/net/tcp.old.lux | 131 ++ stdlib/source/lux/world/net/udp.jvm.lux | 126 -- stdlib/source/lux/world/net/udp.old.lux | 126 ++ stdlib/source/lux/world/shell.lux | 4 +- stdlib/source/test/lux/host.jvm.lux | 134 -- stdlib/source/test/lux/host.old.lux | 134 ++ stdlib/source/test/lux/host/jvm.jvm.lux | 89 - stdlib/source/test/lux/host/jvm.old.lux | 89 + 58 files changed, 5449 insertions(+), 5443 deletions(-) delete mode 100644 stdlib/source/lux/host.jvm.lux create mode 100644 stdlib/source/lux/host.old.lux delete mode 100644 stdlib/source/lux/host/jvm/loader.jvm.lux create mode 100644 stdlib/source/lux/host/jvm/loader.old.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux delete mode 100644 stdlib/source/lux/world/db/jdbc.jvm.lux create mode 100644 stdlib/source/lux/world/db/jdbc.old.lux delete mode 100644 stdlib/source/lux/world/db/jdbc/input.jvm.lux create mode 100644 stdlib/source/lux/world/db/jdbc/input.old.lux delete mode 100644 stdlib/source/lux/world/db/jdbc/output.jvm.lux create mode 100644 stdlib/source/lux/world/db/jdbc/output.old.lux delete mode 100644 stdlib/source/lux/world/environment.jvm.lux create mode 100644 stdlib/source/lux/world/environment.old.lux delete mode 100644 stdlib/source/lux/world/net/tcp.jvm.lux create mode 100644 stdlib/source/lux/world/net/tcp.old.lux delete mode 100644 stdlib/source/lux/world/net/udp.jvm.lux create mode 100644 stdlib/source/lux/world/net/udp.old.lux delete mode 100644 stdlib/source/test/lux/host.jvm.lux create mode 100644 stdlib/source/test/lux/host.old.lux delete mode 100644 stdlib/source/test/lux/host/jvm.jvm.lux create mode 100644 stdlib/source/test/lux/host/jvm.old.lux diff --git a/luxc/src/lux/compiler/io.clj b/luxc/src/lux/compiler/io.clj index 46a3fdfd7..8820bfb05 100644 --- a/luxc/src/lux/compiler/io.clj +++ b/luxc/src/lux/compiler/io.clj @@ -13,7 +13,7 @@ (defn read-file [source-dirs module-name] (|do [jvm? &/jvm? js? &/js? - :let [^String host-file-name (cond jvm? (str module-name ".jvm.lux") + :let [^String host-file-name (cond jvm? (str module-name ".old.lux") js? (str module-name ".js.lux") :else (assert false "[I/O Error] Unknown host platform.")) ^String lux-file-name (str module-name ".lux")]] diff --git a/luxc/src/lux/compiler/jvm.clj b/luxc/src/lux/compiler/jvm.clj index 8e2966b52..b5e04792a 100644 --- a/luxc/src/lux/compiler/jvm.clj +++ b/luxc/src/lux/compiler/jvm.clj @@ -249,7 +249,7 @@ &&jvm-cache/uninstall-all-defs-in-module) _ (compile-module source-dirs "lux")] (compile-module source-dirs program-module))] - (|case (m-action (&/init-state "JVM" mode (jvm-host))) + (|case (m-action (&/init-state "{old}" mode (jvm-host))) (&/$Right ?state _) (do (println "Compilation complete!") (&&cache/clean ?state)) diff --git a/stdlib/source/lux/control/cli.lux b/stdlib/source/lux/control/cli.lux index f8201ce87..ae712d644 100644 --- a/stdlib/source/lux/control/cli.lux +++ b/stdlib/source/lux/control/cli.lux @@ -160,7 +160,7 @@ (~ g!_) ..end] ((~' wrap) ((~! do) (~! io.monad) [(~ g!output) (~ body) - (~+ (`` (for {(~~ (static host.jvm)) + (~+ (`` (for {(~~ (static host.old)) (list)} (list g!_ (` process.run!)))))] diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index c93c224ce..0b5c4fc3f 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -12,7 +12,7 @@ ["." host]]] [host (#+ import:)]]) -(`` (for {(~~ (static host.jvm)) +(`` (for {(~~ (static host.old)) (import: #long (java/util/concurrent/atomic/AtomicReference a) (new [a]) (get [] a) @@ -21,17 +21,17 @@ (`` (abstract: #export (Atom a) {#.doc "Atomic references that are safe to mutate concurrently."} - (for {(~~ (static host.jvm)) + (for {(~~ (static host.old)) (java/util/concurrent/atomic/AtomicReference a)}) (def: #export (atom value) (All [a] (-> a (Atom a))) - (:abstraction (for {(~~ (static host.jvm)) + (:abstraction (for {(~~ (static host.old)) (java/util/concurrent/atomic/AtomicReference::new value)}))) (def: #export (read atom) (All [a] (-> (Atom a) (IO a))) - (io (for {(~~ (static host.jvm)) + (io (for {(~~ (static host.old)) (java/util/concurrent/atomic/AtomicReference::get (:representation atom))}))) (def: #export (compare-and-swap current new atom) diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index c7f9ae82e..322300a17 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -15,26 +15,26 @@ [// ["." atom (#+ Atom)]]) -(`` (for {(~~ (static host.jvm)) - (as-is (import: java/lang/Object) +(`` (for {(~~ (static host.old)) + (as-is (import: #long java/lang/Object) - (import: java/lang/Runtime - (#static getRuntime [] Runtime) + (import: #long java/lang/Runtime + (#static getRuntime [] java/lang/Runtime) (availableProcessors [] int)) - (import: java/lang/Runnable) + (import: #long java/lang/Runnable) - (import: java/util/concurrent/TimeUnit + (import: #long java/util/concurrent/TimeUnit (#enum MILLISECONDS)) - (import: java/util/concurrent/Executor - (execute [Runnable] #io void)) + (import: #long java/util/concurrent/Executor + (execute [java/lang/Runnable] #io void)) - (import: (java/util/concurrent/ScheduledFuture a)) + (import: #long (java/util/concurrent/ScheduledFuture a)) - (import: java/util/concurrent/ScheduledThreadPoolExecutor + (import: #long java/util/concurrent/ScheduledThreadPoolExecutor (new [int]) - (schedule [Runnable long TimeUnit] #io (ScheduledFuture Object))))} + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] #io (java/util/concurrent/ScheduledFuture java/lang/Object))))} ## Default (type: Process @@ -45,17 +45,17 @@ (def: #export parallelism Nat - (`` (for {(~~ (static host.jvm)) - (|> (Runtime::getRuntime) - (Runtime::availableProcessors) + (`` (for {(~~ (static host.old)) + (|> (java/lang/Runtime::getRuntime) + (java/lang/Runtime::availableProcessors) .nat)} ## Default 1))) (def: runner - (`` (for {(~~ (static host.jvm)) - (ScheduledThreadPoolExecutor::new (.int ..parallelism))} + (`` (for {(~~ (static host.old)) + (java/util/concurrent/ScheduledThreadPoolExecutor::new (.int ..parallelism))} ## Default (: (Atom (List Process)) @@ -63,15 +63,15 @@ (def: #export (schedule milli-seconds action) (-> Nat (IO Any) (IO Any)) - (`` (for {(~~ (static host.jvm)) - (let [runnable (object [] [Runnable] + (`` (for {(~~ (static host.old)) + (let [runnable (object [] [java/lang/Runnable] [] - (Runnable [] (run) void - (io.run action)))] + (java/lang/Runnable [] (run) void + (io.run action)))] (case milli-seconds - 0 (Executor::execute runnable runner) - _ (ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) TimeUnit::MILLISECONDS - runner)))} + 0 (java/util/concurrent/Executor::execute runnable runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule runnable (.int milli-seconds) java/util/concurrent/TimeUnit::MILLISECONDS + runner)))} ## Default (atom.update (|>> (#.Cons {#creation ("lux io current-time") @@ -79,7 +79,7 @@ #action action})) runner)))) -(`` (for {(~~ (static host.jvm)) +(`` (for {(~~ (static host.old)) (as-is)} ## Default diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index 2edaeb8b4..db351d87b 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -33,7 +33,7 @@ (def: #export (read box) (All [! a] (-> (Box ! a) (Thread ! a))) (function (_ !) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) ("jvm aaload" (:representation box) 0)})))) (def: #export (write value box) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 946b6a3b4..04b215cf8 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -23,19 +23,19 @@ (def: #export (new size) (All [a] (-> Nat (Array a))) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) (:assume ("jvm anewarray" "(java.lang.Object )" size))}))) (def: #export (size xs) (All [a] (-> (Array a) Nat)) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) ("jvm arraylength" xs)}))) (def: #export (read i xs) (All [a] (-> Nat (Array a) (Maybe a))) (if (n/< (size xs) i) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) (let [value ("jvm aaload" xs i)] (if ("jvm object null?" value) #.None @@ -55,7 +55,7 @@ (def: #export (write i x xs) (All [a] (-> Nat a (Array a) (Array a))) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) ("jvm aastore" xs i x)}))) (def: #export (update index transform array) @@ -79,7 +79,7 @@ (All [a] (-> Nat (Array a) (Array a))) (if (n/< (size xs) i) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) (write i (:assume ("jvm object null")) xs)})) xs)) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 720968ba9..da3f4cd36 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -202,7 +202,7 @@ (def: &equivalence ..equivalence) (def: (hash input) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) (|> input (: (primitive "java.lang.String" [])) "jvm invokevirtual:java.lang.String:hashCode:" diff --git a/stdlib/source/lux/data/text/buffer.lux b/stdlib/source/lux/data/text/buffer.lux index 6260894c6..7549b1be1 100644 --- a/stdlib/source/lux/data/text/buffer.lux +++ b/stdlib/source/lux/data/text/buffer.lux @@ -13,7 +13,7 @@ [host (#+ import:)]] ["." //]) -(`` (for {(~~ (static _.jvm)) +(`` (for {(~~ (static _.old)) (as-is (import: java/lang/CharSequence) (import: java/lang/Appendable @@ -26,21 +26,21 @@ (`` (abstract: #export Buffer {#.doc "Immutable text buffer for efficient text concatenation."} - (for {(~~ (static _.jvm)) + (for {(~~ (static _.old)) [Nat (-> StringBuilder StringBuilder)]} ## default (Row Text)) (def: #export empty Buffer - (:abstraction (for {(~~ (static _.jvm)) + (:abstraction (for {(~~ (static _.old)) [0 id]} ## default row.empty))) (def: #export (append chunk buffer) (-> Text Buffer Buffer) - (for {(~~ (static _.jvm)) + (for {(~~ (static _.old)) (let [[capacity transform] (:representation buffer) append! (: (-> Text StringBuilder StringBuilder) (function (_ chunk builder) @@ -54,7 +54,7 @@ (def: #export (size buffer) (-> Buffer Nat) - (for {(~~ (static _.jvm)) + (for {(~~ (static _.old)) (|> buffer :representation product.left)} ## default (row;fold (function (_ chunk total) @@ -64,7 +64,7 @@ (def: #export (text buffer) (-> Buffer Text) - (for {(~~ (static _.jvm)) + (for {(~~ (static _.old)) (let [[capacity transform] (:representation buffer)] (|> (StringBuilder::new (.int capacity)) transform diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index b4372471c..aae640382 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -173,20 +173,20 @@ (|>> :representation)) ) -(`` (for {(~~ (static _.jvm)) - (as-is (import: java/lang/String - (new [(Array byte) String]) - (getBytes [String] (Array byte))))})) +(`` (for {(~~ (static _.old)) + (as-is (import: #long java/lang/String + (new [(Array byte) java/lang/String]) + (getBytes [java/lang/String] (Array byte))))})) (def: #export (to-utf8 value) (-> Text Binary) - (`` (for {(~~ (static _.jvm)) - (String::getBytes (..name ..utf-8) (:coerce String value))}))) + (`` (for {(~~ (static _.old)) + (java/lang/String::getBytes (..name ..utf-8) (:coerce java/lang/String value))}))) (def: #export (from-utf8 value) (-> Binary (Error Text)) - (`` (for {(~~ (static _.jvm)) - (#error.Success (String::new value (..name ..utf-8)))}))) + (`` (for {(~~ (static _.old)) + (#error.Success (java/lang/String::new value (..name ..utf-8)))}))) (structure: #export UTF-8 (Codec Binary Text) (def: encode ..to-utf8) diff --git a/stdlib/source/lux/host.jvm.lux b/stdlib/source/lux/host.jvm.lux deleted file mode 100644 index 915cdc7bf..000000000 --- a/stdlib/source/lux/host.jvm.lux +++ /dev/null @@ -1,2002 +0,0 @@ -(.module: - [lux (#- type) - [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)]]] - ["." type ("#;." equivalence)] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax: Syntax)]]]) - -(template [ ] - [(def: #export ( value) - {#.doc (doc "Type converter." - (: - ( (: foo))))} - (-> (primitive ) (primitive )) - ( value))] - - [byte-to-long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] - - [short-to-long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"] - - [double-to-int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"] - [double-to-long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"] - [double-to-float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"] - - [float-to-int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"] - [float-to-long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"] - [float-to-double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"] - - [int-to-byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"] - [int-to-short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"] - [int-to-long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"] - [int-to-float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"] - [int-to-double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"] - [int-to-char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"] - - [long-to-byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"] - [long-to-short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"] - [long-to-int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"] - [long-to-float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"] - [long-to-double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"] - - [char-to-byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"] - [char-to-short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"] - [char-to-int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"] - [char-to-long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"] - ) - -## [Utils] -(def: constructor-method-name "") -(def: member-separator "::") - -## Types -(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])) - -## Utils -(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 [ ] - - (#.Some (' ))) - (["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 [ ] - - (#.Some (' ))) - (["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 [ ] - (#GenericClass #.Nil) - ) - (["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 (`' ((~ (code.text (format "jvm getstatic" ":" 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 (`' ((~ (code.text (format "jvm getfield" ":" 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 [] - [meta ( parts)] - [meta ( (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: (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 (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls')))) - (~+ args)))))) - -(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 (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) - (~+ args)))))) - -(template [ ] - [(def: ( 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 (`' ((~ (code.text (format ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) - (~' _jvm_this) (~+ args))))))] - - [make-special-method-parser "jvm invokespecial"] - [make-virtual-method-parser "jvm invokevirtual"] - ) - -(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))) - -## Syntaxes -(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 [ ] - (#GenericClass #.Nil) - (wrap (#GenericClass (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})))) - )) - -## Generators -(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 (`' ((~ (code.text (format "jvm invokespecial" - ":" (get@ #super-class-name super-class) - ":" name - ":" (text.join-with "," arg-decls')))) - (~' _jvm_this) (~+ args)))))))] - (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)))) - -## [Syntax] -(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 return-term) - (-> Import-Member-Declaration Code Code) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ #import-member-maybe? commons) - (` (??? (~ return-term))) - (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 [ ] - [(def: ( member return-term) - (-> Import-Member-Declaration Code Code) - (case member - (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) - (if (get@ commons) - - 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 [ ] - [(def: ( mode [class expression]) - (-> Primitive-Mode [Text Code] Code) - (case mode - #ManualPrM - expression - - #AutoPrM - (case class - "byte" (` ( (~ expression))) - "short" (` ( (~ expression))) - "int" (` ( (~ expression))) - "float" (` ( (~ expression))) - _ expression)))] - - [auto-convert-input long-to-byte long-to-short long-to-int double-to-float] - [auto-convert-output byte-to-long short-to-long int-to-long float-to-double] - ) - -(def: (un-quote quoted) - (-> Code Code) - (` ((~' ~) (~ quoted)))) - -(def: (jvm-extension-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: (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) - ((~ (code.text (format "jvm getstatic" ":" 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-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes))) - jvm-interop (|> (` ((~ jvm-extension) - (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)))) - (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 (.` (~ 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 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-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-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 (.` (~ 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? - (let [jvm-extension (code.text (format "jvm getstatic" ":" full-name ":" import-field-name))] - (` ((~ jvm-extension)))) - (let [jvm-extension (code.text (format "jvm getfield" ":" full-name ":" import-field-name))] - (` ((~ jvm-extension) (~ (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? class) - (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) - ("jvm invokevirtual:java.lang.Class:isInterface:" class)) - -(def: (load-class class-name) - (-> Text (Error (primitive "java.lang.Class" [Any]))) - (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class-name))) - -(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 [ ] - (^ (#GenericClass (list))) - (wrap (list (` ( (~ 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 [ ] - - (wrap (list (` ( (~ 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 [ ] - - (wrap (list (` ( (~ 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))))))))) - -(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." - (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 new file mode 100644 index 000000000..915cdc7bf --- /dev/null +++ b/stdlib/source/lux/host.old.lux @@ -0,0 +1,2002 @@ +(.module: + [lux (#- type) + [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)]]] + ["." type ("#;." equivalence)] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax: Syntax)]]]) + +(template [ ] + [(def: #export ( value) + {#.doc (doc "Type converter." + (: + ( (: foo))))} + (-> (primitive ) (primitive )) + ( value))] + + [byte-to-long "jvm convert byte-to-long" "java.lang.Byte" "java.lang.Long"] + + [short-to-long "jvm convert short-to-long" "java.lang.Short" "java.lang.Long"] + + [double-to-int "jvm convert double-to-int" "java.lang.Double" "java.lang.Integer"] + [double-to-long "jvm convert double-to-long" "java.lang.Double" "java.lang.Long"] + [double-to-float "jvm convert double-to-float" "java.lang.Double" "java.lang.Float"] + + [float-to-int "jvm convert float-to-int" "java.lang.Float" "java.lang.Integer"] + [float-to-long "jvm convert float-to-long" "java.lang.Float" "java.lang.Long"] + [float-to-double "jvm convert float-to-double" "java.lang.Float" "java.lang.Double"] + + [int-to-byte "jvm convert int-to-byte" "java.lang.Integer" "java.lang.Byte"] + [int-to-short "jvm convert int-to-short" "java.lang.Integer" "java.lang.Short"] + [int-to-long "jvm convert int-to-long" "java.lang.Integer" "java.lang.Long"] + [int-to-float "jvm convert int-to-float" "java.lang.Integer" "java.lang.Float"] + [int-to-double "jvm convert int-to-double" "java.lang.Integer" "java.lang.Double"] + [int-to-char "jvm convert int-to-char" "java.lang.Integer" "java.lang.Character"] + + [long-to-byte "jvm convert long-to-byte" "java.lang.Long" "java.lang.Byte"] + [long-to-short "jvm convert long-to-short" "java.lang.Long" "java.lang.Short"] + [long-to-int "jvm convert long-to-int" "java.lang.Long" "java.lang.Integer"] + [long-to-float "jvm convert long-to-float" "java.lang.Long" "java.lang.Float"] + [long-to-double "jvm convert long-to-double" "java.lang.Long" "java.lang.Double"] + + [char-to-byte "jvm convert char-to-byte" "java.lang.Character" "java.lang.Byte"] + [char-to-short "jvm convert char-to-short" "java.lang.Character" "java.lang.Short"] + [char-to-int "jvm convert char-to-int" "java.lang.Character" "java.lang.Integer"] + [char-to-long "jvm convert char-to-long" "java.lang.Character" "java.lang.Long"] + ) + +## [Utils] +(def: constructor-method-name "") +(def: member-separator "::") + +## Types +(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])) + +## Utils +(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 [ ] + + (#.Some (' ))) + (["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 [ ] + + (#.Some (' ))) + (["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 [ ] + (#GenericClass #.Nil) + ) + (["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 (`' ((~ (code.text (format "jvm getstatic" ":" 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 (`' ((~ (code.text (format "jvm getfield" ":" 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 [] + [meta ( parts)] + [meta ( (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: (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 (` ((~ (code.text (format "jvm new" ":" class-name ":" (text.join-with "," arg-decls')))) + (~+ args)))))) + +(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 (`' ((~ (code.text (format "jvm invokestatic" ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) + (~+ args)))))) + +(template [ ] + [(def: ( 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 (`' ((~ (code.text (format ":" class-name ":" method-name ":" (text.join-with "," arg-decls')))) + (~' _jvm_this) (~+ args))))))] + + [make-special-method-parser "jvm invokespecial"] + [make-virtual-method-parser "jvm invokevirtual"] + ) + +(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))) + +## Syntaxes +(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 [ ] + (#GenericClass #.Nil) + (wrap (#GenericClass (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})))) + )) + +## Generators +(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 (`' ((~ (code.text (format "jvm invokespecial" + ":" (get@ #super-class-name super-class) + ":" name + ":" (text.join-with "," arg-decls')))) + (~' _jvm_this) (~+ args)))))))] + (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)))) + +## [Syntax] +(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 return-term) + (-> Import-Member-Declaration Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ #import-member-maybe? commons) + (` (??? (~ return-term))) + (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 [ ] + [(def: ( member return-term) + (-> Import-Member-Declaration Code Code) + (case member + (^or (#ConstructorDecl [commons _]) (#MethodDecl [commons _])) + (if (get@ commons) + + 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 [ ] + [(def: ( mode [class expression]) + (-> Primitive-Mode [Text Code] Code) + (case mode + #ManualPrM + expression + + #AutoPrM + (case class + "byte" (` ( (~ expression))) + "short" (` ( (~ expression))) + "int" (` ( (~ expression))) + "float" (` ( (~ expression))) + _ expression)))] + + [auto-convert-input long-to-byte long-to-short long-to-int double-to-float] + [auto-convert-output byte-to-long short-to-long int-to-long float-to-double] + ) + +(def: (un-quote quoted) + (-> Code Code) + (` ((~' ~) (~ quoted)))) + +(def: (jvm-extension-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: (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) + ((~ (code.text (format "jvm getstatic" ":" 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-extension (code.text (format "jvm new" ":" full-name ":" (text.join-with "," arg-classes))) + jvm-interop (|> (` ((~ jvm-extension) + (~+ (jvm-extension-inputs (get@ #import-member-mode commons) arg-classes arg-function-inputs)))) + (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 (.` (~ 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 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-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-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 (.` (~ 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? + (let [jvm-extension (code.text (format "jvm getstatic" ":" full-name ":" import-field-name))] + (` ((~ jvm-extension)))) + (let [jvm-extension (code.text (format "jvm getfield" ":" full-name ":" import-field-name))] + (` ((~ jvm-extension) (~ (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? class) + (All [a] (-> (primitive "java.lang.Class" [a]) Bit)) + ("jvm invokevirtual:java.lang.Class:isInterface:" class)) + +(def: (load-class class-name) + (-> Text (Error (primitive "java.lang.Class" [Any]))) + (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class-name))) + +(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 [ ] + (^ (#GenericClass (list))) + (wrap (list (` ( (~ 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 [ ] + + (wrap (list (` ( (~ 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 [ ] + + (wrap (list (` ( (~ 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))))))))) + +(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." + (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/jvm/loader.jvm.lux b/stdlib/source/lux/host/jvm/loader.jvm.lux deleted file mode 100644 index 0ca92fa23..000000000 --- a/stdlib/source/lux/host/jvm/loader.jvm.lux +++ /dev/null @@ -1,126 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)] - ["." io (#+ IO)] - [concurrency - ["." atom (#+ Atom)]]] - [data - ["." error (#+ Error)] - ["." text - format] - [collection - ["." array] - ["." list ("#;." functor)] - ["." dictionary (#+ Dictionary)]]] - [world - ["." binary (#+ Binary)]] - ["." host (#+ import: object do-to)]]) - -(type: #export Library - (Atom (Dictionary Text Binary))) - -(exception: #export (already-stored {class Text}) - (ex.report ["Class" class])) - -(exception: #export (unknown {class Text} {known-classes (List Text)}) - (ex.report ["Class" class] - ["Known classes" (|> known-classes - (list.sort (:: text.order <)) - (list;map (|>> (format text.new-line text.tab))) - (text.join-with ""))])) - -(exception: #export (cannot-define {class Text} {error Text}) - (ex.report ["Class" class] - ["Error" error])) - -(import: #long java/lang/Object - (getClass [] (java/lang/Class java/lang/Object))) - -(import: #long java/lang/String) - -(import: #long java/lang/reflect/Method - (invoke [java/lang/Object (Array java/lang/Object)] - #try java/lang/Object)) - -(import: #long (java/lang/Class a) - (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] - #try java/lang/reflect/Method)) - -(import: #long java/lang/Integer - (#static TYPE (java/lang/Class java/lang/Integer))) - -(import: #long java/lang/reflect/AccessibleObject - (setAccessible [boolean] void)) - -(import: #long java/lang/ClassLoader - (loadClass [java/lang/String] - #io #try (java/lang/Class java/lang/Object))) - -(def: java/lang/ClassLoader::defineClass - java/lang/reflect/Method - (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4) - (host.array-write 0 (:coerce (java/lang/Class java/lang/Object) - (host.class-for java/lang/String))) - (host.array-write 1 (java/lang/Object::getClass (host.array byte 0))) - (host.array-write 2 (:coerce (java/lang/Class java/lang/Object) - (java/lang/Integer::TYPE))) - (host.array-write 3 (:coerce (java/lang/Class java/lang/Object) - (java/lang/Integer::TYPE))))] - (do-to (error.assume - (java/lang/Class::getDeclaredMethod "defineClass" - signature - (host.class-for java/lang/ClassLoader))) - (java/lang/reflect/AccessibleObject::setAccessible true)))) - -(def: #export (define class-name bytecode loader) - (-> Text Binary java/lang/ClassLoader (Error java/lang/Object)) - (let [signature (array.from-list (list (:coerce java/lang/Object - class-name) - (:coerce java/lang/Object - bytecode) - (:coerce java/lang/Object - (host.long-to-int +0)) - (:coerce java/lang/Object - (host.long-to-int (.int (binary.size bytecode))))))] - (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) - -(def: #export (new-library _) - (-> Any Library) - (atom.atom (dictionary.new text.hash))) - -(def: #export (memory library) - (-> Library java/lang/ClassLoader) - (object [] java/lang/ClassLoader [] - [] - (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class - (let [classes (|> library atom.read io.run)] - (case (dictionary.get class-name classes) - (#.Some bytecode) - (case (|> _jvm_this - (..define class-name bytecode)) - (#error.Success class) - (:assume class) - - (#error.Failure error) - (error! (ex.construct ..cannot-define [class-name error]))) - - #.None - (error! (ex.construct ..unknown [class-name (dictionary.keys classes)]))))))) - -(def: #export (store name bytecode library) - (-> Text Binary Library (IO (Error Any))) - (do io.monad - [library' (atom.read library)] - (if (dictionary.contains? name library') - (wrap (ex.throw ..already-stored name)) - (do @ - [_ (atom.update (dictionary.put name bytecode) library)] - (wrap (#error.Success [])))))) - -(def: #export (load name loader) - (-> Text java/lang/ClassLoader - (IO (Error (java/lang/Class java/lang/Object)))) - (java/lang/ClassLoader::loadClass name loader)) diff --git a/stdlib/source/lux/host/jvm/loader.old.lux b/stdlib/source/lux/host/jvm/loader.old.lux new file mode 100644 index 000000000..0ca92fa23 --- /dev/null +++ b/stdlib/source/lux/host/jvm/loader.old.lux @@ -0,0 +1,126 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)] + ["." io (#+ IO)] + [concurrency + ["." atom (#+ Atom)]]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + ["." array] + ["." list ("#;." functor)] + ["." dictionary (#+ Dictionary)]]] + [world + ["." binary (#+ Binary)]] + ["." host (#+ import: object do-to)]]) + +(type: #export Library + (Atom (Dictionary Text Binary))) + +(exception: #export (already-stored {class Text}) + (ex.report ["Class" class])) + +(exception: #export (unknown {class Text} {known-classes (List Text)}) + (ex.report ["Class" class] + ["Known classes" (|> known-classes + (list.sort (:: text.order <)) + (list;map (|>> (format text.new-line text.tab))) + (text.join-with ""))])) + +(exception: #export (cannot-define {class Text} {error Text}) + (ex.report ["Class" class] + ["Error" error])) + +(import: #long java/lang/Object + (getClass [] (java/lang/Class java/lang/Object))) + +(import: #long java/lang/String) + +(import: #long java/lang/reflect/Method + (invoke [java/lang/Object (Array java/lang/Object)] + #try java/lang/Object)) + +(import: #long (java/lang/Class a) + (getDeclaredMethod [java/lang/String (Array (java/lang/Class java/lang/Object))] + #try java/lang/reflect/Method)) + +(import: #long java/lang/Integer + (#static TYPE (java/lang/Class java/lang/Integer))) + +(import: #long java/lang/reflect/AccessibleObject + (setAccessible [boolean] void)) + +(import: #long java/lang/ClassLoader + (loadClass [java/lang/String] + #io #try (java/lang/Class java/lang/Object))) + +(def: java/lang/ClassLoader::defineClass + java/lang/reflect/Method + (let [signature (|> (host.array (java/lang/Class java/lang/Object) 4) + (host.array-write 0 (:coerce (java/lang/Class java/lang/Object) + (host.class-for java/lang/String))) + (host.array-write 1 (java/lang/Object::getClass (host.array byte 0))) + (host.array-write 2 (:coerce (java/lang/Class java/lang/Object) + (java/lang/Integer::TYPE))) + (host.array-write 3 (:coerce (java/lang/Class java/lang/Object) + (java/lang/Integer::TYPE))))] + (do-to (error.assume + (java/lang/Class::getDeclaredMethod "defineClass" + signature + (host.class-for java/lang/ClassLoader))) + (java/lang/reflect/AccessibleObject::setAccessible true)))) + +(def: #export (define class-name bytecode loader) + (-> Text Binary java/lang/ClassLoader (Error java/lang/Object)) + (let [signature (array.from-list (list (:coerce java/lang/Object + class-name) + (:coerce java/lang/Object + bytecode) + (:coerce java/lang/Object + (host.long-to-int +0)) + (:coerce java/lang/Object + (host.long-to-int (.int (binary.size bytecode))))))] + (java/lang/reflect/Method::invoke loader signature java/lang/ClassLoader::defineClass))) + +(def: #export (new-library _) + (-> Any Library) + (atom.atom (dictionary.new text.hash))) + +(def: #export (memory library) + (-> Library java/lang/ClassLoader) + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass {class-name java/lang/String}) java/lang/Class + (let [classes (|> library atom.read io.run)] + (case (dictionary.get class-name classes) + (#.Some bytecode) + (case (|> _jvm_this + (..define class-name bytecode)) + (#error.Success class) + (:assume class) + + (#error.Failure error) + (error! (ex.construct ..cannot-define [class-name error]))) + + #.None + (error! (ex.construct ..unknown [class-name (dictionary.keys classes)]))))))) + +(def: #export (store name bytecode library) + (-> Text Binary Library (IO (Error Any))) + (do io.monad + [library' (atom.read library)] + (if (dictionary.contains? name library') + (wrap (ex.throw ..already-stored name)) + (do @ + [_ (atom.update (dictionary.put name bytecode) library)] + (wrap (#error.Success [])))))) + +(def: #export (load name loader) + (-> Text java/lang/ClassLoader + (IO (Error (java/lang/Class java/lang/Object)))) + (java/lang/ClassLoader::loadClass name loader)) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 34ba2a1fd..fbd0aa772 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -47,6 +47,7 @@ Info {#.target (`` (for {(~~ (static ///host.common-lisp)) ///host.common-lisp (~~ (static ///host.js)) ///host.js + (~~ (static ///host.old)) ///host.jvm (~~ (static ///host.jvm)) ///host.jvm (~~ (static ///host.lua)) ///host.lua (~~ (static ///host.php)) ///host.php diff --git a/stdlib/source/lux/tool/compiler/host.lux b/stdlib/source/lux/tool/compiler/host.lux index 71158e724..06c4c7efe 100644 --- a/stdlib/source/lux/tool/compiler/host.lux +++ b/stdlib/source/lux/tool/compiler/host.lux @@ -6,6 +6,9 @@ (template [ ] [(def: #export Host )] + ## TODO: Delete ASAP + [old "{old}"] + [common-lisp "Common Lisp"] [js "JavaScript"] [jvm "JVM"] diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux index 354f84460..f9b01a682 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/archive.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -25,6 +25,7 @@ (<| (format root (:: System separator)) (`` (for {(~~ (static host.common-lisp)) host.common-lisp (~~ (static host.js)) host.js + (~~ (static host.old)) host.jvm (~~ (static host.jvm)) host.jvm (~~ (static host.lua)) host.lua (~~ (static host.php)) host.php diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux index e64a5d7b8..b60616f03 100644 --- a/stdlib/source/lux/tool/compiler/meta/io/context.lux +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -40,6 +40,7 @@ Extension (`` (for {(~~ (static ////host.common-lisp)) ".cl" (~~ (static ////host.js)) ".js" + (~~ (static ////host.old)) ".jvm" (~~ (static ////host.jvm)) ".jvm" (~~ (static ////host.lua)) ".lua" (~~ (static ////host.php)) ".php" diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux deleted file mode 100644 index 13762272e..000000000 --- a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux +++ /dev/null @@ -1,1301 +0,0 @@ -(.module: - [lux (#- char int) - [abstract - ["." monad (#+ do)]] - [control - ["p" parser] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." error (#+ Error)] - ["." maybe] - ["." product] - ["." text ("#@." equivalence) - format] - [collection - ["." list ("#@." fold functor monoid)] - ["." array (#+ Array)] - ["." dictionary (#+ Dictionary)]]] - ["." type - ["." check]] - ["." macro - ["s" syntax]] - ["." host (#+ import:)]] - ["." // #_ - ["#." common] - ["#/" // - ["#." bundle] - ["#/" // ("#@." monad) - [analysis - [".A" type] - [".A" inference]] - ["#/" // #_ - ["#." analysis (#+ Analysis Operation Handler Bundle)]]]]]) - -(type: Method-Signature - {#method Type - #exceptions (List Type)}) - -(import: #long java/lang/reflect/Type - (getTypeName [] String)) - -(template [] - [(exception: #export ( {jvm-type java/lang/reflect/Type}) - (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] - - [jvm-type-is-not-a-class] - [cannot-convert-to-a-class] - [cannot-convert-to-a-parameter] - [cannot-convert-to-a-lux-type] - ) - -(template [] - [(exception: #export ( {type Type}) - (%type type))] - - [non-object] - [non-array] - [non-jvm-type] - ) - -(template [] - [(exception: #export ( {name Text}) - name)] - - [non-interface] - [non-throwable] - ) - -(template [] - [(exception: #export ( {message Text}) - message)] - - [unknown-class] - [primitives-cannot-have-type-parameters] - [primitives-are-not-objects] - [invalid-type-for-array-element] - - [unknown-field] - [mistaken-field-owner] - [not-a-virtual-field] - [not-a-static-field] - [cannot-set-a-final-field] - - [cannot-cast] - - [cannot-possibly-be-an-instance] - - [unknown-type-var] - [type-parameter-mismatch] - [cannot-correspond-type-with-a-class] - ) - -(template [] - [(exception: #export ( {class Text} - {method Text} - {hints (List Method-Signature)}) - (ex.report ["Class" class] - ["Method" method] - ["Hints" (|> hints - (list@map (|>> product.left %type (format text.new-line text.tab))) - (text.join-with ""))]))] - - [no-candidates] - [too-many-candidates] - ) - -(template [ ] - [(def: #export Type (#.Primitive (list)))] - - ## 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"] - [String "java.lang.String"] - - ## Primitives - [boolean "boolean"] - [byte "byte"] - [short "short"] - [int "int"] - [long "long"] - [float "float"] - [double "double"] - [char "char"] - ) - -(def: bundle::conversion - Bundle - (<| (///bundle.prefix "convert") - (|> ///bundle.empty - (///bundle.install "double-to-float" (//common.unary Double Float)) - (///bundle.install "double-to-int" (//common.unary Double Integer)) - (///bundle.install "double-to-long" (//common.unary Double Long)) - (///bundle.install "float-to-double" (//common.unary Float Double)) - (///bundle.install "float-to-int" (//common.unary Float Integer)) - (///bundle.install "float-to-long" (//common.unary Float Long)) - (///bundle.install "int-to-byte" (//common.unary Integer Byte)) - (///bundle.install "int-to-char" (//common.unary Integer Character)) - (///bundle.install "int-to-double" (//common.unary Integer Double)) - (///bundle.install "int-to-float" (//common.unary Integer Float)) - (///bundle.install "int-to-long" (//common.unary Integer Long)) - (///bundle.install "int-to-short" (//common.unary Integer Short)) - (///bundle.install "long-to-double" (//common.unary Long Double)) - (///bundle.install "long-to-float" (//common.unary Long Float)) - (///bundle.install "long-to-int" (//common.unary Long Integer)) - (///bundle.install "long-to-short" (//common.unary Long Short)) - (///bundle.install "long-to-byte" (//common.unary Long Byte)) - (///bundle.install "char-to-byte" (//common.unary Character Byte)) - (///bundle.install "char-to-short" (//common.unary Character Short)) - (///bundle.install "char-to-int" (//common.unary Character Integer)) - (///bundle.install "char-to-long" (//common.unary Character Long)) - (///bundle.install "byte-to-long" (//common.unary Byte Long)) - (///bundle.install "short-to-long" (//common.unary Short Long)) - ))) - -(template [ ] - [(def: - Bundle - (<| (///bundle.prefix ) - (|> ///bundle.empty - (///bundle.install "+" (//common.binary )) - (///bundle.install "-" (//common.binary )) - (///bundle.install "*" (//common.binary )) - (///bundle.install "/" (//common.binary )) - (///bundle.install "%" (//common.binary )) - (///bundle.install "=" (//common.binary Bit)) - (///bundle.install "<" (//common.binary Bit)) - (///bundle.install "and" (//common.binary )) - (///bundle.install "or" (//common.binary )) - (///bundle.install "xor" (//common.binary )) - (///bundle.install "shl" (//common.binary Integer )) - (///bundle.install "shr" (//common.binary Integer )) - (///bundle.install "ushr" (//common.binary Integer )) - )))] - - [bundle::int "int" Integer] - [bundle::long "long" Long] - ) - -(template [ ] - [(def: - Bundle - (<| (///bundle.prefix ) - (|> ///bundle.empty - (///bundle.install "+" (//common.binary )) - (///bundle.install "-" (//common.binary )) - (///bundle.install "*" (//common.binary )) - (///bundle.install "/" (//common.binary )) - (///bundle.install "%" (//common.binary )) - (///bundle.install "=" (//common.binary Bit)) - (///bundle.install "<" (//common.binary Bit)) - )))] - - [bundle::float "float" Float] - [bundle::double "double" Double] - ) - -(def: bundle::char - Bundle - (<| (///bundle.prefix "char") - (|> ///bundle.empty - (///bundle.install "=" (//common.binary Character Character Bit)) - (///bundle.install "<" (//common.binary Character Character Bit)) - ))) - -(def: #export 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: array::length - Handler - (function (_ extension-name analyse args) - (case args - (^ (list arrayC)) - (do ////.monad - [_ (typeA.infer Nat) - [var-id varT] (typeA.with-env check.var) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC))] - (wrap (#/////analysis.Extension extension-name (list arrayA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: array::new - Handler - (function (_ extension-name analyse args) - (case args - (^ (list lengthC)) - (do ////.monad - [lengthA (typeA.with-type Nat - (analyse lengthC)) - expectedT (///.lift macro.expected-type) - [level elem-class] (: (Operation [Nat Text]) - (loop [analysisT expectedT - level 0] - (case analysisT - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur outputT level) - - #.None - (/////analysis.throw non-array expectedT)) - - (^ (#.Primitive "#Array" (list elemT))) - (recur elemT (inc level)) - - (#.Primitive class _) - (wrap [level class]) - - _ - (/////analysis.throw non-array expectedT)))) - _ (if (n/> 0 level) - (wrap []) - (/////analysis.throw non-array expectedT))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (dec level)) - (/////analysis.text elem-class) - lengthA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: (check-jvm objectT) - (-> Type (Operation Text)) - (case objectT - (#.Primitive name _) - (////@wrap name) - - (#.Named name unnamed) - (check-jvm unnamed) - - (#.Var id) - (////@wrap "java.lang.Object") - - (^template [] - ( env unquantified) - (check-jvm unquantified)) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (check-jvm outputT) - - #.None - (/////analysis.throw non-object objectT)) - - _ - (/////analysis.throw non-object objectT))) - -(def: (check-object objectT) - (-> Type (Operation Text)) - (do ////.monad - [name (check-jvm objectT)] - (if (dictionary.contains? name boxes) - (/////analysis.throw primitives-are-not-objects name) - (////@wrap name)))) - -(def: (box-array-element-type elemT) - (-> Type (Operation [Type Text])) - (case elemT - (#.Primitive name #.Nil) - (let [boxed-name (|> (dictionary.get name boxes) - (maybe.default name))] - (////@wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) - - (#.Primitive name _) - (if (dictionary.contains? name boxes) - (/////analysis.throw primitives-cannot-have-type-parameters name) - (////@wrap [elemT name])) - - _ - (/////analysis.throw invalid-type-for-array-element (%type elemT)))) - -(def: array::read - Handler - (function (_ extension-name analyse args) - (case args - (^ (list arrayC idxC)) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer varT) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC)) - ?elemT (typeA.with-env - (check.read var-id)) - [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (typeA.with-type Nat - (analyse idxC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA arrayA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: array::write - Handler - (function (_ extension-name analyse args) - (case args - (^ (list arrayC idxC valueC)) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer (type (Array varT))) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC)) - ?elemT (typeA.with-env - (check.read var-id)) - [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (typeA.with-type Nat - (analyse idxC)) - valueA (typeA.with-type valueT - (analyse valueC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA valueA arrayA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) - -(def: bundle::array - Bundle - (<| (///bundle.prefix "array") - (|> ///bundle.empty - (///bundle.install "length" array::length) - (///bundle.install "new" array::new) - (///bundle.install "read" array::read) - (///bundle.install "write" array::write) - ))) - -(def: object::null - Handler - (function (_ extension-name analyse args) - (case args - (^ (list)) - (do ////.monad - [expectedT (///.lift macro.expected-type) - _ (check-object expectedT)] - (wrap (#/////analysis.Extension extension-name (list)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) - -(def: object::null? - Handler - (function (_ extension-name analyse args) - (case args - (^ (list objectC)) - (do ////.monad - [_ (typeA.infer Bit) - [objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (check-object objectT)] - (wrap (#/////analysis.Extension extension-name (list objectA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: object::synchronized - Handler - (function (_ extension-name analyse args) - (case args - (^ (list monitorC exprC)) - (do ////.monad - [[monitorT monitorA] (typeA.with-inference - (analyse monitorC)) - _ (check-object monitorT) - exprA (analyse exprC)] - (wrap (#/////analysis.Extension extension-name (list monitorA exprA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(import: java/lang/Object - (equals [Object] boolean)) - -(import: java/lang/ClassLoader) - -(import: java/lang/reflect/GenericArrayType - (getGenericComponentType [] java/lang/reflect/Type)) - -(import: java/lang/reflect/ParameterizedType - (getRawType [] java/lang/reflect/Type) - (getActualTypeArguments [] (Array java/lang/reflect/Type))) - -(import: (java/lang/reflect/TypeVariable d) - (getName [] String) - (getBounds [] (Array java/lang/reflect/Type))) - -(import: (java/lang/reflect/WildcardType d) - (getLowerBounds [] (Array java/lang/reflect/Type)) - (getUpperBounds [] (Array java/lang/reflect/Type))) - -(import: java/lang/reflect/Modifier - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)) - -(import: java/lang/reflect/Field - (getDeclaringClass [] (java/lang/Class Object)) - (getModifiers [] int) - (getGenericType [] java/lang/reflect/Type)) - -(import: java/lang/reflect/Method - (getName [] String) - (getModifiers [] int) - (getDeclaringClass [] (Class Object)) - (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java/lang/reflect/Type)) - (getGenericReturnType [] java/lang/reflect/Type) - (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) - -(import: (java/lang/reflect/Constructor c) - (getModifiers [] int) - (getDeclaringClass [] (Class c)) - (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java/lang/reflect/Type)) - (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) - -(import: (java/lang/Class c) - (getName [] String) - (getModifiers [] int) - (#static forName [String] #try (Class Object)) - (isAssignableFrom [(Class Object)] boolean) - (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java/lang/reflect/Type)) - (getGenericSuperclass [] java/lang/reflect/Type) - (getDeclaredField [String] #try Field) - (getConstructors [] (Array (Constructor Object))) - (getDeclaredMethods [] (Array Method))) - -(def: (load-class name) - (-> Text (Operation (Class Object))) - (do ////.monad - [] - (case (Class::forName name) - (#error.Success [class]) - (wrap class) - - (#error.Failure error) - (/////analysis.throw unknown-class name)))) - -(def: (sub-class? super sub) - (-> Text Text (Operation Bit)) - (do ////.monad - [super (load-class super) - sub (load-class sub)] - (wrap (Class::isAssignableFrom sub super)))) - -(def: object::throw - Handler - (function (_ extension-name analyse args) - (case args - (^ (list exceptionC)) - (do ////.monad - [_ (typeA.infer Nothing) - [exceptionT exceptionA] (typeA.with-inference - (analyse exceptionC)) - exception-class (check-object exceptionT) - ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Operation Any) - (if ? - (wrap []) - (/////analysis.throw non-throwable exception-class)))] - (wrap (#/////analysis.Extension extension-name (list exceptionA)))) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: object::class - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC)) - (case classC - [_ (#.Text class)] - (do ////.monad - [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) - _ (load-class class)] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: object::instance? - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC objectC)) - (case classC - [_ (#.Text class)] - (do ////.monad - [_ (typeA.infer Bit) - [objectT objectA] (typeA.with-inference - (analyse objectC)) - object-class (check-object objectT) - ? (sub-class? class object-class)] - (if ? - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))) - (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: (java-type-to-class jvm-type) - (-> java/lang/reflect/Type (Operation Text)) - (<| (case (host.check Class jvm-type) - (#.Some jvm-type) - (////@wrap (Class::getName jvm-type)) - - _) - (case (host.check ParameterizedType jvm-type) - (#.Some jvm-type) - (java-type-to-class (ParameterizedType::getRawType jvm-type)) - - _) - ## else - (/////analysis.throw cannot-convert-to-a-class jvm-type))) - -(type: Mappings - (Dictionary Text Type)) - -(def: fresh-mappings Mappings (dictionary.new text.hash)) - -(def: (java-type-to-lux-type mappings java-type) - (-> Mappings java/lang/reflect/Type (Operation Type)) - (<| (case (host.check TypeVariable java-type) - (#.Some java-type) - (let [var-name (TypeVariable::getName java-type)] - (case (dictionary.get var-name mappings) - (#.Some var-type) - (////@wrap var-type) - - #.None - (/////analysis.throw unknown-type-var var-name))) - - _) - (case (host.check WildcardType java-type) - (#.Some java-type) - (case [(array.read 0 (WildcardType::getUpperBounds java-type)) - (array.read 0 (WildcardType::getLowerBounds java-type))] - (^or [(#.Some bound) _] [_ (#.Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (////@wrap Any)) - - _) - (case (host.check Class java-type) - (#.Some java-type) - (let [java-type (:coerce (Class Object) java-type) - class-name (Class::getName java-type)] - (////@wrap (case (array.size (Class::getTypeParameters java-type)) - 0 - (#.Primitive class-name (list)) - - arity - (|> (list.indices arity) - list.reverse - (list@map (|>> (n/* 2) inc #.Parameter)) - (#.Primitive class-name) - (type.univ-q arity))))) - - _) - (case (host.check ParameterizedType java-type) - (#.Some java-type) - (let [raw (ParameterizedType::getRawType java-type)] - (case (host.check Class raw) - (#.Some raw) - (do ////.monad - [paramsT (|> java-type - ParameterizedType::getActualTypeArguments - array.to-list - (monad.map @ (java-type-to-lux-type mappings)))] - (////@wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) - paramsT))) - - _ - (/////analysis.throw jvm-type-is-not-a-class raw))) - - _) - (case (host.check GenericArrayType java-type) - (#.Some java-type) - (do ////.monad - [innerT (|> java-type - GenericArrayType::getGenericComponentType - (java-type-to-lux-type mappings))] - (wrap (#.Primitive "#Array" (list innerT)))) - - _) - ## else - (/////analysis.throw cannot-convert-to-a-lux-type java-type))) - -(def: (correspond-type-params class type) - (-> (Class Object) Type (Operation Mappings)) - (case type - (#.Primitive name params) - (let [class-name (Class::getName class) - class-params (array.to-list (Class::getTypeParameters class)) - num-class-params (list.size class-params) - num-type-params (list.size params)] - (cond (not (text@= class-name name)) - (/////analysis.throw cannot-correspond-type-with-a-class - (format "Class = " class-name text.new-line - "Type = " (%type type))) - - (not (n/= num-class-params num-type-params)) - (/////analysis.throw type-parameter-mismatch - (format "Expected: " (%i (.int num-class-params)) text.new-line - " Actual: " (%i (.int num-type-params)) text.new-line - " Class: " class-name text.new-line - " Type: " (%type type))) - - ## else - (////@wrap (|> params - (list.zip2 (list@map (|>> TypeVariable::getName) class-params)) - (dictionary.from-list text.hash))) - )) - - _ - (/////analysis.throw non-jvm-type type))) - -(def: object::cast - Handler - (function (_ extension-name analyse args) - (case args - (^ (list valueC)) - (do ////.monad - [toT (///.lift macro.expected-type) - to-name (check-jvm toT) - [valueT valueA] (typeA.with-inference - (analyse valueC)) - from-name (check-jvm valueT) - can-cast? (: (Operation Bit) - (case [from-name to-name] - (^template [ ] - (^or [ ] - [ ]) - (do @ - [_ (typeA.infer (#.Primitive to-name (list)))] - (wrap #1))) - (["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"]) - - _ - (do @ - [_ (////.assert primitives-are-not-objects from-name - (not (dictionary.contains? from-name boxes))) - _ (////.assert primitives-are-not-objects to-name - (not (dictionary.contains? to-name boxes))) - to-class (load-class to-name)] - (loop [[current-name currentT] [from-name valueT]] - (if (text@= to-name current-name) - (do @ - [_ (typeA.infer toT)] - (wrap #1)) - (do @ - [current-class (load-class current-name) - _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line) - (Class::isAssignableFrom current-class to-class)) - candiate-parents (monad.map @ - (function (_ java-type) - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [[class-name java-type] (Class::isAssignableFrom class to-class)]))) - (list& (Class::getGenericSuperclass current-class) - (array.to-list (Class::getGenericInterfaces current-class))))] - (case (|> candiate-parents - (list.filter product.right) - (list@map product.left)) - (#.Cons [next-name nextJT] _) - (do @ - [mapping (correspond-type-params current-class currentT) - nextT (java-type-to-lux-type mapping nextJT)] - (recur [next-name nextT])) - - #.Nil - (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line))) - ))))))] - (if can-cast? - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name) - (/////analysis.text to-name) - valueA))) - (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) - -(def: bundle::object - Bundle - (<| (///bundle.prefix "object") - (|> ///bundle.empty - (///bundle.install "null" object::null) - (///bundle.install "null?" object::null?) - (///bundle.install "synchronized" object::synchronized) - (///bundle.install "throw" object::throw) - (///bundle.install "class" object::class) - (///bundle.install "instance?" object::instance?) - (///bundle.install "cast" object::cast) - ))) - -(def: (find-field class-name field-name) - (-> Text Text (Operation [(Class Object) Field])) - (do ////.monad - [class (load-class class-name)] - (case (Class::getDeclaredField field-name class) - (#error.Success field) - (let [owner (Field::getDeclaringClass field)] - (if (is? owner class) - (wrap [class field]) - (/////analysis.throw mistaken-field-owner - (format " Field: " field-name text.new-line - " Owner Class: " (Class::getName owner) text.new-line - "Target Class: " class-name text.new-line)))) - - (#error.Failure _) - (/////analysis.throw unknown-field (format class-name "#" field-name))))) - -(def: (static-field class-name field-name) - (-> Text Text (Operation [Type Bit])) - (do ////.monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers fieldJ)]] - (if (Modifier::isStatic modifiers) - (let [fieldJT (Field::getGenericType fieldJ)] - (do @ - [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal modifiers)]))) - (/////analysis.throw not-a-static-field (format class-name "#" field-name))))) - -(def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Operation [Type Bit])) - (do ////.monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers fieldJ)]] - (if (not (Modifier::isStatic modifiers)) - (do @ - [#let [fieldJT (Field::getGenericType fieldJ) - var-names (|> class - Class::getTypeParameters - array.to-list - (list@map (|>> TypeVariable::getName)))] - mappings (: (Operation Mappings) - (case objectT - (#.Primitive _class-name _class-params) - (do @ - [#let [num-params (list.size _class-params) - num-vars (list.size var-names)] - _ (////.assert type-parameter-mismatch - (format "Expected: " (%i (.int num-params)) text.new-line - " Actual: " (%i (.int num-vars)) text.new-line - " Class: " _class-name text.new-line - " Type: " (%type objectT)) - (n/= num-params num-vars))] - (wrap (|> (list.zip2 var-names _class-params) - (dictionary.from-list text.hash)))) - - _ - (/////analysis.throw non-object objectT))) - fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal modifiers)])) - (/////analysis.throw not-a-virtual-field (format class-name "#" field-name))))) - -(def: static::get - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[fieldT final?] (static-field class field)] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: static::put - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC valueC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [_ (typeA.infer Any) - [fieldT final?] (static-field class field) - _ (////.assert cannot-set-a-final-field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) - -(def: virtual::get - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC objectC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - [fieldT final?] (virtual-field class field objectT)] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) - -(def: virtual::put - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC valueC objectC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (typeA.infer objectT) - [fieldT final?] (virtual-field class field objectT) - _ (////.assert cannot-set-a-final-field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA)))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])) - - _ - (/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) - -(def: (java-type-to-parameter type) - (-> java/lang/reflect/Type (Operation Text)) - (<| (case (host.check Class type) - (#.Some type) - (////@wrap (Class::getName type)) - - _) - (case (host.check ParameterizedType type) - (#.Some type) - (java-type-to-parameter (ParameterizedType::getRawType type)) - - _) - (case (host.check TypeVariable type) - (#.Some type) - (////@wrap "java.lang.Object") - - _) - (case (host.check WildcardType type) - (#.Some type) - (////@wrap "java.lang.Object") - - _) - (case (host.check GenericArrayType type) - (#.Some type) - (do ////.monad - [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType type))] - (wrap (format componentP "[]"))) - - _) - - ## else - (/////analysis.throw cannot-convert-to-a-parameter type))) - -(type: Method-Style - #Static - #Abstract - #Virtual - #Special - #Interface) - -(def: (check-method class method-name method-style arg-classes method) - (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) - (do ////.monad - [parameters (|> (Method::getGenericParameterTypes method) - array.to-list - (monad.map @ java-type-to-parameter)) - #let [modifiers (Method::getModifiers method)]] - (wrap (and (Object::equals class (Method::getDeclaringClass method)) - (text@= method-name (Method::getName method)) - (case #Static - #Special - (Modifier::isStatic modifiers) - - _ - #1) - (case method-style - #Special - (not (or (Modifier::isInterface (Class::getModifiers class)) - (Modifier::isAbstract modifiers))) - - _ - #1) - (n/= (list.size arg-classes) (list.size parameters)) - (list@fold (function (_ [expectedJC actualJC] prev) - (and prev - (text@= expectedJC actualJC))) - #1 - (list.zip2 arg-classes parameters)))))) - -(def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) - (do ////.monad - [parameters (|> (Constructor::getGenericParameterTypes constructor) - array.to-list - (monad.map @ java-type-to-parameter))] - (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) - (n/= (list.size arg-classes) (list.size parameters)) - (list@fold (function (_ [expectedJC actualJC] prev) - (and prev - (text@= expectedJC actualJC))) - #1 - (list.zip2 arg-classes parameters)))))) - -(def: idx-to-parameter - (-> Nat Type) - (|>> (n/* 2) inc #.Parameter)) - -(def: (type-vars amount offset) - (-> Nat Nat (List Type)) - (if (n/= 0 amount) - (list) - (|> (list.indices amount) - (list@map (|>> (n/+ offset) idx-to-parameter))))) - -(def: (method-signature method-style method) - (-> Method-Style Method (Operation Method-Signature)) - (let [owner (Method::getDeclaringClass method) - owner-name (Class::getName owner) - owner-tvars (case method-style - #Static - (list) - - _ - (|> (Class::getTypeParameters owner) - array.to-list - (list@map (|>> TypeVariable::getName)))) - method-tvars (|> (Method::getTypeParameters method) - array.to-list - (list@map (|>> TypeVariable::getName))) - num-owner-tvars (list.size owner-tvars) - num-method-tvars (list.size method-tvars) - all-tvars (list@compose owner-tvars method-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars 0) - method-tvarsT (type-vars num-method-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list@compose owner-tvarsT method-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dictionary.from-list text.hash))))] - (do ////.monad - [inputsT (|> (Method::getGenericParameterTypes method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method)) - exceptionsT (|> (Method::getGenericExceptionTypes method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type.univ-q num-all-tvars) - (type.function (case method-style - #Static - inputsT - - _ - (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) - inputsT))) - outputT)]] - (wrap [methodT exceptionsT])))) - -(type: Evaluation - (#Pass Method-Signature) - (#Hint Method-Signature) - #Fail) - -(template [ ] - [(def: - (-> Evaluation (Maybe Method-Signature)) - (|>> (case> ( output) - (#.Some output) - - _ - #.None)))] - - [pass! #Pass] - [hint! #Hint] - ) - -(def: (method-candidate class-name method-name method-style arg-classes) - (-> Text Text Method-Style (List Text) (Operation Method-Signature)) - (do ////.monad - [class (load-class class-name) - candidates (|> class - Class::getDeclaredMethods - array.to-list - (monad.map @ (: (-> Method (Operation Evaluation)) - (function (_ method) - (do @ - [passes? (check-method class method-name method-style arg-classes method)] - (cond passes? - (:: @ map (|>> #Pass) (method-signature method-style method)) - - (text@= method-name (Method::getName method)) - (:: @ map (|>> #Hint) (method-signature method-style method)) - - ## else - (wrap #Fail)))))))] - (case (list.search-all pass! candidates) - (#.Cons method #.Nil) - (wrap method) - - #.Nil - (/////analysis.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) - - candidates - (/////analysis.throw too-many-candidates [class-name method-name candidates])))) - -(def: (constructor-signature constructor) - (-> (Constructor Object) (Operation Method-Signature)) - (let [owner (Constructor::getDeclaringClass constructor) - owner-name (Class::getName owner) - owner-tvars (|> (Class::getTypeParameters owner) - array.to-list - (list@map (|>> TypeVariable::getName))) - constructor-tvars (|> (Constructor::getTypeParameters constructor) - array.to-list - (list@map (|>> TypeVariable::getName))) - num-owner-tvars (list.size owner-tvars) - all-tvars (list@compose owner-tvars constructor-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars 0) - constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list@compose owner-tvarsT constructor-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dictionary.from-list text.hash))))] - (do ////.monad - [inputsT (|> (Constructor::getGenericParameterTypes constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) - constructorT (<| (type.univ-q num-all-tvars) - (type.function inputsT) - objectT)]] - (wrap [constructorT exceptionsT])))) - -(def: constructor-method "") - -(def: (constructor-candidate class-name arg-classes) - (-> Text (List Text) (Operation Method-Signature)) - (do ////.monad - [class (load-class class-name) - candidates (|> class - Class::getConstructors - array.to-list - (monad.map @ (function (_ constructor) - (do @ - [passes? (check-constructor class arg-classes constructor)] - (:: @ map - (if passes? (|>> #Pass) (|>> #Hint)) - (constructor-signature constructor))))))] - (case (list.search-all pass! candidates) - (#.Cons constructor #.Nil) - (wrap constructor) - - #.Nil - (/////analysis.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) - - candidates - (/////analysis.throw too-many-candidates [class-name ..constructor-method candidates])))) - -(def: (decorate-inputs typesT inputsA) - (-> (List Text) (List Analysis) (List Analysis)) - (|> inputsA - (list.zip2 (list@map /////analysis.text typesT)) - (list@map (function (_ [type value]) - (/////analysis.tuple (list type value)))))) - -(def: invoke::static - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text (List [Text Code])]) - (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class method argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Static argsT) - [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC)) - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) - -(def: invoke::virtual - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class method objectC argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Virtual argsT) - [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) - -(def: invoke::special - Handler - (function (_ extension-name analyse args) - (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) - (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) - (#error.Success [_ [class method objectC argsTC _]]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Special argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) - (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) - -(def: invoke::interface - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class-name method objectC argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - class (load-class class-name) - _ (////.assert non-interface class-name - (Modifier::isInterface (Class::getModifiers class))) - [methodT exceptionsT] (method-candidate class-name method #Interface argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#/////analysis.Extension extension-name - (list& (/////analysis.text class-name) (/////analysis.text method) (/////analysis.text outputJC) - (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) - -(def: invoke::constructor - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text (List [Text Code])]) - (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class argsTC]) - (do ////.monad - [#let [argsT (list@map product.left argsTC)] - [methodT exceptionsT] (constructor-candidate class argsT) - [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))] - (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (decorate-inputs argsT argsA))))) - - _ - (/////analysis.throw ///.invalid-syntax [extension-name args])))) - -(def: bundle::member - Bundle - (<| (///bundle.prefix "member") - (|> ///bundle.empty - (dictionary.merge (<| (///bundle.prefix "static") - (|> ///bundle.empty - (///bundle.install "get" static::get) - (///bundle.install "put" static::put)))) - (dictionary.merge (<| (///bundle.prefix "virtual") - (|> ///bundle.empty - (///bundle.install "get" virtual::get) - (///bundle.install "put" virtual::put)))) - (dictionary.merge (<| (///bundle.prefix "invoke") - (|> ///bundle.empty - (///bundle.install "static" invoke::static) - (///bundle.install "virtual" invoke::virtual) - (///bundle.install "special" invoke::special) - (///bundle.install "interface" invoke::interface) - (///bundle.install "constructor" invoke::constructor) - ))) - ))) - -(def: #export bundle - Bundle - (<| (///bundle.prefix "jvm") - (|> ///bundle.empty - (dictionary.merge bundle::conversion) - (dictionary.merge bundle::int) - (dictionary.merge bundle::long) - (dictionary.merge bundle::float) - (dictionary.merge bundle::double) - (dictionary.merge bundle::char) - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - (dictionary.merge bundle::member) - ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux new file mode 100644 index 000000000..13762272e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.old.lux @@ -0,0 +1,1301 @@ +(.module: + [lux (#- char int) + [abstract + ["." monad (#+ do)]] + [control + ["p" parser] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." error (#+ Error)] + ["." maybe] + ["." product] + ["." text ("#@." equivalence) + format] + [collection + ["." list ("#@." fold functor monoid)] + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["s" syntax]] + ["." host (#+ import:)]] + ["." // #_ + ["#." common] + ["#/" // + ["#." bundle] + ["#/" // ("#@." monad) + [analysis + [".A" type] + [".A" inference]] + ["#/" // #_ + ["#." analysis (#+ Analysis Operation Handler Bundle)]]]]]) + +(type: Method-Signature + {#method Type + #exceptions (List Type)}) + +(import: #long java/lang/reflect/Type + (getTypeName [] String)) + +(template [] + [(exception: #export ( {jvm-type java/lang/reflect/Type}) + (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] + + [jvm-type-is-not-a-class] + [cannot-convert-to-a-class] + [cannot-convert-to-a-parameter] + [cannot-convert-to-a-lux-type] + ) + +(template [] + [(exception: #export ( {type Type}) + (%type type))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(template [] + [(exception: #export ( {name Text}) + name)] + + [non-interface] + [non-throwable] + ) + +(template [] + [(exception: #export ( {message Text}) + message)] + + [unknown-class] + [primitives-cannot-have-type-parameters] + [primitives-are-not-objects] + [invalid-type-for-array-element] + + [unknown-field] + [mistaken-field-owner] + [not-a-virtual-field] + [not-a-static-field] + [cannot-set-a-final-field] + + [cannot-cast] + + [cannot-possibly-be-an-instance] + + [unknown-type-var] + [type-parameter-mismatch] + [cannot-correspond-type-with-a-class] + ) + +(template [] + [(exception: #export ( {class Text} + {method Text} + {hints (List Method-Signature)}) + (ex.report ["Class" class] + ["Method" method] + ["Hints" (|> hints + (list@map (|>> product.left %type (format text.new-line text.tab))) + (text.join-with ""))]))] + + [no-candidates] + [too-many-candidates] + ) + +(template [ ] + [(def: #export Type (#.Primitive (list)))] + + ## 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"] + [String "java.lang.String"] + + ## Primitives + [boolean "boolean"] + [byte "byte"] + [short "short"] + [int "int"] + [long "long"] + [float "float"] + [double "double"] + [char "char"] + ) + +(def: bundle::conversion + Bundle + (<| (///bundle.prefix "convert") + (|> ///bundle.empty + (///bundle.install "double-to-float" (//common.unary Double Float)) + (///bundle.install "double-to-int" (//common.unary Double Integer)) + (///bundle.install "double-to-long" (//common.unary Double Long)) + (///bundle.install "float-to-double" (//common.unary Float Double)) + (///bundle.install "float-to-int" (//common.unary Float Integer)) + (///bundle.install "float-to-long" (//common.unary Float Long)) + (///bundle.install "int-to-byte" (//common.unary Integer Byte)) + (///bundle.install "int-to-char" (//common.unary Integer Character)) + (///bundle.install "int-to-double" (//common.unary Integer Double)) + (///bundle.install "int-to-float" (//common.unary Integer Float)) + (///bundle.install "int-to-long" (//common.unary Integer Long)) + (///bundle.install "int-to-short" (//common.unary Integer Short)) + (///bundle.install "long-to-double" (//common.unary Long Double)) + (///bundle.install "long-to-float" (//common.unary Long Float)) + (///bundle.install "long-to-int" (//common.unary Long Integer)) + (///bundle.install "long-to-short" (//common.unary Long Short)) + (///bundle.install "long-to-byte" (//common.unary Long Byte)) + (///bundle.install "char-to-byte" (//common.unary Character Byte)) + (///bundle.install "char-to-short" (//common.unary Character Short)) + (///bundle.install "char-to-int" (//common.unary Character Integer)) + (///bundle.install "char-to-long" (//common.unary Character Long)) + (///bundle.install "byte-to-long" (//common.unary Byte Long)) + (///bundle.install "short-to-long" (//common.unary Short Long)) + ))) + +(template [ ] + [(def: + Bundle + (<| (///bundle.prefix ) + (|> ///bundle.empty + (///bundle.install "+" (//common.binary )) + (///bundle.install "-" (//common.binary )) + (///bundle.install "*" (//common.binary )) + (///bundle.install "/" (//common.binary )) + (///bundle.install "%" (//common.binary )) + (///bundle.install "=" (//common.binary Bit)) + (///bundle.install "<" (//common.binary Bit)) + (///bundle.install "and" (//common.binary )) + (///bundle.install "or" (//common.binary )) + (///bundle.install "xor" (//common.binary )) + (///bundle.install "shl" (//common.binary Integer )) + (///bundle.install "shr" (//common.binary Integer )) + (///bundle.install "ushr" (//common.binary Integer )) + )))] + + [bundle::int "int" Integer] + [bundle::long "long" Long] + ) + +(template [ ] + [(def: + Bundle + (<| (///bundle.prefix ) + (|> ///bundle.empty + (///bundle.install "+" (//common.binary )) + (///bundle.install "-" (//common.binary )) + (///bundle.install "*" (//common.binary )) + (///bundle.install "/" (//common.binary )) + (///bundle.install "%" (//common.binary )) + (///bundle.install "=" (//common.binary Bit)) + (///bundle.install "<" (//common.binary Bit)) + )))] + + [bundle::float "float" Float] + [bundle::double "double" Double] + ) + +(def: bundle::char + Bundle + (<| (///bundle.prefix "char") + (|> ///bundle.empty + (///bundle.install "=" (//common.binary Character Character Bit)) + (///bundle.install "<" (//common.binary Character Character Bit)) + ))) + +(def: #export 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: array::length + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC)) + (do ////.monad + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC))] + (wrap (#/////analysis.Extension extension-name (list arrayA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: array::new + Handler + (function (_ extension-name analyse args) + (case args + (^ (list lengthC)) + (do ////.monad + [lengthA (typeA.with-type Nat + (analyse lengthC)) + expectedT (///.lift macro.expected-type) + [level elem-class] (: (Operation [Nat Text]) + (loop [analysisT expectedT + level 0] + (case analysisT + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur outputT level) + + #.None + (/////analysis.throw non-array expectedT)) + + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (inc level)) + + (#.Primitive class _) + (wrap [level class]) + + _ + (/////analysis.throw non-array expectedT)))) + _ (if (n/> 0 level) + (wrap []) + (/////analysis.throw non-array expectedT))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.nat (dec level)) + (/////analysis.text elem-class) + lengthA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (check-jvm objectT) + (-> Type (Operation Text)) + (case objectT + (#.Primitive name _) + (////@wrap name) + + (#.Named name unnamed) + (check-jvm unnamed) + + (#.Var id) + (////@wrap "java.lang.Object") + + (^template [] + ( env unquantified) + (check-jvm unquantified)) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (check-jvm outputT) + + #.None + (/////analysis.throw non-object objectT)) + + _ + (/////analysis.throw non-object objectT))) + +(def: (check-object objectT) + (-> Type (Operation Text)) + (do ////.monad + [name (check-jvm objectT)] + (if (dictionary.contains? name boxes) + (/////analysis.throw primitives-are-not-objects name) + (////@wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Operation [Type Text])) + (case elemT + (#.Primitive name #.Nil) + (let [boxed-name (|> (dictionary.get name boxes) + (maybe.default name))] + (////@wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) + + (#.Primitive name _) + (if (dictionary.contains? name boxes) + (/////analysis.throw primitives-cannot-have-type-parameters name) + (////@wrap [elemT name])) + + _ + (/////analysis.throw invalid-type-for-array-element (%type elemT)))) + +(def: array::read + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC idxC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (check.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA arrayA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: array::write + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC idxC valueC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (check.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC)) + valueA (typeA.with-type valueT + (analyse valueC))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text elem-class) idxA valueA arrayA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: bundle::array + Bundle + (<| (///bundle.prefix "array") + (|> ///bundle.empty + (///bundle.install "length" array::length) + (///bundle.install "new" array::new) + (///bundle.install "read" array::read) + (///bundle.install "write" array::write) + ))) + +(def: object::null + Handler + (function (_ extension-name analyse args) + (case args + (^ (list)) + (do ////.monad + [expectedT (///.lift macro.expected-type) + _ (check-object expectedT)] + (wrap (#/////analysis.Extension extension-name (list)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) + +(def: object::null? + Handler + (function (_ extension-name analyse args) + (case args + (^ (list objectC)) + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (check-object objectT)] + (wrap (#/////analysis.Extension extension-name (list objectA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::synchronized + Handler + (function (_ extension-name analyse args) + (case args + (^ (list monitorC exprC)) + (do ////.monad + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#/////analysis.Extension extension-name (list monitorA exprA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(import: java/lang/Object + (equals [Object] boolean)) + +(import: java/lang/ClassLoader) + +(import: java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) + +(import: java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/TypeVariable d) + (getName [] String) + (getBounds [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) + +(import: java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(import: java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type)) + +(import: java/lang/reflect/Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(import: (java/lang/Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (Class c)))) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) + +(def: (load-class name) + (-> Text (Operation (Class Object))) + (do ////.monad + [] + (case (Class::forName name) + (#error.Success [class]) + (wrap class) + + (#error.Failure error) + (/////analysis.throw unknown-class name)))) + +(def: (sub-class? super sub) + (-> Text Text (Operation Bit)) + (do ////.monad + [super (load-class super) + sub (load-class sub)] + (wrap (Class::isAssignableFrom sub super)))) + +(def: object::throw + Handler + (function (_ extension-name analyse args) + (case args + (^ (list exceptionC)) + (do ////.monad + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse exceptionC)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Operation Any) + (if ? + (wrap []) + (/////analysis.throw non-throwable exception-class)))] + (wrap (#/////analysis.Extension extension-name (list exceptionA)))) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::class + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do ////.monad + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (load-class class)] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::instance? + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC objectC)) + (case classC + [_ (#.Text class)] + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class)))) + (/////analysis.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (java-type-to-class jvm-type) + (-> java/lang/reflect/Type (Operation Text)) + (<| (case (host.check Class jvm-type) + (#.Some jvm-type) + (////@wrap (Class::getName jvm-type)) + + _) + (case (host.check ParameterizedType jvm-type) + (#.Some jvm-type) + (java-type-to-class (ParameterizedType::getRawType jvm-type)) + + _) + ## else + (/////analysis.throw cannot-convert-to-a-class jvm-type))) + +(type: Mappings + (Dictionary Text Type)) + +(def: fresh-mappings Mappings (dictionary.new text.hash)) + +(def: (java-type-to-lux-type mappings java-type) + (-> Mappings java/lang/reflect/Type (Operation Type)) + (<| (case (host.check TypeVariable java-type) + (#.Some java-type) + (let [var-name (TypeVariable::getName java-type)] + (case (dictionary.get var-name mappings) + (#.Some var-type) + (////@wrap var-type) + + #.None + (/////analysis.throw unknown-type-var var-name))) + + _) + (case (host.check WildcardType java-type) + (#.Some java-type) + (case [(array.read 0 (WildcardType::getUpperBounds java-type)) + (array.read 0 (WildcardType::getLowerBounds java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (////@wrap Any)) + + _) + (case (host.check Class java-type) + (#.Some java-type) + (let [java-type (:coerce (Class Object) java-type) + class-name (Class::getName java-type)] + (////@wrap (case (array.size (Class::getTypeParameters java-type)) + 0 + (#.Primitive class-name (list)) + + arity + (|> (list.indices arity) + list.reverse + (list@map (|>> (n/* 2) inc #.Parameter)) + (#.Primitive class-name) + (type.univ-q arity))))) + + _) + (case (host.check ParameterizedType java-type) + (#.Some java-type) + (let [raw (ParameterizedType::getRawType java-type)] + (case (host.check Class raw) + (#.Some raw) + (do ////.monad + [paramsT (|> java-type + ParameterizedType::getActualTypeArguments + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (////@wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) + paramsT))) + + _ + (/////analysis.throw jvm-type-is-not-a-class raw))) + + _) + (case (host.check GenericArrayType java-type) + (#.Some java-type) + (do ////.monad + [innerT (|> java-type + GenericArrayType::getGenericComponentType + (java-type-to-lux-type mappings))] + (wrap (#.Primitive "#Array" (list innerT)))) + + _) + ## else + (/////analysis.throw cannot-convert-to-a-lux-type java-type))) + +(def: (correspond-type-params class type) + (-> (Class Object) Type (Operation Mappings)) + (case type + (#.Primitive name params) + (let [class-name (Class::getName class) + class-params (array.to-list (Class::getTypeParameters class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] + (cond (not (text@= class-name name)) + (/////analysis.throw cannot-correspond-type-with-a-class + (format "Class = " class-name text.new-line + "Type = " (%type type))) + + (not (n/= num-class-params num-type-params)) + (/////analysis.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) text.new-line + " Actual: " (%i (.int num-type-params)) text.new-line + " Class: " class-name text.new-line + " Type: " (%type type))) + + ## else + (////@wrap (|> params + (list.zip2 (list@map (|>> TypeVariable::getName) class-params)) + (dictionary.from-list text.hash))) + )) + + _ + (/////analysis.throw non-jvm-type type))) + +(def: object::cast + Handler + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [toT (///.lift macro.expected-type) + to-name (check-jvm toT) + [valueT valueA] (typeA.with-inference + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Operation Bit) + (case [from-name to-name] + (^template [ ] + (^or [ ] + [ ]) + (do @ + [_ (typeA.infer (#.Primitive to-name (list)))] + (wrap #1))) + (["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"]) + + _ + (do @ + [_ (////.assert primitives-are-not-objects from-name + (not (dictionary.contains? from-name boxes))) + _ (////.assert primitives-are-not-objects to-name + (not (dictionary.contains? to-name boxes))) + to-class (load-class to-name)] + (loop [[current-name currentT] [from-name valueT]] + (if (text@= to-name current-name) + (do @ + [_ (typeA.infer toT)] + (wrap #1)) + (do @ + [current-class (load-class current-name) + _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line) + (Class::isAssignableFrom current-class to-class)) + candiate-parents (monad.map @ + (function (_ java-type) + (do @ + [class-name (java-type-to-class java-type) + class (load-class class-name)] + (wrap [[class-name java-type] (Class::isAssignableFrom class to-class)]))) + (list& (Class::getGenericSuperclass current-class) + (array.to-list (Class::getGenericInterfaces current-class))))] + (case (|> candiate-parents + (list.filter product.right) + (list@map product.left)) + (#.Cons [next-name nextJT] _) + (do @ + [mapping (correspond-type-params current-class currentT) + nextT (java-type-to-lux-type mapping nextJT)] + (recur [next-name nextT])) + + #.Nil + (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line))) + ))))))] + (if can-cast? + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text from-name) + (/////analysis.text to-name) + valueA))) + (/////analysis.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line)))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])))) + +(def: bundle::object + Bundle + (<| (///bundle.prefix "object") + (|> ///bundle.empty + (///bundle.install "null" object::null) + (///bundle.install "null?" object::null?) + (///bundle.install "synchronized" object::synchronized) + (///bundle.install "throw" object::throw) + (///bundle.install "class" object::class) + (///bundle.install "instance?" object::instance?) + (///bundle.install "cast" object::cast) + ))) + +(def: (find-field class-name field-name) + (-> Text Text (Operation [(Class Object) Field])) + (do ////.monad + [class (load-class class-name)] + (case (Class::getDeclaredField field-name class) + (#error.Success field) + (let [owner (Field::getDeclaringClass field)] + (if (is? owner class) + (wrap [class field]) + (/////analysis.throw mistaken-field-owner + (format " Field: " field-name text.new-line + " Owner Class: " (Class::getName owner) text.new-line + "Target Class: " class-name text.new-line)))) + + (#error.Failure _) + (/////analysis.throw unknown-field (format class-name "#" field-name))))) + +(def: (static-field class-name field-name) + (-> Text Text (Operation [Type Bit])) + (do ////.monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers fieldJ)]] + (if (Modifier::isStatic modifiers) + (let [fieldJT (Field::getGenericType fieldJ)] + (do @ + [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal modifiers)]))) + (/////analysis.throw not-a-static-field (format class-name "#" field-name))))) + +(def: (virtual-field class-name field-name objectT) + (-> Text Text Type (Operation [Type Bit])) + (do ////.monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers fieldJ)]] + (if (not (Modifier::isStatic modifiers)) + (do @ + [#let [fieldJT (Field::getGenericType fieldJ) + var-names (|> class + Class::getTypeParameters + array.to-list + (list@map (|>> TypeVariable::getName)))] + mappings (: (Operation Mappings) + (case objectT + (#.Primitive _class-name _class-params) + (do @ + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (////.assert type-parameter-mismatch + (format "Expected: " (%i (.int num-params)) text.new-line + " Actual: " (%i (.int num-vars)) text.new-line + " Class: " _class-name text.new-line + " Type: " (%type objectT)) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dictionary.from-list text.hash)))) + + _ + (/////analysis.throw non-object objectT))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal modifiers)])) + (/////analysis.throw not-a-virtual-field (format class-name "#" field-name))))) + +(def: static::get + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[fieldT final?] (static-field class field)] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: static::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [_ (typeA.infer Any) + [fieldT final?] (static-field class field) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA)))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: virtual::get + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) objectA)))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: virtual::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [fieldT final?] (virtual-field class field objectT) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#/////analysis.Extension extension-name (list (/////analysis.text class) (/////analysis.text field) valueA objectA)))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])) + + _ + (/////analysis.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) + +(def: (java-type-to-parameter type) + (-> java/lang/reflect/Type (Operation Text)) + (<| (case (host.check Class type) + (#.Some type) + (////@wrap (Class::getName type)) + + _) + (case (host.check ParameterizedType type) + (#.Some type) + (java-type-to-parameter (ParameterizedType::getRawType type)) + + _) + (case (host.check TypeVariable type) + (#.Some type) + (////@wrap "java.lang.Object") + + _) + (case (host.check WildcardType type) + (#.Some type) + (////@wrap "java.lang.Object") + + _) + (case (host.check GenericArrayType type) + (#.Some type) + (do ////.monad + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType type))] + (wrap (format componentP "[]"))) + + _) + + ## else + (/////analysis.throw cannot-convert-to-a-parameter type))) + +(type: Method-Style + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-style arg-classes method) + (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) + (do ////.monad + [parameters (|> (Method::getGenericParameterTypes method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers method)]] + (wrap (and (Object::equals class (Method::getDeclaringClass method)) + (text@= method-name (Method::getName method)) + (case #Static + #Special + (Modifier::isStatic modifiers) + + _ + #1) + (case method-style + #Special + (not (or (Modifier::isInterface (Class::getModifiers class)) + (Modifier::isAbstract modifiers))) + + _ + #1) + (n/= (list.size arg-classes) (list.size parameters)) + (list@fold (function (_ [expectedJC actualJC] prev) + (and prev + (text@= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters)))))) + +(def: (check-constructor class arg-classes constructor) + (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) + (do ////.monad + [parameters (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) + (n/= (list.size arg-classes) (list.size parameters)) + (list@fold (function (_ [expectedJC actualJC] prev) + (and prev + (text@= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters)))))) + +(def: idx-to-parameter + (-> Nat Type) + (|>> (n/* 2) inc #.Parameter)) + +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n/= 0 amount) + (list) + (|> (list.indices amount) + (list@map (|>> (n/+ offset) idx-to-parameter))))) + +(def: (method-signature method-style method) + (-> Method-Style Method (Operation Method-Signature)) + (let [owner (Method::getDeclaringClass method) + owner-name (Class::getName owner) + owner-tvars (case method-style + #Static + (list) + + _ + (|> (Class::getTypeParameters owner) + array.to-list + (list@map (|>> TypeVariable::getName)))) + method-tvars (|> (Method::getTypeParameters method) + array.to-list + (list@map (|>> TypeVariable::getName))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) + all-tvars (list@compose owner-tvars method-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars 0) + method-tvarsT (type-vars num-method-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list@compose owner-tvarsT method-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dictionary.from-list text.hash))))] + (do ////.monad + [inputsT (|> (Method::getGenericParameterTypes method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method)) + exceptionsT (|> (Method::getGenericExceptionTypes method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-style + #Static + inputsT + + _ + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(type: Evaluation + (#Pass Method-Signature) + (#Hint Method-Signature) + #Fail) + +(template [ ] + [(def: + (-> Evaluation (Maybe Method-Signature)) + (|>> (case> ( output) + (#.Some output) + + _ + #.None)))] + + [pass! #Pass] + [hint! #Hint] + ) + +(def: (method-candidate class-name method-name method-style arg-classes) + (-> Text Text Method-Style (List Text) (Operation Method-Signature)) + (do ////.monad + [class (load-class class-name) + candidates (|> class + Class::getDeclaredMethods + array.to-list + (monad.map @ (: (-> Method (Operation Evaluation)) + (function (_ method) + (do @ + [passes? (check-method class method-name method-style arg-classes method)] + (cond passes? + (:: @ map (|>> #Pass) (method-signature method-style method)) + + (text@= method-name (Method::getName method)) + (:: @ map (|>> #Hint) (method-signature method-style method)) + + ## else + (wrap #Fail)))))))] + (case (list.search-all pass! candidates) + (#.Cons method #.Nil) + (wrap method) + + #.Nil + (/////analysis.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) + + candidates + (/////analysis.throw too-many-candidates [class-name method-name candidates])))) + +(def: (constructor-signature constructor) + (-> (Constructor Object) (Operation Method-Signature)) + (let [owner (Constructor::getDeclaringClass constructor) + owner-name (Class::getName owner) + owner-tvars (|> (Class::getTypeParameters owner) + array.to-list + (list@map (|>> TypeVariable::getName))) + constructor-tvars (|> (Constructor::getTypeParameters constructor) + array.to-list + (list@map (|>> TypeVariable::getName))) + num-owner-tvars (list.size owner-tvars) + all-tvars (list@compose owner-tvars constructor-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars 0) + constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list@compose owner-tvarsT constructor-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dictionary.from-list text.hash))))] + (do ////.monad + [inputsT (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + +(def: constructor-method "") + +(def: (constructor-candidate class-name arg-classes) + (-> Text (List Text) (Operation Method-Signature)) + (do ////.monad + [class (load-class class-name) + candidates (|> class + Class::getConstructors + array.to-list + (monad.map @ (function (_ constructor) + (do @ + [passes? (check-constructor class arg-classes constructor)] + (:: @ map + (if passes? (|>> #Pass) (|>> #Hint)) + (constructor-signature constructor))))))] + (case (list.search-all pass! candidates) + (#.Cons constructor #.Nil) + (wrap constructor) + + #.Nil + (/////analysis.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) + + candidates + (/////analysis.throw too-many-candidates [class-name ..constructor-method candidates])))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list@map /////analysis.text typesT)) + (list@map (function (_ [type value]) + (/////analysis.tuple (list type value)))))) + +(def: invoke::static + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text (List [Text Code])]) + (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class method argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) + (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])))) + +(def: invoke::virtual + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class method objectC argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Virtual argsT) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) + (/////analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])))) + +(def: invoke::special + Handler + (function (_ extension-name analyse args) + (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) + (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) + (#error.Success [_ [class method objectC argsTC _]]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (/////analysis.text method) + (/////analysis.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])))) + +(def: invoke::interface + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class-name method objectC argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + class (load-class class-name) + _ (////.assert non-interface class-name + (Modifier::isInterface (Class::getModifiers class))) + [methodT exceptionsT] (method-candidate class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list@map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#/////analysis.Extension extension-name + (list& (/////analysis.text class-name) (/////analysis.text method) (/////analysis.text outputJC) + (decorate-inputs argsT argsA))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])))) + +(def: invoke::constructor + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text (List [Text Code])]) + (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class argsTC]) + (do ////.monad + [#let [argsT (list@map product.left argsTC)] + [methodT exceptionsT] (constructor-candidate class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list@map product.right argsTC))] + (wrap (#/////analysis.Extension extension-name (list& (/////analysis.text class) (decorate-inputs argsT argsA))))) + + _ + (/////analysis.throw ///.invalid-syntax [extension-name args])))) + +(def: bundle::member + Bundle + (<| (///bundle.prefix "member") + (|> ///bundle.empty + (dictionary.merge (<| (///bundle.prefix "static") + (|> ///bundle.empty + (///bundle.install "get" static::get) + (///bundle.install "put" static::put)))) + (dictionary.merge (<| (///bundle.prefix "virtual") + (|> ///bundle.empty + (///bundle.install "get" virtual::get) + (///bundle.install "put" virtual::put)))) + (dictionary.merge (<| (///bundle.prefix "invoke") + (|> ///bundle.empty + (///bundle.install "static" invoke::static) + (///bundle.install "virtual" invoke::virtual) + (///bundle.install "special" invoke::special) + (///bundle.install "interface" invoke::interface) + (///bundle.install "constructor" invoke::constructor) + ))) + ))) + +(def: #export bundle + Bundle + (<| (///bundle.prefix "jvm") + (|> ///bundle.empty + (dictionary.merge bundle::conversion) + (dictionary.merge bundle::int) + (dictionary.merge bundle::long) + (dictionary.merge bundle::float) + (dictionary.merge bundle::double) + (dictionary.merge bundle::char) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::member) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux deleted file mode 100644 index d68abbdd7..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux +++ /dev/null @@ -1,175 +0,0 @@ -(.module: - [lux (#- case let if) - [abstract - [monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] - [data - ["." number] - ["." text - format] - [collection - ["." list ("#;." functor fold)]]] - [host - ["_" scheme (#+ Expression Computation Var)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase)] - ["#." primitive] - ["#/" // #_ - ["#." reference] - ["#/" // ("#;." monad) - ["#/" // #_ - [reference (#+ Register)] - ["#." synthesis (#+ Synthesis Path)]]]]]) - -(def: #export register - (///reference.local _.var)) - -(def: #export (let generate [valueS register bodyS]) - (-> Phase [Synthesis Register Synthesis] - (Operation Computation)) - (do ////.monad - [valueO (generate valueS) - bodyO (generate bodyS)] - (wrap (_.let (list [(..register register) valueO]) - bodyO)))) - -(def: #export (record-get generate valueS pathP) - (-> Phase Synthesis (List [Nat Bit]) - (Operation Expression)) - (do ////.monad - [valueO (generate valueS)] - (wrap (list;fold (function (_ [idx tail?] source) - (.let [method (.if tail? - //runtime.product//right - //runtime.product//left)] - (method source (_.int (.int idx))))) - valueO - pathP)))) - -(def: #export (if generate [testS thenS elseS]) - (-> Phase [Synthesis Synthesis Synthesis] - (Operation Computation)) - (do ////.monad - [testO (generate testS) - thenO (generate thenS) - elseO (generate elseS)] - (wrap (_.if testO thenO elseO)))) - -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) -(def: @alt-error (_.var "alt_error")) - -(def: (push! value var) - (-> Expression Var Computation) - (_.set! var (_.cons/2 value var))) - -(def: (push-cursor! value) - (-> Expression Computation) - (push! value @cursor)) - -(def: (pop! var) - (-> Var Computation) - (_.set! var var)) - -(def: save-cursor! - Computation - (push! @cursor @savepoint)) - -(def: restore-cursor! - Computation - (_.set! @cursor (_.car/1 @savepoint))) - -(def: cursor-top - Computation - (_.car/1 @cursor)) - -(def: pop-cursor! - Computation - (pop! @cursor)) - -(def: pm-error (_.string "PM-ERROR")) - -(def: fail-pm! (_.raise/1 pm-error)) - -(exception: #export unrecognized-path) - -(def: (pm-catch handler) - (-> Expression Computation) - (_.lambda [(list @alt-error) #.None] - (_.if (|> @alt-error (_.eqv?/2 pm-error)) - handler - (_.raise/1 @alt-error)))) - -(def: (pattern-matching' generate pathP) - (-> Phase Path (Operation Expression)) - (.case pathP - (^ (/////synthesis.path/then bodyS)) - (generate bodyS) - - #/////synthesis.Pop - (////;wrap pop-cursor!) - - (#/////synthesis.Bind register) - (////;wrap (_.define (..register register) [(list) #.None] - cursor-top)) - - (^template [ <=>] - (^ ( value)) - (////;wrap (_.when (|> value (<=> cursor-top) _.not/1) - fail-pm!))) - ([/////synthesis.path/bit //primitive.bit _.eqv?/2] - [/////synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] - [/////synthesis.path/f64 //primitive.f64 _.=/2] - [/////synthesis.path/text //primitive.text _.eqv?/2]) - - (^template [ ] - (^ ( idx)) - (////;wrap (_.let (list [@temp (|> idx .int _.int (//runtime.sum//get cursor-top ))]) - (_.if (_.null?/1 @temp) - fail-pm! - (push-cursor! @temp))))) - ([/////synthesis.side/left _.nil (<|)] - [/////synthesis.side/right (_.string "") inc]) - - (^template [ ] - (^ ( idx)) - (////;wrap (|> idx .int _.int ( cursor-top) push-cursor!))) - ([/////synthesis.member/left //runtime.product//left (<|)] - [/////synthesis.member/right //runtime.product//right inc]) - - (^template [ ] - (^ ( leftP rightP)) - (do ////.monad - [leftO (pattern-matching' generate leftP) - rightO (pattern-matching' generate rightP)] - (wrap ))) - ([/////synthesis.path/seq (_.begin (list leftO - rightO))] - [/////synthesis.path/alt (_.with-exception-handler - (pm-catch (_.begin (list restore-cursor! - rightO))) - (_.lambda [(list) #.None] - (_.begin (list save-cursor! - leftO))))]) - - _ - (////.throw unrecognized-path []))) - -(def: (pattern-matching generate pathP) - (-> Phase Path (Operation Computation)) - (do ////.monad - [pattern-matching! (pattern-matching' generate pathP)] - (wrap (_.with-exception-handler - (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (_.lambda [(list) #.None] - pattern-matching!))))) - -(def: #export (case generate [valueS pathP]) - (-> Phase [Synthesis Path] (Operation Computation)) - (do ////.monad - [valueO (generate valueS)] - (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] - [@savepoint (_.list/* (list))]))) - (pattern-matching generate pathP)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux new file mode 100644 index 000000000..d68abbdd7 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.lux @@ -0,0 +1,175 @@ +(.module: + [lux (#- case let if) + [abstract + [monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + ["." list ("#;." functor fold)]]] + [host + ["_" scheme (#+ Expression Computation Var)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." primitive] + ["#/" // #_ + ["#." reference] + ["#/" // ("#;." monad) + ["#/" // #_ + [reference (#+ Register)] + ["#." synthesis (#+ Synthesis Path)]]]]]) + +(def: #export register + (///reference.local _.var)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation Computation)) + (do ////.monad + [valueO (generate valueS) + bodyO (generate bodyS)] + (wrap (_.let (list [(..register register) valueO]) + bodyO)))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation Expression)) + (do ////.monad + [valueO (generate valueS)] + (wrap (list;fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.int (.int idx))))) + valueO + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do ////.monad + [testO (generate testS) + thenO (generate thenS) + elseO (generate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @alt-error (_.var "alt_error")) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(exception: #export unrecognized-path) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list @alt-error) #.None] + (_.if (|> @alt-error (_.eqv?/2 pm-error)) + handler + (_.raise/1 @alt-error)))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation Expression)) + (.case pathP + (^ (/////synthesis.path/then bodyS)) + (generate bodyS) + + #/////synthesis.Pop + (////;wrap pop-cursor!) + + (#/////synthesis.Bind register) + (////;wrap (_.define (..register register) [(list) #.None] + cursor-top)) + + (^template [ <=>] + (^ ( value)) + (////;wrap (_.when (|> value (<=> cursor-top) _.not/1) + fail-pm!))) + ([/////synthesis.path/bit //primitive.bit _.eqv?/2] + [/////synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] + [/////synthesis.path/f64 //primitive.f64 _.=/2] + [/////synthesis.path/text //primitive.text _.eqv?/2]) + + (^template [ ] + (^ ( idx)) + (////;wrap (_.let (list [@temp (|> idx .int _.int (//runtime.sum//get cursor-top ))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([/////synthesis.side/left _.nil (<|)] + [/////synthesis.side/right (_.string "") inc]) + + (^template [ ] + (^ ( idx)) + (////;wrap (|> idx .int _.int ( cursor-top) push-cursor!))) + ([/////synthesis.member/left //runtime.product//left (<|)] + [/////synthesis.member/right //runtime.product//right inc]) + + (^template [ ] + (^ ( leftP rightP)) + (do ////.monad + [leftO (pattern-matching' generate leftP) + rightO (pattern-matching' generate rightP)] + (wrap ))) + ([/////synthesis.path/seq (_.begin (list leftO + rightO))] + [/////synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation Computation)) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation Computation)) + (do ////.monad + [valueO (generate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching generate pathP)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux deleted file mode 100644 index 3bc0a0887..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux +++ /dev/null @@ -1,13 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common]]) - -(def: #export bundle - Bundle - common.bundle) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.lux new file mode 100644 index 000000000..3bc0a0887 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.lux @@ -0,0 +1,13 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common]]) + +(def: #export bundle + Bundle + common.bundle) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux deleted file mode 100644 index cb96a5718..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux +++ /dev/null @@ -1,245 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [control - ["ex" exception (#+ exception:)]] - [data - ["e" error] - ["." product] - ["." text - format] - [number (#+ hex)] - [collection - ["." list ("#;." functor)] - ["dict" dictionary (#+ Dictionary)]]] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax:)]] - [host (#+ import:) - ["_" scheme (#+ Expression Computation)]]] - ["." /// #_ - ["#." runtime (#+ Operation Phase Handler Bundle)] - ["#//" /// - ["#." extension - ["." bundle]] - ["#/" // #_ - ["#." synthesis (#+ Synthesis)]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Expression) Computation)) -(type: #export Unary (-> (Vector 1 Expression) Computation)) -(type: #export Binary (-> (Vector 2 Expression) Computation)) -(type: #export Trinary (-> (Vector 3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!phase g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - Handler) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do /////.monad - [(~+ (|> g!input+ - (list;map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name) - (function (_ phase inputsS) - (do /////.monad - [inputsI (monad.map @ phase inputsS)] - (wrap (extension inputsI)))))) - -(def: bundle::lux - Bundle - (|> bundle.empty - (bundle.install "is?" (binary (product.uncurry _.eq?/2))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [bit::and _.bit-and/2] - [bit::or _.bit-or/2] - [bit::xor _.bit-xor/2] - ) - -(def: (bit::left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) - subjectO)) - -(def: (bit::arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) - subjectO)) - -(def: (bit::logical-right-shift [subjectO paramO]) - Binary - (///runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) - -(def: bundle::bit - Bundle - (<| (bundle.prefix "bit") - (|> bundle.empty - (bundle.install "and" (binary bit::and)) - (bundle.install "or" (binary bit::or)) - (bundle.install "xor" (binary bit::xor)) - (bundle.install "left-shift" (binary bit::left-shift)) - (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) - ))) - -(import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(template [ ] - [(def: ( _) - Nullary - ( ))] - - [frac::smallest (Double::MIN_VALUE) _.float] - [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] - [frac::max (Double::MAX_VALUE) _.float] - ) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - (|> subjectO ( paramO)))] - - [int::+ _.+/2] - [int::- _.-/2] - [int::* _.*/2] - [int::/ _.quotient/2] - [int::% _.remainder/2] - ) - -(template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [frac::+ _.+/2] - [frac::- _.-/2] - [frac::* _.*/2] - [frac::/ _.//2] - [frac::% _.mod/2] - [frac::= _.=/2] - [frac::< _. ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [int::= _.=/2] - [int::< _.> _.integer->char/1 _.string/1)) - -(def: bundle::int - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "+" (binary int::+)) - (bundle.install "-" (binary int::-)) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "=" (binary int::=)) - (bundle.install "<" (binary int::<)) - (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) - (bundle.install "char" (unary int::char))))) - -(def: bundle::frac - Bundle - (<| (bundle.prefix "frac") - (|> bundle.empty - (bundle.install "+" (binary frac::+)) - (bundle.install "-" (binary frac::-)) - (bundle.install "*" (binary frac::*)) - (bundle.install "/" (binary frac::/)) - (bundle.install "%" (binary frac::%)) - (bundle.install "=" (binary frac::=)) - (bundle.install "<" (binary frac::<)) - (bundle.install "smallest" (nullary frac::smallest)) - (bundle.install "min" (nullary frac::min)) - (bundle.install "max" (nullary frac::max)) - (bundle.install "to-int" (unary _.exact/1)) - (bundle.install "encode" (unary _.number->string/1)) - (bundle.install "decode" (unary ///runtime.frac//decode))))) - -(def: (text::char [subjectO paramO]) - Binary - (_.string/1 (_.string-ref/2 subjectO paramO))) - -(def: (text::clip [subjectO startO endO]) - Trinary - (_.substring/3 subjectO startO endO)) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary (product.uncurry _.string-append/2))) - (bundle.install "size" (unary _.string-length/1)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: (io::log input) - Unary - (_.begin (list (_.display/1 input) - _.newline/0))) - -(def: (void code) - (-> Expression Computation) - (_.begin (list code (_.string //////synthesis.unit)))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> io::log ..void))) - (bundle.install "error" (unary _.raise/1)) - (bundle.install "exit" (unary _.exit/1)) - (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit)))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dict.merge bundle::bit) - (dict.merge bundle::int) - (dict.merge bundle::frac) - (dict.merge bundle::text) - (dict.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux new file mode 100644 index 000000000..cb96a5718 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.lux @@ -0,0 +1,245 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [control + ["ex" exception (#+ exception:)]] + [data + ["e" error] + ["." product] + ["." text + format] + [number (#+ hex)] + [collection + ["." list ("#;." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:) + ["_" scheme (#+ Expression Computation)]]] + ["." /// #_ + ["#." runtime (#+ Operation Phase Handler Bundle)] + ["#//" /// + ["#." extension + ["." bundle]] + ["#/" // #_ + ["#." synthesis (#+ Synthesis)]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list;map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw /////extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do /////.monad + [inputsI (monad.map @ phase inputsS)] + (wrap (extension inputsI)))))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is?" (binary (product.uncurry _.eq?/2))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [bit::and _.bit-and/2] + [bit::or _.bit-or/2] + [bit::xor _.bit-xor/2] + ) + +(def: (bit::left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) + subjectO)) + +(def: (bit::arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit::logical-right-shift [subjectO paramO]) + Binary + (///runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) + +(def: bundle::bit + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (bundle.install "and" (binary bit::and)) + (bundle.install "or" (binary bit::or)) + (bundle.install "xor" (binary bit::xor)) + (bundle.install "left-shift" (binary bit::left-shift)) + (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) + ))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(template [ ] + [(def: ( _) + Nullary + ( ))] + + [frac::smallest (Double::MIN_VALUE) _.float] + [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] + [frac::max (Double::MAX_VALUE) _.float] + ) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + (|> subjectO ( paramO)))] + + [int::+ _.+/2] + [int::- _.-/2] + [int::* _.*/2] + [int::/ _.quotient/2] + [int::% _.remainder/2] + ) + +(template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [frac::+ _.+/2] + [frac::- _.-/2] + [frac::* _.*/2] + [frac::/ _.//2] + [frac::% _.mod/2] + [frac::= _.=/2] + [frac::< _. ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [int::= _.=/2] + [int::< _.> _.integer->char/1 _.string/1)) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "+" (binary int::+)) + (bundle.install "-" (binary int::-)) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "=" (binary int::=)) + (bundle.install "<" (binary int::<)) + (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary int::char))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary frac::+)) + (bundle.install "-" (binary frac::-)) + (bundle.install "*" (binary frac::*)) + (bundle.install "/" (binary frac::/)) + (bundle.install "%" (binary frac::%)) + (bundle.install "=" (binary frac::=)) + (bundle.install "<" (binary frac::<)) + (bundle.install "smallest" (nullary frac::smallest)) + (bundle.install "min" (nullary frac::min)) + (bundle.install "max" (nullary frac::max)) + (bundle.install "to-int" (unary _.exact/1)) + (bundle.install "encode" (unary _.number->string/1)) + (bundle.install "decode" (unary ///runtime.frac//decode))))) + +(def: (text::char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text::clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary (product.uncurry _.string-append/2))) + (bundle.install "size" (unary _.string-length/1)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: (io::log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string //////synthesis.unit)))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> io::log ..void))) + (bundle.install "error" (unary _.raise/1)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (function (_ _) (///runtime.io//current-time (_.string //////synthesis.unit)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dict.merge bundle::bit) + (dict.merge bundle::int) + (dict.merge bundle::frac) + (dict.merge bundle::text) + (dict.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux deleted file mode 100644 index 28bfd36ba..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux +++ /dev/null @@ -1,97 +0,0 @@ -(.module: - [lux (#- function) - [abstract - ["." monad (#+ do)]] - [control - pipe] - [data - ["." product] - [text - format] - [collection - ["." list ("#;." functor)]]] - [host - ["_" scheme (#+ Expression Computation Var)]]] - ["." // #_ - ["#." runtime (#+ Operation Phase)] - ["#." reference] - ["#." case] - ["#/" // - ["#." reference] - ["#/" // ("#;." monad) - ["#/" // #_ - [reference (#+ Register Variable)] - [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] - [synthesis (#+ Synthesis)]]]]]) - -(def: #export (apply generate [functionS argsS+]) - (-> Phase (Application Synthesis) (Operation Computation)) - (do ////.monad - [functionO (generate functionS) - argsO+ (monad.map @ generate argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: #export capture - (///reference.foreign _.var)) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Computation (Operation Computation)) - (////;wrap - (case inits - #.Nil - function-definition - - _ - (let [@closure (_.var (format function-name "___CLOSURE"))] - (_.letrec (list [@closure - (_.lambda [(|> (list.enumerate inits) - (list;map (|>> product.left ..capture))) - #.None] - function-definition)]) - (_.apply/* @closure inits)))))) - -(def: @curried (_.var "curried")) -(def: @missing (_.var "missing")) - -(def: input - (|>> inc //case.register)) - -(def: #export (function generate [environment arity bodyS]) - (-> Phase (Abstraction Synthesis) (Operation Computation)) - (do ////.monad - [[function-name bodyO] (///.with-context - (do @ - [function-name ///.context] - (///.with-anchor (_.var function-name) - (generate bodyS)))) - closureO+ (: (Operation (List Expression)) - (monad.map @ (:: //reference.system variable) environment)) - #let [arityO (|> arity .int _.int) - apply-poly (.function (_ args func) - (_.apply/2 (_.global "apply") func args)) - @num-args (_.var "num_args") - @function (_.var function-name)]] - (with-closure function-name closureO+ - (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] - (_.let (list [@num-args (_.length/1 @curried)]) - (<| (_.if (|> @num-args (_.=/2 arityO)) - (<| (_.let (list [(//case.register 0) @function])) - (_.let-values (list [[(|> (list.indices arity) - (list;map ..input)) - #.None] - (_.apply/2 (_.global "apply") (_.global "values") @curried)])) - bodyO)) - (_.if (|> @num-args (_.>/2 arityO)) - (let [arity-args (//runtime.slice (_.int +0) arityO @curried) - output-func-args (//runtime.slice arityO - (|> @num-args (_.-/2 arityO)) - @curried)] - (|> @function - (apply-poly arity-args) - (apply-poly output-func-args)))) - ## (|> @num-args (_. @function - (apply-poly (_.append/2 @curried @missing))))) - ))]) - @function)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux new file mode 100644 index 000000000..28bfd36ba --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.lux @@ -0,0 +1,97 @@ +(.module: + [lux (#- function) + [abstract + ["." monad (#+ do)]] + [control + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#;." functor)]]] + [host + ["_" scheme (#+ Expression Computation Var)]]] + ["." // #_ + ["#." runtime (#+ Operation Phase)] + ["#." reference] + ["#." case] + ["#/" // + ["#." reference] + ["#/" // ("#;." monad) + ["#/" // #_ + [reference (#+ Register Variable)] + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)]]]]]) + +(def: #export (apply generate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.monad + [functionO (generate functionS) + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: #export capture + (///reference.foreign _.var)) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (////;wrap + (case inits + #.Nil + function-definition + + _ + (let [@closure (_.var (format function-name "___CLOSURE"))] + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list;map (|>> product.left ..capture))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc //case.register)) + +(def: #export (function generate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (generate bodyS)))) + closureO+ (: (Operation (List Expression)) + (monad.map @ (:: //reference.system variable) environment)) + #let [arityO (|> arity .int _.int) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args)) + @num-args (_.var "num_args") + @function (_.var function-name)]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(//case.register 0) @function])) + (_.let-values (list [[(|> (list.indices arity) + (list;map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (//runtime.slice (_.int +0) arityO @curried) + output-func-args (//runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_. @function + (apply-poly (_.append/2 @curried @missing))))) + ))]) + @function)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux deleted file mode 100644 index 6922806e2..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux (#- Scope) - [abstract - ["." monad (#+ do)]] - [data - ["." product] - ["." text - format] - [collection - ["." list ("#;." functor)]]] - [host - ["_" scheme (#+ Computation Var)]]] - ["." // #_ - [runtime (#+ Operation Phase)] - ["#." case] - ["#/" // - ["#/" // - [// - [synthesis (#+ Scope Synthesis)]]]]]) - -(def: @scope (_.var "scope")) - -(def: #export (scope generate [start initsS+ bodyS]) - (-> Phase (Scope Synthesis) (Operation Computation)) - (do ////.monad - [initsO+ (monad.map @ generate initsS+) - bodyO (///.with-anchor @scope - (generate bodyS))] - (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ - list.enumerate - (list;map (|>> product.left (n/+ start) //case.register))) - #.None] - bodyO)]) - (_.apply/* @scope initsO+))))) - -(def: #export (recur generate argsS+) - (-> Phase (List Synthesis) (Operation Computation)) - (do ////.monad - [@scope ///.anchor - argsO+ (monad.map @ generate argsS+)] - (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.lux new file mode 100644 index 000000000..6922806e2 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.lux @@ -0,0 +1,41 @@ +(.module: + [lux (#- Scope) + [abstract + ["." monad (#+ do)]] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#;." functor)]]] + [host + ["_" scheme (#+ Computation Var)]]] + ["." // #_ + [runtime (#+ Operation Phase)] + ["#." case] + ["#/" // + ["#/" // + [// + [synthesis (#+ Scope Synthesis)]]]]]) + +(def: @scope (_.var "scope")) + +(def: #export (scope generate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation Computation)) + (do ////.monad + [initsO+ (monad.map @ generate initsS+) + bodyO (///.with-anchor @scope + (generate bodyS))] + (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumerate + (list;map (|>> product.left (n/+ start) //case.register))) + #.None] + bodyO)]) + (_.apply/* @scope initsO+))))) + +(def: #export (recur generate argsS+) + (-> Phase (List Synthesis) (Operation Computation)) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux deleted file mode 100644 index 5405e4c55..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [host - ["_" scheme (#+ Expression)]]]) - -(template [ ] - [(def: #export - (-> Expression) - )] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int _.int)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.lux new file mode 100644 index 000000000..5405e4c55 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.lux @@ -0,0 +1,15 @@ +(.module: + [lux (#- i64) + [host + ["_" scheme (#+ Expression)]]]) + +(template [ ] + [(def: #export + (-> Expression) + )] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int _.int)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux deleted file mode 100644 index b531c38f7..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #* - [host - ["_" scheme (#+ Expression)]]] - [/// - ["." reference]]) - -(def: #export system - (reference.system (: (-> Text Expression) _.global) - (: (-> Text Expression) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.lux new file mode 100644 index 000000000..b531c38f7 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.lux @@ -0,0 +1,10 @@ +(.module: + [lux #* + [host + ["_" scheme (#+ Expression)]]] + [/// + ["." reference]]) + +(def: #export system + (reference.system (: (-> Text Expression) _.global) + (: (-> Text Expression) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux deleted file mode 100644 index b66b7abaf..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,322 +0,0 @@ -(.module: - [lux #* - [abstract - [monad (#+ do)]] - [control - ["." function] - ["p" parser ("#;." monad)]] - [data - [number (#+ hex)] - [text - format] - [collection - ["." list ("#;." monad)]]] - [macro - ["." code] - ["s" syntax (#+ syntax:)]] - [host - ["_" scheme (#+ Expression Computation Var)]]] - ["." /// - ["#/" // - ["#/" // #_ - [analysis (#+ Variant)] - ["#." name] - ["#." synthesis]]]]) - -(template [ ] - [(type: #export - ( Var Expression Expression))] - - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] - ) - -(def: prefix Text "LuxRuntime") - -(def: unit (_.string /////synthesis.unit)) - -(def: #export variant-tag "lux-variant") - -(def: (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Computation) - (<| (_.cons/2 (_.symbol ..variant-tag)) - (_.cons/2 tag) - (_.cons/2 last?) - value)) - -(def: #export (variant [lefts right? value]) - (-> (Variant Expression) Computation) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - Computation - (variant [0 #0 ..unit])) - -(def: #export some - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.and s.local-identifier (p;wrap (list))) - (s.form (p.and s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format prefix "__" (/////name.normalize name)) - @runtime (` (_.var (~ (code.text runtime)))) - argsC+ (list;map code.local-identifier args) - argsLC+ (list;map (|>> /////name.normalize (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Computation))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Computation - (~ (case argsC+ - #.Nil - (` (_.define (~ @runtime) [(list) #.None] (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list;map (function (_ [left right]) - (list left right))) - list;join))] - (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] - (~ definition)))))))))))) - -(runtime: (slice offset length list) - (<| (_.if (_.null?/1 list) - list) - (_.if (|> offset (_.>/2 (_.int +0))) - (slice (|> offset (_.-/2 (_.int +1))) - length - (_.cdr/1 list))) - (_.if (|> length (_.>/2 (_.int +0))) - (_.cons/2 (_.car/1 list) - (slice offset - (|> length (_.-/2 (_.int +1))) - (_.cdr/1 list)))) - _.nil)) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list;map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (format "LRV__" (/////name.normalize var))))))))) - list;join))] - (~ body)))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler - (_.lambda [(list error) #.None] - (..left error)) - (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) - -(runtime: (lux//program-args program-args) - (with-vars [@loop @input @output] - (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) - -(def: runtime//lux - Computation - (_.begin (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Computation) - (|>> (_.+/2 (_.int +1)))) - -(def: product-element - (-> Expression Expression Computation) - (function.flip _.vector-ref/2)) - -(def: (product-tail product) - (-> Expression Computation) - (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Computation) - (|> min-length (_.-/2 (_.length/1 product)))) - -(runtime: (product//left product index) - (let [@index_min_length (_.var "index_min_length")] - (_.begin - (list (_.define @index_min_length [(list) #.None] - (minimum-index-length index)) - (_.if (|> product _.length/1 (_.>/2 @index_min_length)) - ## No need for recursion - (product-element index product) - ## Needs recursion - (product//left (product-tail product) - (updated-index @index_min_length product))))))) - -(runtime: (product//right product index) - (let [@index_min_length (_.var "index_min_length") - @product_length (_.var "product_length") - @slice (_.var "slice") - last-element? (|> @product_length (_.=/2 @index_min_length)) - needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) - (_.vector-copy!/5 @slice (_.int +0) product index @product_length) - @slice))))))) - -(runtime: (sum//get sum last? wanted-tag) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get sum-value - (|> wanted-tag (_.-/2 sum-tag)) - last?) - no-match)] - (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] - (_.apply/* (_.global "apply") (list (_.global "values") sum))])) - (_.if (|> wanted-tag (_.=/2 sum-tag)) - (_.if (|> sum-flag (_.eqv?/2 last?)) - sum-value - test-recursion)) - (_.if (|> wanted-tag (_.>/2 sum-tag)) - test-recursion) - (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) - (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) - no-match)))) - -(def: runtime//adt - Computation - (_.begin (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.=/2 (_.int +0) shift) - input - (|> input - (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) - (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Computation - (_.begin (list @@bit//logical-right-shift))) - -(runtime: (frac//decode input) - (with-vars [@output] - (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) - (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) - (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) - ..none - (..some @output))))) - -(def: runtime//frac - Computation - (_.begin - (list @@frac//decode))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Computation) - (_.if (|> idx (_.<=/2 (_.length/1 array))) - body - (_.raise/1 (_.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (with-vars [@temp] - (<| (check-index-out-of-bounds array idx) - (_.let (list [@temp (_.vector-ref/2 array idx)]) - (_.if (|> @temp (_.eqv?/2 _.nil)) - ..none - (..some @temp)))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds array idx) - (_.begin - (list (_.vector-set!/3 array idx value) - array)))) - -(def: runtime//array - Computation - (_.begin - (list @@array//get - @@array//put))) - -(runtime: (box//write value box) - (_.begin - (list - (_.vector-set!/3 box (_.int +0) value) - ..unit))) - -(def: runtime//box - Computation - (_.begin (list @@box//write))) - -(runtime: (io//current-time _) - (|> (_.apply/* (_.global "current-second") (list)) - (_.*/2 (_.int +1,000)) - _.exact/1)) - -(def: runtime//io - (_.begin (list @@io//current-time))) - -(def: runtime - Computation - (_.begin (list @@slice - runtime//lux - runtime//bit - runtime//adt - runtime//frac - runtime//array - runtime//box - runtime//io - ))) - -(def: #export generate - (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.save! ["" ..prefix] ..runtime)] - (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux new file mode 100644 index 000000000..b66b7abaf --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.lux @@ -0,0 +1,322 @@ +(.module: + [lux #* + [abstract + [monad (#+ do)]] + [control + ["." function] + ["p" parser ("#;." monad)]] + [data + [number (#+ hex)] + [text + format] + [collection + ["." list ("#;." monad)]]] + [macro + ["." code] + ["s" syntax (#+ syntax:)]] + [host + ["_" scheme (#+ Expression Computation Var)]]] + ["." /// + ["#/" // + ["#/" // #_ + [analysis (#+ Variant)] + ["#." name] + ["#." synthesis]]]]) + +(template [ ] + [(type: #export + ( Var Expression Expression))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string /////synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [0 #0 ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.and s.local-identifier (p;wrap (list))) + (s.form (p.and s.local-identifier (p.some s.local-identifier))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-identifier (format "@@" name)) + runtime (format prefix "__" (/////name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list;map code.local-identifier args) + argsLC+ (list;map (|>> /////name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-identifier name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list;map (function (_ [left right]) + (list left right))) + list;join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int +0))) + (slice (|> offset (_.-/2 (_.int +1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int +0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int +1))) + (_.cdr/1 list)))) + _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list;map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (format "LRV__" (/////name.normalize var))))))))) + list;join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int +1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## Needs recursion + (product//left (product-tail product) + (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) + (let [@index_min_length (_.var "index_min_length") + @product_length (_.var "product_length") + @slice (_.var "slice") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int +0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int +0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [@temp] + (<| (check-index-out-of-bounds array idx) + (_.let (list [@temp (_.vector-ref/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int +0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int +1,000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//box + runtime//io + ))) + +(def: #export generate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux deleted file mode 100644 index e44ab508b..000000000 --- a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux +++ /dev/null @@ -1,33 +0,0 @@ -(.module: - [lux #* - [abstract - ["." monad (#+ do)]] - [host - ["_" scheme (#+ Expression)]]] - [// - ["." runtime (#+ Operation Phase)] - ["." primitive] - ["." /// - [// - [analysis (#+ Variant Tuple)] - ["." synthesis (#+ Synthesis)]]]]) - -(def: #export (tuple generate elemsS+) - (-> Phase (Tuple Synthesis) (Operation Expression)) - (case elemsS+ - #.Nil - (:: ///.monad wrap (primitive.text synthesis.unit)) - - (#.Cons singletonS #.Nil) - (generate singletonS) - - _ - (do ///.monad - [elemsT+ (monad.map @ generate elemsS+)] - (wrap (_.vector/* elemsT+))))) - -(def: #export (variant generate [lefts right? valueS]) - (-> Phase (Variant Synthesis) (Operation Expression)) - (do ///.monad - [valueT (generate valueS)] - (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux new file mode 100644 index 000000000..e44ab508b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.lux @@ -0,0 +1,33 @@ +(.module: + [lux #* + [abstract + ["." monad (#+ do)]] + [host + ["_" scheme (#+ Expression)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." primitive] + ["." /// + [// + [analysis (#+ Variant Tuple)] + ["." synthesis (#+ Synthesis)]]]]) + +(def: #export (tuple generate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (:: ///.monad wrap (primitive.text synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate singletonS) + + _ + (do ///.monad + [elemsT+ (monad.map @ generate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant generate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (do ///.monad + [valueT (generate valueS)] + (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index a5a0c7b06..effcff8a3 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -57,7 +57,7 @@ [can-write ..can-write] [can-close ..can-close]))))) -(`` (for {(~~ (static host.jvm)) +(`` (for {(~~ (static host.old)) (as-is (import: java/lang/String) (import: #long java/io/Console diff --git a/stdlib/source/lux/world/db/jdbc.jvm.lux b/stdlib/source/lux/world/db/jdbc.jvm.lux deleted file mode 100644 index 8fd0ecf4c..000000000 --- a/stdlib/source/lux/world/db/jdbc.jvm.lux +++ /dev/null @@ -1,175 +0,0 @@ -(.module: - [lux (#- and int) - [control - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - ["ex" exception] - [concurrency - ["." promise (#+ Promise) ("#;." monad)]] - [security - ["!" capability (#+ capability:)]]] - [data - ["." product] - ["." error (#+ Error)] - [text - format] - [collection - ["." list ("#;." fold)]]] - ["." io (#+ IO)] - [world - [net (#+ URL)]] - [host (#+ import:)]] - [// - ["." sql]] - ["." / #_ - ["#." input (#+ Input)] - ["#." output (#+ Output)]]) - -(import: #long java/sql/ResultSet - (getRow [] #try int) - (next [] #try boolean) - (close [] #io #try void)) - -(import: #long java/sql/Statement - (#static NO_GENERATED_KEYS int) - (#static RETURN_GENERATED_KEYS int) - (getGeneratedKeys [] #try java/sql/ResultSet) - (close [] #io #try void)) - -(import: #long java/sql/PreparedStatement - (executeUpdate [] #io #try int) - (executeQuery [] #io #try java/sql/ResultSet)) - -(import: #long java/sql/Connection - (prepareStatement [String int] #try java/sql/PreparedStatement) - (isValid [int] #try boolean) - (close [] #io #try void)) - -(import: #long java/sql/DriverManager - (#static getConnection [String String String] #io #try java/sql/Connection)) - -(type: #export Credentials - {#url URL - #user Text - #password Text}) - -(type: #export ID Int) - -(type: #export (Statement input) - {#sql sql.Statement - #input (Input input) - #value input}) - -(template [ ] - [(capability: #export ( ! i) - ( (Statement i) (! (Error ))))] - - [Can-Execute can-execute Nat] - [Can-Insert can-insert (List ID)] - ) - -(capability: #export (Can-Query ! i o) - (can-query [(Statement i) (Output o)] (! (Error (List o))))) - -(capability: #export (Can-Close !) - (can-close Any (! (Error Any)))) - -(signature: #export (DB !) - (: (Can-Execute !) - execute) - (: (Can-Insert !) - insert) - (: (Can-Query !) - query) - (: (Can-Close !) - close)) - -(def: (with-statement statement conn action) - (All [i a] - (-> (Statement i) java/sql/Connection - (-> java/sql/PreparedStatement (IO (Error a))) - (IO (Error a)))) - (do (error.with io.monad) - [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement)) - (java/sql/Statement::RETURN_GENERATED_KEYS) - conn)) - _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared])) - result (action prepared) - _ (java/sql/Statement::close prepared)] - (wrap result))) - -(def: #export (async db) - (-> (DB IO) (DB Promise)) - (`` (structure - (~~ (template [ ] - [(def: ( (|>> (!.use (:: db )) promise.future)))] - - [execute can-execute] - [insert can-insert] - [close can-close] - [query can-query]))))) - -(def: #export (connect creds) - (-> Credentials (IO (Error (DB IO)))) - (do (error.with io.monad) - [connection (java/sql/DriverManager::getConnection (get@ #url creds) - (get@ #user creds) - (get@ #password creds))] - (wrap (: (DB IO) - (structure - (def: execute - (..can-execute - (function (execute statement) - (with-statement statement connection - (function (_ prepared) - (do (error.with io.monad) - [row-count (java/sql/PreparedStatement::executeUpdate prepared)] - (wrap (.nat row-count)))))))) - - (def: insert - (..can-insert - (function (insert statement) - (with-statement statement connection - (function (_ prepared) - (do (error.with io.monad) - [_ (java/sql/PreparedStatement::executeUpdate prepared) - result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))] - (/output.rows /output.long result-set))))))) - - (def: close - (..can-close - (function (close _) - (java/sql/Connection::close connection)))) - - (def: query - (..can-query - (function (query [statement output]) - (with-statement statement connection - (function (_ prepared) - (do (error.with io.monad) - [result-set (java/sql/PreparedStatement::executeQuery prepared)] - (/output.rows output result-set))))))) - ))))) - -(def: #export (with-db creds action) - (All [a] - (-> Credentials - (-> (DB IO) (IO (Error a))) - (IO (Error a)))) - (do (error.with io.monad) - [db (..connect creds) - result (action db) - _ (!.use (:: db close) [])] - (wrap result))) - -(def: #export (with-async-db creds action) - (All [a] - (-> Credentials - (-> (DB Promise) (Promise (Error a))) - (Promise (Error a)))) - (do (error.with promise.monad) - [db (promise.future (..connect creds)) - result (action (..async db)) - _ (promise;wrap (io.run (!.use (:: db close) [])))] - (wrap result))) diff --git a/stdlib/source/lux/world/db/jdbc.old.lux b/stdlib/source/lux/world/db/jdbc.old.lux new file mode 100644 index 000000000..8fd0ecf4c --- /dev/null +++ b/stdlib/source/lux/world/db/jdbc.old.lux @@ -0,0 +1,175 @@ +(.module: + [lux (#- and int) + [control + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + ["ex" exception] + [concurrency + ["." promise (#+ Promise) ("#;." monad)]] + [security + ["!" capability (#+ capability:)]]] + [data + ["." product] + ["." error (#+ Error)] + [text + format] + [collection + ["." list ("#;." fold)]]] + ["." io (#+ IO)] + [world + [net (#+ URL)]] + [host (#+ import:)]] + [// + ["." sql]] + ["." / #_ + ["#." input (#+ Input)] + ["#." output (#+ Output)]]) + +(import: #long java/sql/ResultSet + (getRow [] #try int) + (next [] #try boolean) + (close [] #io #try void)) + +(import: #long java/sql/Statement + (#static NO_GENERATED_KEYS int) + (#static RETURN_GENERATED_KEYS int) + (getGeneratedKeys [] #try java/sql/ResultSet) + (close [] #io #try void)) + +(import: #long java/sql/PreparedStatement + (executeUpdate [] #io #try int) + (executeQuery [] #io #try java/sql/ResultSet)) + +(import: #long java/sql/Connection + (prepareStatement [String int] #try java/sql/PreparedStatement) + (isValid [int] #try boolean) + (close [] #io #try void)) + +(import: #long java/sql/DriverManager + (#static getConnection [String String String] #io #try java/sql/Connection)) + +(type: #export Credentials + {#url URL + #user Text + #password Text}) + +(type: #export ID Int) + +(type: #export (Statement input) + {#sql sql.Statement + #input (Input input) + #value input}) + +(template [ ] + [(capability: #export ( ! i) + ( (Statement i) (! (Error ))))] + + [Can-Execute can-execute Nat] + [Can-Insert can-insert (List ID)] + ) + +(capability: #export (Can-Query ! i o) + (can-query [(Statement i) (Output o)] (! (Error (List o))))) + +(capability: #export (Can-Close !) + (can-close Any (! (Error Any)))) + +(signature: #export (DB !) + (: (Can-Execute !) + execute) + (: (Can-Insert !) + insert) + (: (Can-Query !) + query) + (: (Can-Close !) + close)) + +(def: (with-statement statement conn action) + (All [i a] + (-> (Statement i) java/sql/Connection + (-> java/sql/PreparedStatement (IO (Error a))) + (IO (Error a)))) + (do (error.with io.monad) + [prepared (io.io (java/sql/Connection::prepareStatement (sql.sql (get@ #sql statement)) + (java/sql/Statement::RETURN_GENERATED_KEYS) + conn)) + _ (io.io ((get@ #input statement) (get@ #value statement) [1 prepared])) + result (action prepared) + _ (java/sql/Statement::close prepared)] + (wrap result))) + +(def: #export (async db) + (-> (DB IO) (DB Promise)) + (`` (structure + (~~ (template [ ] + [(def: ( (|>> (!.use (:: db )) promise.future)))] + + [execute can-execute] + [insert can-insert] + [close can-close] + [query can-query]))))) + +(def: #export (connect creds) + (-> Credentials (IO (Error (DB IO)))) + (do (error.with io.monad) + [connection (java/sql/DriverManager::getConnection (get@ #url creds) + (get@ #user creds) + (get@ #password creds))] + (wrap (: (DB IO) + (structure + (def: execute + (..can-execute + (function (execute statement) + (with-statement statement connection + (function (_ prepared) + (do (error.with io.monad) + [row-count (java/sql/PreparedStatement::executeUpdate prepared)] + (wrap (.nat row-count)))))))) + + (def: insert + (..can-insert + (function (insert statement) + (with-statement statement connection + (function (_ prepared) + (do (error.with io.monad) + [_ (java/sql/PreparedStatement::executeUpdate prepared) + result-set (io.io (java/sql/Statement::getGeneratedKeys prepared))] + (/output.rows /output.long result-set))))))) + + (def: close + (..can-close + (function (close _) + (java/sql/Connection::close connection)))) + + (def: query + (..can-query + (function (query [statement output]) + (with-statement statement connection + (function (_ prepared) + (do (error.with io.monad) + [result-set (java/sql/PreparedStatement::executeQuery prepared)] + (/output.rows output result-set))))))) + ))))) + +(def: #export (with-db creds action) + (All [a] + (-> Credentials + (-> (DB IO) (IO (Error a))) + (IO (Error a)))) + (do (error.with io.monad) + [db (..connect creds) + result (action db) + _ (!.use (:: db close) [])] + (wrap result))) + +(def: #export (with-async-db creds action) + (All [a] + (-> Credentials + (-> (DB Promise) (Promise (Error a))) + (Promise (Error a)))) + (do (error.with promise.monad) + [db (promise.future (..connect creds)) + result (action (..async db)) + _ (promise;wrap (io.run (!.use (:: db close) [])))] + (wrap result))) diff --git a/stdlib/source/lux/world/db/jdbc/input.jvm.lux b/stdlib/source/lux/world/db/jdbc/input.jvm.lux deleted file mode 100644 index 68045b058..000000000 --- a/stdlib/source/lux/world/db/jdbc/input.jvm.lux +++ /dev/null @@ -1,109 +0,0 @@ -(.module: - [lux (#- and int) - [control - [functor (#+ Contravariant)] - [monad (#+ Monad do)]] - [data - ["." error (#+ Error)] - [collection - ["." list ("#;." fold)]]] - [time - ["." instant (#+ Instant)]] - ["." io (#+ IO)] - [world - [binary (#+ Binary)]] - [host (#+ import:)]]) - -(import: #long java/lang/String) - -(template [] - [(import: #long - (new [long]))] - - [java/sql/Date] [java/sql/Time] [java/sql/Timestamp] - ) - -(`` (import: #long java/sql/PreparedStatement - (~~ (template [ ] - [( [int ] #try void)] - - [setBoolean boolean] - - [setByte byte] - [setShort short] - [setInt int] - [setLong long] - - [setFloat float] - [setDouble double] - - [setString java/lang/String] - [setBytes (Array byte)] - - [setDate java/sql/Date] - [setTime java/sql/Time] - [setTimestamp java/sql/Timestamp] - )))) - -(type: #export (Input a) - (-> a [Nat java/sql/PreparedStatement] - (Error [Nat java/sql/PreparedStatement]))) - -(structure: #export contravariant (Contravariant Input) - (def: (map-1 f fb) - (function (fa value circumstance) - (fb (f value) circumstance)))) - -(def: #export (and pre post) - (All [l r] (-> (Input l) (Input r) (Input [l r]))) - (function (_ [left right] context) - (do error.monad - [context (pre left context)] - (post right context)))) - -(def: #export (fail error) - (All [a] (-> Text (Input a))) - (function (_ value [idx context]) - (#error.Failure error))) - -(def: #export empty - (Input Any) - (function (_ value context) - (#error.Success context))) - -(template [ ] - [(def: #export - (Input ) - (function (_ value [idx statement]) - (do error.monad - [_ ( (.int idx) value statement)] - (wrap [(.inc idx) statement]))))] - - [boolean Bit java/sql/PreparedStatement::setBoolean] - - [byte Int java/sql/PreparedStatement::setByte] - [short Int java/sql/PreparedStatement::setShort] - [int Int java/sql/PreparedStatement::setInt] - [long Int java/sql/PreparedStatement::setLong] - - [float Frac java/sql/PreparedStatement::setFloat] - [double Frac java/sql/PreparedStatement::setDouble] - - [string Text java/sql/PreparedStatement::setString] - [bytes Binary java/sql/PreparedStatement::setBytes] - ) - -(template [ ] - [(def: #export - (Input Instant) - (function (_ value [idx statement]) - (do error.monad - [_ ( (.int idx) - ( (instant.to-millis value)) - statement)] - (wrap [(.inc idx) statement]))))] - - [date java/sql/PreparedStatement::setDate java/sql/Date::new] - [time java/sql/PreparedStatement::setTime java/sql/Time::new] - [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new] - ) diff --git a/stdlib/source/lux/world/db/jdbc/input.old.lux b/stdlib/source/lux/world/db/jdbc/input.old.lux new file mode 100644 index 000000000..68045b058 --- /dev/null +++ b/stdlib/source/lux/world/db/jdbc/input.old.lux @@ -0,0 +1,109 @@ +(.module: + [lux (#- and int) + [control + [functor (#+ Contravariant)] + [monad (#+ Monad do)]] + [data + ["." error (#+ Error)] + [collection + ["." list ("#;." fold)]]] + [time + ["." instant (#+ Instant)]] + ["." io (#+ IO)] + [world + [binary (#+ Binary)]] + [host (#+ import:)]]) + +(import: #long java/lang/String) + +(template [] + [(import: #long + (new [long]))] + + [java/sql/Date] [java/sql/Time] [java/sql/Timestamp] + ) + +(`` (import: #long java/sql/PreparedStatement + (~~ (template [ ] + [( [int ] #try void)] + + [setBoolean boolean] + + [setByte byte] + [setShort short] + [setInt int] + [setLong long] + + [setFloat float] + [setDouble double] + + [setString java/lang/String] + [setBytes (Array byte)] + + [setDate java/sql/Date] + [setTime java/sql/Time] + [setTimestamp java/sql/Timestamp] + )))) + +(type: #export (Input a) + (-> a [Nat java/sql/PreparedStatement] + (Error [Nat java/sql/PreparedStatement]))) + +(structure: #export contravariant (Contravariant Input) + (def: (map-1 f fb) + (function (fa value circumstance) + (fb (f value) circumstance)))) + +(def: #export (and pre post) + (All [l r] (-> (Input l) (Input r) (Input [l r]))) + (function (_ [left right] context) + (do error.monad + [context (pre left context)] + (post right context)))) + +(def: #export (fail error) + (All [a] (-> Text (Input a))) + (function (_ value [idx context]) + (#error.Failure error))) + +(def: #export empty + (Input Any) + (function (_ value context) + (#error.Success context))) + +(template [ ] + [(def: #export + (Input ) + (function (_ value [idx statement]) + (do error.monad + [_ ( (.int idx) value statement)] + (wrap [(.inc idx) statement]))))] + + [boolean Bit java/sql/PreparedStatement::setBoolean] + + [byte Int java/sql/PreparedStatement::setByte] + [short Int java/sql/PreparedStatement::setShort] + [int Int java/sql/PreparedStatement::setInt] + [long Int java/sql/PreparedStatement::setLong] + + [float Frac java/sql/PreparedStatement::setFloat] + [double Frac java/sql/PreparedStatement::setDouble] + + [string Text java/sql/PreparedStatement::setString] + [bytes Binary java/sql/PreparedStatement::setBytes] + ) + +(template [ ] + [(def: #export + (Input Instant) + (function (_ value [idx statement]) + (do error.monad + [_ ( (.int idx) + ( (instant.to-millis value)) + statement)] + (wrap [(.inc idx) statement]))))] + + [date java/sql/PreparedStatement::setDate java/sql/Date::new] + [time java/sql/PreparedStatement::setTime java/sql/Time::new] + [time-stamp java/sql/PreparedStatement::setTimestamp java/sql/Timestamp::new] + ) diff --git a/stdlib/source/lux/world/db/jdbc/output.jvm.lux b/stdlib/source/lux/world/db/jdbc/output.jvm.lux deleted file mode 100644 index 39c4cb92b..000000000 --- a/stdlib/source/lux/world/db/jdbc/output.jvm.lux +++ /dev/null @@ -1,189 +0,0 @@ -(.module: - [lux (#- and int) - [control - [functor (#+ Functor)] - [apply (#+ Apply)] - [monad (#+ Monad do)] - ["ex" exception]] - [data - ["." error (#+ Error)]] - [time - ["." instant (#+ Instant)]] - ["." io (#+ IO)] - [world - [binary (#+ Binary)]] - [host (#+ import:)]]) - -(import: #long java/lang/String) - -(import: #long java/util/Date - (getTime [] long)) - -(import: #long java/sql/Date) -(import: #long java/sql/Time) -(import: #long java/sql/Timestamp) - -(`` (import: #long java/sql/ResultSet - (~~ (template [ ] - [( [int] #try )] - - [getBoolean boolean] - - [getByte byte] - [getShort short] - [getInt int] - [getLong long] - - [getDouble double] - [getFloat float] - - [getString java/lang/String] - [getBytes (Array byte)] - - [getDate java/sql/Date] - [getTime java/sql/Time] - [getTimestamp java/sql/Timestamp] - )) - (next [] #try boolean) - (close [] #io #try void))) - -(type: #export (Output a) - (-> [Nat java/sql/ResultSet] (Error [Nat a]))) - -(structure: #export functor (Functor Output) - (def: (map f fa) - (function (_ idx+rs) - (case (fa idx+rs) - (#error.Failure error) - (#error.Failure error) - - (#error.Success [idx' value]) - (#error.Success [idx' (f value)]))))) - -(structure: #export apply (Apply Output) - (def: &functor ..functor) - - (def: (apply ff fa) - (function (_ [idx rs]) - (case (ff [idx rs]) - (#error.Success [idx' f]) - (case (fa [idx' rs]) - (#error.Success [idx'' a]) - (#error.Success [idx'' (f a)]) - - (#error.Failure msg) - (#error.Failure msg)) - - (#error.Failure msg) - (#error.Failure msg))))) - -(structure: #export monad (Monad Output) - (def: &functor ..functor) - - (def: (wrap a) - (function (_ [idx rs]) - (#.Some [idx a]))) - - (def: (join mma) - (function (_ [idx rs]) - (case (mma [idx rs]) - (#error.Failure error) - (#error.Failure error) - - (#error.Success [idx' ma]) - (ma [idx' rs]))))) - -(def: #export (fail error) - (All [a] (-> Text (Output a))) - (function (_ [idx result-set]) - (#error.Failure error))) - -(def: #export (and left right) - (All [a b] - (-> (Output a) (Output b) (Output [a b]))) - (do ..monad - [=left left - =right right] - (wrap [=left =right]))) - -(template [ ] - [(def: #export - (Output ) - (function (_ [idx result-set]) - (case ( [(.int idx)] result-set) - (#error.Failure error) - (#error.Failure error) - - (#error.Success value) - (#error.Success [(inc idx) value]))))] - - [boolean java/sql/ResultSet::getBoolean Bit] - - [byte java/sql/ResultSet::getByte Int] - [short java/sql/ResultSet::getShort Int] - [int java/sql/ResultSet::getInt Int] - [long java/sql/ResultSet::getLong Int] - - [float java/sql/ResultSet::getFloat Frac] - [double java/sql/ResultSet::getDouble Frac] - - [string java/sql/ResultSet::getString Text] - [bytes java/sql/ResultSet::getBytes Binary] - ) - -(template [ ] - [(def: #export - (Output Instant) - (function (_ [idx result-set]) - (case ( [(.int idx)] result-set) - (#error.Failure error) - (#error.Failure error) - - (#error.Success value) - (#error.Success [(inc idx) - (instant.from-millis (java/util/Date::getTime value))]))))] - - [date java/sql/ResultSet::getDate] - [time java/sql/ResultSet::getTime] - [time-stamp java/sql/ResultSet::getTimestamp] - ) - -(def: #export (rows output results) - (All [a] (-> (Output a) java/sql/ResultSet (IO (Error (List a))))) - (case (java/sql/ResultSet::next results) - (#error.Success has-next?) - (if has-next? - (case (output [1 results]) - (#.Some [_ head]) - (do io.monad - [?tail (rows output results)] - (case ?tail - (#error.Success tail) - (wrap (ex.return (#.Cons head tail))) - - (#error.Failure error) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do error.monad - [_ temp] - (error.fail error)))))) - - (#error.Failure error) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do error.monad - [_ temp] - (error.fail error))))) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do error.monad - [_ temp] - (wrap (list)))))) - - (#error.Failure error) - (do io.monad - [temp (java/sql/ResultSet::close results)] - (wrap (do error.monad - [_ temp] - (error.fail error)))) - )) diff --git a/stdlib/source/lux/world/db/jdbc/output.old.lux b/stdlib/source/lux/world/db/jdbc/output.old.lux new file mode 100644 index 000000000..39c4cb92b --- /dev/null +++ b/stdlib/source/lux/world/db/jdbc/output.old.lux @@ -0,0 +1,189 @@ +(.module: + [lux (#- and int) + [control + [functor (#+ Functor)] + [apply (#+ Apply)] + [monad (#+ Monad do)] + ["ex" exception]] + [data + ["." error (#+ Error)]] + [time + ["." instant (#+ Instant)]] + ["." io (#+ IO)] + [world + [binary (#+ Binary)]] + [host (#+ import:)]]) + +(import: #long java/lang/String) + +(import: #long java/util/Date + (getTime [] long)) + +(import: #long java/sql/Date) +(import: #long java/sql/Time) +(import: #long java/sql/Timestamp) + +(`` (import: #long java/sql/ResultSet + (~~ (template [ ] + [( [int] #try )] + + [getBoolean boolean] + + [getByte byte] + [getShort short] + [getInt int] + [getLong long] + + [getDouble double] + [getFloat float] + + [getString java/lang/String] + [getBytes (Array byte)] + + [getDate java/sql/Date] + [getTime java/sql/Time] + [getTimestamp java/sql/Timestamp] + )) + (next [] #try boolean) + (close [] #io #try void))) + +(type: #export (Output a) + (-> [Nat java/sql/ResultSet] (Error [Nat a]))) + +(structure: #export functor (Functor Output) + (def: (map f fa) + (function (_ idx+rs) + (case (fa idx+rs) + (#error.Failure error) + (#error.Failure error) + + (#error.Success [idx' value]) + (#error.Success [idx' (f value)]))))) + +(structure: #export apply (Apply Output) + (def: &functor ..functor) + + (def: (apply ff fa) + (function (_ [idx rs]) + (case (ff [idx rs]) + (#error.Success [idx' f]) + (case (fa [idx' rs]) + (#error.Success [idx'' a]) + (#error.Success [idx'' (f a)]) + + (#error.Failure msg) + (#error.Failure msg)) + + (#error.Failure msg) + (#error.Failure msg))))) + +(structure: #export monad (Monad Output) + (def: &functor ..functor) + + (def: (wrap a) + (function (_ [idx rs]) + (#.Some [idx a]))) + + (def: (join mma) + (function (_ [idx rs]) + (case (mma [idx rs]) + (#error.Failure error) + (#error.Failure error) + + (#error.Success [idx' ma]) + (ma [idx' rs]))))) + +(def: #export (fail error) + (All [a] (-> Text (Output a))) + (function (_ [idx result-set]) + (#error.Failure error))) + +(def: #export (and left right) + (All [a b] + (-> (Output a) (Output b) (Output [a b]))) + (do ..monad + [=left left + =right right] + (wrap [=left =right]))) + +(template [ ] + [(def: #export + (Output ) + (function (_ [idx result-set]) + (case ( [(.int idx)] result-set) + (#error.Failure error) + (#error.Failure error) + + (#error.Success value) + (#error.Success [(inc idx) value]))))] + + [boolean java/sql/ResultSet::getBoolean Bit] + + [byte java/sql/ResultSet::getByte Int] + [short java/sql/ResultSet::getShort Int] + [int java/sql/ResultSet::getInt Int] + [long java/sql/ResultSet::getLong Int] + + [float java/sql/ResultSet::getFloat Frac] + [double java/sql/ResultSet::getDouble Frac] + + [string java/sql/ResultSet::getString Text] + [bytes java/sql/ResultSet::getBytes Binary] + ) + +(template [ ] + [(def: #export + (Output Instant) + (function (_ [idx result-set]) + (case ( [(.int idx)] result-set) + (#error.Failure error) + (#error.Failure error) + + (#error.Success value) + (#error.Success [(inc idx) + (instant.from-millis (java/util/Date::getTime value))]))))] + + [date java/sql/ResultSet::getDate] + [time java/sql/ResultSet::getTime] + [time-stamp java/sql/ResultSet::getTimestamp] + ) + +(def: #export (rows output results) + (All [a] (-> (Output a) java/sql/ResultSet (IO (Error (List a))))) + (case (java/sql/ResultSet::next results) + (#error.Success has-next?) + (if has-next? + (case (output [1 results]) + (#.Some [_ head]) + (do io.monad + [?tail (rows output results)] + (case ?tail + (#error.Success tail) + (wrap (ex.return (#.Cons head tail))) + + (#error.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do error.monad + [_ temp] + (error.fail error)))))) + + (#error.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do error.monad + [_ temp] + (error.fail error))))) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do error.monad + [_ temp] + (wrap (list)))))) + + (#error.Failure error) + (do io.monad + [temp (java/sql/ResultSet::close results)] + (wrap (do error.monad + [_ temp] + (error.fail error)))) + )) diff --git a/stdlib/source/lux/world/environment.jvm.lux b/stdlib/source/lux/world/environment.jvm.lux deleted file mode 100644 index 8ad10f1f9..000000000 --- a/stdlib/source/lux/world/environment.jvm.lux +++ /dev/null @@ -1,52 +0,0 @@ -(.module: - [lux #* - [data - ["." text] - [format - [context (#+ Context)]] - [collection - ["." dictionary]]] - [io (#- run)] - [host (#+ import:)]]) - -## Do not trust the values of environment variables -## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables - -(import: java/lang/String) - -(import: (java/util/Map$Entry k v) - (getKey [] k) - (getValue [] v)) - -(import: (java/util/Iterator a) - (hasNext [] boolean) - (next [] a)) - -(import: (java/util/Set a) - (iterator [] (Iterator a))) - -(import: (java/util/Map k v) - (entrySet [] (Set (Map$Entry k v)))) - -(import: java/lang/System - (#static getenv [] (Map String String))) - -(def: (consume-iterator f iterator) - (All [a b] (-> (-> a b) (Iterator a) (List b))) - (if (Iterator::hasNext iterator) - (#.Cons (f (Iterator::next iterator)) - (consume-iterator f iterator)) - #.Nil)) - -(def: (entry-to-kv entry) - (All [k v] (-> (Map$Entry k v) [k v])) - [(Map$Entry::getKey entry) - (Map$Entry::getValue entry)]) - -(def: #export read - (IO Context) - (io (|> (System::getenv) - Map::entrySet - Set::iterator - (consume-iterator entry-to-kv) - (dictionary.from-list text.hash)))) diff --git a/stdlib/source/lux/world/environment.old.lux b/stdlib/source/lux/world/environment.old.lux new file mode 100644 index 000000000..8ad10f1f9 --- /dev/null +++ b/stdlib/source/lux/world/environment.old.lux @@ -0,0 +1,52 @@ +(.module: + [lux #* + [data + ["." text] + [format + [context (#+ Context)]] + [collection + ["." dictionary]]] + [io (#- run)] + [host (#+ import:)]]) + +## Do not trust the values of environment variables +## https://wiki.sei.cmu.edu/confluence/display/java/ENV02-J.+Do+not+trust+the+values+of+environment+variables + +(import: java/lang/String) + +(import: (java/util/Map$Entry k v) + (getKey [] k) + (getValue [] v)) + +(import: (java/util/Iterator a) + (hasNext [] boolean) + (next [] a)) + +(import: (java/util/Set a) + (iterator [] (Iterator a))) + +(import: (java/util/Map k v) + (entrySet [] (Set (Map$Entry k v)))) + +(import: java/lang/System + (#static getenv [] (Map String String))) + +(def: (consume-iterator f iterator) + (All [a b] (-> (-> a b) (Iterator a) (List b))) + (if (Iterator::hasNext iterator) + (#.Cons (f (Iterator::next iterator)) + (consume-iterator f iterator)) + #.Nil)) + +(def: (entry-to-kv entry) + (All [k v] (-> (Map$Entry k v) [k v])) + [(Map$Entry::getKey entry) + (Map$Entry::getValue entry)]) + +(def: #export read + (IO Context) + (io (|> (System::getenv) + Map::entrySet + Set::iterator + (consume-iterator entry-to-kv) + (dictionary.from-list text.hash)))) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 1e201d898..ec3cee16f 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -194,7 +194,7 @@ _ (io.io (ex.throw exception [path]))))) -(`` (for {(~~ (static host.jvm)) +(`` (for {(~~ (static host.old)) (as-is (import: #long java/io/File (new [String]) (~~ (template [] diff --git a/stdlib/source/lux/world/net/http/client.lux b/stdlib/source/lux/world/net/http/client.lux index f2cafb0e3..dfef02f3f 100644 --- a/stdlib/source/lux/world/net/http/client.lux +++ b/stdlib/source/lux/world/net/http/client.lux @@ -20,7 +20,7 @@ [// (#+ URL)]]) ## TODO: This is unfinished work. Things like headers and cookies are missing. -(`` (for {(~~ (static host.jvm)) +(`` (for {(~~ (static host.old)) (as-is (import: #long java/lang/String) (import: #long java/io/Flushable @@ -50,7 +50,7 @@ (def: #export (request [method url headers body]) Client - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) (promise.future (do (error.with io.monad) [conn (java/net/URL::openConnection (java/net/URL::new url)) diff --git a/stdlib/source/lux/world/net/tcp.jvm.lux b/stdlib/source/lux/world/net/tcp.jvm.lux deleted file mode 100644 index 0b1d725e5..000000000 --- a/stdlib/source/lux/world/net/tcp.jvm.lux +++ /dev/null @@ -1,131 +0,0 @@ -(.module: - [lux #* - [abstract - monad] - [control - ["." io (#+ IO)] - [concurrency - ["." promise (#+ Promise Resolver)] - ["." frp (#+ Channel Sink)]] - [security - ["!" capability]]] - [data - ["." error (#+ Error)]] - [world - ["." binary (#+ Binary)]] - [host (#+ import:)] - [tool - [compiler - ["." host]]]] - ["." // (#+ Can-Read Can-Write Can-Close)]) - -(import: java/lang/AutoCloseable - (close [] #io #try void)) - -(import: java/io/Flushable - (flush [] #io #try void)) - -(import: java/io/InputStream - (read [(Array byte) int int] #io #try int)) - -(import: java/io/OutputStream - (write [(Array byte) int int] #io #try void)) - -(import: java/net/Socket - (new [String int] #io #try) - (getInputStream [] #try InputStream) - (getOutputStream [] #try OutputStream)) - -(import: java/net/ServerSocket - (new [int] #io #try) - (accept [] #io #try Socket)) - -############################################################ -############################################################ -############################################################ - -(signature: #export (TCP !) - (: (Can-Read ! [Nat Binary]) - read) - - (: (Can-Write ! Binary) - write) - - (: (Can-Close !) - close)) - -(def: #export (async tcp) - (-> (TCP IO) (TCP Promise)) - (`` (structure (~~ (template [ ] - [(def: ( (|>> (!.use (:: tcp )) promise.future)))] - - [read //.can-read] - [write //.can-write] - [close //.can-close]))))) - -(`` (for {(~~ (static host.jvm)) - (as-is (def: (tcp socket) - (-> Socket (Error (TCP IO))) - (do error.monad - [input (Socket::getInputStream socket) - output (Socket::getOutputStream socket)] - (wrap (: (TCP IO) - (structure (def: read - (//.can-read - (function (read size) - (do (error.with io.monad) - [#let [data (binary.create size)] - bytes-read (InputStream::read data +0 (.int size) input)] - (wrap [(.nat bytes-read) - data]))))) - - (def: write - (//.can-write - (function (write data) - (do (error.with io.monad) - [_ (OutputStream::write data +0 (.int (binary.size data)) - output)] - (Flushable::flush output))))) - - (def: close - (//.can-close - (function (close _) - (do (error.with io.monad) - [_ (AutoCloseable::close input) - _ (AutoCloseable::close output)] - (AutoCloseable::close socket)))))))))) - - (def: #export (client address port) - (-> //.Address //.Port (IO (Error (TCP IO)))) - (do (error.with io.monad) - [socket (Socket::new address (.int port))] - (io.io (tcp socket)))) - - (def: #export (server port) - (-> //.Port (IO (Error [(Resolver Any) - (Channel (TCP IO))]))) - (do (error.with io.monad) - [server (ServerSocket::new (.int port)) - #let [[close-signal close-resolver] (: [(Promise Any) (Resolver Any)] - (promise.promise [])) - _ (promise.await (function (_ _) - (AutoCloseable::close server)) - close-signal) - [output sink] (: [(Channel (TCP IO)) (Sink (TCP IO))] - (frp.channel [])) - _ (: (Promise Any) - (promise.future - (loop [_ []] - (do io.monad - [?client (do (error.with io.monad) - [socket (ServerSocket::accept server)] - (io.io (tcp socket)))] - (case ?client - (#error.Failure error) - (wrap []) - - (#error.Success client) - (do @ - [_ (:: sink feed client)] - (recur [])))))))]] - (wrap [close-resolver output]))))})) diff --git a/stdlib/source/lux/world/net/tcp.old.lux b/stdlib/source/lux/world/net/tcp.old.lux new file mode 100644 index 000000000..1b7a8af18 --- /dev/null +++ b/stdlib/source/lux/world/net/tcp.old.lux @@ -0,0 +1,131 @@ +(.module: + [lux #* + [abstract + monad] + [control + ["." io (#+ IO)] + [concurrency + ["." promise (#+ Promise Resolver)] + ["." frp (#+ Channel Sink)]] + [security + ["!" capability]]] + [data + ["." error (#+ Error)]] + [world + ["." binary (#+ Binary)]] + [host (#+ import:)] + [tool + [compiler + ["." host]]]] + ["." // (#+ Can-Read Can-Write Can-Close)]) + +(import: java/lang/AutoCloseable + (close [] #io #try void)) + +(import: java/io/Flushable + (flush [] #io #try void)) + +(import: java/io/InputStream + (read [(Array byte) int int] #io #try int)) + +(import: java/io/OutputStream + (write [(Array byte) int int] #io #try void)) + +(import: java/net/Socket + (new [String int] #io #try) + (getInputStream [] #try InputStream) + (getOutputStream [] #try OutputStream)) + +(import: java/net/ServerSocket + (new [int] #io #try) + (accept [] #io #try Socket)) + +############################################################ +############################################################ +############################################################ + +(signature: #export (TCP !) + (: (Can-Read ! [Nat Binary]) + read) + + (: (Can-Write ! Binary) + write) + + (: (Can-Close !) + close)) + +(def: #export (async tcp) + (-> (TCP IO) (TCP Promise)) + (`` (structure (~~ (template [ ] + [(def: ( (|>> (!.use (:: tcp )) promise.future)))] + + [read //.can-read] + [write //.can-write] + [close //.can-close]))))) + +(`` (for {(~~ (static host.old)) + (as-is (def: (tcp socket) + (-> Socket (Error (TCP IO))) + (do error.monad + [input (Socket::getInputStream socket) + output (Socket::getOutputStream socket)] + (wrap (: (TCP IO) + (structure (def: read + (//.can-read + (function (read size) + (do (error.with io.monad) + [#let [data (binary.create size)] + bytes-read (InputStream::read data +0 (.int size) input)] + (wrap [(.nat bytes-read) + data]))))) + + (def: write + (//.can-write + (function (write data) + (do (error.with io.monad) + [_ (OutputStream::write data +0 (.int (binary.size data)) + output)] + (Flushable::flush output))))) + + (def: close + (//.can-close + (function (close _) + (do (error.with io.monad) + [_ (AutoCloseable::close input) + _ (AutoCloseable::close output)] + (AutoCloseable::close socket)))))))))) + + (def: #export (client address port) + (-> //.Address //.Port (IO (Error (TCP IO)))) + (do (error.with io.monad) + [socket (Socket::new address (.int port))] + (io.io (tcp socket)))) + + (def: #export (server port) + (-> //.Port (IO (Error [(Resolver Any) + (Channel (TCP IO))]))) + (do (error.with io.monad) + [server (ServerSocket::new (.int port)) + #let [[close-signal close-resolver] (: [(Promise Any) (Resolver Any)] + (promise.promise [])) + _ (promise.await (function (_ _) + (AutoCloseable::close server)) + close-signal) + [output sink] (: [(Channel (TCP IO)) (Sink (TCP IO))] + (frp.channel [])) + _ (: (Promise Any) + (promise.future + (loop [_ []] + (do io.monad + [?client (do (error.with io.monad) + [socket (ServerSocket::accept server)] + (io.io (tcp socket)))] + (case ?client + (#error.Failure error) + (wrap []) + + (#error.Success client) + (do @ + [_ (:: sink feed client)] + (recur [])))))))]] + (wrap [close-resolver output]))))})) diff --git a/stdlib/source/lux/world/net/udp.jvm.lux b/stdlib/source/lux/world/net/udp.jvm.lux deleted file mode 100644 index 497ed6893..000000000 --- a/stdlib/source/lux/world/net/udp.jvm.lux +++ /dev/null @@ -1,126 +0,0 @@ -(.module: - [lux #* - [abstract - monad] - [control - ["ex" exception (#+ exception:)] - ["." io (#+ IO)] - [concurrency - ["." promise (#+ Promise)]] - [security - ["!" capability]]] - [data - ["." error (#+ Error)] - ["." maybe] - [collection - ["." array]]] - [world - ["." binary (#+ Binary)]] - [host (#+ import:)] - [tool - [compiler - ["." host]]]] - ["." // (#+ Location Can-Read Can-Write Can-Close)]) - -(import: java/lang/AutoCloseable - (close [] #io #try void)) - -(import: java/io/Flushable - (flush [] #io #try void)) - -(import: java/net/InetAddress - (#static getAllByName [String] #io #try (Array InetAddress)) - (getHostAddress [] String)) - -(import: java/net/DatagramPacket - (new #as new|send [(Array byte) int int InetAddress int]) - (new #as new|receive [(Array byte) int int]) - (getAddress [] InetAddress) - (getPort [] int) - (getLength [] int)) - -(import: java/net/DatagramSocket - (new #as new|client [] #io #try) - (new #as new|server [int] #io #try) - (receive [DatagramPacket] #io #try void) - (send [DatagramPacket] #io #try void)) - -############################################################ -############################################################ -############################################################ - -(exception: #export (cannot-resolve-address {address //.Address}) - (ex.report ["Address" address])) - -(exception: #export (multiple-candidate-addresses {address //.Address}) - (ex.report ["Address" address])) - -(signature: #export (UDP !) - (: (Can-Read ! [Nat Location Binary]) - read) - - (: (Can-Write ! [Location Binary]) - write) - - (: (Can-Close !) - close)) - -(def: #export (async udp) - (-> (UDP IO) (UDP Promise)) - (`` (structure (~~ (template [ ] - [(def: ( (|>> (!.use (:: udp )) promise.future)))] - - [read //.can-read] - [write //.can-write] - [close //.can-close]))))) - -(`` (for {(~~ (static host.jvm)) - (as-is (def: (resolve address) - (-> //.Address (IO (Error InetAddress))) - (do (error.with io.monad) - [addresses (InetAddress::getAllByName address)] - (: (IO (Error InetAddress)) - (case (array.size addresses) - 0 (io.io (ex.throw cannot-resolve-address address)) - 1 (wrap (maybe.assume (array.read 0 addresses))) - _ (io.io (ex.throw multiple-candidate-addresses address)))))) - - (def: (udp socket) - (-> DatagramSocket (UDP IO)) - (structure (def: read - (//.can-read - (function (read size) - (let [data (binary.create size) - packet (DatagramPacket::new|receive data +0 (.int size))] - (do (error.with io.monad) - [_ (DatagramSocket::receive packet socket) - #let [bytes-read (.nat (DatagramPacket::getLength packet))]] - (wrap [bytes-read - {#//.address (|> packet DatagramPacket::getAddress InetAddress::getHostAddress) - #//.port (.nat (DatagramPacket::getPort packet))} - data])))))) - - (def: write - (//.can-write - (function (write [location data]) - (do (error.with io.monad) - [address (resolve (get@ #//.address location))] - (DatagramSocket::send (DatagramPacket::new|send data +0 (.int (binary.size data)) address (.int (get@ #//.port location))) - socket))))) - - (def: close - (//.can-close - (function (close _) - (AutoCloseable::close socket)))))) - - (def: #export client - (IO (Error (UDP IO))) - (|> (DatagramSocket::new|client) - (:: (error.with io.monad) map ..udp))) - - (def: #export server - (-> //.Port (IO (Error (UDP IO)))) - (|>> .int - DatagramSocket::new|server - (:: (error.with io.monad) map ..udp))) - )})) diff --git a/stdlib/source/lux/world/net/udp.old.lux b/stdlib/source/lux/world/net/udp.old.lux new file mode 100644 index 000000000..9c58404fb --- /dev/null +++ b/stdlib/source/lux/world/net/udp.old.lux @@ -0,0 +1,126 @@ +(.module: + [lux #* + [abstract + monad] + [control + ["ex" exception (#+ exception:)] + ["." io (#+ IO)] + [concurrency + ["." promise (#+ Promise)]] + [security + ["!" capability]]] + [data + ["." error (#+ Error)] + ["." maybe] + [collection + ["." array]]] + [world + ["." binary (#+ Binary)]] + [host (#+ import:)] + [tool + [compiler + ["." host]]]] + ["." // (#+ Location Can-Read Can-Write Can-Close)]) + +(import: java/lang/AutoCloseable + (close [] #io #try void)) + +(import: java/io/Flushable + (flush [] #io #try void)) + +(import: java/net/InetAddress + (#static getAllByName [String] #io #try (Array InetAddress)) + (getHostAddress [] String)) + +(import: java/net/DatagramPacket + (new #as new|send [(Array byte) int int InetAddress int]) + (new #as new|receive [(Array byte) int int]) + (getAddress [] InetAddress) + (getPort [] int) + (getLength [] int)) + +(import: java/net/DatagramSocket + (new #as new|client [] #io #try) + (new #as new|server [int] #io #try) + (receive [DatagramPacket] #io #try void) + (send [DatagramPacket] #io #try void)) + +############################################################ +############################################################ +############################################################ + +(exception: #export (cannot-resolve-address {address //.Address}) + (ex.report ["Address" address])) + +(exception: #export (multiple-candidate-addresses {address //.Address}) + (ex.report ["Address" address])) + +(signature: #export (UDP !) + (: (Can-Read ! [Nat Location Binary]) + read) + + (: (Can-Write ! [Location Binary]) + write) + + (: (Can-Close !) + close)) + +(def: #export (async udp) + (-> (UDP IO) (UDP Promise)) + (`` (structure (~~ (template [ ] + [(def: ( (|>> (!.use (:: udp )) promise.future)))] + + [read //.can-read] + [write //.can-write] + [close //.can-close]))))) + +(`` (for {(~~ (static host.old)) + (as-is (def: (resolve address) + (-> //.Address (IO (Error InetAddress))) + (do (error.with io.monad) + [addresses (InetAddress::getAllByName address)] + (: (IO (Error InetAddress)) + (case (array.size addresses) + 0 (io.io (ex.throw cannot-resolve-address address)) + 1 (wrap (maybe.assume (array.read 0 addresses))) + _ (io.io (ex.throw multiple-candidate-addresses address)))))) + + (def: (udp socket) + (-> DatagramSocket (UDP IO)) + (structure (def: read + (//.can-read + (function (read size) + (let [data (binary.create size) + packet (DatagramPacket::new|receive data +0 (.int size))] + (do (error.with io.monad) + [_ (DatagramSocket::receive packet socket) + #let [bytes-read (.nat (DatagramPacket::getLength packet))]] + (wrap [bytes-read + {#//.address (|> packet DatagramPacket::getAddress InetAddress::getHostAddress) + #//.port (.nat (DatagramPacket::getPort packet))} + data])))))) + + (def: write + (//.can-write + (function (write [location data]) + (do (error.with io.monad) + [address (resolve (get@ #//.address location))] + (DatagramSocket::send (DatagramPacket::new|send data +0 (.int (binary.size data)) address (.int (get@ #//.port location))) + socket))))) + + (def: close + (//.can-close + (function (close _) + (AutoCloseable::close socket)))))) + + (def: #export client + (IO (Error (UDP IO))) + (|> (DatagramSocket::new|client) + (:: (error.with io.monad) map ..udp))) + + (def: #export server + (-> //.Port (IO (Error (UDP IO)))) + (|>> .int + DatagramSocket::new|server + (:: (error.with io.monad) map ..udp))) + )})) diff --git a/stdlib/source/lux/world/shell.lux b/stdlib/source/lux/world/shell.lux index 82541c5f3..d7fedc6d0 100644 --- a/stdlib/source/lux/world/shell.lux +++ b/stdlib/source/lux/world/shell.lux @@ -58,7 +58,7 @@ (|>> (text.replace-all "'" "\'") (text.enclose' "'")))) -(`` (for {(~~ (static host.jvm)) +(`` (for {(~~ (static host.old)) (as-is (import: #long java/lang/String (toLowerCase [] java/lang/String)) @@ -149,7 +149,7 @@ (def: #export (execute environment command arguments) (-> Context Text (List Text) (IO (Error (Console IO)))) - (`` (for {(~~ (static host.jvm)) + (`` (for {(~~ (static host.old)) (do (error.with io.monad) [windows? (:: @ map (|>> java/lang/String::toLowerCase ..windows?) (java/lang/System::getProperty "os.name")) diff --git a/stdlib/source/test/lux/host.jvm.lux b/stdlib/source/test/lux/host.jvm.lux deleted file mode 100644 index 04c149881..000000000 --- a/stdlib/source/test/lux/host.jvm.lux +++ /dev/null @@ -1,134 +0,0 @@ -(.module: - [lux #* - [abstract/monad (#+ Monad do)] - [control - pipe] - [data - ["." text ("#;." equivalence)]] - [math - ["r" random]] - ["_" test (#+ Test)]] - {1 - ["." / (#+ import: class: interface: object)]}) - -(import: (java/util/concurrent/Callable a)) - -(import: java/lang/Exception - (new [String])) - -(import: java/lang/Object) - -(import: (java/lang/Class a) - (getName [] String)) - -(import: java/lang/System - (#static out java/io/PrintStream) - (#static currentTimeMillis [] #io long) - (#static getenv [String] #io #? String)) - -(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 - [])) - -(def: test-runnable - (object [] [Runnable] - [] - (Runnable [] (run) void - []))) - -(def: test-callable - (object [a] [(Callable a)] - [] - (Callable [] (call) a - (undefined)))) - -(interface: TestInterface - ([] foo [boolean String] void #throws [Exception])) - -(def: conversions - Test - (do r.monad - [sample r.int] - (`` ($_ _.and - (~~ (template [ ] - [(_.test - (or (|> sample (i/= sample)) - (let [capped-sample (|> sample )] - (|> capped-sample (i/= capped-sample)))))] - - [/.long-to-byte /.byte-to-long "Can succesfully convert to/from byte."] - [/.long-to-short /.short-to-long "Can succesfully convert to/from short."] - [/.long-to-int /.int-to-long "Can succesfully convert to/from int."] - [/.long-to-float /.float-to-long "Can succesfully convert to/from float."] - [/.long-to-double /.double-to-long "Can succesfully convert to/from double."] - [(<| /.int-to-char /.long-to-int) (<| /.int-to-long /.char-to-int) "Can succesfully convert to/from char."] - )) - )))) - -(def: miscellaneous - Test - (do r.monad - [sample (r.ascii 1)] - ($_ _.and - (_.test "Can check if an object is of a certain class." - (and (case (/.check String sample) (#.Some _) true #.None false) - (case (/.check Long sample) (#.Some _) false #.None true) - (case (/.check Object sample) (#.Some _) true #.None false) - (case (/.check Object (/.null)) (#.Some _) false #.None true))) - - (_.test "Can run code in a 'synchronized' block." - (/.synchronized sample #1)) - - (_.test "Can access Class instances." - (text;= "java.lang.Class" (Class::getName (/.class-for java/lang/Class)))) - - (_.test "Can check if a value is null." - (and (/.null? (/.null)) - (not (/.null? sample)))) - - (_.test "Can safely convert nullable references into Maybe values." - (and (|> (: (Maybe Object) (/.??? (/.null))) - (case> #.None #1 - _ #0)) - (|> (: (Maybe Object) (/.??? sample)) - (case> (#.Some _) #1 - _ #0)))) - ))) - -(def: arrays - Test - (do r.monad - [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) - idx (|> r.nat (:: @ map (n/% size))) - value r.int] - ($_ _.and - (_.test "Can create arrays of some length." - (n/= size (/.array-length (/.array Long size)))) - - (_.test "Can set and get array values." - (let [arr (/.array Long size)] - (exec (/.array-write idx value arr) - (i/= value (/.array-read idx arr)))))))) - -(def: #export test - ($_ _.and - (<| (_.context "Conversions.") - ..conversions) - (<| (_.context "Miscellaneous.") - ..miscellaneous) - (<| (_.context "Arrays.") - ..arrays))) diff --git a/stdlib/source/test/lux/host.old.lux b/stdlib/source/test/lux/host.old.lux new file mode 100644 index 000000000..04c149881 --- /dev/null +++ b/stdlib/source/test/lux/host.old.lux @@ -0,0 +1,134 @@ +(.module: + [lux #* + [abstract/monad (#+ Monad do)] + [control + pipe] + [data + ["." text ("#;." equivalence)]] + [math + ["r" random]] + ["_" test (#+ Test)]] + {1 + ["." / (#+ import: class: interface: object)]}) + +(import: (java/util/concurrent/Callable a)) + +(import: java/lang/Exception + (new [String])) + +(import: java/lang/Object) + +(import: (java/lang/Class a) + (getName [] String)) + +(import: java/lang/System + (#static out java/io/PrintStream) + (#static currentTimeMillis [] #io long) + (#static getenv [String] #io #? String)) + +(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 + [])) + +(def: test-runnable + (object [] [Runnable] + [] + (Runnable [] (run) void + []))) + +(def: test-callable + (object [a] [(Callable a)] + [] + (Callable [] (call) a + (undefined)))) + +(interface: TestInterface + ([] foo [boolean String] void #throws [Exception])) + +(def: conversions + Test + (do r.monad + [sample r.int] + (`` ($_ _.and + (~~ (template [ ] + [(_.test + (or (|> sample (i/= sample)) + (let [capped-sample (|> sample )] + (|> capped-sample (i/= capped-sample)))))] + + [/.long-to-byte /.byte-to-long "Can succesfully convert to/from byte."] + [/.long-to-short /.short-to-long "Can succesfully convert to/from short."] + [/.long-to-int /.int-to-long "Can succesfully convert to/from int."] + [/.long-to-float /.float-to-long "Can succesfully convert to/from float."] + [/.long-to-double /.double-to-long "Can succesfully convert to/from double."] + [(<| /.int-to-char /.long-to-int) (<| /.int-to-long /.char-to-int) "Can succesfully convert to/from char."] + )) + )))) + +(def: miscellaneous + Test + (do r.monad + [sample (r.ascii 1)] + ($_ _.and + (_.test "Can check if an object is of a certain class." + (and (case (/.check String sample) (#.Some _) true #.None false) + (case (/.check Long sample) (#.Some _) false #.None true) + (case (/.check Object sample) (#.Some _) true #.None false) + (case (/.check Object (/.null)) (#.Some _) false #.None true))) + + (_.test "Can run code in a 'synchronized' block." + (/.synchronized sample #1)) + + (_.test "Can access Class instances." + (text;= "java.lang.Class" (Class::getName (/.class-for java/lang/Class)))) + + (_.test "Can check if a value is null." + (and (/.null? (/.null)) + (not (/.null? sample)))) + + (_.test "Can safely convert nullable references into Maybe values." + (and (|> (: (Maybe Object) (/.??? (/.null))) + (case> #.None #1 + _ #0)) + (|> (: (Maybe Object) (/.??? sample)) + (case> (#.Some _) #1 + _ #0)))) + ))) + +(def: arrays + Test + (do r.monad + [size (|> r.nat (:: @ map (|>> (n/% 100) (n/max 1)))) + idx (|> r.nat (:: @ map (n/% size))) + value r.int] + ($_ _.and + (_.test "Can create arrays of some length." + (n/= size (/.array-length (/.array Long size)))) + + (_.test "Can set and get array values." + (let [arr (/.array Long size)] + (exec (/.array-write idx value arr) + (i/= value (/.array-read idx arr)))))))) + +(def: #export test + ($_ _.and + (<| (_.context "Conversions.") + ..conversions) + (<| (_.context "Miscellaneous.") + ..miscellaneous) + (<| (_.context "Arrays.") + ..arrays))) diff --git a/stdlib/source/test/lux/host/jvm.jvm.lux b/stdlib/source/test/lux/host/jvm.jvm.lux deleted file mode 100644 index 47c6f35d9..000000000 --- a/stdlib/source/test/lux/host/jvm.jvm.lux +++ /dev/null @@ -1,89 +0,0 @@ -(.module: - [lux #* - [abstract/monad (#+ do)] - [control - ["." io (#+ IO)] - [concurrency - ["." atom]] - [security - ["!" capability]]] - [data - ["." error (#+ Error)] - ["." text - format] - [format - ["." binary]] - [collection - ["." dictionary] - ["." row]]] - [world - ["." file (#+ File)] - [binary (#+ Binary)]] - [math - ["r" random]] - ["_" test (#+ Test)]] - {1 - ["." / #_ - ["#." loader (#+ Library)] - ["#." version] - ["#." name] - ["#." descriptor] - ["#." field] - ["#." class] - [modifier - ["#.M" inner]]]}) - -(def: (write-class! name bytecode) - (-> Text Binary (IO Text)) - (let [file-path (format name ".class")] - (do io.monad - [outcome (do (error.with @) - [file (: (IO (Error (File IO))) - (file.get-file io.monad file.system file-path))] - (!.use (:: file over-write) bytecode))] - (wrap (case outcome - (#error.Success definition) - (format "Wrote: " (%t file-path)) - - (#error.Failure error) - error))))) - -(def: class - Test - (do r.monad - [_ (wrap []) - #let [package "my.package" - name "MyClass" - full-name (format package "." name) - input (/class.class /version.v6_0 /class.public - (/name.internal "java.lang.Object") - (/name.internal full-name) - (list (/name.internal "java.io.Serializable") - (/name.internal "java.lang.Runnable")) - (list (/field.field /field.public "foo" /descriptor.long (row.row)) - (/field.field /field.public "bar" /descriptor.double (row.row))) - (row.row) - (row.row)) - bytecode (binary.write /class.format input) - loader (/loader.memory (/loader.new-library []))]] - ($_ _.and - (_.test "Can read a generated class." - (case (binary.read /class.format bytecode) - (#error.Success output) - (:: /class.equivalence = input output) - - (#error.Failure error) - false)) - (_.test "Can generate a class." - (case (/loader.define full-name bytecode loader) - (#error.Success definition) - true - - (#error.Failure error) - false)) - ))) - -(def: #export test - Test - (<| (_.context "Class") - ..class)) diff --git a/stdlib/source/test/lux/host/jvm.old.lux b/stdlib/source/test/lux/host/jvm.old.lux new file mode 100644 index 000000000..47c6f35d9 --- /dev/null +++ b/stdlib/source/test/lux/host/jvm.old.lux @@ -0,0 +1,89 @@ +(.module: + [lux #* + [abstract/monad (#+ do)] + [control + ["." io (#+ IO)] + [concurrency + ["." atom]] + [security + ["!" capability]]] + [data + ["." error (#+ Error)] + ["." text + format] + [format + ["." binary]] + [collection + ["." dictionary] + ["." row]]] + [world + ["." file (#+ File)] + [binary (#+ Binary)]] + [math + ["r" random]] + ["_" test (#+ Test)]] + {1 + ["." / #_ + ["#." loader (#+ Library)] + ["#." version] + ["#." name] + ["#." descriptor] + ["#." field] + ["#." class] + [modifier + ["#.M" inner]]]}) + +(def: (write-class! name bytecode) + (-> Text Binary (IO Text)) + (let [file-path (format name ".class")] + (do io.monad + [outcome (do (error.with @) + [file (: (IO (Error (File IO))) + (file.get-file io.monad file.system file-path))] + (!.use (:: file over-write) bytecode))] + (wrap (case outcome + (#error.Success definition) + (format "Wrote: " (%t file-path)) + + (#error.Failure error) + error))))) + +(def: class + Test + (do r.monad + [_ (wrap []) + #let [package "my.package" + name "MyClass" + full-name (format package "." name) + input (/class.class /version.v6_0 /class.public + (/name.internal "java.lang.Object") + (/name.internal full-name) + (list (/name.internal "java.io.Serializable") + (/name.internal "java.lang.Runnable")) + (list (/field.field /field.public "foo" /descriptor.long (row.row)) + (/field.field /field.public "bar" /descriptor.double (row.row))) + (row.row) + (row.row)) + bytecode (binary.write /class.format input) + loader (/loader.memory (/loader.new-library []))]] + ($_ _.and + (_.test "Can read a generated class." + (case (binary.read /class.format bytecode) + (#error.Success output) + (:: /class.equivalence = input output) + + (#error.Failure error) + false)) + (_.test "Can generate a class." + (case (/loader.define full-name bytecode loader) + (#error.Success definition) + true + + (#error.Failure error) + false)) + ))) + +(def: #export test + Test + (<| (_.context "Class") + ..class)) -- cgit v1.2.3