From ad2bd2abad4d7e014791257af066aa964c5c5aa5 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Sun, 3 Sep 2023 18:10:49 -0400 Subject: [PATCH] Eliminated the bootstrapping compiler --- .gitignore | 5 - lux-bootstrapper/commands.md | 35 - lux-bootstrapper/project.clj | 45 - lux-bootstrapper/src/lux.clj | 41 - lux-bootstrapper/src/lux/analyser.clj | 206 -- lux-bootstrapper/src/lux/analyser/base.clj | 130 -- lux-bootstrapper/src/lux/analyser/case.clj | 662 ------ lux-bootstrapper/src/lux/analyser/env.clj | 81 - .../src/lux/analyser/function.clj | 31 - lux-bootstrapper/src/lux/analyser/lux.clj | 737 ------- lux-bootstrapper/src/lux/analyser/module.clj | 438 ---- lux-bootstrapper/src/lux/analyser/parser.clj | 484 ----- .../src/lux/analyser/proc/common.clj | 278 --- .../src/lux/analyser/proc/jvm.clj | 1094 ---------- lux-bootstrapper/src/lux/analyser/record.clj | 132 -- lux-bootstrapper/src/lux/base.clj | 1544 -------------- lux-bootstrapper/src/lux/compiler.clj | 32 - lux-bootstrapper/src/lux/compiler/cache.clj | 211 -- .../src/lux/compiler/cache/ann.clj | 127 -- .../src/lux/compiler/cache/type.clj | 146 -- lux-bootstrapper/src/lux/compiler/core.clj | 83 - lux-bootstrapper/src/lux/compiler/io.clj | 39 - lux-bootstrapper/src/lux/compiler/jvm.clj | 273 --- .../src/lux/compiler/jvm/base.clj | 95 - .../src/lux/compiler/jvm/cache.clj | 66 - .../src/lux/compiler/jvm/case.clj | 210 -- .../src/lux/compiler/jvm/function.clj | 281 --- lux-bootstrapper/src/lux/compiler/jvm/lux.clj | 406 ---- .../src/lux/compiler/jvm/proc/common.clj | 447 ---- .../src/lux/compiler/jvm/proc/host.clj | 1142 ----------- lux-bootstrapper/src/lux/compiler/jvm/rt.clj | 409 ---- .../src/lux/compiler/parallel.clj | 48 - lux-bootstrapper/src/lux/host.clj | 488 ----- lux-bootstrapper/src/lux/host/generics.clj | 210 -- lux-bootstrapper/src/lux/lexer.clj | 133 -- lux-bootstrapper/src/lux/lib/loader.clj | 45 - lux-bootstrapper/src/lux/optimizer.clj | 1207 ----------- lux-bootstrapper/src/lux/parser.clj | 88 - lux-bootstrapper/src/lux/reader.clj | 156 -- lux-bootstrapper/src/lux/repl.clj | 90 - lux-bootstrapper/src/lux/type.clj | 963 --------- lux-bootstrapper/src/lux/type/host.clj | 422 ---- lux-cl/source/program.lux | 2 +- lux-lua/source/program.lux | 1584 ++++++++------- lux-php/source/program.lux | 2 +- lux-python/source/program.lux | 904 +++++---- lux-r/source/program.lux | 2 +- lux-scheme/source/program.lux | 2 +- stdlib/source/library/lux.lux | 31 +- stdlib/source/library/lux/abstract/apply.lux | 12 +- .../source/library/lux/abstract/functor.lux | 19 +- stdlib/source/library/lux/algorithm/mix.lux | 18 +- .../library/lux/control/concurrency/atom.lux | 44 +- .../lux/control/concurrency/thread.lux | 186 +- stdlib/source/library/lux/control/writer.lux | 10 +- .../library/lux/data/collection/list.lux | 6 +- .../lux/data/collection/tree/zipper.lux | 53 +- stdlib/source/library/lux/data/text.lux | 29 +- .../source/library/lux/data/text/buffer.lux | 257 ++- .../library/lux/data/text/encoding/utf8.lux | 194 +- stdlib/source/library/lux/debug.lux | 592 +++--- stdlib/source/library/lux/ffi.old.lux | 1790 ----------------- stdlib/source/library/lux/math.lux | 313 ++- .../library/lux/math/geometry/circle.lux | 18 +- stdlib/source/library/lux/math/number/dec.lux | 37 +- stdlib/source/library/lux/math/number/i32.lux | 29 +- stdlib/source/library/lux/math/random.lux | 75 +- .../lux/meta/compiler/default/platform.lux | 13 +- .../lux/meta/compiler/meta/cache/module.lux | 3 +- .../lux/meta/compiler/meta/cli/compiler.lux | 2 +- .../lux/meta/compiler/meta/io/archive.lux | 14 +- .../lux/meta/compiler/target/jvm/constant.lux | 8 +- .../lux/meta/compiler/target/jvm/loader.lux | 43 +- .../meta/compiler/target/jvm/reflection.lux | 2 +- .../lux/meta/compiler/target/jvm/type/lux.lux | 2 +- .../compiler/target/jvm/type/projection.lux | 2 +- .../library/lux/meta/compiler/target/php.lux | 2 +- stdlib/source/library/lux/meta/extension.lux | 6 +- .../source/library/lux/meta/type/object.lux | 17 +- stdlib/source/library/lux/program.lux | 3 +- stdlib/source/library/lux/web/html.lux | 2 +- stdlib/source/library/lux/web/html/tag.lux | 2 +- stdlib/source/library/lux/world/console.lux | 242 ++- .../source/library/lux/world/environment.lux | 527 +++-- stdlib/source/library/lux/world/file.lux | 1606 ++++++++------- .../source/library/lux/world/file/watch.lux | 419 ++-- .../library/lux/world/net/http/client.lux | 434 ++-- stdlib/source/library/lux/world/shell.lux | 289 +-- .../source/library/lux/world/time/instant.lux | 3 +- stdlib/source/projection/lux/meta/type.lux | 2 +- stdlib/source/projection/lux/program.lux | 2 +- stdlib/source/test/lux.lux | 186 +- .../source/test/lux/abstract/equivalence.lux | 10 +- stdlib/source/test/lux/abstract/functor.lux | 132 +- stdlib/source/test/lux/data/format/json.lux | 16 +- stdlib/source/test/lux/ffi.old.lux | 254 --- stdlib/source/test/lux/math/number/dec.lux | 96 +- stdlib/source/test/lux/meta.lux | 3 +- stdlib/source/test/lux/meta/compiler.lux | 3 +- .../test/lux/meta/compiler/target/jvm.lux | 196 +- stdlib/source/test/lux/meta/extension.lux | 273 ++- stdlib/source/test/lux/meta/static.lux | 1 - stdlib/source/unsafe/lux/data/binary.lux | 228 +-- .../unsafe/lux/data/collection/array.lux | 168 +- to_do.md | 2 +- 105 files changed, 4493 insertions(+), 20689 deletions(-) delete mode 100644 lux-bootstrapper/commands.md delete mode 100644 lux-bootstrapper/project.clj delete mode 100644 lux-bootstrapper/src/lux.clj delete mode 100644 lux-bootstrapper/src/lux/analyser.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/base.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/case.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/env.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/function.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/lux.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/module.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/parser.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/proc/common.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/proc/jvm.clj delete mode 100644 lux-bootstrapper/src/lux/analyser/record.clj delete mode 100644 lux-bootstrapper/src/lux/base.clj delete mode 100644 lux-bootstrapper/src/lux/compiler.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/cache.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/cache/ann.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/cache/type.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/core.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/io.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/base.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/cache.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/case.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/function.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/lux.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/jvm/rt.clj delete mode 100644 lux-bootstrapper/src/lux/compiler/parallel.clj delete mode 100644 lux-bootstrapper/src/lux/host.clj delete mode 100644 lux-bootstrapper/src/lux/host/generics.clj delete mode 100644 lux-bootstrapper/src/lux/lexer.clj delete mode 100644 lux-bootstrapper/src/lux/lib/loader.clj delete mode 100644 lux-bootstrapper/src/lux/optimizer.clj delete mode 100644 lux-bootstrapper/src/lux/parser.clj delete mode 100644 lux-bootstrapper/src/lux/reader.clj delete mode 100644 lux-bootstrapper/src/lux/repl.clj delete mode 100644 lux-bootstrapper/src/lux/type.clj delete mode 100644 lux-bootstrapper/src/lux/type/host.clj delete mode 100644 stdlib/source/library/lux/ffi.old.lux delete mode 100644 stdlib/source/test/lux/ffi.old.lux diff --git a/.gitignore b/.gitignore index 7420bd537a..61f64bf1b4 100644 --- a/.gitignore +++ b/.gitignore @@ -11,11 +11,6 @@ aedifex.jar /lux-jvm-function/RELEASE -/lux-bootstrapper/RELEASE -/lux-bootstrapper/target -/lux-bootstrapper/classes -/lux-bootstrapper/checkouts - /lux-lein/RELEASE /lux-lein/target diff --git a/lux-bootstrapper/commands.md b/lux-bootstrapper/commands.md deleted file mode 100644 index aca53f2a90..0000000000 --- a/lux-bootstrapper/commands.md +++ /dev/null @@ -1,35 +0,0 @@ -``` -cd ~/lux && grep -r "" --include *.clj | sort -``` - -# Install - -``` -cd ~/lux/lux-bootstrapper/ \ -&& lein clean \ -&& lein install -``` - -# Release - -``` -LUX_VERSION=0.7.0 && \ -cd ~/lux/lux-bootstrapper/ && \ -lein pom && \ -mv pom.xml RELEASE/lux-bootstrapper-$LUX_VERSION.pom && \ -cp ~/.m2/repository/com/github/luxlang/lux-bootstrapper/$LUX_VERSION/lux-bootstrapper-$LUX_VERSION.jar RELEASE && \ -cd RELEASE && \ -touch README.md && \ -zip lux-bootstrapper-$LUX_VERSION-sources.jar README.md && \ -zip lux-bootstrapper-$LUX_VERSION-javadoc.jar README.md && \ -rm README.md && \ -for file in *.*; do gpg -ab $file; done -``` - -# Run JBE (Read generated bytecode) - -``` -cd ~/lux/jbe/bin/ \ -&& java ee.ioc.cs.jbe.browser.BrowserApplication -``` - diff --git a/lux-bootstrapper/project.clj b/lux-bootstrapper/project.clj deleted file mode 100644 index 0335da3199..0000000000 --- a/lux-bootstrapper/project.clj +++ /dev/null @@ -1,45 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(def version "0.8.0-SNAPSHOT") - -(defproject com.github.luxlang/lux-bootstrapper #=(identity version) - :min-lein-version "2.1.0" ;; 2.1.0 introduced jar classifiers - :description "The JVM (bootstrapping) compiler for the Lux programming language." - :url "https://github.com/LuxLang/lux" - :license {:name "Lux License v0.1.2" - :url "https://github.com/LuxLang/lux/blob/master/license.txt"} - :deploy-repositories [["releases" {:url "https://oss.sonatype.org/service/local/staging/deploy/maven2/" - :creds :gpg}] - ["snapshots" {:url "https://oss.sonatype.org/content/repositories/snapshots/" - :creds :gpg}]] - :pom-addition [:developers [:developer - [:name "Eduardo Julian"] - [:url "https://github.com/eduardoejp"]]] - :dependencies [[org.clojure/clojure "1.6.0"] - [org.clojure/core.match "0.2.1"] - - [com.github.luxlang/lux-jvm-function "0.6.5"] - - ;; Prefer when building JS compiler. - [org.ow2.asm/asm "7.3.1"] - [org.ow2.asm/asm-commons "7.3.1"] - [org.ow2.asm/asm-analysis "7.3.1"] - [org.ow2.asm/asm-tree "7.3.1"] - [org.ow2.asm/asm-util "7.3.1"]] - :warn-on-reflection true - :repositories [["snapshots" "https://oss.sonatype.org/content/repositories/snapshots/"]] - :source-paths ["src"] - - :scm {:name "git" - :url "https://github.com/LuxLang/lux.git"} - - :main lux - :profiles {:uberjar {:classifiers {:sources {:resource-paths ["src"]} - :javadoc {:resource-paths ["src"]}} - :aot [lux]}} - - :jvm-opts ^:replace ["-server" "-Xms2048m" "-Xmx2048m" - "-Xss16m" - "-XX:+OptimizeStringConcat"] - ) diff --git a/lux-bootstrapper/src/lux.clj b/lux-bootstrapper/src/lux.clj deleted file mode 100644 index 29b245f81b..0000000000 --- a/lux-bootstrapper/src/lux.clj +++ /dev/null @@ -1,41 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux - (:gen-class) - (:require [lux.base :as & :refer [|let |do return return* |case]] - [lux.compiler :as &compiler] - [lux.repl :as &repl] - [clojure.string :as string] - :reload-all) - (:import (java.io File))) - -(def unit-separator - (str (char 31))) - -(defn- separate-paths - "(-> Text (List Text))" - [paths] - (-> paths - (string/replace unit-separator "\n") - string/split-lines - rest - &/->list)) - -(defn -main [& args] - (|case (&/->list args) - (&/$Item "release" (&/$Item program-module (&/$Item program-definition (&/$Item dependencies (&/$Item source-dirs (&/$Item target-dir (&/$End))))))) - (&compiler/compile-program &/$Build - program-module - program-definition - (separate-paths dependencies) - (separate-paths source-dirs) - target-dir) - - (&/$Item "repl" (&/$Item dependencies (&/$Item source-dirs (&/$Item target-dir (&/$End))))) - (&repl/repl (separate-paths dependencies) - (separate-paths source-dirs) - target-dir) - - _ - (println "Cannot understand command."))) diff --git a/lux-bootstrapper/src/lux/analyser.clj b/lux-bootstrapper/src/lux/analyser.clj deleted file mode 100644 index 8539546ab7..0000000000 --- a/lux-bootstrapper/src/lux/analyser.clj +++ /dev/null @@ -1,206 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return return* |case]] - [reader :as &reader] - [parser :as &parser] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &&] - [lux :as &&lux] - [module :as &&module] - [parser :as &&a-parser]) - (lux.analyser.proc [common :as &&common] - [jvm :as &&jvm]))) - -;; [Utils] -(defn ^:private just-analyse [analyser syntax] - (&type/with-var - (fn [?var] - (|do [[[?output-type ?output-location] ?output-term] (&&/analyse-1 analyser ?var syntax)] - (|case [?var ?output-type] - [(&/$Var ?e-id) (&/$Var ?a-id)] - (if (= ?e-id ?a-id) - (|do [=output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-location ?output-term))) - (|do [=output-type (&type/clean ?var ?var)] - (return (&&/|meta =output-type ?output-location ?output-term)))) - - [_ _] - (|do [=output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-location ?output-term)))) - )))) - -(defn ^:private analyse-ast [optimize eval! compile-module ^"[Ljava.lang.Object;" compilers exo-type ?token] - (|let [analyse (partial analyse-ast optimize eval! compile-module compilers) - [location token] ?token - compile-def (aget compilers 0) - macro-caller (aget compilers 1)] - (|case token - ;; Standard special forms - (&/$Bit ?value) - (|do [_ (&type/check exo-type &type/Bit)] - (return (&/|list (&&/|meta exo-type location (&&/$bit ?value))))) - - (&/$Nat ?value) - (|do [_ (&type/check exo-type &type/Nat)] - (return (&/|list (&&/|meta exo-type location (&&/$nat ?value))))) - - (&/$Int ?value) - (|do [_ (&type/check exo-type &type/Int)] - (return (&/|list (&&/|meta exo-type location (&&/$int ?value))))) - - (&/$Rev ?value) - (|do [_ (&type/check exo-type &type/Rev)] - (return (&/|list (&&/|meta exo-type location (&&/$rev ?value))))) - - (&/$Dec ?value) - (|do [_ (&type/check exo-type &type/Dec)] - (return (&/|list (&&/|meta exo-type location (&&/$dec ?value))))) - - (&/$Text ?value) - (|do [_ (&type/check exo-type &type/Text)] - (return (&/|list (&&/|meta exo-type location (&&/$text ?value))))) - - (&/$Variant (&/$Item [command-meta command] parameters)) - (|case command - (&/$Bit ?right) - (&/with-analysis-meta location exo-type - (&&lux/analyse-variant analyse (&/$Right exo-type) 0 ?right parameters)) - - (&/$Nat lefts) - (|let [(&/$Item [_ (&/$Bit ?right)] parameters*) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-variant analyse (&/$Right exo-type) lefts ?right parameters*))) - - (&/$Identifier ?ident) - (&/with-analysis-meta location exo-type - (|do [[normal-module normal-short] (&/normalize ?ident)] - (&&lux/analyse-variant+ analyse exo-type normal-module normal-short parameters))) - - _ - (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (&/show-ast (&/T [(&/T ["" -1 -1]) token]))))) - - (&/$Tuple ?elems) - (&/with-analysis-meta location exo-type - (&&lux/analyse-record analyse exo-type ?elems)) - - (&/$Identifier ?ident) - (&/with-analysis-meta location exo-type - (|let [[quoted_module quoted_line quoted_column] location] - (&&lux/analyse-identifier analyse exo-type quoted_module ?ident))) - - (&/$Form (&/$Item [command-meta command] parameters)) - (|case command - (&/$Identifier "library/lux" "def#") - (|let [(&/$Item [_ (&/$Identifier "" ?name)] - (&/$Item ?value - (&/$Item exported? - (&/$End)) - )) parameters] - (&/with-location location - (&&lux/analyse-def analyse optimize eval! compile-def ?name ?value exported?))) - - (&/$Identifier "library/lux" "module#") - (|let [(&/$Item ?imports (&/$End)) parameters] - (&/with-location location - (&&lux/analyse-module analyse optimize eval! compile-module ?imports))) - - (&/$Identifier "library/lux" "is#") - (|let [(&/$Item ?type - (&/$Item ?value - (&/$End))) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-type-check analyse optimize eval! exo-type ?type ?value))) - - (&/$Identifier "library/lux" "as#") - (|let [(&/$Item ?type - (&/$Item ?value - (&/$End))) parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-type-as analyse optimize eval! exo-type ?type ?value))) - - (&/$Identifier "library/lux" "is_type#") - (|let [(&/$Item ?value (&/$End)) parameters] - (analyse-ast optimize eval! compile-module compilers &type/Type ?value)) - - (&/$Identifier "library/lux" "in_module#") - (|let [(&/$Item ?module (&/$Item ?expr (&/$End))) parameters] - (&/with-location location - (|do [module (&&lux/eval analyse optimize eval! &type/Text ?module)] - (&/with-module module - (analyse exo-type ?expr))))) - - (&/$Identifier "library/lux" "universe#") - (|do [_ (&type/check exo-type &type/Nat)] - (return (&/|list (&&/|meta exo-type location (&&/$nat 0))))) - - ;; Pattern-matching syntax. - (&/$Identifier "library/lux" "when#") - (|let [(&/$Item ?input ?pattern-matching) parameters] - (if (even? (&/|length ?pattern-matching)) - (&/with-analysis-meta location exo-type - (&&lux/analyse-case analyse exo-type ?input (&/|as-pairs ?pattern-matching))) - (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (&/show-ast (&/T [(&/T ["" -1 -1]) token])))))) - - ;; Function syntax. - (&/$Identifier "library/lux" "function#") - (|let [(&/$Item [_ (&/$Identifier "" ?self)] - (&/$Item [_ (&/$Identifier "" ?arg)] - (&/$Item ?body - (&/$End)))) - parameters] - (&/with-analysis-meta location exo-type - (&&lux/analyse-function analyse exo-type ?self ?arg ?body))) - - (&/$Identifier "library/lux" extension) - (if (&&common/uses_new_format? extension) - (&/with-analysis-meta location exo-type - (&&common/analyse-proc analyse exo-type extension parameters)) - (&/with-location location - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse location exo-type macro-caller =fn parameters)))) - - (&/$Text ?procedure) - (case ?procedure - ;; else - (&/with-analysis-meta location exo-type - (cond (.startsWith ^String ?procedure "jvm") - (|do [_ &/jvm-host] - (&&jvm/analyse-host analyse exo-type compilers ?procedure parameters)) - - :else - (&&common/analyse-proc analyse exo-type ?procedure parameters)))) - - _ - (&/with-location location - (|do [=fn (just-analyse analyse (&/T [command-meta command]))] - (&&lux/analyse-apply analyse location exo-type macro-caller =fn parameters)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Unknown syntax: " (&/show-ast (&/T [(&/T ["" -1 -1]) token])))) - ))) - -;; [Resources] -(defn analyse [optimize eval! compile-module compilers] - (|do [asts &parser/parse] - (&/flat-map% (partial analyse-ast optimize eval! compile-module compilers &type/Nothing) asts))) - -(defn clean-output [?var analysis] - (|do [:let [[[?output-type ?output-location] ?output-term] analysis] - =output-type (&type/clean ?var ?output-type)] - (return (&&/|meta =output-type ?output-location ?output-term)))) - -(defn repl-analyse [optimize eval! compile-module compilers] - (|do [asts &parser/parse] - (&/flat-map% (fn [ast] - (&type/with-var - (fn [?var] - (|do [=outputs (&/with-closure - (analyse-ast optimize eval! compile-module compilers ?var ast))] - (&/map% (partial clean-output ?var) =outputs))))) - asts))) diff --git a/lux-bootstrapper/src/lux/analyser/base.clj b/lux-bootstrapper/src/lux/analyser/base.clj deleted file mode 100644 index 578b6e8207..0000000000 --- a/lux-bootstrapper/src/lux/analyser/base.clj +++ /dev/null @@ -1,130 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.base - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant |let |do return* return |case]] - [type :as &type]))) - -;; [Tags] -(defvariant - ("bit" 1) - ("nat" 1) - ("int" 1) - ("rev" 1) - ("dec" 1) - ("text" 1) - ("variant" 3) - ("tuple" 1) - ("apply" 2) - ("case" 2) - ("function" 4) - ("ann" 2) - ("def" 1) - ("var" 1) - ("captured" 1) - ("proc" 3) - ) - -;; [Exports] -(defn expr-meta [analysis] - (|let [[meta _] analysis] - meta)) - -(defn expr-type* [analysis] - (|let [[[type _] _] analysis] - type)) - -(defn expr-term [analysis] - (|let [[[type _] term] analysis] - term)) - -(defn with-type [new-type analysis] - (|let [[[type location] adt] analysis] - (&/T [(&/T [new-type location]) adt]))) - -(defn clean-analysis - "(-> Type Analysis (Lux Analysis))" - [$var an] - (|do [=an-type (&type/clean $var (expr-type* an))] - (return (with-type =an-type an)))) - -(def jvm-this "_jvm_this") - -(defn cap-1 [action] - (|do [result action] - (|case result - (&/$Item x (&/$End)) - (return x) - - _ - (&/fail-with-loc "[Analyser Error] Macro cannot expand to more than 1 output.")))) - -(defn analyse-1 [analyse exo-type elem] - (&/with-expected-type exo-type - (cap-1 (analyse exo-type elem)))) - -(defn analyse-1+ [analyse ?token] - (&type/with-var - (fn [$var] - (|do [=expr (analyse-1 analyse $var ?token)] - (clean-analysis $var =expr))))) - -(defn resolved-ident [ident] - (|do [:let [[?module ?name] ident] - module* (if (.equals "" ?module) - &/get-module-name - (return ?module))] - (return (&/T [module* ?name])))) - -(let [tag-names #{"Nominal" "Sum" "Product" "Function" "Parameter" "Var" "Ex" "Universal" "Existential" "Apply" "Named"}] - (defn type-tag? [module name] - (and (= &/prelude module) - (contains? tag-names name)))) - -(defn |meta [type location analysis] - (&/T [(&/T [type location]) analysis])) - -(defn de-meta - "(-> Analysis Analysis)" - [analysis] - (|let [[meta analysis-] analysis] - (|case analysis- - ($variant idx is-last? value) - ($variant idx is-last? (de-meta value)) - - ($tuple elems) - ($tuple (&/|map de-meta elems)) - - ($apply func args) - ($apply (de-meta func) - (&/|map de-meta args)) - - ($case value branches) - ($case (de-meta value) - (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [_pattern (de-meta _body)]))) - branches)) - - ($function _register-offset scope captured body) - ($function _register-offset scope - (&/|map (fn [branch] - (|let [[_name _captured] branch] - (&/T [_name (de-meta _captured)]))) - captured) - (de-meta body)) - - ($ann value-expr type-expr) - (de-meta value-expr) - - ($captured scope idx source) - ($captured scope idx (de-meta source)) - - ($proc proc-ident args special-args) - ($proc proc-ident (&/|map de-meta args) special-args) - - _ - analysis- - ))) diff --git a/lux-bootstrapper/src/lux/analyser/case.clj b/lux-bootstrapper/src/lux/analyser/case.clj deleted file mode 100644 index c87540d079..0000000000 --- a/lux-bootstrapper/src/lux/analyser/case.clj +++ /dev/null @@ -1,662 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.case - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant |do return |let |case]] - [parser :as &parser] - [type :as &type]) - (lux.analyser [base :as &&] - [env :as &env] - [module :as &module] - [record :as &&record]))) - -;; [Tags] -(defvariant - ("DefaultTotal" 1) - ("BitTotal" 2) - ("NatTotal" 2) - ("IntTotal" 2) - ("RevTotal" 2) - ("DecTotal" 2) - ("TextTotal" 2) - ("TupleTotal" 2) - ("VariantTotal" 2)) - -(defvariant - ("NoTestAC" 0) - ("StoreTestAC" 1) - ("BitTestAC" 1) - ("NatTestAC" 1) - ("IntTestAC" 1) - ("RevTestAC" 1) - ("DecTestAC" 1) - ("TextTestAC" 1) - ("TupleTestAC" 1) - ("VariantTestAC" 1)) - -;; [Utils] -(def ^:private unit-tuple - (&/T [(&/T ["" -1 -1]) (&/$Tuple &/$End)])) - -(defn ^:private resolve-type [type] - (if (&type/type= &type/Any type) - (return type) - (|case type - (&/$Var ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (&/fail-with-loc "##1##")))] - (resolve-type type*)) - - (&/$Universal _) - (|do [$var &type/existential - =type (&type/apply-type type $var) - ==type (&type/actual-type =type)] - (resolve-type ==type)) - - (&/$Existential _ _) - (|do [$var &type/existential - =type (&type/apply-type type $var) - ==type (&type/actual-type =type)] - (resolve-type ==type)) - - _ - (&type/actual-type type)))) - -(defn update-up-frame [frame] - (|let [[_env _idx _var] frame] - (&/T [_env (+ 2 _idx) _var]))) - -(defn clean! [level ?tid parameter-idx type] - (|case type - (&/$Var ?id) - (if (= ?tid ?id) - (&/$Parameter (+ (* 2 level) parameter-idx)) - type) - - (&/$Nominal ?name ?params) - (&/$Nominal ?name (&/|map (partial clean! level ?tid parameter-idx) - ?params)) - - (&/$Function ?arg ?return) - (&/$Function (clean! level ?tid parameter-idx ?arg) - (clean! level ?tid parameter-idx ?return)) - - (&/$Apply ?param ?lambda) - (&/$Apply (clean! level ?tid parameter-idx ?param) - (clean! level ?tid parameter-idx ?lambda)) - - (&/$Product ?left ?right) - (&/$Product (clean! level ?tid parameter-idx ?left) - (clean! level ?tid parameter-idx ?right)) - - (&/$Sum ?left ?right) - (&/$Sum (clean! level ?tid parameter-idx ?left) - (clean! level ?tid parameter-idx ?right)) - - (&/$Universal ?env ?body) - (&/$Universal (&/|map (partial clean! level ?tid parameter-idx) ?env) - (clean! (inc level) ?tid parameter-idx ?body)) - - (&/$Existential ?env ?body) - (&/$Existential (&/|map (partial clean! level ?tid parameter-idx) ?env) - (clean! (inc level) ?tid parameter-idx ?body)) - - _ - type - )) - -(defn beta-reduce! [level env type] - (|case type - (&/$Nominal ?name ?params) - (&/$Nominal ?name (&/|map (partial beta-reduce! level env) ?params)) - - (&/$Sum ?left ?right) - (&/$Sum (beta-reduce! level env ?left) - (beta-reduce! level env ?right)) - - (&/$Product ?left ?right) - (&/$Product (beta-reduce! level env ?left) - (beta-reduce! level env ?right)) - - (&/$Apply ?type-arg ?type-fn) - (&/$Apply (beta-reduce! level env ?type-arg) - (beta-reduce! level env ?type-fn)) - - (&/$Universal ?local-env ?local-def) - (|case ?local-env - (&/$End) - (&/$Universal ?local-env (beta-reduce! (inc level) env ?local-def)) - - _ - type) - - (&/$Existential ?local-env ?local-def) - (|case ?local-env - (&/$End) - (&/$Existential ?local-env (beta-reduce! (inc level) env ?local-def)) - - _ - type) - - (&/$Function ?input ?output) - (&/$Function (beta-reduce! level env ?input) - (beta-reduce! level env ?output)) - - (&/$Parameter ?idx) - (|case (&/|at (- ?idx (* 2 level)) env) - (&/$Some parameter) - (beta-reduce! level env parameter) - - _ - type) - - _ - type - )) - -(defn apply-type! [type-fn param] - (|case type-fn - (&/$Universal local-env local-def) - (return (beta-reduce! 0 (->> local-env - (&/$Item param) - (&/$Item type-fn)) - local-def)) - - (&/$Existential local-env local-def) - (return (beta-reduce! 0 (->> local-env - (&/$Item param) - (&/$Item type-fn)) - local-def)) - - (&/$Apply A F) - (|do [type-fn* (apply-type! F A)] - (apply-type! type-fn* param)) - - (&/$Named ?name ?type) - (apply-type! ?type param) - - (&/$Opaque id) - (return (&/$Apply param type-fn)) - - (&/$Var id) - (|do [=type-fun (deref id)] - (apply-type! =type-fun param)) - - _ - (&/fail-with-loc (str "[Type System] Not a type-function:\n" (&type/show-type type-fn) "\n")))) - -(defn adjust-type* - "(-> (List (, (Maybe (List Type)) Int Type)) Type (Lux Type))" - [up type] - (|case type - (&/$Universal _aenv _abody) - (&type/with-var - (fn [$var] - (|do [=type (apply-type! type $var) - ==type (adjust-type* (&/$Item (&/T [_aenv 1 $var]) - (&/|map update-up-frame up)) - =type)] - (&type/clean $var ==type)))) - - (&/$Existential _aenv _abody) - (|do [$var &type/existential - =type (apply-type! type $var)] - (adjust-type* up =type)) - - (&/$Product ?left ?right) - (let [=type (&/fold (fn [_abody ena] - (|let [[_aenv _aidx (&/$Var _avar)] ena] - (clean! 0 _avar _aidx _abody))) - type - up) - distributor (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aidx _avar] ena] - (&/$Universal _aenv _abody))) - v - up))] - (return (&type/Tuple$ (&/|map distributor - (&type/flatten-prod =type))))) - - (&/$Sum ?left ?right) - (let [=type (&/fold (fn [_abody ena] - (|let [[_aenv _aidx (&/$Var _avar)] ena] - (clean! 0 _avar _aidx _abody))) - type - up) - distributor (fn [v] - (&/fold (fn [_abody ena] - (|let [[_aenv _aidx _avar] ena] - (&/$Universal _aenv _abody))) - v - up))] - (return (&type/Variant$ (&/|map distributor - (&type/flatten-sum =type))))) - - (&/$Apply ?targ ?tfun) - (|do [=type (apply-type! ?tfun ?targ)] - (adjust-type* up =type)) - - (&/$Var ?id) - (|do [type* (&/try-all% (&/|list (&type/deref ?id) - (&/fail-with-loc (str "##2##: " ?id))))] - (adjust-type* up type*)) - - (&/$Named ?name ?type) - (adjust-type* up ?type) - - _ - (&/fail-with-loc (str "[Pattern-matching Error] Cannot pattern-match against type: " (&type/show-type type))) - )) - -(defn adjust-type - "(-> Type (Lux Type))" - [type] - (adjust-type* &/$End type)) - -(defn analyse-tuple-pattern [analyse-pattern pattern value-type ?members kont] - (|do [must-infer? (&type/unknown? value-type) - value-type* (if must-infer? - (|do [member-types (&/map% (fn [_] &type/create-var+) (&/|range (&/|length ?members)))] - (return (&type/fold-prod member-types))) - (adjust-type value-type))] - (|case value-type* - (&/$Product _) - (|let [num-elems (&/|length ?members) - [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?members) value-type*)] - (if (= num-elems _shorter) - (|do [[=tests =kont] (&/fold (fn [kont* vm] - (|let [[v m] vm] - (|do [[=test [=tests =kont]] (analyse-pattern &/$None v m kont*)] - (return (&/T [(&/$Item =test =tests) =kont]))))) - (|do [=kont kont] - (return (&/T [&/$End =kont]))) - (&/|reverse (&/zip2 _tuple-types ?members)))] - (return (&/T [($TupleTestAC =tests) =kont]))) - (&/fail-with-loc (str "[Pattern-matching Error] Pattern-matching mismatch. Requires tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?members) "].\n" - " At: " (&/show-ast pattern) "\n" - "Expected type: " (&type/show-type value-type*) "\n" - " Actual type: " (&type/show-type value-type))))) - - _ - (&/fail-with-loc (str "[Pattern-matching Error] Tuples require tuple-types: " (&type/show-type value-type)))))) - -(defn ^:private anonymous_variant [analyse-pattern - value-type kont - lefts right? ?values] - (let [idx (if right? (inc lefts) lefts)] - (|do [value-type* (adjust-type value-type) - case-type (&type/sum-at idx value-type*) - [=test =kont] (case (int (&/|length ?values)) - 0 (analyse-pattern &/$None case-type unit-tuple kont) - 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) - ;; 1+ - (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$Tuple ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [lefts right? =test])) =kont]))))) - -(defn ^:private analyse-pattern [var?? value-type pattern kont] - (|let [[meta pattern*] pattern] - (|case pattern* - (&/$Identifier "" name) - (|case var?? - (&/$Some var-analysis) - (|do [=kont (&env/with-alias name var-analysis - kont)] - (return (&/T [$NoTestAC =kont]))) - - _ - (|do [=kont (&env/with-local name value-type - kont) - idx &env/next-local-idx] - (return (&/T [($StoreTestAC idx) =kont])))) - - (&/$Identifier ident) - (&/fail-with-loc (str "[Pattern-matching Error] Identifiers must be unqualified: " (&/ident->text ident))) - - (&/$Bit ?value) - (|do [_ (&type/check value-type &type/Bit) - =kont kont] - (return (&/T [($BitTestAC ?value) =kont]))) - - (&/$Nat ?value) - (|do [_ (&type/check value-type &type/Nat) - =kont kont] - (return (&/T [($NatTestAC ?value) =kont]))) - - (&/$Int ?value) - (|do [_ (&type/check value-type &type/Int) - =kont kont] - (return (&/T [($IntTestAC ?value) =kont]))) - - (&/$Rev ?value) - (|do [_ (&type/check value-type &type/Rev) - =kont kont] - (return (&/T [($RevTestAC ?value) =kont]))) - - (&/$Dec ?value) - (|do [_ (&type/check value-type &type/Dec) - =kont kont] - (return (&/T [($DecTestAC ?value) =kont]))) - - (&/$Text ?value) - (|do [_ (&type/check value-type &type/Text) - =kont kont] - (return (&/T [($TextTestAC ?value) =kont]))) - - (&/$Tuple (&/$End)) - (|do [_ (&type/check value-type &type/Any) - =kont kont] - (return (&/T [($TupleTestAC (&/|list)) =kont]))) - - (&/$Tuple (&/$Item ?member (&/$End))) - (analyse-pattern var?? value-type ?member kont) - - (&/$Tuple ?members) - (|do [rec-members&rec-type (&&record/order-record true ?members)] - (|case rec-members&rec-type - (&/$Some [rec-members rec-type]) - (|do [must-infer? (&type/unknown? value-type) - rec-type* (if must-infer? - (&type/instantiate-inference rec-type) - (return value-type)) - _ (&type/check value-type rec-type*)] - (|case rec-members - (&/$Item singleton (&/$End)) - (analyse-pattern &/$None rec-type* singleton kont) - - _ - (analyse-tuple-pattern analyse-pattern pattern rec-type* rec-members kont))) - - (&/$None) - (analyse-tuple-pattern analyse-pattern pattern value-type ?members kont))) - - (&/$Variant (&/$Item [_ (&/$Bit right?)] ?values)) - (anonymous_variant analyse-pattern - value-type kont - 0 right? ?values) - - (&/$Variant (&/$Item [_ (&/$Nat lefts)] (&/$Item [_ (&/$Bit right?)] ?values))) - (anonymous_variant analyse-pattern - value-type kont - lefts right? ?values) - - (&/$Variant (&/$Item [_ (&/$Identifier ?ident)] ?values)) - (|do [[=module =name] (&&/resolved-ident ?ident) - must-infer? (&type/unknown? value-type) - [_exported? [label* variant-type**]] (&module/find-tag =module =name) - [lefts right?] (return (|case label* - (&/$Some [lefts right? family]) - (&/T [lefts right?]) - - (&/$None) - (&/T [0 false]))) - variant-type (if must-infer? - (|do [variant-type* (&type/instantiate-inference variant-type**) - _ (&type/check value-type variant-type*)] - (return variant-type*)) - (return value-type)) - value-type* (adjust-type variant-type) - case-type (let [idx (if right? - (inc lefts) - lefts)] - (&type/sum-at idx value-type*)) - [=test =kont] (case (int (&/|length ?values)) - 0 (analyse-pattern &/$None case-type unit-tuple kont) - 1 (analyse-pattern &/$None case-type (&/|head ?values) kont) - ;; 1+ - (analyse-pattern &/$None case-type (&/T [(&/T ["" -1 -1]) (&/$Tuple ?values)]) kont))] - (return (&/T [($VariantTestAC (&/T [lefts right? =test])) =kont]))) - - _ - (&/fail-with-loc (str "[Pattern-matching Error] Unrecognized pattern syntax: " (&/show-ast pattern))) - ))) - -(defn ^:private analyse-branch [analyse exo-type var?? value-type pattern body patterns] - (|do [pattern+body (analyse-pattern var?? value-type pattern - (&&/analyse-1 analyse exo-type body))] - (return (&/$Item pattern+body patterns)))) - -;; (defn ^:private merge-total [struct test+body] -;; (|let [[test ?body] test+body] -;; (|case [struct test] -;; [($DefaultTotal total?) ($NoTestAC)] -;; (return ($DefaultTotal true)) - -;; [($BitTotal total? ?values) ($NoTestAC)] -;; (return ($BitTotal true ?values)) - -;; [($NatTotal total? ?values) ($NoTestAC)] -;; (return ($NatTotal true ?values)) - -;; [($IntTotal total? ?values) ($NoTestAC)] -;; (return ($IntTotal true ?values)) - -;; [($RevTotal total? ?values) ($NoTestAC)] -;; (return ($RevTotal true ?values)) - -;; [($DecTotal total? ?values) ($NoTestAC)] -;; (return ($DecTotal true ?values)) - -;; [($TextTotal total? ?values) ($NoTestAC)] -;; (return ($TextTotal true ?values)) - -;; [($TupleTotal total? ?values) ($NoTestAC)] -;; (return ($TupleTotal true ?values)) - -;; [($VariantTotal total? ?values) ($NoTestAC)] -;; (return ($VariantTotal true ?values)) - -;; [($DefaultTotal total?) ($StoreTestAC ?idx)] -;; (return ($DefaultTotal true)) - -;; [($BitTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($BitTotal true ?values)) - -;; [($NatTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($NatTotal true ?values)) - -;; [($IntTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($IntTotal true ?values)) - -;; [($RevTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($RevTotal true ?values)) - -;; [($DecTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($DecTotal true ?values)) - -;; [($TextTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($TextTotal true ?values)) - -;; [($TupleTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($TupleTotal true ?values)) - -;; [($VariantTotal total? ?values) ($StoreTestAC ?idx)] -;; (return ($VariantTotal true ?values)) - -;; [($DefaultTotal total?) ($BitTestAC ?value)] -;; (return ($BitTotal total? (&/|list ?value))) - -;; [($BitTotal total? ?values) ($BitTestAC ?value)] -;; (return ($BitTotal total? (&/$Item ?value ?values))) - -;; [($DefaultTotal total?) ($NatTestAC ?value)] -;; (return ($NatTotal total? (&/|list ?value))) - -;; [($NatTotal total? ?values) ($NatTestAC ?value)] -;; (return ($NatTotal total? (&/$Item ?value ?values))) - -;; [($DefaultTotal total?) ($IntTestAC ?value)] -;; (return ($IntTotal total? (&/|list ?value))) - -;; [($IntTotal total? ?values) ($IntTestAC ?value)] -;; (return ($IntTotal total? (&/$Item ?value ?values))) - -;; [($DefaultTotal total?) ($RevTestAC ?value)] -;; (return ($RevTotal total? (&/|list ?value))) - -;; [($RevTotal total? ?values) ($RevTestAC ?value)] -;; (return ($RevTotal total? (&/$Item ?value ?values))) - -;; [($DefaultTotal total?) ($DecTestAC ?value)] -;; (return ($DecTotal total? (&/|list ?value))) - -;; [($DecTotal total? ?values) ($DecTestAC ?value)] -;; (return ($DecTotal total? (&/$Item ?value ?values))) - -;; [($DefaultTotal total?) ($TextTestAC ?value)] -;; (return ($TextTotal total? (&/|list ?value))) - -;; [($TextTotal total? ?values) ($TextTestAC ?value)] -;; (return ($TextTotal total? (&/$Item ?value ?values))) - -;; [($DefaultTotal total?) ($TupleTestAC ?tests)] -;; (|do [structs (&/map% (fn [t] -;; (merge-total ($DefaultTotal total?) (&/T [t ?body]))) -;; ?tests)] -;; (return ($TupleTotal total? structs))) - -;; [($TupleTotal total? ?values) ($TupleTestAC ?tests)] -;; (if (.equals ^Object (&/|length ?values) (&/|length ?tests)) -;; (|do [structs (&/map2% (fn [v t] -;; (merge-total v (&/T [t ?body]))) -;; ?values ?tests)] -;; (return ($TupleTotal total? structs))) -;; (&/fail-with-loc (str "[Pattern-matching Error] Inconsistent tuple-size.\n" -;; "Expected: " (&/|length ?values) "\n" -;; " Actual: " (&/|length ?tests)))) - -;; [($DefaultTotal total?) ($VariantTestAC ?tag ?count ?test)] -;; (|do [sub-struct (merge-total ($DefaultTotal total?) -;; (&/T [?test ?body])) -;; structs (|case (&/|list-put ?tag sub-struct (&/|repeat ?count ($DefaultTotal total?))) -;; (&/$Some list) -;; (return list) - -;; (&/$None) -;; (assert false))] -;; (return ($VariantTotal total? structs))) - -;; [($VariantTotal total? ?branches) ($VariantTestAC ?tag ?count ?test)] -;; (|do [sub-struct (merge-total (|case (&/|at ?tag ?branches) -;; (&/$Some sub) -;; sub - -;; (&/$None) -;; ($DefaultTotal total?)) -;; (&/T [?test ?body])) -;; structs (|case (&/|list-put ?tag sub-struct ?branches) -;; (&/$Some list) -;; (return list) - -;; (&/$None) -;; (assert false))] -;; (return ($VariantTotal total? structs))) -;; ))) - -;; (defn check-totality+ [check-totality] -;; (fn [?token] -;; (&type/with-var -;; (fn [$var] -;; (|do [=output (check-totality $var ?token) -;; ?type (&type/deref+ $var) -;; =type (&type/clean $var ?type)] -;; (return (&/T [=output =type]))))))) - -;; (defn ^:private check-totality [value-type struct] -;; (|case struct -;; ($DefaultTotal ?total) -;; (return ?total) - -;; ($BitTotal ?total ?values) -;; (|do [_ (&type/check value-type &type/Bit)] -;; (return (or ?total -;; (= #{true false} (set (&/->seq ?values)))))) - -;; ($NatTotal ?total _) -;; (|do [_ (&type/check value-type &type/Nat)] -;; (return ?total)) - -;; ($IntTotal ?total _) -;; (|do [_ (&type/check value-type &type/Int)] -;; (return ?total)) - -;; ($RevTotal ?total _) -;; (|do [_ (&type/check value-type &type/Rev)] -;; (return ?total)) - -;; ($DecTotal ?total _) -;; (|do [_ (&type/check value-type &type/Dec)] -;; (return ?total)) - -;; ($TextTotal ?total _) -;; (|do [_ (&type/check value-type &type/Text)] -;; (return ?total)) - -;; ($TupleTotal ?total ?structs) -;; (|case ?structs -;; (&/$End) -;; (|do [value-type* (resolve-type value-type)] -;; (if (&type/type= &type/Any value-type*) -;; (return true) -;; (&/fail-with-loc "[Pattern-maching Error] Unit is not total."))) - -;; _ -;; (|do [unknown? (&type/unknown? value-type)] -;; (if unknown? -;; (|do [=structs (&/map% (check-totality+ check-totality) ?structs) -;; _ (&type/check value-type (|case (->> (&/|map &/|second =structs) (&/|reverse)) -;; (&/$Item last prevs) -;; (&/fold (fn [right left] (&/$Product left right)) -;; last prevs)))] -;; (return (or ?total -;; (&/fold #(and %1 %2) true (&/|map &/|first =structs))))) -;; (if ?total -;; (return true) -;; (|do [value-type* (resolve-type value-type)] -;; (|case value-type* -;; (&/$Product _) -;; (|let [num-elems (&/|length ?structs) -;; [_shorter _tuple-types] (&type/tuple-types-for (&/|length ?structs) value-type*) -;; _ (&/assert! (= num-elems _shorter) -;; (&/fail-with-loc (str "[Pattern-maching Error] Tuple-mismatch. Require tuple[" (&/|length (&type/flatten-prod value-type*)) "]. Given tuple [" (&/|length ?structs) "]")))] -;; (|do [totals (&/map2% check-totality _tuple-types ?structs)] -;; (return (&/fold #(and %1 %2) true totals)))) - -;; _ -;; (&/fail-with-loc (str "[Pattern-maching Error] Tuple is not total." " - " (&type/show-type value-type*))))))))) - -;; ($VariantTotal ?total ?structs) -;; (if ?total -;; (return true) -;; (|do [value-type* (resolve-type value-type)] -;; (|case value-type* -;; (&/$Sum _) -;; (|do [totals (&/map2% check-totality -;; (&type/flatten-sum value-type*) -;; ?structs)] -;; (return (&/fold #(and %1 %2) true totals))) - -;; _ -;; (&/fail-with-loc "[Pattern-maching Error] Variant is not total.")))) -;; )) - -;; [Exports] -(defn analyse-branches [analyse exo-type var?? value-type branches] - (&/fold% (fn [patterns branch] - (|let [[pattern body] branch] - (analyse-branch analyse exo-type var?? value-type pattern body patterns))) - &/$End - branches) - ;; (|do [patterns (&/fold% (fn [patterns branch] - ;; (|let [[pattern body] branch] - ;; (analyse-branch analyse exo-type var?? value-type pattern body patterns))) - ;; &/$End - ;; branches) - ;; ;; struct (&/fold% merge-total ($DefaultTotal false) patterns) - ;; ;; ? (check-totality value-type struct) - ;; ;; _ (&/assert! ? "[Pattern-maching Error] Pattern-matching is not total.") - ;; ] - ;; (return patterns)) - ) diff --git a/lux-bootstrapper/src/lux/analyser/env.clj b/lux-bootstrapper/src/lux/analyser/env.clj deleted file mode 100644 index dfd87213d1..0000000000 --- a/lux-bootstrapper/src/lux/analyser/env.clj +++ /dev/null @@ -1,81 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.env - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return return* |case |let]]) - [lux.analyser.base :as &&])) - -;; [Exports] -(def next-local-idx - (fn [state] - (return* state (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$counter))))) - -(defn with-local [name type body] - (fn [state] - (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) - =return (body (&/update$ &/$scopes - (fn [stack] - (let [var-analysis (&&/|meta type &/empty-location (&&/$var (&/$Local (->> (&/|head stack) (&/get$ &/$locals) (&/get$ &/$counter)))))] - (&/$Item (&/update$ &/$locals #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [m] (&/|put name (&/T [type var-analysis]) m)))) - (&/|head stack)) - (&/|tail stack)))) - state))] - (|case =return - (&/$Right ?state ?value) - (return* (&/update$ &/$scopes (fn [stack*] - (&/$Item (&/update$ &/$locals #(->> % - (&/update$ &/$counter dec) - (&/set$ &/$mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) - ?value) - - _ - =return)))) - -(defn with-alias [name var-analysis body] - (fn [state] - (let [old-mappings (->> state (&/get$ &/$scopes) &/|head (&/get$ &/$locals) (&/get$ &/$mappings)) - =return (body (&/update$ &/$scopes - (fn [stack] - (&/$Item (&/update$ &/$locals #(->> % - (&/update$ &/$mappings (fn [m] (&/|put name - (&/T [(&&/expr-type* var-analysis) - var-analysis]) - m)))) - (&/|head stack)) - (&/|tail stack))) - state))] - (|case =return - (&/$Right ?state ?value) - (return* (&/update$ &/$scopes (fn [stack*] - (&/$Item (&/update$ &/$locals #(->> % - (&/set$ &/$mappings old-mappings)) - (&/|head stack*)) - (&/|tail stack*))) - ?state) - ?value) - - _ - =return)))) - -(def captured-vars - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$End) - ((&/fail-with-loc "[Analyser Error] Cannot obtain captured vars without environments.") - state) - - (&/$Item env _) - (return* state (->> env - (&/get$ &/$captured) - (&/get$ &/$mappings) - (&/|map (fn [mapping] - (|let [[k v] mapping] - (&/T [k (&/|second v)]))))))) - )) diff --git a/lux-bootstrapper/src/lux/analyser/function.clj b/lux-bootstrapper/src/lux/analyser/function.clj deleted file mode 100644 index 1ab6fa10dc..0000000000 --- a/lux-bootstrapper/src/lux/analyser/function.clj +++ /dev/null @@ -1,31 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.function - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return |case]] - [host :as &host]) - (lux.analyser [base :as &&] - [env :as &env]))) - -;; [Resource] -(defn with-function [self self-type arg arg-type body] - (&/with-closure - (|do [scope-name &/get-scope-name] - (&env/with-local self self-type - (&env/with-local arg arg-type - (|do [=return body - =captured &env/captured-vars] - (return (&/T [scope-name =captured =return])))))))) - -(defn close-over [scope name register frame] - (|let [[[register-type register-location] _] register - register* (&&/|meta register-type register-location - (&&/$captured (&/T [scope - (->> frame (&/get$ &/$captured) (&/get$ &/$counter)) - register])))] - (&/T [register* (&/update$ &/$captured #(->> % - (&/update$ &/$counter inc) - (&/update$ &/$mappings (fn [mps] (&/|put name (&/T [register-type register*]) mps)))) - frame)]))) diff --git a/lux-bootstrapper/src/lux/analyser/lux.clj b/lux-bootstrapper/src/lux/analyser/lux.clj deleted file mode 100644 index cbc632aa61..0000000000 --- a/lux-bootstrapper/src/lux/analyser/lux.clj +++ /dev/null @@ -1,737 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.lux - (:refer-clojure :exclude [eval]) - (:require (clojure [template :refer [do-template]] - [set :as set]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return return* |let |list |case]] - [parser :as &parser] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &&] - [function :as &&function] - [case :as &&case] - [env :as &&env] - [module :as &&module] - [record :as &&record]))) - -;; [Utils] -;; TODO: Walk the type to set up the parameter-type, instead of doing a -;; rough calculation like this one. -(defn ^:private count-univq - "(-> Type Int)" - [type] - (|case type - (&/$Universal env type*) - (inc (count-univq type*)) - - _ - 0)) - -;; TODO: This technique will not work if the body of the type contains -;; nested quantifications that cannot be directly counted. -(defn ^:private next-parameter-type - "(-> Type Type)" - [type] - (&/$Parameter (->> (count-univq type) (* 2) (+ 1)))) - -(defn ^:private embed-inferred-input - "(-> Type Type Type)" - [input output] - (|case output - (&/$Universal env output*) - (&/$Universal env (embed-inferred-input input output*)) - - _ - (&/$Function input output))) - -;; [Exports] -(defn analyse-unit [analyse ?exo-type] - (|do [_location &/location - _ (&type/check ?exo-type &type/Any)] - (return (&/|list (&&/|meta ?exo-type _location - (&&/$tuple (&/|list))))))) - -(defn analyse-tuple [analyse ?exo-type ?elems] - (|case ?elems - (&/$End) - (analyse-unit analyse (|case ?exo-type - (&/$Left exo-type) exo-type - (&/$Right exo-type) exo-type)) - - (&/$Item ?elem (&/$End)) - (analyse (|case ?exo-type - (&/$Left exo-type) exo-type - (&/$Right exo-type) exo-type) - ?elem) - - _ - (|case ?exo-type - (&/$Left exo-type) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$Universal _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left exo-type**) ?elems)) - =var (&type/resolve-type $var) - inferred-type (|case =var - (&/$Var iid) - (|do [:let [=var* (next-parameter-type tuple-type)] - _ (&type/set-var iid =var*) - tuple-type* (&type/clean $var tuple-type)] - (return (&/$Universal &/$End tuple-type*))) - - _ - (&type/clean $var tuple-type))] - (return (&/|list (&&/|meta inferred-type tuple-location - tuple-analysis)))))) - - _ - (analyse-tuple analyse (&/$Right exo-type*) ?elems))) - - (&/$Right exo-type) - (|do [unknown? (&type/unknown? exo-type)] - (if unknown? - (|do [=elems (&/map% #(|do [=analysis (&&/analyse-1+ analyse %)] - (return =analysis)) - ?elems) - _ (&type/check exo-type (|case (->> (&/|map &&/expr-type* =elems) (&/|reverse)) - (&/$Item last prevs) - (&/fold (fn [right left] (&/$Product left right)) - last prevs))) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$tuple =elems) - )))) - (|do [exo-type* (&type/actual-type exo-type)] - (&/with-attempt - (|case exo-type* - (&/$Product _) - (|let [num-elems (&/|length ?elems) - [_shorter _tuple-types] (&type/tuple-types-for num-elems exo-type*)] - (if (= num-elems _shorter) - (|do [=elems (&/map2% (fn [elem-t elem] - (&&/analyse-1 analyse elem-t elem)) - _tuple-types - ?elems) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$tuple =elems) - )))) - (|do [=direct-elems (&/map2% (fn [elem-t elem] (&&/analyse-1 analyse elem-t elem)) - (&/|take (dec _shorter) _tuple-types) - (&/|take (dec _shorter) ?elems)) - =indirect-elems (analyse-tuple analyse - (&/$Right (&/|last _tuple-types)) - (&/|drop (dec _shorter) ?elems)) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$tuple (&/|++ =direct-elems =indirect-elems)) - )))))) - - (&/$Existential _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)) - =tuple-analysis (&&/clean-analysis $var (&&/|meta exo-type tuple-location - tuple-analysis))] - (return (&/|list =tuple-analysis))))) - - (&/$Universal _) - (|do [$var &type/existential - :let [(&/$Opaque $var-id) $var] - exo-type** (&type/apply-type exo-type* $var) - [[tuple-type tuple-location] tuple-analysis] (&/with-scope-type-var $var-id - (&&/cap-1 (analyse-tuple analyse (&/$Right exo-type**) ?elems)))] - (return (&/|list (&&/|meta exo-type tuple-location - tuple-analysis)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type*))) - ) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Tuples require tuple-types: " (&type/show-type exo-type))))))))) - )) - -(defn ^:private analyse-variant-body [analyse exo-type ?values] - (|do [_location &/location - output (|case ?values - (&/$End) - (analyse-unit analyse exo-type) - - (&/$Item ?value (&/$End)) - (analyse exo-type ?value) - - _ - (analyse-tuple analyse (&/$Right exo-type) ?values))] - (|case output - (&/$Item x (&/$End)) - (return x) - - _ - (&/fail-with-loc "[Analyser Error] Macro cannot expand to more than 1 output.")))) - -(defn analyse-variant [analyse ?exo-type lefts right? ?values] - (|case ?exo-type - (&/$Left exo-type) - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$Universal _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left exo-type**) lefts right? ?values)) - =var (&type/resolve-type $var) - inferred-type (|case =var - (&/$Var iid) - (|do [:let [=var* (next-parameter-type variant-type)] - _ (&type/set-var iid =var*) - variant-type* (&type/clean $var variant-type)] - (return (&/$Universal &/$End variant-type*))) - - _ - (&type/clean $var variant-type))] - (return (&/|list (&&/|meta inferred-type variant-location - variant-analysis)))))) - - _ - (analyse-variant analyse (&/$Right exo-type*) lefts right? ?values))) - - (&/$Right exo-type) - (|do [exo-type* (|case exo-type - (&/$Var ?id) - (&/try-all% (&/|list (|do [exo-type* (&type/deref ?id)] - (&type/actual-type exo-type*)) - (|do [_ (&type/set-var ?id &type/Type)] - (&type/actual-type &type/Type)))) - - _ - (&type/actual-type exo-type))] - (&/with-attempt - (|case exo-type* - (&/$Sum _) - (|do [:let [idx (if right? - (inc lefts) - lefts)] - vtype (&type/sum-at idx exo-type*) - =value (analyse-variant-body analyse vtype ?values) - _location &/location] - (if (= 1 (&/|length (&type/flatten-sum exo-type*))) - (return (&/|list =value)) - (return (&/|list (&&/|meta exo-type _location (&&/$variant idx right? =value)))) - )) - - (&/$Universal _) - (|do [$var &type/existential - exo-type** (&type/apply-type exo-type* $var)] - (analyse-variant analyse (&/$Right exo-type**) lefts right? ?values)) - - (&/$Existential _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - =exprs (analyse-variant analyse (&/$Right exo-type**) lefts right? ?values)] - (&/map% (partial &&/clean-analysis $var) =exprs)))) - - _ - (&/fail-with-loc (str "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type*) " " lefts " " right? " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) - (fn [err] - (|case exo-type - (&/$Var ?id) - (|do [=exo-type (&type/deref ?id)] - (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type =exo-type) " " lefts " " right? " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))) - - _ - (&/fail-with-loc (str err "\n" "[Analyser Error] Cannot create variant if the expected type is " (&type/show-type exo-type) " " lefts " " right? " " (->> ?values (&/|map &/show-ast) (&/|interpose " ") (&/fold str ""))))))) - ))) - -(defn analyse-variant+ [analyse exo-type module tag-name values] - (|do [[exported? [label* variant_type]] (&&module/find-tag module tag-name)] - (|case label* - (&/$None) - (|do [_location &/location] - (analyse exo-type (&/T [_location (&/$Tuple values)]))) - - (&/$Some [lefts right? family]) - (|case exo-type - (&/$Var id) - (|do [? (&type/bound? id)] - (if (or ? (&&/type-tag? module tag-name)) - (analyse-variant analyse (&/$Right exo-type) lefts right? values) - (|do [variant_type* (&type/instantiate-inference variant_type) - [[variant-type variant-location] variant-analysis] (&&/cap-1 (analyse-variant analyse (&/$Left variant_type*) lefts right? values)) - _ (&type/check exo-type variant-type)] - (return (&/|list (&&/|meta exo-type variant-location variant-analysis)))))) - - _ - (analyse-variant analyse (&/$Right exo-type) lefts right? values))))) - -(defn analyse-record [analyse exo-type ?elems] - (|do [rec-members&rec-type (&&record/order-record false ?elems)] - (|case rec-members&rec-type - (&/$Some [rec-members rec-type]) - (|case exo-type - (&/$Var id) - (|do [verdict (&type/bound? id)] - (if verdict - (analyse-tuple analyse (&/$Right exo-type) rec-members) - (|do [[[tuple-type tuple-location] tuple-analysis] (&&/cap-1 (analyse-tuple analyse (&/$Left rec-type) rec-members)) - _ (&type/check exo-type tuple-type)] - (return (&/|list (&&/|meta exo-type tuple-location - tuple-analysis)))))) - - _ - (analyse-tuple analyse (&/$Right exo-type) rec-members)) - - (&/$None) - (analyse-tuple analyse (&/$Right exo-type) ?elems)))) - -(defn ^:private analyse-global [analyse exo-type quoted_module module name] - (|do [[[r-module r-name] [exported? [endo-type ?value]]] (&&module/find-def quoted_module module name) - ;; This is a small shortcut to optimize analysis of typing code. - _ (if (and (&type/type= &type/Type endo-type) - (&type/type= &type/Type exo-type)) - (return nil) - (&type/check exo-type endo-type)) - _location &/location] - (return (&/|list (&&/|meta endo-type _location - (&&/$def (&/T [r-module r-name]))))))) - -(defn ^:private analyse-local [analyse exo-type quoted_module name] - (|do [local? (&&module/find_local name)] - (|case local? - (&/$None) - (|do [module-name &/get-module-name] - (analyse-global analyse exo-type quoted_module module-name name)) - - (&/$Some [local inner outer]) - (|let [scopes (&/|map #(&/get$ &/$name %) inner) - [=local inner*] (&/fold2 (fn [register+new-inner frame in-scope] - (|let [[register new-inner] register+new-inner - [register* frame*] (&&function/close-over in-scope name register frame)] - (&/T [register* (&/$Item frame* new-inner)]))) - (&/T [local &/$End]) - inner scopes)] - (fn [state] - ((|do [_ (&type/check exo-type (&&/expr-type* =local))] - (return (&/|list =local))) - (&/set$ &/$scopes (&/|++ inner* outer) state))))))) - -(defn analyse-identifier [analyse exo-type quoted_module ident] - (|do [:let [[?module ?name] ident]] - (if (= "" ?module) - (analyse-local analyse exo-type quoted_module ?name) - (analyse-global analyse exo-type quoted_module ?module ?name)))) - -(defn ^:private analyse-apply* [analyse exo-type fun-type ?args] - (|case ?args - (&/$End) - (|do [_ (&type/check exo-type fun-type)] - (return (&/T [fun-type &/$End]))) - - (&/$Item ?arg ?args*) - (|do [?fun-type* (&type/actual-type fun-type)] - (&/with-attempt - (|case ?fun-type* - (&/$Universal _) - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - [=output-t =args] (analyse-apply* analyse exo-type type* ?args) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (|case $var - (&/$Var ?id) - (|do [? (&type/bound? ?id) - type** (if ? - (&type/clean $var =output-t) - (|do [_ (&type/set-var ?id (next-parameter-type =output-t)) - cleaned-output* (&type/clean $var =output-t) - :let [cleaned-output (&/$Universal &/$End cleaned-output*)]] - (return cleaned-output))) - _ (&type/clean $var exo-type)] - (return (&/T [type** ==args]))) - )))) - - (&/$Existential _) - (&type/with-var - (fn [$var] - (|do [type* (&type/apply-type ?fun-type* $var) - [=output-t =args] (analyse-apply* analyse exo-type type* ?args) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (|case $var - (&/$Var ?id) - (|do [? (&type/bound? ?id) - type** (if ? - (&type/clean $var =output-t) - (|do [idT &type/existential - _ (&type/set-var ?id idT)] - (&type/clean $var =output-t))) - _ (&type/clean $var exo-type)] - (return (&/T [type** ==args]))) - )))) - - (&/$Function ?input-t ?output-t) - (|do [[=output-t =args] (analyse-apply* analyse exo-type ?output-t ?args*) - =arg (&/with-attempt - (&&/analyse-1 analyse ?input-t ?arg) - (fn [err] - (&/fail-with-loc (str err "\n" - "[Analyser Error] Argument expected: " (&type/show-type ?input-t)))))] - (return (&/T [=output-t (&/$Item =arg =args)]))) - - _ - (&/fail-with-loc (str "[Analyser Error] Cannot apply a non-function: " (&type/show-type ?fun-type*)))) - (fn [err] - (&/fail-with-loc (str err "\n" - "[Analyser Error] Cannot apply function " (&type/show-type fun-type) - " to args: " (->> ?args - (&/|map &/show-ast) - (&/|interpose " ") - (&/fold str ""))))))) - )) - -(defn ^:private do-analyse-apply [analyse exo-type =fn ?args] - (|do [:let [[[=fn-type =fn-location] =fn-form] =fn] - [=output-t =args] (analyse-apply* analyse exo-type =fn-type ?args)] - (return (&/|list (&&/|meta =output-t =fn-location - (&&/$apply =fn =args) - ))))) - -(defn analyse-apply [analyse location exo-type macro-caller =fn ?args] - (|case =fn - [_ (&&/$def ?module ?name)] - (|do [[real-name [exported? [?type ?value]]] (&&module/find-def! ?module ?name)] - (if (&type/type= &type/Macro ?type) - (|do [macro-expansion (fn [state] - (|case (macro-caller ?value ?args state) - (&/$Right state* output) - (&/$Right (&/T [state* output])) - - (&/$Left error) - ((&/fail-with-loc error) state))) - module-name &/get-module-name - ;; :let [[r-prefix r-name] real-name - ;; _ (when (or (= "\\" r-name)) - ;; (->> macro-expansion - ;; (&/|map (fn [ast] (str (&/show-ast ast) "\n"))) - ;; (&/fold str "") - ;; (&/|log! (str 'macro-expansion " " (&/ident->text real-name) " @ " module-name))))] - ] - (&/flat-map% (partial analyse exo-type) macro-expansion)) - (do-analyse-apply analyse exo-type =fn ?args))) - - _ - (do-analyse-apply analyse exo-type =fn ?args))) - -(defn analyse-case [analyse exo-type ?value ?branches] - (|do [_ (&/assert! (> (&/|length ?branches) 0) - "[Analyser Error] Cannot have empty branches in \"case\" expression.") - =value (&&/analyse-1+ analyse ?value) - :let [var?? (|case =value - [_ (&&/$var =var-kind)] - (&/$Some =value) - - _ - &/$None)] - =match (&&case/analyse-branches analyse exo-type var?? (&&/expr-type* =value) ?branches) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$case =value =match) - ))))) - -(defn ^:private unravel-inf-appt [type] - (|case type - (&/$Apply (&/$Var _inf-var) =input+) - (&/$Item _inf-var (unravel-inf-appt =input+)) - - _ - (&/|list))) - -(defn ^:private clean-func-inference [$input $output =input =func] - (|case =input - (&/$Var iid) - (|do [:let [=input* (next-parameter-type =func)] - _ (&type/set-var iid =input*) - =func* (&type/clean $input =func) - =func** (&type/clean $output =func*)] - (return (&/$Universal &/$End =func**))) - - (&/$Apply (&/$Var _inf-var) =input+) - (&/fold% (fn [_func _inf-var] - (|do [:let [$inf-var (&/$Var _inf-var)] - =inf-var (&type/resolve-type $inf-var) - _func* (clean-func-inference $inf-var $output =inf-var _func)] - (return _func*))) - =func - (unravel-inf-appt =input)) - - (&/$Product _ _) - (&/fold% (fn [_func _inf-var] - (|do [:let [$inf-var (&/$Var _inf-var)] - =inf-var (&type/resolve-type $inf-var) - _func* (clean-func-inference $inf-var $output =inf-var _func)] - (return _func*))) - =func - (&/|reverse (&type/flatten-prod =input))) - - _ - (|do [=func* (&type/clean $input =func) - =func** (&type/clean $output =func*)] - (return =func**)))) - -(defn analyse-function* [analyse exo-type ?self ?arg ?body] - (|case exo-type - (&/$Var id) - (|do [? (&type/bound? id)] - (if ? - (|do [exo-type* (&type/deref id)] - (analyse-function* analyse exo-type* ?self ?arg ?body)) - ;; Inference - (&type/with-var - (fn [$input] - (&type/with-var - (fn [$output] - (|do [[[function-type function-location] function-analysis] (analyse-function* analyse (&/$Function $input $output) ?self ?arg ?body) - =input (&type/resolve-type $input) - =output (&type/resolve-type $output) - inferred-type (clean-func-inference $input $output =input (embed-inferred-input =input =output)) - _ (&type/check exo-type inferred-type)] - (return (&&/|meta inferred-type function-location - function-analysis))) - )))))) - - _ - (&/with-attempt - (|do [exo-type* (&type/actual-type exo-type)] - (|case exo-type* - (&/$Universal _) - (|do [$var &type/existential - :let [(&/$Opaque $var-id) $var] - exo-type** (&type/apply-type exo-type* $var)] - (&/with-scope-type-var $var-id - (analyse-function* analyse exo-type** ?self ?arg ?body))) - - (&/$Existential _) - (&type/with-var - (fn [$var] - (|do [exo-type** (&type/apply-type exo-type* $var) - =expr (analyse-function* analyse exo-type** ?self ?arg ?body)] - (&&/clean-analysis $var =expr)))) - - (&/$Function ?arg-t ?return-t) - (|do [[=scope =captured =body] (&&function/with-function ?self exo-type* - ?arg ?arg-t - (&&/analyse-1 analyse ?return-t ?body)) - _location &/location - register-offset &&env/next-local-idx] - (return (&&/|meta exo-type* _location - (&&/$function register-offset =scope =captured =body)))) - - _ - (&/fail ""))) - (fn [err] - (&/fail-with-loc (str err "\n" "[Analyser Error] Functions require function types: " (&type/show-type exo-type))))) - )) - -(defn analyse-function** [analyse exo-type ?self ?arg ?body] - (|case exo-type - (&/$Universal _) - (|do [$var &type/existential - :let [(&/$Opaque $var-id) $var] - exo-type* (&type/apply-type exo-type $var) - [_ _expr] (&/with-scope-type-var $var-id - (analyse-function** analyse exo-type* ?self ?arg ?body)) - _location &/location] - (return (&&/|meta exo-type _location _expr))) - - (&/$Var id) - (|do [? (&type/bound? id)] - (if ? - (|do [exo-type* (&type/actual-type exo-type)] - (analyse-function* analyse exo-type* ?self ?arg ?body)) - ;; Inference - (analyse-function* analyse exo-type ?self ?arg ?body))) - - _ - (|do [exo-type* (&type/actual-type exo-type)] - (analyse-function* analyse exo-type* ?self ?arg ?body)) - )) - -(defn analyse-function [analyse exo-type ?self ?arg ?body] - (|do [output (analyse-function** analyse exo-type ?self ?arg ?body)] - (return (&/|list output)))) - -(defn ^:private ensure-undefined! [module-name local-name] - (|do [verdict (&&module/defined? module-name local-name)] - (if verdict - (|do [[[real-module real-name] _] (&&module/find-def "" module-name local-name) - :let [wanted-name (str module-name &/+name-separator+ local-name) - source-name (str real-module &/+name-separator+ real-name)]] - (&/assert! false - (str "[Analyser Error] Cannot re-define " wanted-name - (if (= wanted-name source-name) - "" - (str "\nThis is an alias for " source-name))))) - (return &/$End)))) - -(defn eval [analyse optimize eval! type code] - (|do [analysis (&/without-scope - (&&/analyse-1 analyse type code))] - (eval! (optimize analysis)))) - -(defn analyse-def* [analyse optimize eval! compile-def ?name ?value exported? & [?expected-type]] - (|do [_ &/ensure-declaration - module-name &/get-module-name - _ (ensure-undefined! module-name ?name) - =value (&/without-repl-closure - (&/with-scope ?name - (if ?expected-type - (&/with-expected-type ?expected-type - (&&/analyse-1 analyse ?expected-type ?value)) - (&&/analyse-1+ analyse ?value)))) - :let [aliased (|case =value - [_ (&&/$def ?original)] - ?original - - _ - nil)] - ==exported? (eval analyse optimize eval! &type/Bit exported?) - def-value (if aliased - (&/without-repl-closure - (&&module/define-alias module-name ?name ==exported? aliased)) - (compile-def ?name (optimize =value) ==exported?)) - _ &type/reset-mappings - :let [def-type (&&/expr-type* =value) - _ (if aliased - nil - (println 'DEF (str module-name &/+name-separator+ ?name - " : " (&type/show-type def-type))))]] - (return (&/T [module-name def-type def-value ==exported?])))) - -(defn analyse-def [analyse optimize eval! compile-def ?name ?value exported?] - (|do [_ (analyse-def* analyse optimize eval! compile-def ?name ?value exported?)] - (return &/$End))) - -(defn ^:private merge-module-states - "(-> Host Host Host)" - [new old] - (|let [merged-module-states (&/fold (fn [total new-module] - (|let [[_name _module] new-module] - (|case (&/get$ &&module/$module-state _module) - (&&module/$Cached) - (&/|put _name _module total) - - (&&module/$Compiled) - (&/|put _name _module total) - - _ - total))) - (&/get$ &/$modules old) - (&/get$ &/$modules new))] - (&/set$ &/$modules merged-module-states old))) - -(defn ^:private merge-modules - "(-> Text Module Module Module)" - [current-module new old] - (&/fold (fn [total* entry] - (|let [[_name _module] entry] - (if (or (= current-module _name) - (->> _module - (&/get$ &&module/$defs) - &/|length - (= 0))) - ;; Do not modify the entry of the current module, to - ;; avoid overwritting it's data in improper ways. - ;; Since it's assumed the "original" old module - ;; contains all the proper own-module information. - total* - (&/|put _name _module total*)))) - old new)) - -(defn ^:private merge-compilers - "(-> Text Lux Lux Lux)" - [current-module new old] - (->> old - (&/set$ &/$modules (merge-modules current-module - (&/get$ &/$modules new) - (&/get$ &/$modules old))) - (&/set$ &/$seed (max (&/get$ &/$seed new) - (&/get$ &/$seed old))) - (merge-module-states new))) - -(def ^:private get-compiler - (fn [compiler] - (return* compiler compiler))) - -(defn ^:private set-compiler [compiler*] - (fn [_] - (return* compiler* compiler*))) - -(defn try-async-compilation [path compile-module] - (|do [already-compiled? (&&module/exists? path)] - (if (not already-compiled?) - (compile-module path) - (|do [_compiler get-compiler] - (return (doto (promise) - (deliver (&/$Right _compiler)))))))) - -(defn analyse-module [analyse optimize eval! compile-module ?imports] - (|do [_ &/ensure-declaration - module-name &/get-module-name - _imports (&&module/fetch-imports ?imports) - current-module &/get-module-name - =asyncs (&/map% (fn [_import] - (|let [[path alias] _import] - (&/without-repl - (&/save-module - (|do [_ (&/assert! (not (= current-module path)) - (str "[Analyser Error] Module cannot import itself: " path)) - active? (&&module/active-module? path) - ;; TODO: Enrich this error-message - ;; to explicitly show the cyclic dependency. - _ (&/assert! (not active?) - (str "[Analyser Error] Cannot import a module that is mid-compilation { cyclic dependency }: " path " @ " current-module)) - _ (&&module/add-import path) - _ (if (= "" alias) - (return nil) - (&&module/alias current-module alias path))] - (try-async-compilation path compile-module)))))) - _imports) - _compiler get-compiler - _ (&/fold% (fn [compiler _async] - (|case @_async - (&/$Right _new-compiler) - (set-compiler (merge-compilers current-module _new-compiler compiler)) - - (&/$Left ?error) - (&/fail ?error))) - _compiler - =asyncs)] - (return &/$End))) - -(defn ^:private coerce - "(-> Type Analysis Analysis)" - [new-type analysis] - (|let [[[_type _location] _analysis] analysis] - (&&/|meta new-type _location - _analysis))) - -(defn analyse-type-check [analyse optimize eval! exo-type ?type ?value] - (|do [==type (eval analyse optimize eval! &type/Type ?type) - _ (&type/check exo-type ==type) - =value (&&/analyse-1 analyse ==type ?value) - _location &/location] - (return (&/|list (&&/|meta ==type _location - (&&/$ann =value ==type)))))) - -(defn analyse-type-as [analyse optimize eval! exo-type ?type ?value] - (|do [==type (eval analyse optimize eval! &type/Type ?type) - _ (&type/check exo-type ==type) - =value (&&/analyse-1+ analyse ?value)] - (return (&/|list (coerce ==type =value))))) diff --git a/lux-bootstrapper/src/lux/analyser/module.clj b/lux-bootstrapper/src/lux/analyser/module.clj deleted file mode 100644 index ed6f7e0319..0000000000 --- a/lux-bootstrapper/src/lux/analyser/module.clj +++ /dev/null @@ -1,438 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.module - (:refer-clojure :exclude [alias]) - (:require (clojure [string :as string] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [defvariant deftuple |let |do return return* |case]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics])) - -;; [Utils] -;; ModuleState -(defvariant - ("Active" 0) - ("Compiled" 0) - ("Cached" 0)) - -;; Module -(deftuple - ["module-hash" - "module-aliases" - "defs" - "imports" - "module-state"]) - -(defn ^:private new-module [hash] - (&/T [;; lux;module-hash - hash - ;; "lux;module-aliases" - (&/|table) - ;; "lux;defs" - (&/|table) - ;; "lux;imports" - &/$End - ;; "module-state" - $Active] - )) - -(do-template [ ] - (do (defn - "(-> Text (Lux Any))" - [module-name] - (fn [state] - (let [state* (&/update$ &/$modules - (fn [modules] - (&/|update module-name - (fn [=module] - (&/set$ $module-state =module)) - modules)) - state)] - (&/$Right (&/T [state* &/unit-tag]))))) - (defn - "(-> Text (Lux Bit))" - [module-name] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module-name))] - (&/$Right (&/T [state (|case (&/get$ $module-state =module) - () true - _ false)])) - (&/$Right (&/T [state false]))) - ))) - - flag-active-module active-module? $Active - flag-compiled-module compiled-module? $Compiled - flag-cached-module cached-module? $Cached - ) - -;; [Exports] -(defn add-import - "(-> Text (Lux Null))" - [module] - (|do [current-module &/get-module-name] - (fn [state] - (if (&/|member? module (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $imports))) - ((&/fail-with-loc (str "[Analyser Error] Cannot import module " (pr-str module) " twice @ " current-module)) - state) - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/update$ $imports (partial &/$Item module) m)) - ms)) - state) - nil))))) - -(defn set-imports - "(-> (List Text) (Lux Null))" - [imports] - (|do [current-module &/get-module-name] - (fn [state] - (return* (&/update$ &/$modules - (fn [ms] - (&/|update current-module - (fn [m] (&/set$ $imports imports m)) - ms)) - state) - nil)))) - -(defn type-def - "(-> Text Text (Lux [Bit Type]))" - [module name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [exported? (&/$AliasG [o-module o-name])] - ((type-def o-module o-name) state) - - [exported? (&/$DefinitionG [?type ?value])] - (if (&type/type= &type/Type ?type) - (return* state (&/T [exported? ?value])) - ((&/fail-with-loc (str "[Analyser Error] Not a type: " (&/ident->text (&/T [module name])))) - state))) - ((&/fail-with-loc (str "[Analyser Error] Unknown definition: " (&/ident->text (&/T [module name])))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Unknown module: " module)) - state)))) - -(defn exists? - "(-> Text (Lux Bit))" - [name] - (fn [state] - (return* state - (->> state (&/get$ &/$modules) (&/|contains? name))))) - -(defn dealias [name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [real-name (->> state (&/get$ &/$modules) (&/|get current-module) (&/get$ $module-aliases) (&/|get name))] - (return* state real-name) - ((&/fail-with-loc (str "[Analyser Error] Unknown alias: " name)) - state))))) - -(defn alias [module alias reference] - (fn [state] - (let [_module_ (->> state (&/get$ &/$modules) (&/|get module))] - (if (&/|member? module (->> _module_ (&/get$ $imports))) - ((&/fail-with-loc (str "[Analyser Error] Cannot create alias that is the same as a module nameL " (pr-str alias) " for " reference)) - state) - (if-let [real-name (->> _module_ (&/get$ $module-aliases) (&/|get alias))] - ((&/fail-with-loc (str "[Analyser Error] Cannot re-use alias \"" alias "\" @ " module)) - state) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - #(&/update$ $module-aliases - (fn [aliases] - (&/|put alias reference aliases)) - %) - ms)))) - nil)))) - )) - -(defn ^:private imports? [state imported-module-name source-module-name] - (->> state - (&/get$ &/$modules) - (&/|get source-module-name) - (&/get$ $imports) - (&/|any? (partial = imported-module-name)))) - -(defn find-def! [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [exported? (&/$AliasG [?r-module ?r-name])] - ((find-def! ?r-module ?r-name) - state) - - [exported? (&/$DefinitionG $def*)] - (return* state (&/T [(&/T [module name]) - (&/T [exported? $def*])]))) - ((&/fail-with-loc (str "[Analyser Error @ find-def!] Definition does not exist: " (&/ident->text (&/T [module name])) - " at module: " (pr-str current-module))) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def!] Module does not exist: " (pr-str module) - " for symbol: " (&/ident->text (&/T [module name])) - " at module: " (pr-str current-module))) - state))))) - -(defn find-def [quoted_module module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [exported? $def*] - (if (or (.equals ^Object current-module module) - (and exported? - (or (.equals ^Object &/prelude module) - (.equals ^Object quoted_module module) - (imports? state module current-module)))) - (|case $def* - (&/$AliasG [?r-module ?r-name]) - ((find-def! ?r-module ?r-name) - state) - - (&/$DefinitionG [?type ?value]) - (return* state (&/T [(&/T [module name]) - (&/T [exported? (&/T [?type ?value])])]))) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Cannot use private global: " (str module &/+name-separator+ name) - " at module: " current-module)) - state))) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Definition does not exist: " (str module &/+name-separator+ name) - " at module: " current-module)) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Module does not exist: " module - " at module: " current-module)) - state))))) - -(defn find-global [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [exported? (&/$AliasG [?r-module ?r-name])] (return* state $def) - [exported? (&/$DefinitionG _)] (return* state $def)) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Global does not exist: " (str module &/+name-separator+ name) - " at module: " current-module)) - state)) - ((&/fail-with-loc (str "[Analyser Error @ find-def] Module does not exist: " module - " at module: " current-module)) - state))))) - -(defn label - "(-> Text Nat (List Text) Type - Label)" - [module index group type] - (let [max_size (&/|length group)] - (if (= 1 max_size) - (&/T [&/$None type]) - (let [right? (= index (dec max_size)) - lefts (if right? - (dec index) - index)] - (&/T [(&/$Some (&/T [lefts right? (&/|map (fn [it] (&/T [module it])) group)])) - type]))))) - -(do-template [ ] - (do (defn [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - (&/$AliasG [?r-module ?r-name]) - (( ?r-module ?r-name) - state) - - _ - ((&/fail-with-loc (str "[Analyser Error] Not a label: " (&/ident->text (&/T [module name])) - " @ " (quote ))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Label does not exist: " (str module &/+name-separator+ name) - " at module: " current-module - " @ " (quote ))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module - " at module: " current-module - " @ " (quote ))) - state))))) - (defn [module name] - (|do [current-module &/get-module-name] - (fn [state] - (if-let [$module (->> state (&/get$ &/$modules) (&/|get module))] - (if-let [$def (->> $module (&/get$ $defs) (&/|get name))] - (|case $def - [exported? (&/$AliasG [?r-module ?r-name])] - (if (.equals ^Object current-module module) - (( ?r-module ?r-name) - state) - ((&/fail-with-loc (str "[Analyser Error] Cannot use (private) alias: " (str module &/+name-separator+ name) - " at module: " current-module - " @ " (quote ))) - state)) - - [exported? (&/$DefinitionG [?type ?value])] - (if (or (.equals ^Object current-module module) - exported?) - (if (&type/type= ?type) - (return* state (&/T [exported? ?value])) - ((&/fail-with-loc (str "[Analyser Error] Invalid type for label: " (str module &/+name-separator+ name) - " at module: " current-module - " @ " (quote ))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Cannot use private definition: " (str module &/+name-separator+ name) - " at module: " current-module - " @ " (quote ))) - state)) - - _ - ((&/fail-with-loc (str "[Analyser Error] Not a label: " (&/ident->text (&/T [module name])) - " @ " (quote ))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Label does not exist: " (str module &/+name-separator+ name) - " at module: " current-module - " @ " (quote ))) - state)) - ((&/fail-with-loc (str "[Analyser Error] Module does not exist: " module - " at module: " current-module - " @ " (quote ))) - state)))))) - - find-tag! find-tag &type/Tag - find-slot! find-slot &type/Slot - ) - -(defn if_not_defined [module name then] - (|do [exists? (&/try% (find-global module name))] - (|case exists? - (&/$Some _) - (fn [state] - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global because the name is already taken." - "\n" "Module: " module - "\n" "Name: " name)) - state)) - - (&/$None) - then))) - -(defn defined? [module name] - (&/try-all% (&/|list (|do [_ (find-def! module name)] - (return true)) - (return false)))) - -(defn create-module - "(-> Text Hash-Code (Lux Null))" - [name hash] - (fn [state] - (return* (->> state - (&/update$ &/$modules #(&/|put name (new-module hash) %)) - (&/set$ &/$scopes (&/|list (&/env name &/$End))) - (&/set$ &/$current-module (&/$Some name))) - nil))) - -(defn module-hash - "(-> Text (Lux Int))" - [module] - (fn [state] - (if-let [=module (->> state (&/get$ &/$modules) (&/|get module))] - (return* state (&/get$ $module-hash =module)) - ((&/fail-with-loc (str "[Lux Error] Unknown module: " module)) - state)))) - -(def imports - (|do [module &/get-module-name - _imports (fn [state] - (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $imports))))] - (&/map% (fn [_module] - (|do [_hash (module-hash _module)] - (return (&/T [_module _hash])))) - _imports))) - -(defn define-alias [module name exported? de-aliased] - (if_not_defined - module name - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Item ?env (&/$End)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T [exported? (&/$AliasG de-aliased)]) %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) - state))))) - -(defn define [module name exported? def-type def-value] - (if_not_defined - module name - (fn [state] - (|case (&/get$ &/$scopes state) - (&/$Item ?env (&/$End)) - (return* (->> state - (&/update$ &/$modules - (fn [ms] - (&/|update module - (fn [m] - (&/update$ $defs - #(&/|put name (&/T [exported? (&/$DefinitionG (&/T [def-type def-value]))]) %) - m)) - ms)))) - nil) - - _ - ((&/fail-with-loc (str "[Analyser Error] Cannot create a new global definition outside of a global environment: " (str module &/+name-separator+ name))) - state))))) - -(def defs - (|do [module &/get-module-name] - (fn [state] - (return* state (->> state (&/get$ &/$modules) (&/|get module) (&/get$ $defs)))))) - -(defn fetch-imports [imports] - (|case imports - [_ (&/$Tuple _parts)] - (&/map% (fn [_part] - (|case _part - [_ (&/$Tuple (&/$Item [[_ (&/$Text _module)] - (&/$Item [[_ (&/$Text _alias)] - (&/$End)])]))] - (return (&/T [_module _alias])) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) - _parts) - - _ - (&/fail-with-loc "[Analyser Error] Incorrect import syntax."))) - -(defn find_local [name] - (fn [state] - (|let [stack (&/get$ &/$scopes state) - no-binding? #(and (->> % (&/get$ &/$locals) (&/get$ &/$mappings) (&/|contains? name) not) - (->> % (&/get$ &/$captured) (&/get$ &/$mappings) (&/|contains? name) not)) - [inner outer] (&/|split-with no-binding? stack)] - (|case outer - (&/$End) - (return* state &/$None) - - (&/$Item bottom-outer _) - (let [local (&/|second (or (->> bottom-outer (&/get$ &/$locals) (&/get$ &/$mappings) (&/|get name)) - (->> bottom-outer (&/get$ &/$captured) (&/get$ &/$mappings) (&/|get name))))] - (return* state (&/$Some (&/T [local (&/|reverse inner) outer])))) - )))) diff --git a/lux-bootstrapper/src/lux/analyser/parser.clj b/lux-bootstrapper/src/lux/analyser/parser.clj deleted file mode 100644 index 39678bd9ae..0000000000 --- a/lux-bootstrapper/src/lux/analyser/parser.clj +++ /dev/null @@ -1,484 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.parser - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser]))) - -(declare parse-gclass) - -;; [Parsers] -(def ^:private _space_ (&reader/read-text " ")) - -(defn ^:private with-pre-space [action] - (|do [_ _space_] - action)) - -(defn ^:private repeat% [action] - (fn [state] - (|case (action state) - (&/$Left ^String error) - (&/$Right (&/T [state &/$End])) - - (&/$Right state* head) - ((|do [tail (repeat% action)] - (return (&/$Item head tail))) - state*)))) - -(defn ^:private spaced [action] - (fn [state] - (|case (action state) - (&/$Left ^String error) - (&/$Right (&/T [state &/$End])) - - (&/$Right state* head) - ((&/try-all% (&/|list (|do [_ _space_ - tail (spaced action)] - (return (&/$Item head tail))) - (return (&/|list head)))) - state*)))) - -(def ^:private class-name-regex - #"^([a-zA-Z0-9_\.$]+)") - -(def ^:private parse-name - (|do [[_ _ =name] (&reader/read-regex class-name-regex)] - (return =name))) - -(def ^:private parse-name? - (|do [[_ _ =name] (&reader/read-regex? class-name-regex)] - (return =name))) - -(def ^:private parse-ident - (|do [[_ _ =name] (&reader/read-regex &lexer/+ident-re+)] - (return =name))) - -(defn ^:private with-parens [body] - (|do [_ (&reader/read-text "(") - output body - _ (&reader/read-text ")")] - (return output))) - -(defn ^:private with-brackets [body] - (|do [_ (&reader/read-text "[") - output body - _ (&reader/read-text "]")] - (return output))) - -(defn ^:private with-braces [body] - (|do [_ (&reader/read-text "{") - output body - _ (&reader/read-text "}")] - (return output))) - -(def ^:private parse-type-param - (with-parens - (|do [=name parse-name - =bounds (with-pre-space - (spaced parse-gclass))] - (return (&/T [=name =bounds]))))) - -(def ^:private parse-gclass-decl - (with-parens - (|do [=class-name parse-name - =params (with-pre-space - (spaced parse-type-param))] - (return (&/T [=class-name =params]))))) - -(def ^:private parse-bound-kind - (&/try-all% (&/|list (|do [_ (&reader/read-text "<")] - (return &/$UpperBound)) - - (|do [_ (&reader/read-text ">")] - (return &/$LowerBound)) - ))) - -(def parse-gclass - (&/try-all% (&/|list (|do [=bound-kind parse-bound-kind - =bound parse-gclass] - (return (&/$GenericWildcard (&/$Some (&/T [=bound-kind =bound]))))) - - (|do [_ (&reader/read-text "?")] - (return (&/$GenericWildcard &/$None))) - - (|do [var-name parse-name] - (return (&/$GenericTypeVar var-name))) - - (with-parens - (|do [class-name parse-name - =params (with-pre-space - (spaced parse-gclass))] - (return (&/$GenericClass class-name =params)))) - - (with-parens - (|do [_ (&reader/read-text "#Array") - =param (with-pre-space - parse-gclass)] - (return (&/$GenericArray =param)))) - ))) - -(def ^:private parse-gclass-super - (with-parens - (|do [class-name parse-name - =params (with-pre-space - (spaced parse-gclass))] - (return (&/T [class-name =params]))))) - -(def ^:private parse-ctor-arg - (with-brackets - (|do [=class parse-gclass - (&/$Item =term (&/$End)) (with-pre-space - &parser/parse)] - (return (&/T [=class =term]))))) - -(def ^:private parse-ann-param - (|do [param-name parse-name - _ (&reader/read-text "=") - param-value (&/try-all% (&/|list (|do [[_ (&lexer/$Bit param-value*)] &lexer/lex-bit] - (return (boolean param-value*))) - - (|do [[_ (&lexer/$Int param-value*)] &lexer/lex-int] - (return (int param-value*))) - - (|do [_ (&reader/read-text "l") - [_ (&lexer/$Int param-value*)] &lexer/lex-int] - (return (long param-value*))) - - (|do [[_ (&lexer/$Dec param-value*)] &lexer/lex-dec] - (return (float param-value*))) - - (|do [_ (&reader/read-text "d") - [_ (&lexer/$Dec param-value*)] &lexer/lex-dec] - (return (double param-value*))) - - (|do [[_ (&lexer/$Text param-value*)] &lexer/lex-text] - (return param-value*)) - ))] - (return (&/T [param-name param-value])))) - -(def ^:private parse-ann - (with-parens - (|do [ann-name parse-name - =ann-params (with-pre-space - (with-braces - (spaced parse-ann-param)))] - (return {:name ann-name - :params =ann-params})))) - -(def ^:private parse-arg-decl - (with-parens - (|do [=arg-name parse-ident - _ (&reader/read-text " ") - =gclass parse-gclass] - (return (&/T [=arg-name =gclass]))))) - -(def ^:private parse-gvars - (|do [?=head parse-name?] - (|case ?=head - (&/$Some =head) - (|do [[_ _ ?] (&reader/read-text? " ")] - (if ? - (|do [=tail parse-gvars] - (return (&/$Item =head =tail))) - (return (&/|list =head)))) - - (&/$None) - (return (&/|list))))) - -(def ^:private parse-method-decl - (with-parens - (|do [=method-name parse-name - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - parse-gvars)) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-gclass))) - =output (with-pre-space - parse-gclass)] - (return (&/T [=method-name =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-privacy-modifier - (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] - (return &/$DefaultPM)) - - (|do [_ (&reader/read-text "public")] - (return &/$PublicPM)) - - (|do [_ (&reader/read-text "protected")] - (return &/$ProtectedPM)) - - (|do [_ (&reader/read-text "private")] - (return &/$PrivatePM)) - ))) - -(def ^:private parse-state-modifier - (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] - (return &/$DefaultSM)) - - (|do [_ (&reader/read-text "volatile")] - (return &/$VolatileSM)) - - (|do [_ (&reader/read-text "final")] - (return &/$FinalSM)) - ))) - -(def ^:private parse-inheritance-modifier - (&/try-all% (&/|list (|do [_ (&reader/read-text "default")] - (return &/$DefaultIM)) - - (|do [_ (&reader/read-text "abstract")] - (return &/$AbstractIM)) - - (|do [_ (&reader/read-text "final")] - (return &/$FinalIM)) - ))) - -(def ^:private parse-method-init-def - (|do [_ (&reader/read-text "init") - =privacy-modifier (with-pre-space - parse-privacy-modifier) - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =ctor-args (with-pre-space - (with-brackets - (spaced parse-ctor-arg))) - (&/$Item =body (&/$End)) (with-pre-space - &parser/parse)] - (return (&/$ConstructorMethodSyntax (&/T [=privacy-modifier =strict =anns =gvars =exceptions =inputs =ctor-args =body]))))) - -(def ^:private parse-method-virtual-def - (|do [_ (&reader/read-text "virtual") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - [_ (&lexer/$Bit =final?*)] (with-pre-space - &lexer/lex-bit) - :let [=final? (Boolean/parseBoolean =final?*)] - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass) - (&/$Item =body (&/$End)) (with-pre-space - &parser/parse)] - (return (&/$VirtualMethodSyntax (&/T [=name =privacy-modifier =final? =strict =anns =gvars =exceptions =inputs =output =body]))))) - -(def ^:private parse-method-override-def - (|do [_ (&reader/read-text "override") - =class-decl (with-pre-space - parse-gclass-decl) - =name (with-pre-space - parse-name) - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass) - (&/$Item =body (&/$End)) (with-pre-space - &parser/parse)] - (return (&/$OverridenMethodSyntax (&/T [=class-decl =name =strict =anns =gvars =exceptions =inputs =output =body]))))) - -(def ^:private parse-method-static-def - (|do [_ (&reader/read-text "static") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - [_ (&lexer/$Bit =strict*)] (with-pre-space - &lexer/lex-bit) - :let [=strict (Boolean/parseBoolean =strict*)] - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass) - (&/$Item =body (&/$End)) (with-pre-space - &parser/parse)] - (return (&/$StaticMethodSyntax (&/T [=name =privacy-modifier =strict =anns =gvars =exceptions =inputs =output =body]))))) - -(def ^:private parse-method-abstract-def - (|do [_ (&reader/read-text "abstract") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass)] - (return (&/$AbstractMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-method-native-def - (|do [_ (&reader/read-text "native") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =gvars (with-pre-space - (with-brackets - (spaced parse-type-param))) - =exceptions (with-pre-space - (with-brackets - (spaced parse-gclass))) - =inputs (with-pre-space - (with-brackets - (spaced parse-arg-decl))) - =output (with-pre-space - parse-gclass)] - (return (&/$NativeMethodSyntax (&/T [=name =privacy-modifier =anns =gvars =exceptions =inputs =output]))))) - -(def ^:private parse-method-def - (with-parens - (&/try-all% (&/|list parse-method-init-def - parse-method-virtual-def - parse-method-override-def - parse-method-static-def - parse-method-abstract-def - parse-method-native-def - )))) - -(def ^:private parse-field - (with-parens - (&/try-all% (&/|list (|do [_ (&reader/read-text "constant") - =name (with-pre-space - parse-name) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =type (with-pre-space - parse-gclass) - (&/$Item =value (&/$End)) (with-pre-space - &parser/parse)] - (return (&/$ConstantFieldSyntax =name =anns =type =value))) - - (|do [_ (&reader/read-text "variable") - =name (with-pre-space - parse-name) - =privacy-modifier (with-pre-space - parse-privacy-modifier) - =state-modifier (with-pre-space - parse-state-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =type (with-pre-space - parse-gclass)] - (return (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type))) - )))) - -(def parse-interface-def - (|do [=gclass-decl parse-gclass-decl - =supers (with-pre-space - (with-brackets - (spaced parse-gclass-super))) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =methods (with-pre-space - (spaced parse-method-decl))] - (return (&/T [=gclass-decl =supers =anns =methods])))) - -(def parse-class-def - (|do [=gclass-decl parse-gclass-decl - =super-class (with-pre-space - parse-gclass-super) - =interfaces (with-pre-space - (with-brackets - (spaced parse-gclass-super))) - =inheritance-modifier (with-pre-space - parse-inheritance-modifier) - =anns (with-pre-space - (with-brackets - (spaced parse-ann))) - =fields (with-pre-space - (with-brackets - (spaced parse-field))) - =methods (with-pre-space - (with-brackets - (spaced parse-method-def)))] - (return (&/T [=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods])))) - -(def parse-anon-class-def - (|do [=super-class parse-gclass-super - =interfaces (with-pre-space - (with-brackets - (spaced parse-gclass-super))) - =ctor-args (with-pre-space - (with-brackets - (spaced parse-ctor-arg))) - =methods (with-pre-space - (with-brackets - (spaced parse-method-def)))] - (return (&/T [=super-class =interfaces =ctor-args =methods])))) diff --git a/lux-bootstrapper/src/lux/analyser/proc/common.clj b/lux-bootstrapper/src/lux/analyser/proc/common.clj deleted file mode 100644 index 76b19c2b09..0000000000 --- a/lux-bootstrapper/src/lux/analyser/proc/common.clj +++ /dev/null @@ -1,278 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.proc.common - (:require (clojure [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type]) - (lux.analyser [base :as &&] - [module :as &&module]))) - -(defn- analyse-lux-is [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Item reference (&/$Item sample (&/$End))) ?values] - =reference (&&/analyse-1 analyse $var reference) - =sample (&&/analyse-1 analyse $var sample) - _ (&type/check exo-type &type/Bit) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["lux" "is"]) (&/|list =sample =reference) (&/|list))))))))) - -(defn- analyse-lux-try [analyse exo-type ?values] - (&type/with-var - (fn [$var] - (|do [:let [(&/$Item op (&/$End)) ?values] - =op (&&/analyse-1 analyse (&/$Function &type/Any $var) op) - _ (&type/check exo-type (&/$Sum &type/Text ;; lux.Left - $var ;; lux.Right - )) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["lux" "try"]) (&/|list =op) (&/|list))))))))) - -(do-template [ ] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item reference (&/$Item sample (&/$End))) ?values] - =reference (&&/analyse-1 analyse reference) - =sample (&&/analyse-1 analyse sample) - _ (&type/check exo-type ) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ) (&/|list =sample =reference) (&/|list))))))) - - analyse-text-eq ["text" "="] &type/Text &type/Bit - analyse-text-lt ["text" "<"] &type/Text &type/Bit - ) - -(defn- analyse-text-concat [analyse exo-type ?values] - (|do [=values (&/map% (fn [it] (&&/analyse-1 analyse &type/Text it)) - ?values) - _ (&type/check exo-type &type/Text) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "concat"]) =values (&/|list))))))) - -(defn- analyse-text-index [analyse exo-type ?values] - (|do [:let [(&/$Item start (&/$Item part (&/$Item text (&/$End)))) ?values] - =start (&&/analyse-1 analyse &type/Nat start) - =part (&&/analyse-1 analyse &type/Text part) - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type (&/$Apply &type/Nat &type/Maybe)) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "index"]) - (&/|list =text =part =start) - (&/|list))))))) - -(defn- analyse-text-clip [analyse exo-type ?values] - (|do [:let [(&/$Item from (&/$Item to (&/$Item text (&/$End)))) ?values] - =from (&&/analyse-1 analyse &type/Nat from) - =to (&&/analyse-1 analyse &type/Nat to) - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Text) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "clip"]) - (&/|list =text =from =to) - (&/|list))))))) - -(do-template [ ] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item text (&/$End)) ?values] - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" ]) - (&/|list =text) - (&/|list))))))) - - analyse-text-size "size" - ) - -(defn- analyse-text-char [analyse exo-type ?values] - (|do [:let [(&/$Item idx (&/$Item text (&/$End))) ?values] - =idx (&&/analyse-1 analyse &type/Nat idx) - =text (&&/analyse-1 analyse &type/Text text) - _ (&type/check exo-type &type/Nat) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["text" "char"]) - (&/|list =text =idx) - (&/|list))))))) - -(do-template [ ] - (let [inputT (&/$Apply &type/Any &type/I64) - outputT &type/I64] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item mask (&/$Item input (&/$End))) ?values] - =mask (&&/analyse-1 analyse inputT mask) - =input (&&/analyse-1 analyse inputT input) - _ (&type/check exo-type outputT) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["i64" ]) (&/|list =input =mask) (&/|list)))))))) - - analyse-i64-and "and" - analyse-i64-or "or" - analyse-i64-xor "xor" - ) - -(do-template [ ] - (let [inputT (&/$Apply &type/Any &type/I64) - outputT &type/I64] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item shift (&/$Item input (&/$End))) ?values] - =shift (&&/analyse-1 analyse &type/Nat shift) - =input (&&/analyse-1 analyse inputT input) - _ (&type/check exo-type outputT) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["i64" ]) (&/|list =input =shift) (&/|list)))))))) - - analyse-i64-left-shift "left-shift" - analyse-i64-right-shift "right-shift" - ) - -(do-template [ ] - (let [inputT - outputT ] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item parameterC (&/$Item subjectC (&/$End))) ?values] - parameterA (&&/analyse-1 analyse parameterC) - subjectA (&&/analyse-1 analyse subjectC) - _ (&type/check exo-type ) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ) (&/|list subjectA parameterA) (&/|list)))))))) - - ["i64" "="] analyse-i64-eq (&/$Apply &type/Any &type/I64) &type/Bit - ["i64" "+"] analyse-i64-add (&/$Apply &type/Any &type/I64) &type/I64 - ["i64" "-"] analyse-i64-sub (&/$Apply &type/Any &type/I64) &type/I64 - - ["i64" "*"] analyse-int-mul &type/Int &type/Int - ["i64" "/"] analyse-int-div &type/Int &type/Int - ["i64" "%"] analyse-int-rem &type/Int &type/Int - ["i64" "<"] analyse-int-lt &type/Int &type/Bit - - ["f64" "+"] analyse-f64-add &type/Dec &type/Dec - ["f64" "-"] analyse-f64-sub &type/Dec &type/Dec - ["f64" "*"] analyse-f64-mul &type/Dec &type/Dec - ["f64" "/"] analyse-f64-div &type/Dec &type/Dec - ["f64" "%"] analyse-f64-rem &type/Dec &type/Dec - ["f64" "="] analyse-f64-eq &type/Dec &type/Bit - ["f64" "<"] analyse-f64-lt &type/Dec &type/Bit - ) - -(do-template [ ] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item x (&/$End)) ?values] - =x (&&/analyse-1 analyse x) - _ (&type/check exo-type ) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ) (&/|list =x) (&/|list))))))) - - analyse-int-char &type/Int &type/Text ["i64" "char"] - analyse-int-dec &type/Int &type/Dec ["i64" "f64"] - analyse-f64-int &type/Dec &type/Int ["f64" "i64"] - - analyse-io-log &type/Text &type/Any ["io" "log"] - analyse-io-error &type/Text &type/Nothing ["io" "error"] - ) - -(defn- analyse-syntax-char-case! [analyse exo-type ?values] - (|do [:let [(&/$Item ?input (&/$Item [_ (&/$Tuple ?pairs)] (&/$Item ?else (&/$End)))) ?values] - _location &/location - =input (&&/analyse-1 analyse &type/Nat ?input) - _ (assert! (even? (&/|length ?pairs)) "The number of matches must be even!") - =pairs (&/map% (fn [?pair] - (|let [[[_ (&/$Tuple ?patterns)] ?match] ?pair] - (|do [=match (&&/analyse-1 analyse exo-type ?match)] - (return (&/T [(&/|map (fn [?pattern] - (|let [[_ (&/$Text ^String ?pattern-char)] ?pattern] - (int (.charAt ?pattern-char 0)))) - ?patterns) - =match]))))) - (&/|as-pairs ?pairs)) - =else (&&/analyse-1 analyse exo-type ?else)] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["lux" "syntax char case!"]) - (&/$Item =input (&/$Item =else (&/|map &/|second =pairs))) - (&/|map &/|first =pairs))))))) - -(let [extensions #{"is?#" "try#" "when_char#" - - "log!#" "error#" - - "text_=#" "text_<#" "text_composite#" - "text_clip#" "text_index#" "text_size#" "text_char#" - - "i64_and#" "i64_or#" "i64_xor#" "i64_left#" "i64_right#" - "i64_+#" "i64_-#" "i64_=#" - - "int_*#" "int_/#" "int_%#" "int_<#" - "int_f64#" "int_char#" - - "f64_+#" "f64_-#" "f64_*#" "f64_/#" "f64_%#" - "f64_=#" "f64_<#" - "f64_int#"}] - (defn uses_new_format? [extension] - (if (extensions extension) - true - false))) - -(defn analyse-proc [analyse exo-type proc ?values] - (try (case proc - "is?#" (analyse-lux-is analyse exo-type ?values) - "try#" (analyse-lux-try analyse exo-type ?values) - ;; Special extensions for performance reasons - ;; Will be replaced by custom extensions in the future. - "when_char#" (analyse-syntax-char-case! analyse exo-type ?values) - - "log!#" (analyse-io-log analyse exo-type ?values) - "error#" (analyse-io-error analyse exo-type ?values) - - "text_=#" (analyse-text-eq analyse exo-type ?values) - "text_<#" (analyse-text-lt analyse exo-type ?values) - "text_composite#" (analyse-text-concat analyse exo-type ?values) - "text_clip#" (analyse-text-clip analyse exo-type ?values) - "text_index#" (analyse-text-index analyse exo-type ?values) - "text_size#" (analyse-text-size analyse exo-type ?values) - "text_char#" (analyse-text-char analyse exo-type ?values) - - "i64_and#" (analyse-i64-and analyse exo-type ?values) - "i64_or#" (analyse-i64-or analyse exo-type ?values) - "i64_xor#" (analyse-i64-xor analyse exo-type ?values) - "i64_left#" (analyse-i64-left-shift analyse exo-type ?values) - "i64_right#" (analyse-i64-right-shift analyse exo-type ?values) - - "i64_+#" (analyse-i64-add analyse exo-type ?values) - "i64_-#" (analyse-i64-sub analyse exo-type ?values) - "i64_=#" (analyse-i64-eq analyse exo-type ?values) - - "int_*#" (analyse-int-mul analyse exo-type ?values) - "int_/#" (analyse-int-div analyse exo-type ?values) - "int_%#" (analyse-int-rem analyse exo-type ?values) - "int_<#" (analyse-int-lt analyse exo-type ?values) - - "int_f64#" (analyse-int-dec analyse exo-type ?values) - "int_char#" (analyse-int-char analyse exo-type ?values) - - "f64_+#" (analyse-f64-add analyse exo-type ?values) - "f64_-#" (analyse-f64-sub analyse exo-type ?values) - "f64_*#" (analyse-f64-mul analyse exo-type ?values) - "f64_/#" (analyse-f64-div analyse exo-type ?values) - "f64_%#" (analyse-f64-rem analyse exo-type ?values) - "f64_=#" (analyse-f64-eq analyse exo-type ?values) - "f64_<#" (analyse-f64-lt analyse exo-type ?values) - - "f64_int#" (analyse-f64-int analyse exo-type ?values) - - ;; else - (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " proc))) - (catch Exception ex - (&/fail-with-loc (str "[Analyser Error] Invalid syntax for procedure: " proc))))) diff --git a/lux-bootstrapper/src/lux/analyser/proc/jvm.clj b/lux-bootstrapper/src/lux/analyser/proc/jvm.clj deleted file mode 100644 index 2e9832cc3a..0000000000 --- a/lux-bootstrapper/src/lux/analyser/proc/jvm.clj +++ /dev/null @@ -1,1094 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.proc.jvm - (:require (clojure [template :refer [do-template]] - [string :as string]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case assert!]] - [type :as &type] - [host :as &host] - [lexer :as &lexer] - [parser :as &parser] - [reader :as &reader]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &&] - [env :as &&env] - [parser :as &&a-parser]) - [lux.compiler.jvm.base :as &c!base]) - (:import (java.lang.reflect Type TypeVariable))) - -;; [Utils] -(defn- ensure-object - "(-> Type (Lux (, Text (List Type))))" - [type] - (|case type - (&/$Nominal payload) - (return payload) - - (&/$Var id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$Opaque id) - (return (&/T ["java.lang.Object" (&/|list)])) - - (&/$Named _ type*) - (ensure-object type*) - - (&/$Universal _ type*) - (ensure-object type*) - - (&/$Existential _ type*) - (ensure-object type*) - - (&/$Apply A F) - (|do [type* (&type/apply-type F A)] - (ensure-object type*)) - - _ - (&/fail-with-loc (str "[Analyser Error] Was expecting object type. Instead got: " (&type/show-type type))))) - -(defn- as-object - "(-> Type Type)" - [type] - (|case type - (&/$Nominal class params) - (&/$Nominal (&host-type/as-obj class) params) - - _ - type)) - -(defn- as-otype [tname] - (case tname - "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" - ;; else - tname - )) - -(defn- as-otype+ - "(-> Type Type)" - [type] - (|case type - (&/$Nominal name params) - (&/$Nominal (as-otype name) params) - - _ - type)) - -(defn- clean-gtype-var [idx gtype-var] - (|let [(&/$Var id) gtype-var] - (|do [? (&type/bound? id)] - (if ? - (|do [real-type (&type/deref id)] - (return (&/T [idx real-type]))) - (return (&/T [(+ 2 idx) (&/$Parameter idx)])))))) - -(defn- clean-gtype-vars [gtype-vars] - (|do [[_ clean-types] (&/fold% (fn [idx+types gtype-var] - (|do [:let [[idx types] idx+types] - [idx* real-type] (clean-gtype-var idx gtype-var)] - (return (&/T [idx* (&/$Item real-type types)])))) - (&/T [1 &/$End]) - gtype-vars)] - (return clean-types))) - -(defn- make-gtype - "(-> Text (List Type) Type)" - [class-name type-args] - (&/fold (fn [base-type type-arg] - (|case type-arg - (&/$Parameter _) - (&/$Universal &type/empty-env base-type) - - _ - base-type)) - (&/$Nominal class-name type-args) - type-args)) - -;; [Resources] -(defn- analyse-field-access-helper - "(-> Type (List (^ java.lang.reflect.Type)) (^ java.lang.reflect.Type) (Lux Type))" - [obj-type gvars gtype] - (|case obj-type - (&/$Nominal class targs) - (if (= (&/|length targs) (&/|length gvars)) - (|let [gtype-env (&/fold2 (fn [m ^TypeVariable g t] (&/$Item (&/T [(.getName g) t]) m)) - (&/|table) - gvars - targs)] - (&host-type/instance-param &type/existential gtype-env gtype)) - (&/fail-with-loc (str "[Type Error] Mismatched number of type-parameters for " (&type/show-type obj-type) "\n" - "Expected: " (&/|length targs) "\n" - " Actual: " (&/|length gvars)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not an object type: " (&type/show-type obj-type))))) - -(defn generic-class->simple-class [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar var-name) - "java.lang.Object" - - (&/$GenericWildcard _) - "java.lang.Object" - - (&/$GenericClass name params) - name - - (&/$GenericArray param) - (|case param - (&/$GenericArray _) - (str "[" (generic-class->simple-class param)) - - (&/$GenericClass "boolean" _) - "[Z" - - (&/$GenericClass "byte" _) - "[B" - - (&/$GenericClass "short" _) - "[S" - - (&/$GenericClass "int" _) - "[I" - - (&/$GenericClass "long" _) - "[J" - - (&/$GenericClass "float" _) - "[F" - - (&/$GenericClass "double" _) - "[D" - - (&/$GenericClass "char" _) - "[C" - - (&/$GenericClass name params) - (str "[L" name ";") - - (&/$GenericTypeVar var-name) - "[Ljava.lang.Object;" - - (&/$GenericWildcard _) - "[Ljava.lang.Object;") - )) - -(defn generic-class->type [env gclass] - "(-> (List (, TypeVar Type)) GenericClass (Lux Type))" - (|case gclass - (&/$GenericTypeVar var-name) - (if-let [ex (&/|get var-name env)] - (return ex) - (&/fail-with-loc (str "[Analysis Error] Unknown type-var: " var-name))) - - (&/$GenericClass name params) - (case name - "boolean" (return (&/$Nominal "java.lang.Boolean" &/$End)) - "byte" (return (&/$Nominal "java.lang.Byte" &/$End)) - "short" (return (&/$Nominal "java.lang.Short" &/$End)) - "int" (return (&/$Nominal "java.lang.Integer" &/$End)) - "long" (return (&/$Nominal "java.lang.Long" &/$End)) - "float" (return (&/$Nominal "java.lang.Float" &/$End)) - "double" (return (&/$Nominal "java.lang.Double" &/$End)) - "char" (return (&/$Nominal "java.lang.Character" &/$End)) - "void" (return &type/Any) - ;; else - (|do [=params (&/map% (partial generic-class->type env) params)] - (return (&/$Nominal name =params)))) - - (&/$GenericArray param) - (|do [=param (generic-class->type env param)] - (return (&type/Array =param))) - - (&/$GenericWildcard _) - (return (&/$Existential &/$End (&/$Parameter 1))) - )) - -(defn gen-super-env - "(-> (List (, TypeVar Type)) (List SuperClassDecl) ClassDecl (Lux (List (, Text Type))))" - [class-env supers class-decl] - (|let [[class-name class-vars] class-decl] - (|case (&/|some (fn [super] - (|let [[super-name super-params] super] - (if (= class-name super-name) - (&/$Some (&/zip2 (&/|map &/|first class-vars) super-params)) - &/$None))) - supers) - (&/$None) - (&/fail-with-loc (str "[Analyser Error] Unrecognized super-class: " class-name)) - - (&/$Some vars+gtypes) - (&/map% (fn [var+gtype] - (|do [:let [[var gtype] var+gtype] - =gtype (generic-class->type class-env gtype)] - (return (&/T [var =gtype])))) - vars+gtypes) - ))) - -(defn- make-type-env - "(-> (List TypeParam) (Lux (List [Text Type])))" - [type-params] - (&/map% (fn [gvar] - (|do [:let [[gvar-name _] gvar] - ex &type/existential] - (return (&/T [gvar-name ex])))) - type-params)) - -(defn- double-register-gclass? [gclass] - (|case gclass - (&/$GenericClass name _) - (|case name - "long" true - "double" true - _ false) - - _ - false)) - -(defn- method-input-folder [full-env] - (fn [body* input*] - (|do [:let [[iname itype*] input*] - itype (generic-class->type full-env itype*)] - (if (double-register-gclass? itype*) - (&&env/with-local iname itype - (&&env/with-local "" &type/Nothing - body*)) - (&&env/with-local iname itype - body*))))) - -(defn- analyse-method - "(-> Analyser ClassDecl (List (, TypeVar Type)) (List SuperClassDecl) MethodSyntax (Lux MethodAnalysis))" - [analyse class-decl class-env all-supers method] - (|let [[?cname ?cparams] class-decl - class-type (&/$Nominal ?cname (&/|map &/|second class-env))] - (|case method - (&/$ConstructorMethodSyntax =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - :let [output-type &type/Any] - =ctor-args (&/map% (fn [ctor-arg] - (|do [:let [[ca-type ca-term] ctor-arg] - =ca-type (generic-class->type full-env ca-type) - =ca-term (&&/analyse-1 analyse =ca-type ca-term)] - (return (&/T [ca-type =ca-term])))) - ?ctor-args) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))] - (return (&/$ConstructorMethodAnalysis (&/T [=privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs =ctor-args =body])))) - - (&/$VirtualMethodSyntax ?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env (&/|++ class-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))] - (return (&/$VirtualMethodAnalysis (&/T [?name =privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$OverridenMethodSyntax ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [super-env (gen-super-env class-env all-supers ?class-decl) - method-env (make-type-env ?gvars) - :let [full-env (&/|++ super-env method-env)] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&&env/with-local &&/jvm-this class-type - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs))))] - (return (&/$OverridenMethodAnalysis (&/T [?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$StaticMethodSyntax ?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|do [method-env (make-type-env ?gvars) - :let [full-env method-env] - output-type (generic-class->type full-env ?output) - =body (&/with-type-env full-env - (&/fold (method-input-folder full-env) - (&&/analyse-1 analyse output-type ?body) - (&/|reverse ?inputs)))] - (return (&/$StaticMethodAnalysis (&/T [?name =privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output =body])))) - - (&/$AbstractMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$AbstractMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - - (&/$NativeMethodSyntax ?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (return (&/$NativeMethodAnalysis (&/T [?name =privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output]))) - ))) - -(defn- mandatory-methods [supers] - (|do [class-loader &/loader] - (&/flat-map% (partial &host/abstract-methods class-loader) supers))) - -(defn- check-method-completion - "(-> (List SuperClassDecl) (List (, MethodDecl Analysis)) (Lux Null))" - [supers methods] - (|do [abstract-methods (mandatory-methods supers) - :let [methods-map (&/fold (fn [mmap mentry] - (|case mentry - (&/$ConstructorMethodAnalysis _) - mmap - - (&/$VirtualMethodAnalysis _) - mmap - - (&/$OverridenMethodAnalysis =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (update-in mmap [=name] (fn [old-inputs] (if old-inputs (conj old-inputs =inputs) [=inputs]))) - - (&/$StaticMethodAnalysis _) - mmap - - (&/$AbstractMethodSyntax _) - mmap - - (&/$NativeMethodSyntax _) - mmap - )) - {} - methods) - missing-method (&/fold (fn [missing abs-meth] - (or missing - (|let [[am-name am-inputs] abs-meth] - (if-let [meth-struct (get methods-map am-name)] - (if (some (fn [=inputs] - (and (= (&/|length =inputs) (&/|length am-inputs)) - (&/fold2 (fn [prev mi ai] - (|let [[iname itype] mi] - (and prev (= (generic-class->simple-class itype) ai)))) - true - =inputs am-inputs))) - meth-struct) - nil - abs-meth) - abs-meth)))) - nil - abstract-methods)]] - (if (nil? missing-method) - (return nil) - (|let [[am-name am-inputs] missing-method] - (&/fail-with-loc (str "[Analyser Error] Missing method: " am-name " " "(" (->> am-inputs (&/|interpose " ") (&/fold str "")) ")")))))) - -(defn- analyse-field - "(-> Analyser GTypeEnv FieldSyntax (Lux FieldAnalysis))" - [analyse gtype-env field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|do [=gtype (&host-type/instance-gtype &type/existential gtype-env ?gclass) - =value (&&/analyse-1 analyse =gtype ?value)] - (return (&/$ConstantFieldAnalysis ?name ?anns ?gclass =value))) - - (&/$VariableFieldSyntax ?name ?privacy-modifier ?state-modifier ?anns ?type) - (return (&/$VariableFieldAnalysis ?name ?privacy-modifier ?state-modifier ?anns ?type)) - )) - -(do-template [ ] - (let [output-type (&/$Nominal &/$End)] - (defn- [analyse exo-type _?value] - (|do [:let [(&/$Item ?value (&/$End)) _?value] - =value (&&/analyse-1 analyse (&/$Nominal &/$End) ?value) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location (&&/$proc (&/T ["jvm" ]) (&/|list =value) (&/|list)))))))) - - analyse-jvm-double-to-float "double-to-float" "java.lang.Double" "java.lang.Float" - analyse-jvm-double-to-int "double-to-int" "java.lang.Double" "java.lang.Integer" - analyse-jvm-double-to-long "double-to-long" "java.lang.Double" "java.lang.Long" - - analyse-jvm-float-to-double "float-to-double" "java.lang.Float" "java.lang.Double" - analyse-jvm-float-to-int "float-to-int" "java.lang.Float" "java.lang.Integer" - analyse-jvm-float-to-long "float-to-long" "java.lang.Float" "java.lang.Long" - - analyse-jvm-int-to-byte "int-to-byte" "java.lang.Integer" "java.lang.Byte" - analyse-jvm-int-to-char "int-to-char" "java.lang.Integer" "java.lang.Character" - analyse-jvm-int-to-double "int-to-double" "java.lang.Integer" "java.lang.Double" - analyse-jvm-int-to-float "int-to-float" "java.lang.Integer" "java.lang.Float" - analyse-jvm-int-to-long "int-to-long" "java.lang.Integer" "java.lang.Long" - analyse-jvm-int-to-short "int-to-short" "java.lang.Integer" "java.lang.Short" - - analyse-jvm-long-to-double "long-to-double" "java.lang.Long" "java.lang.Double" - analyse-jvm-long-to-float "long-to-float" "java.lang.Long" "java.lang.Float" - analyse-jvm-long-to-int "long-to-int" "java.lang.Long" "java.lang.Integer" - analyse-jvm-long-to-short "long-to-short" "java.lang.Long" "java.lang.Short" - analyse-jvm-long-to-byte "long-to-byte" "java.lang.Long" "java.lang.Byte" - - analyse-jvm-char-to-byte "char-to-byte" "java.lang.Character" "java.lang.Byte" - analyse-jvm-char-to-short "char-to-short" "java.lang.Character" "java.lang.Short" - analyse-jvm-char-to-int "char-to-int" "java.lang.Character" "java.lang.Integer" - analyse-jvm-char-to-long "char-to-long" "java.lang.Character" "java.lang.Long" - - analyse-jvm-short-to-long "short-to-long" "java.lang.Short" "java.lang.Long" - - analyse-jvm-byte-to-long "byte-to-long" "java.lang.Byte" "java.lang.Long" - ) - -(do-template [ ] - (let [output-type (&/$Nominal &/$End)] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item ?value1 (&/$Item ?value2 (&/$End))) ?values] - =value1 (&&/analyse-1 analyse (&/$Nominal &/$End) ?value1) - =value2 (&&/analyse-1 analyse (&/$Nominal &/$End) ?value2) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location (&&/$proc (&/T ["jvm" ]) (&/|list =value1 =value2) (&/|list)))))))) - - analyse-jvm-iand "iand" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ior "ior" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ixor "ixor" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishl "ishl" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ishr "ishr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-iushr "iushr" "java.lang.Integer" "java.lang.Integer" "java.lang.Integer" - - analyse-jvm-land "land" "java.lang.Long" "java.lang.Long" "java.lang.Long" - analyse-jvm-lor "lor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - analyse-jvm-lxor "lxor" "java.lang.Long" "java.lang.Long" "java.lang.Long" - analyse-jvm-lshl "lshl" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - analyse-jvm-lshr "lshr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - analyse-jvm-lushr "lushr" "java.lang.Long" "java.lang.Integer" "java.lang.Long" - ) - -(do-template [ ] - (let [input-type (&/$Nominal &/$End) - output-type (&/$Nominal &/$End)] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item x (&/$Item y (&/$End))) ?values] - =x (&&/analyse-1 analyse input-type x) - =y (&&/analyse-1 analyse input-type y) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location - (&&/$proc (&/T ["jvm" ]) (&/|list =x =y) (&/|list)))))))) - - analyse-jvm-iadd "iadd" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-isub "isub" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-imul "imul" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-idiv "idiv" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-irem "irem" "java.lang.Integer" "java.lang.Integer" - analyse-jvm-ieq "ieq" "java.lang.Integer" "#Bit" - analyse-jvm-ilt "ilt" "java.lang.Integer" "#Bit" - analyse-jvm-igt "igt" "java.lang.Integer" "#Bit" - - analyse-jvm-ceq "ceq" "java.lang.Character" "#Bit" - analyse-jvm-clt "clt" "java.lang.Character" "#Bit" - analyse-jvm-cgt "cgt" "java.lang.Character" "#Bit" - - analyse-jvm-ladd "ladd" "java.lang.Long" "java.lang.Long" - analyse-jvm-lsub "lsub" "java.lang.Long" "java.lang.Long" - analyse-jvm-lmul "lmul" "java.lang.Long" "java.lang.Long" - analyse-jvm-ldiv "ldiv" "java.lang.Long" "java.lang.Long" - analyse-jvm-lrem "lrem" "java.lang.Long" "java.lang.Long" - analyse-jvm-leq "leq" "java.lang.Long" "#Bit" - analyse-jvm-llt "llt" "java.lang.Long" "#Bit" - analyse-jvm-lgt "lgt" "java.lang.Long" "#Bit" - - analyse-jvm-fadd "fadd" "java.lang.Float" "java.lang.Float" - analyse-jvm-fsub "fsub" "java.lang.Float" "java.lang.Float" - analyse-jvm-fmul "fmul" "java.lang.Float" "java.lang.Float" - analyse-jvm-fdiv "fdiv" "java.lang.Float" "java.lang.Float" - analyse-jvm-frem "frem" "java.lang.Float" "java.lang.Float" - analyse-jvm-feq "feq" "java.lang.Float" "#Bit" - analyse-jvm-flt "flt" "java.lang.Float" "#Bit" - analyse-jvm-fgt "fgt" "java.lang.Float" "#Bit" - - analyse-jvm-dadd "dadd" "java.lang.Double" "java.lang.Double" - analyse-jvm-dsub "dsub" "java.lang.Double" "java.lang.Double" - analyse-jvm-dmul "dmul" "java.lang.Double" "java.lang.Double" - analyse-jvm-ddiv "ddiv" "java.lang.Double" "java.lang.Double" - analyse-jvm-drem "drem" "java.lang.Double" "java.lang.Double" - analyse-jvm-deq "deq" "java.lang.Double" "#Bit" - analyse-jvm-dlt "dlt" "java.lang.Double" "#Bit" - analyse-jvm-dgt "dgt" "java.lang.Double" "#Bit" - ) - -(let [length-type &type/Nat - idx-type &type/Nat] - (do-template [ ] - (let [elem-type (&/$Nominal &/$End) - array-type (&/$Nominal &/$End)] - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item length (&/$End)) ?values] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" ]) (&/|list =length) (&/|list))))))) - - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item array (&/$Item idx (&/$End))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type elem-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx) (&/|list))))))) - - (defn- [analyse exo-type ?values] - (|do [:let [(&/$Item array (&/$Item idx (&/$Item elem (&/$End)))) ?values] - =array (&&/analyse-1 analyse array-type array) - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse elem-type elem) - _ (&type/check exo-type array-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" ]) (&/|list =array =idx =elem) (&/|list))))))) - ) - - "java.lang.Boolean" "[Z" analyse-jvm-znewarray "znewarray" analyse-jvm-zaload "zaload" analyse-jvm-zastore "zastore" - "java.lang.Byte" "[B" analyse-jvm-bnewarray "bnewarray" analyse-jvm-baload "baload" analyse-jvm-bastore "bastore" - "java.lang.Short" "[S" analyse-jvm-snewarray "snewarray" analyse-jvm-saload "saload" analyse-jvm-sastore "sastore" - "java.lang.Integer" "[I" analyse-jvm-inewarray "inewarray" analyse-jvm-iaload "iaload" analyse-jvm-iastore "iastore" - "java.lang.Long" "[J" analyse-jvm-lnewarray "lnewarray" analyse-jvm-laload "laload" analyse-jvm-lastore "lastore" - "java.lang.Float" "[F" analyse-jvm-fnewarray "fnewarray" analyse-jvm-faload "faload" analyse-jvm-fastore "fastore" - "java.lang.Double" "[D" analyse-jvm-dnewarray "dnewarray" analyse-jvm-daload "daload" analyse-jvm-dastore "dastore" - "java.lang.Character" "[C" analyse-jvm-cnewarray "cnewarray" analyse-jvm-caload "caload" analyse-jvm-castore "castore" - )) - -(defn- array-class? [class-name] - (or (= &host-type/array-data-tag class-name) - (case class-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") true - ;; else - false))) - -(let [length-type &type/Nat - idx-type &type/Nat] - (defn- analyse-jvm-anewarray [analyse exo-type ?values] - (|do [:let [(&/$Item [_ (&/$Text _gclass)] (&/$Item length (&/$End))) ?values] - gclass (&reader/with-source "jvm-anewarray" _gclass - &&a-parser/parse-gclass) - gtype-env &/get-type-env - =gclass (&host-type/instance-gtype &type/existential gtype-env gclass) - :let [array-type (&type/Array =gclass)] - =length (&&/analyse-1 analyse length-type length) - _ (&type/check exo-type array-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "anewarray"]) (&/|list =length) (&/|list gclass gtype-env))))))) - - (defn- analyse-jvm-aaload [analyse exo-type ?values] - (|do [:let [(&/$Item array (&/$Item idx (&/$End))) ?values] - =array (&&/analyse-1+ analyse array) - array-type (&type/normal (&&/expr-type* =array)) - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Item mutable_type (&/$End)) arr-params - (&/$Nominal "#Mutable" (&/$Item type_variance (&/$End))) mutable_type - (&/$Function write_type read_type) type_variance] - =idx (&&/analyse-1 analyse idx-type idx) - _ (&type/check exo-type read_type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "aaload"]) (&/|list =array =idx) (&/|list))))))) - - (defn- analyse-jvm-aastore [analyse exo-type ?values] - (|do [:let [(&/$Item array (&/$Item idx (&/$Item elem (&/$End)))) ?values] - =array (&&/analyse-1+ analyse array) - array-type (&type/normal (&&/expr-type* =array)) - [arr-class arr-params] (ensure-object array-type) - _ (&/assert! (= &host-type/array-data-tag arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - :let [(&/$Item mutable_type (&/$End)) arr-params - (&/$Nominal "#Mutable" (&/$Item type_variance (&/$End))) mutable_type - (&/$Function write_type read_type) type_variance] - =idx (&&/analyse-1 analyse idx-type idx) - =elem (&&/analyse-1 analyse write_type elem) - _ (&type/check exo-type array-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "aastore"]) (&/|list =array =idx =elem) (&/|list)))))))) - -(defn- analyse-jvm-arraylength [analyse exo-type ?values] - (|do [:let [(&/$Item array (&/$End)) ?values] - =array (&&/analyse-1+ analyse array) - [arr-class arr-params] (ensure-object (&&/expr-type* =array)) - _ (&/assert! (array-class? arr-class) (str "[Analyser Error] Expected array. Instead got: " arr-class)) - _ (&type/check exo-type &type/Nat) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "arraylength"]) (&/|list =array) (&/|list)) - ))))) - -(defn- analyse-jvm-object-null? [analyse exo-type ?values] - (|do [:let [(&/$Item object (&/$End)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bit] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "object null?"]) (&/|list =object) (&/|list))))))) - -(defn- analyse-jvm-object-null [analyse exo-type ?values] - (|do [:let [(&/$End) ?values] - :let [output-type (&/$Nominal &host-type/null-data-tag &/$End)] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "object null"]) (&/|list) (&/|list))))))) - -(defn analyse-jvm-object-synchronized [analyse exo-type ?values] - (|do [:let [(&/$Item ?monitor (&/$Item ?expr (&/$End))) ?values] - =monitor (&&/analyse-1+ analyse ?monitor) - _ (ensure-object (&&/expr-type* =monitor)) - =expr (&&/analyse-1 analyse exo-type ?expr) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "object synchronized"]) (&/|list =monitor =expr) (&/|list))))))) - -(defn- analyse-jvm-throw [analyse exo-type ?values] - (|do [:let [(&/$Item ?ex (&/$End)) ?values] - =ex (&&/analyse-1+ analyse ?ex) - _ (&type/check (&/$Nominal "java.lang.Throwable" &/$End) (&&/expr-type* =ex)) - [throw-class throw-params] (ensure-object (&&/expr-type* =ex)) - _location &/location - _ (&type/check exo-type &type/Nothing)] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "throw"]) (&/|list =ex) (&/|list))))))) - -(defn- analyse-jvm-getstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$End) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - =type (&host-type/instance-param &type/existential &/$End gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "getstatic"]) (&/|list) (&/|list class field output-type))))))) - -(defn- analyse-jvm-getfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Item object (&/$End)) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - [gvars gtype] (&host/lookup-field class-loader !class! field) - =type (analyse-field-access-helper (&&/expr-type* =object) gvars gtype) - :let [output-type =type] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "getfield"]) (&/|list =object) (&/|list class field output-type))))))) - -(defn- analyse-jvm-putstatic [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Item value (&/$End)) ?values] - class-loader &/loader - [gvars gtype] (&host/lookup-static-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (&host-type/instance-param &type/existential &/$End gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &type/Any] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "putstatic"]) (&/|list =value) (&/|list class field gclass))))))) - -(defn- analyse-jvm-putfield [analyse exo-type class field ?values] - (|do [!class! (&/de-alias-class class) - :let [(&/$Item object (&/$Item value (&/$End))) ?values] - class-loader &/loader - =object (&&/analyse-1+ analyse object) - :let [obj-type (&&/expr-type* =object)] - _ (ensure-object obj-type) - [gvars gtype] (&host/lookup-field class-loader !class! field) - :let [gclass (&host-type/gtype->gclass gtype)] - =type (analyse-field-access-helper obj-type gvars gtype) - =value (&&/analyse-1 analyse =type value) - :let [output-type &type/Any] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "putfield"]) (&/|list =object =value) (&/|list class field gclass =type))))))) - -(defn- analyse-method-call-helper [analyse exo-type gret gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$End) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =arg-types (&/map% &type/show-type+ arg-types) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - =gret (&host-type/instance-param &type/existential gtype-env gret) - _ (&type/check exo-type (as-otype+ =gret))] - (return (&/T [=gret =args]))) - - (&/$Item ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [(&/$Var _id) $var - gtype-env* (&/$Item (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-method-call-helper analyse exo-type gret gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn- up-cast [class parent-gvars class-loader !class! object-type] - (|do [[sub-class sub-params] (ensure-object object-type) - (&/$Nominal super-class* super-params*) (&host-type/->super-type &type/existential class-loader !class! (if (= sub-class class) - !class! - sub-class) - sub-params)] - (return (&/fold2 (fn [m ^TypeVariable g t] (&/$Item (&/T [(.getName g) t]) m)) - (&/|table) - parent-gvars - super-params*)))) - -(defn- check-method! [only-interface? class method] - (|do [!class!* (&/de-alias-class class) - :let [!class! (string/replace !class!* "/" ".")] - class-loader &/loader - _ (try (assert! (let [=class (Class/forName !class! true class-loader)] - (= only-interface? (.isInterface =class))) - (if only-interface? - (str "[Analyser Error] Can only invoke method \"" method "\"" " on interface.") - (str "[Analyser Error] Can only invoke method \"" method "\"" " on class."))) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " !class!))))] - (return (&/T [!class! class-loader])))) - -(let [dummy-type-param (&/$Nominal "java.lang.Object" &/$End)] - (do-template [ ] - (defn- [analyse exo-type class method classes ?values] - (|do [:let [(&/$Item object args) ?values] - [!class! class-loader] (check-method! class method) - [gret exceptions parent-gvars gvars gargs] (if (= "" method) - (return (&/T [Void/TYPE &/$End &/$End &/$End &/$End])) - (&host/lookup-virtual-method class-loader !class! method classes)) - =object (&&/analyse-1+ analyse object) - gtype-env (up-cast class parent-gvars class-loader !class! (&&/expr-type* =object)) - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" ]) (&/$Item =object =args) (&/|list class method classes output-type gret))))))) - - analyse-jvm-invokevirtual "invokevirtual" false - analyse-jvm-invokespecial "invokespecial" false - analyse-jvm-invokeinterface "invokeinterface" true - )) - -(defn- analyse-jvm-invokestatic [analyse exo-type class method classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [gret exceptions parent-gvars gvars gargs] (&host/lookup-static-method class-loader !class! method classes) - :let [gtype-env (&/|table)] - [output-type =args] (analyse-method-call-helper analyse exo-type gret gtype-env gvars gargs args) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "invokestatic"]) =args (&/|list class method classes output-type gret))))))) - -(defn- analyse-jvm-new-helper [analyse gtype gtype-env gtype-vars gtype-args args] - (|case gtype-vars - (&/$End) - (|do [arg-types (&/map% (partial &host-type/instance-param &type/existential gtype-env) gtype-args) - =args (&/map2% (partial &&/analyse-1 analyse) arg-types args) - gtype-vars* (->> gtype-env (&/|map &/|second) (clean-gtype-vars))] - (return (&/T [(make-gtype gtype gtype-vars*) - =args]))) - - (&/$Item ^TypeVariable gtv gtype-vars*) - (&type/with-var - (fn [$var] - (|do [:let [gtype-env* (&/$Item (&/T [(.getName gtv) $var]) gtype-env)] - [=gret =args] (analyse-jvm-new-helper analyse gtype gtype-env* gtype-vars* gtype-args args) - ==gret (&type/clean $var =gret) - ==args (&/map% (partial &&/clean-analysis $var) =args)] - (return (&/T [==gret ==args]))))) - )) - -(defn- analyse-jvm-new [analyse exo-type class classes ?values] - (|do [!class! (&/de-alias-class class) - :let [args ?values] - class-loader &/loader - [exceptions gvars gargs] (&host/lookup-constructor class-loader !class! classes) - [output-type =args] (analyse-jvm-new-helper analyse class (&/|table) gvars gargs args) - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta exo-type _location - (&&/$proc (&/T ["jvm" "new"]) =args (&/|list class classes))))))) - -(defn- analyse-jvm-instanceof [analyse exo-type class ?values] - (|do [:let [(&/$Item object (&/$End)) ?values] - =object (&&/analyse-1+ analyse object) - _ (ensure-object (&&/expr-type* =object)) - :let [output-type &type/Bit] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location - (&&/$proc (&/T ["jvm" "instanceof"]) (&/|list =object) (&/|list class))))))) - -(defn- analyse-jvm-object-class [analyse exo-type ?values] - (|do [:let [(&/$Item [_ (&/$Text _class-name)] (&/$End)) ?values] - ^ClassLoader class-loader &/loader - _ (try (do (.loadClass class-loader _class-name) - (return nil)) - (catch Exception e - (&/fail-with-loc (str "[Analyser Error] Unknown class: " _class-name)))) - :let [output-type (&/$Nominal "java.lang.Class" (&/|list (&/$Nominal _class-name (&/|list))))] - _ (&type/check exo-type output-type) - _location &/location] - (return (&/|list (&&/|meta output-type _location - (&&/$proc (&/T ["jvm" "object class"]) (&/|list) (&/|list _class-name output-type))))))) - -(defn- analyse-jvm-interface [analyse compile-interface interface-decl supers =anns =methods] - (|do [module &/get-module-name - _ (compile-interface interface-decl supers =anns =methods) - :let [_ (println 'INTERFACE (str module "." (&/|first interface-decl)))] - _location &/location] - (return (&/|list (&&/|meta &type/Any _location - (&&/$tuple (&/|list))))))) - -(defn- analyse-jvm-class [analyse compile-class class-decl super-class interfaces =inheritance-modifier =anns ?fields methods] - (&/with-closure - (|do [module &/get-module-name - :let [[?name ?params] class-decl - full-name (str (string/replace module "/" ".") "." ?name) - class-decl* (&/T [full-name ?params]) - all-supers (&/$Item super-class interfaces)] - class-env (make-type-env ?params) - =fields (&/map% (partial analyse-field analyse class-env) ?fields) - _ (&host/use-dummy-class class-decl super-class interfaces &/$None =fields methods) - =methods (&/map% (partial analyse-method analyse class-decl* class-env all-supers) methods) - ;; TODO: Uncomment - ;; _ (check-method-completion all-supers =methods) - _ (compile-class class-decl super-class interfaces =inheritance-modifier =anns =fields =methods &/$End &/$None) - _ &/pop-dummy-name - :let [_ (println 'CLASS full-name)] - _location &/location] - (return (&/|list (&&/|meta &type/Any _location - (&&/$tuple (&/|list)))))))) - -(defn- captured-source [env-entry] - (|case env-entry - [name [_ (&&/$captured _ _ source)]] - source)) - -(defn- analyse-methods [analyse class-decl all-supers methods] - (|do [=methods (&/map% (partial analyse-method analyse class-decl &/$End all-supers) methods) - ;; TODO: Uncomment - ;; _ (check-method-completion all-supers =methods) - =captured &&env/captured-vars] - (return (&/T [=methods =captured])))) - -(defn- get-names [] - (|do [module &/get-module-name - scope &/get-scope-name] - (return (&/T [module scope])))) - -(let [default- (fn [ctor-args] - (&/$ConstructorMethodSyntax (&/T [&/$PublicPM ;; privacy-modifier - false ;; strict - &/$End ;; anns - &/$End ;; gvars - &/$End ;; exceptions - &/$End ;; inputs - ctor-args ;; ctor-args - (&/$Tuple &/$End) ;; body - ]))) - captured-slot-class "java.lang.Object" - captured-slot-type (&/$GenericClass captured-slot-class &/$End)] - (defn- analyse-jvm-anon-class [analyse compile-class exo-type super-class interfaces ctor-args methods] - (&/with-closure - (|do [[module scope] (get-names) - :let [name (->> scope &/|reverse &/|tail &host/location) - class-decl (&/T [name &/$End]) - anon-class (str (string/replace module "/" ".") "." name) - class-type-decl (&/T [anon-class &/$End]) - anon-class-type (&/$Nominal anon-class &/$End)] - =ctor-args (&/map% (fn [ctor-arg] - (|let [[arg-type arg-term] ctor-arg] - (|do [=arg-term (&&/analyse-1+ analyse arg-term)] - (return (&/T [arg-type =arg-term]))))) - ctor-args) - _ (->> methods - (&/$Item (default- =ctor-args)) - (&host/use-dummy-class class-decl super-class interfaces (&/$Some =ctor-args) &/$End)) - [=methods =captured] (let [all-supers (&/$Item super-class interfaces)] - (analyse-methods analyse class-type-decl all-supers methods)) - _ (let [=fields (&/|map (fn [^objects idx+capt] - (|let [[idx _] idx+capt] - (&/$VariableFieldAnalysis (str &c!base/closure-prefix idx) - &/$PublicPM - &/$FinalSM - &/$End - captured-slot-type))) - (&/enumerate =captured))] - (compile-class class-decl super-class interfaces &/$DefaultIM &/$End =fields =methods =captured (&/$Some =ctor-args))) - _ &/pop-dummy-name - _location &/location] - (let [sources (&/|map captured-source =captured)] - (return (&/|list (&&/|meta anon-class-type _location - (&&/$proc (&/T ["jvm" "new"]) sources (&/|list anon-class (&/|repeat (&/|length sources) captured-slot-class))))))) - )))) - -(defn analyse-host [analyse exo-type compilers proc ?values] - (|let [[_ _ compile-class compile-interface] compilers] - (try (case proc - "jvm object synchronized" (analyse-jvm-object-synchronized analyse exo-type ?values) - "jvm object class" (analyse-jvm-object-class analyse exo-type ?values) - "jvm throw" (analyse-jvm-throw analyse exo-type ?values) - "jvm object null?" (analyse-jvm-object-null? analyse exo-type ?values) - "jvm object null" (analyse-jvm-object-null analyse exo-type ?values) - "jvm anewarray" (analyse-jvm-anewarray analyse exo-type ?values) - "jvm aaload" (analyse-jvm-aaload analyse exo-type ?values) - "jvm aastore" (analyse-jvm-aastore analyse exo-type ?values) - "jvm arraylength" (analyse-jvm-arraylength analyse exo-type ?values) - "jvm znewarray" (analyse-jvm-znewarray analyse exo-type ?values) - "jvm bnewarray" (analyse-jvm-bnewarray analyse exo-type ?values) - "jvm snewarray" (analyse-jvm-snewarray analyse exo-type ?values) - "jvm inewarray" (analyse-jvm-inewarray analyse exo-type ?values) - "jvm lnewarray" (analyse-jvm-lnewarray analyse exo-type ?values) - "jvm fnewarray" (analyse-jvm-fnewarray analyse exo-type ?values) - "jvm dnewarray" (analyse-jvm-dnewarray analyse exo-type ?values) - "jvm cnewarray" (analyse-jvm-cnewarray analyse exo-type ?values) - "jvm zaload" (analyse-jvm-zaload analyse exo-type ?values) - "jvm zastore" (analyse-jvm-zastore analyse exo-type ?values) - "jvm baload" (analyse-jvm-baload analyse exo-type ?values) - "jvm bastore" (analyse-jvm-bastore analyse exo-type ?values) - "jvm saload" (analyse-jvm-saload analyse exo-type ?values) - "jvm sastore" (analyse-jvm-sastore analyse exo-type ?values) - "jvm iaload" (analyse-jvm-iaload analyse exo-type ?values) - "jvm iastore" (analyse-jvm-iastore analyse exo-type ?values) - "jvm laload" (analyse-jvm-laload analyse exo-type ?values) - "jvm lastore" (analyse-jvm-lastore analyse exo-type ?values) - "jvm faload" (analyse-jvm-faload analyse exo-type ?values) - "jvm fastore" (analyse-jvm-fastore analyse exo-type ?values) - "jvm daload" (analyse-jvm-daload analyse exo-type ?values) - "jvm dastore" (analyse-jvm-dastore analyse exo-type ?values) - "jvm caload" (analyse-jvm-caload analyse exo-type ?values) - "jvm castore" (analyse-jvm-castore analyse exo-type ?values) - "jvm iadd" (analyse-jvm-iadd analyse exo-type ?values) - "jvm isub" (analyse-jvm-isub analyse exo-type ?values) - "jvm imul" (analyse-jvm-imul analyse exo-type ?values) - "jvm idiv" (analyse-jvm-idiv analyse exo-type ?values) - "jvm irem" (analyse-jvm-irem analyse exo-type ?values) - "jvm ieq" (analyse-jvm-ieq analyse exo-type ?values) - "jvm ilt" (analyse-jvm-ilt analyse exo-type ?values) - "jvm igt" (analyse-jvm-igt analyse exo-type ?values) - "jvm ceq" (analyse-jvm-ceq analyse exo-type ?values) - "jvm clt" (analyse-jvm-clt analyse exo-type ?values) - "jvm cgt" (analyse-jvm-cgt analyse exo-type ?values) - "jvm ladd" (analyse-jvm-ladd analyse exo-type ?values) - "jvm lsub" (analyse-jvm-lsub analyse exo-type ?values) - "jvm lmul" (analyse-jvm-lmul analyse exo-type ?values) - "jvm ldiv" (analyse-jvm-ldiv analyse exo-type ?values) - "jvm lrem" (analyse-jvm-lrem analyse exo-type ?values) - "jvm leq" (analyse-jvm-leq analyse exo-type ?values) - "jvm llt" (analyse-jvm-llt analyse exo-type ?values) - "jvm lgt" (analyse-jvm-lgt analyse exo-type ?values) - "jvm fadd" (analyse-jvm-fadd analyse exo-type ?values) - "jvm fsub" (analyse-jvm-fsub analyse exo-type ?values) - "jvm fmul" (analyse-jvm-fmul analyse exo-type ?values) - "jvm fdiv" (analyse-jvm-fdiv analyse exo-type ?values) - "jvm frem" (analyse-jvm-frem analyse exo-type ?values) - "jvm feq" (analyse-jvm-feq analyse exo-type ?values) - "jvm flt" (analyse-jvm-flt analyse exo-type ?values) - "jvm fgt" (analyse-jvm-fgt analyse exo-type ?values) - "jvm dadd" (analyse-jvm-dadd analyse exo-type ?values) - "jvm dsub" (analyse-jvm-dsub analyse exo-type ?values) - "jvm dmul" (analyse-jvm-dmul analyse exo-type ?values) - "jvm ddiv" (analyse-jvm-ddiv analyse exo-type ?values) - "jvm drem" (analyse-jvm-drem analyse exo-type ?values) - "jvm deq" (analyse-jvm-deq analyse exo-type ?values) - "jvm dlt" (analyse-jvm-dlt analyse exo-type ?values) - "jvm dgt" (analyse-jvm-dgt analyse exo-type ?values) - "jvm iand" (analyse-jvm-iand analyse exo-type ?values) - "jvm ior" (analyse-jvm-ior analyse exo-type ?values) - "jvm ixor" (analyse-jvm-ixor analyse exo-type ?values) - "jvm ishl" (analyse-jvm-ishl analyse exo-type ?values) - "jvm ishr" (analyse-jvm-ishr analyse exo-type ?values) - "jvm iushr" (analyse-jvm-iushr analyse exo-type ?values) - "jvm land" (analyse-jvm-land analyse exo-type ?values) - "jvm lor" (analyse-jvm-lor analyse exo-type ?values) - "jvm lxor" (analyse-jvm-lxor analyse exo-type ?values) - "jvm lshl" (analyse-jvm-lshl analyse exo-type ?values) - "jvm lshr" (analyse-jvm-lshr analyse exo-type ?values) - "jvm lushr" (analyse-jvm-lushr analyse exo-type ?values) - "jvm convert double-to-float" (analyse-jvm-double-to-float analyse exo-type ?values) - "jvm convert double-to-int" (analyse-jvm-double-to-int analyse exo-type ?values) - "jvm convert double-to-long" (analyse-jvm-double-to-long analyse exo-type ?values) - "jvm convert float-to-double" (analyse-jvm-float-to-double analyse exo-type ?values) - "jvm convert float-to-int" (analyse-jvm-float-to-int analyse exo-type ?values) - "jvm convert float-to-long" (analyse-jvm-float-to-long analyse exo-type ?values) - "jvm convert int-to-byte" (analyse-jvm-int-to-byte analyse exo-type ?values) - "jvm convert int-to-char" (analyse-jvm-int-to-char analyse exo-type ?values) - "jvm convert int-to-double" (analyse-jvm-int-to-double analyse exo-type ?values) - "jvm convert int-to-float" (analyse-jvm-int-to-float analyse exo-type ?values) - "jvm convert int-to-long" (analyse-jvm-int-to-long analyse exo-type ?values) - "jvm convert int-to-short" (analyse-jvm-int-to-short analyse exo-type ?values) - "jvm convert long-to-double" (analyse-jvm-long-to-double analyse exo-type ?values) - "jvm convert long-to-float" (analyse-jvm-long-to-float analyse exo-type ?values) - "jvm convert long-to-int" (analyse-jvm-long-to-int analyse exo-type ?values) - "jvm convert long-to-short" (analyse-jvm-long-to-short analyse exo-type ?values) - "jvm convert long-to-byte" (analyse-jvm-long-to-byte analyse exo-type ?values) - "jvm convert char-to-byte" (analyse-jvm-char-to-byte analyse exo-type ?values) - "jvm convert char-to-short" (analyse-jvm-char-to-short analyse exo-type ?values) - "jvm convert char-to-int" (analyse-jvm-char-to-int analyse exo-type ?values) - "jvm convert char-to-long" (analyse-jvm-char-to-long analyse exo-type ?values) - "jvm convert byte-to-long" (analyse-jvm-byte-to-long analyse exo-type ?values) - "jvm convert short-to-long" (analyse-jvm-short-to-long analyse exo-type ?values) - ;; else - (->> (&/fail-with-loc (str "[Analyser Error] Unknown host procedure: " ["jvm" proc])) - (if-let [[_ _def-code] (re-find #"^jvm interface:(.*)$" proc)] - (|do [[_module _line _column] &/location] - (&reader/with-source (str "interface@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =supers =anns =methods] &&a-parser/parse-interface-def] - (analyse-jvm-interface analyse compile-interface =gclass-decl =supers =anns =methods))))) - - (if-let [[_ _def-code] (re-find #"^jvm class:(.*)$" proc)] - (|do [[_module _line _column] &/location] - (&reader/with-source (str "class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods] &&a-parser/parse-class-def] - (analyse-jvm-class analyse compile-class =gclass-decl =super-class =interfaces =inheritance-modifier =anns =fields =methods))))) - - (if-let [[_ _def-code] (re-find #"^jvm anon-class:(.*)$" proc)] - (|do [[_module _line _column] &/location] - (&reader/with-source (str "anon-class@" "(" _module "," _line "," _column ")") _def-code - (|do [[=super-class =interfaces =ctor-args =methods] &&a-parser/parse-anon-class-def] - (analyse-jvm-anon-class analyse compile-class exo-type =super-class =interfaces =ctor-args =methods))))) - - (if-let [[_ _class] (re-find #"^jvm instanceof:([^:]+)$" proc)] - (analyse-jvm-instanceof analyse exo-type _class ?values)) - - (if-let [[_ _class _arg-classes] (re-find #"^jvm new:([^:]+):([^:]*)$" proc)] - (analyse-jvm-new analyse exo-type _class (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokestatic:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokestatic analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokeinterface:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokeinterface analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokevirtual:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokevirtual analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _method _arg-classes] (re-find #"^jvm invokespecial:([^:]+):([^:]+):([^:]*)$" proc)] - (analyse-jvm-invokespecial analyse exo-type _class _method (if (= "" _arg-classes) (&/|list) (&/->list (string/split _arg-classes #","))) ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm getstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm getfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-getfield analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm putstatic:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putstatic analyse exo-type _class _field ?values)) - - (if-let [[_ _class _field] (re-find #"^jvm putfield:([^:]+):([^:]+)$" proc)] - (analyse-jvm-putfield analyse exo-type _class _field ?values)))) - (catch Exception ex - (&/fail-with-loc (str "[Analyser Error] Invalid syntax for procedure: " proc)))) - )) diff --git a/lux-bootstrapper/src/lux/analyser/record.clj b/lux-bootstrapper/src/lux/analyser/record.clj deleted file mode 100644 index a90c52cc3b..0000000000 --- a/lux-bootstrapper/src/lux/analyser/record.clj +++ /dev/null @@ -1,132 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.analyser.record - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return |case]] - [type :as &type]) - (lux.analyser [base :as &&] - [module :as &&module]))) - -(defn ^:private record_slot [slot0] - (|do [[module name] (&&/resolved-ident slot0) - exported?&label (fn [lux] - (|case ((&&module/find-slot module name) lux) - (&/$Left error) - (&/$Right (&/T [lux &/$None])) - - (&/$Right [lux* output]) - (&/$Right (&/T [lux* (&/$Some output)]))))] - (return (|case exported?&label - (&/$Some [exported? [label* type]]) - (&/$Some (&/T [label* type])) - - (&/$None) - &/$None)))) - -(defn ^:private slot_type - "(-> [Label Code] Type)" - [it] - (|let [[[label* type] value] it] - type)) - -(defn ^:private same_record? - "(-> (List [Label Code]) Bit)" - [it] - (|case it - (&/$Item head tail) - (|let [expected (slot_type head)] - (&/|every? (fn [it] (->> it slot_type (&type/type= expected))) - tail)) - - (&/$End) - false)) - -(defn ^:private complete_record? - "(-> (List [Label Code]) Bit)" - [it] - (loop [expected_lefts 0 - remaining it] - (|case remaining - (&/$Item [[label* type] value] (&/$End)) - (|case label* - (&/$Some [lefts true family]) - (= (dec expected_lefts) lefts) - - (&/$None) - (= 0 expected_lefts)) - - (&/$Item [[(&/$Some [lefts false family]) type] value] tail) - (and (= expected_lefts lefts) - (recur (inc expected_lefts) tail)) - - _ - false))) - -;; [Exports] -(defn order-record - "(-> (List Syntax) (Lux (Maybe (List Syntax))))" - [pattern_matching? pairs] - (let [arity (&/|length pairs)] - (cond (= 0 arity) - (return &/$None) - - (even? arity) - (let [pairs (&/|as-pairs pairs)] - (|do [resolved_slots* (&/map% (fn [pair] - (|case pair - [[_ (&/$Identifier slot0)] value] - (|case slot0 - ["" short0] - (if pattern_matching? - (return &/$None) - (|do [local? (&&module/find_local short0)] - (|case local? - (&/$None) - (|do [slot (record_slot slot0)] - (return (|case slot - (&/$Some slot*) - (&/$Some (&/T [slot* value])) - - (&/$None) - &/$None))) - - (&/$Some [local _inner _outer]) - (return &/$None)))) - - [module0 short0] - (|do [slot (record_slot slot0)] - (return (|case slot - (&/$Some slot*) - (&/$Some (&/T [slot* value])) - - (&/$None) - &/$None)))) - - _ - (return &/$None))) - pairs)] - (|case (&/all_maybe resolved_slots*) - (&/$Some resolved_slots) - (|do [:let [sorted_slots (->> resolved_slots - &/->seq - (sort (fn [left right] - (|let [[[(&/$Some [leftsL right?L familyL]) typeL] valueL] left - [[(&/$Some [leftsR right?R familyR]) typeR] valueR] right] - (if (= leftsL leftsR) - (not right?L) - (< leftsL leftsR))))) - &/->list)] - _ (&/assert! (same_record? sorted_slots) - "[Analyser Error] Slots correspond to different record types.") - _ (&/assert! (complete_record? sorted_slots) - "[Analyser Error] Missing record slots.")] - (return (&/$Some (&/T [(&/|map &/|second sorted_slots) - (slot_type (&/|head sorted_slots))])))) - - (&/$None) - (return &/$None)))) - - true - (return &/$None)))) diff --git a/lux-bootstrapper/src/lux/base.clj b/lux-bootstrapper/src/lux/base.clj deleted file mode 100644 index 982630727d..0000000000 --- a/lux-bootstrapper/src/lux/base.clj +++ /dev/null @@ -1,1544 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.base - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array)) - -(def prelude - "library/lux") - -(def !log! (atom false)) -(defn flag-prn! [& args] - (when @!log! - (apply prn args))) - -;; [Tags] -(def unit-tag - (.intern "")) - -(defn T [elems] - (case (count elems) - 0 - unit-tag - - 1 - (first elems) - - ;; else - (to-array elems))) - -(defmacro defvariant [& names] - (assert (> (count names) 1)) - `(do ~@(for [[[name num-params] idx] (map vector names (range (count names))) - :let [last-idx (dec (count names)) - [lefts right?] (if (= idx last-idx) - [(dec idx) ""] - [idx nil]) - def-name (with-meta (symbol (str "$" name)) - {::lefts lefts - ::right? right?})]] - (cond (= 0 num-params) - `(def ~def-name - (to-array [(int ~lefts) ~right? unit-tag])) - - (= 1 num-params) - `(defn ~def-name [arg#] - (to-array [(int ~lefts) ~right? arg#])) - - :else - (let [g!args (map (fn [_] (gensym "arg")) - (range num-params))] - `(defn ~def-name [~@g!args] - (to-array [(int ~lefts) ~right? (T [~@g!args])]))) - )))) - -(defmacro deftuple [names] - (assert (vector? names)) - `(do ~@(for [[name idx] (map vector names (range (count names)))] - `(def ~(symbol (str "$" name)) - (int ~idx))))) - -;; List -(defvariant - ("End" 0) - ("Item" 2)) - -;; Maybe -(defvariant - ("None" 0) - ("Some" 1)) - -;; Either -(defvariant - ("Left" 1) - ("Right" 1)) - -;; Code -(defvariant - ("Bit" 1) - ("Nat" 1) - ("Int" 1) - ("Rev" 1) - ("Dec" 1) - ("Text" 1) - ("Identifier" 1) - ("Form" 1) - ("Variant" 1) - ("Tuple" 1)) - -;; Type -(defvariant - ("Nominal" 2) - ("Sum" 2) - ("Product" 2) - ("Function" 2) - ("Parameter" 1) - ("Var" 1) - ("Opaque" 1) - ("Universal" 2) - ("Existential" 2) - ("Apply" 2) - ("Named" 2)) - -;; Vars -(defvariant - ("Local" 1) - ("Captured" 1)) - -;; Binding -(deftuple - ["counter" - "mappings"]) - -;; Type-Context -(deftuple - ["ex-counter" - "var-counter" - "var-bindings"]) - -;; Env -(deftuple - ["name" - "inner" - "locals" - "captured"]) - -;; Host -(deftuple - ["writer" - "loader" - "classes" - "type-env" - "dummy-mappings"]) - -(defvariant - ("Build" 0) - ("Eval" 0) - ("REPL" 0)) - -(deftuple - ["target" - "version" - "mode" - "configuration"]) - -;; Hosts -(defvariant - ("Jvm" 1) - ("Js" 1)) - -(defvariant - ("DefinitionG" 1) - ("AliasG" 1) - ("DefaultG" 1)) - -(deftuple - ["info" - "source" - "location" - "current-module" - "modules" - "scopes" - "type-context" - "expected" - "seed" - "scope-type-vars" - "extensions" - "eval" - "host"]) - -(defvariant - ("UpperBound" 0) - ("LowerBound" 0)) - -(defvariant - ("GenericTypeVar" 1) - ("GenericClass" 2) - ("GenericArray" 1) - ("GenericWildcard" 1)) - -;; Privacy Modifiers -(defvariant - ("DefaultPM" 0) - ("PublicPM" 0) - ("PrivatePM" 0) - ("ProtectedPM" 0)) - -;; State Modifiers -(defvariant - ("DefaultSM" 0) - ("VolatileSM" 0) - ("FinalSM" 0)) - -;; Inheritance Modifiers -(defvariant - ("DefaultIM" 0) - ("AbstractIM" 0) - ("FinalIM" 0)) - -;; Fields -(defvariant - ("ConstantFieldSyntax" 4) - ("VariableFieldSyntax" 5)) - -(defvariant - ("ConstantFieldAnalysis" 4) - ("VariableFieldAnalysis" 5)) - -;; Methods -(defvariant - ("ConstructorMethodSyntax" 1) - ("VirtualMethodSyntax" 1) - ("OverridenMethodSyntax" 1) - ("StaticMethodSyntax" 1) - ("AbstractMethodSyntax" 1) - ("NativeMethodSyntax" 1)) - -(defvariant - ("ConstructorMethodAnalysis" 1) - ("VirtualMethodAnalysis" 1) - ("OverridenMethodAnalysis" 1) - ("StaticMethodAnalysis" 1) - ("AbstractMethodAnalysis" 1) - ("NativeMethodAnalysis" 1)) - -;; [Exports] -(def ^:const value-field "_value") -(def ^:const module-class-name "_") -(def ^:const +name-separator+ ".") - -(def ^:const ^String version "00.08.00") - -;; Constructors -(def empty-location (T ["" -1 -1])) - -(defn get$ [slot ^objects record] - (aget record slot)) - -(defn set$ [slot value ^objects record] - (doto (aclone ^objects record) - (aset slot value))) - -(defmacro update$ [slot f record] - `(let [record# ~record] - (set$ ~slot (~f (get$ ~slot record#)) - record#))) - -(defn fail* [message] - ($Left message)) - -(defn return* [state value] - ($Right (T [state value]))) - -(defn transform-pattern [pattern] - (cond (vector? pattern) (case (count pattern) - 0 - unit-tag - - 1 - (transform-pattern (first pattern)) - - ;; else - (mapv transform-pattern pattern)) - (seq? pattern) (if-let [tag-var (ns-resolve *ns* (first pattern))] - [(-> tag-var meta ::lefts) - (-> tag-var meta ::right?) - (transform-pattern (vec (rest pattern)))] - (assert false (str "Unknown var: " (first pattern)))) - :else pattern)) - -(defmacro |case [value & branches] - (assert (even? (count branches))) - (let [value* (if (vector? value) - [`(T [~@value])] - [value])] - `(matchv ::M/objects ~value* - ~@(mapcat (fn [[pattern body]] - (list [(transform-pattern pattern)] - body)) - (partition 2 branches))))) - -(defmacro |let [bindings body] - (reduce (fn [inner [left right]] - `(|case ~right - ~left - ~inner)) - body - (reverse (partition 2 bindings)))) - -(defmacro |list [& elems] - (reduce (fn [tail head] - `($Item ~head ~tail)) - `$End - (reverse elems))) - -(defn |get [slot table] - (|case table - ($End) - nil - - ($Item [k v] table*) - (if (= k slot) - v - (recur slot table*)))) - -(defn |remove [slot table] - (|case table - ($End) - table - - ($Item [k v] table*) - (if (= k slot) - table* - ($Item (T [k v]) (|remove slot table*))))) - -(defn |update [k f table] - (|case table - ($End) - table - - ($Item [k* v] table*) - (if (= k k*) - ($Item (T [k* (f v)]) table*) - ($Item (T [k* v]) (|update k f table*))))) - -(defn |head [xs] - (|case xs - ($End) - (assert false (prn-str '|head)) - - ($Item x _) - x)) - -(defn |tail [xs] - (|case xs - ($End) - (assert false (prn-str '|tail)) - - ($Item _ xs*) - xs*)) - -;; [Resources/Monads] -(defn fail [message] - (fn [_] - ($Left message))) - -(defn return [value] - (fn [state] - ($Right (T [state value])))) - -(defn bind [m-value step] - (fn [state] - (let [inputs (m-value state)] - (|case inputs - ($Right ?state ?datum) - ((step ?datum) ?state) - - ($Left _) - inputs - )))) - -(defmacro |do [steps return] - (assert (even? (count steps)) "The number of steps must be even!") - (reduce (fn [inner [label computation]] - (case label - :let `(|let ~computation ~inner) - ;; else - `(bind ~computation - (fn [val#] - (|case val# - ~label - ~inner))))) - return - (reverse (partition 2 steps)))) - -;; [Resources/Combinators] -(let [array-class (class (to-array []))] - (defn adt->text [adt] - (if (= array-class (class adt)) - (str "[" (->> adt (map adt->text) (interpose " ") (reduce str "")) "]") - (pr-str adt)))) - -(defn |++ [xs ys] - (|case xs - ($End) - ys - - ($Item x xs*) - ($Item x (|++ xs* ys)))) - -(defn |map [f xs] - (|case xs - ($End) - xs - - ($Item x xs*) - ($Item (f x) (|map f xs*)) - - _ - (assert false (prn-str '|map f (adt->text xs))))) - -(defn |empty? - "(All [a] (-> (List a) Bit))" - [xs] - (|case xs - ($End) - true - - ($Item _ _) - false)) - -(defn |filter - "(All [a] (-> (-> a Bit) (List a) (List a)))" - [p xs] - (|case xs - ($End) - xs - - ($Item x xs*) - (if (p x) - ($Item x (|filter p xs*)) - (|filter p xs*)))) - -(defn flat-map - "(All [a b] (-> (-> a (List b)) (List a) (List b)))" - [f xs] - (|case xs - ($End) - xs - - ($Item x xs*) - (|++ (f x) (flat-map f xs*)))) - -(defn |split-with [p xs] - (|case xs - ($End) - (T [xs xs]) - - ($Item x xs*) - (if (p x) - (|let [[pre post] (|split-with p xs*)] - (T [($Item x pre) post])) - (T [$End xs])))) - -(defn |contains? [k table] - (|case table - ($End) - false - - ($Item [k* _] table*) - (or (= k k*) - (|contains? k table*)))) - -(defn |member? [x xs] - (|case xs - ($End) - false - - ($Item x* xs*) - (or (= x x*) (|member? x xs*)))) - -(defn fold [f init xs] - (|case xs - ($End) - init - - ($Item x xs*) - (recur f (f init x) xs*))) - -(defn |put [slot value table] - (loop [prefix $End - input table] - (|case input - ($End) - (fold (fn [tail head] - ($Item head tail)) - ($Item (T [slot value]) $End) - prefix) - - ($Item [k v] input*) - (if (= k slot) - (fold (fn [tail head] - ($Item head tail)) - ($Item (T [slot value]) input*) - prefix) - (recur ($Item (T [k v]) prefix) - input*)) - ))) - -(defmacro |table [& elems] - (reduce (fn [table [k v]] - `(|put ~k ~v ~table)) - `$End - (reverse (partition 2 elems)))) - -(defn fold% [f init xs] - (|case xs - ($End) - (return init) - - ($Item x xs*) - (|do [init* (f init x)] - (fold% f init* xs*)))) - -(defn folds [f init xs] - (|case xs - ($End) - (|list init) - - ($Item x xs*) - ($Item init (folds f (f init x) xs*)))) - -(defn |length [xs] - (fold (fn [acc _] (inc acc)) 0 xs)) - -(defn |range* [from to] - (if (<= from to) - ($Item from (|range* (inc from) to)) - $End)) - -(let [|range* (fn |range* [from to] - (if (< from to) - ($Item from (|range* (inc from) to)) - $End))] - (defn |range [n] - (|range* 0 n))) - -(defn |first [pair] - (|let [[_1 _2] pair] - _1)) - -(defn |second [pair] - (|let [[_1 _2] pair] - _2)) - -(defn zip2 [xs ys] - (|case [xs ys] - [($Item x xs*) ($Item y ys*)] - ($Item (T [x y]) (zip2 xs* ys*)) - - [_ _] - $End)) - -(defn |keys [plist] - (|case plist - ($End) - $End - - ($Item [k v] plist*) - ($Item k (|keys plist*)))) - -(defn |vals [plist] - (|case plist - ($End) - $End - - ($Item [k v] plist*) - ($Item v (|vals plist*)))) - -(defn |interpose [sep xs] - (|case xs - ($End) - xs - - ($Item _ ($End)) - xs - - ($Item x xs*) - ($Item x ($Item sep (|interpose sep xs*))))) - -(do-template [ ] - (defn [f xs] - (|case xs - ($End) - (return xs) - - ($Item x xs*) - (|do [y (f x) - ys ( f xs*)] - (return ( y ys))))) - - map% $Item - flat-map% |++) - -(defn list-join [xss] - (fold |++ $End xss)) - -(defn |reverse [xs] - (fold (fn [tail head] - ($Item head tail)) - $End - xs)) - -(defn |as-pairs [xs] - (loop [input xs - output $End] - (|case input - ($Item headL ($Item headR tail)) - (recur tail ($Item (T [headL headR]) output)) - - _ - (|reverse output)))) - -(defn add-loc [meta ^String msg] - (if (.startsWith msg "@") - msg - (|let [[file line col] meta] - (str "@ " file "," line "," col "\n" msg)))) - -(defn fail-with-loc [^String msg] - (fn [state] - (fail* (add-loc (get$ $location state) msg)))) - -(defn assert! [test ^String message] - (if test - (return unit-tag) - (fail-with-loc message))) - -(def get-state - (fn [state] - (return* state state))) - -(defn try% [action] - (fn [state] - (|case (action state) - ($Right output) - ($Right (T [state ($Some output)])) - - ($Left _) - ($Right (T [state $None]))))) - -(defn try-all% [monads] - (|case monads - ($End) - (fail "[Error] There are no alternatives to try!") - - ($Item m monads*) - (fn [state] - (let [output (m state)] - (|case [output monads*] - [($Right _) _] - output - - [_ ($End)] - output - - [_ _] - ((try-all% monads*) state) - ))) - )) - -(defn try-all-% [prefix monads] - (|case monads - ($End) - (fail "[Error] There are no alternatives to try!") - - ($Item m monads*) - (fn [state] - (let [output (m state)] - (|case [output monads*] - [($Right _) _] - output - - [_ ($End)] - output - - [($Left ^String error) _] - (if (.contains error prefix) - ((try-all-% prefix monads*) state) - output) - ))) - )) - -(defn exhaust% [step] - (fn [state] - (|case (step state) - ($Right state* _) - ((exhaust% step) state*) - - ($Left ^String msg) - (if (.contains msg "[Reader Error] EOF") - (return* state unit-tag) - (fail* msg))))) - -(defn |some - "(All [a b] (-> (-> a (Maybe b)) (List a) (Maybe b)))" - [f xs] - (|case xs - ($End) - $None - - ($Item x xs*) - (|case (f x) - ($None) (|some f xs*) - output output) - )) - -(defn ^:private normalize-char [char] - (case char - \* "_AS" - \+ "_PL" - \- "_DS" - \/ "_SL" - \\ "_BS" - \_ "_US" - \% "_PC" - \$ "_DL" - \' "_QU" - \` "_BQ" - \@ "_AT" - \^ "_CR" - \& "_AA" - \= "_EQ" - \! "_BG" - \? "_QM" - \: "_CO" - \; "_SC" - \. "_PD" - \, "_CM" - \< "_LT" - \> "_GT" - \~ "_TI" - \| "_PI" - ;; default - char)) - -(defn normalize-name [ident] - (reduce str "" (map normalize-char ident))) - -(def +init-bindings+ - (T [;; "lux;counter" - 0 - ;; "lux;mappings" - (|table)])) - -(def +init-type-context+ - (T [;; ex-counter - 0 - ;; var-counter - 0 - ;; var-bindings - (|table)])) - -(defn env [name old-name] - (T [;; name - ($Item name old-name) - ;; inner - 0 - ;; locals - +init-bindings+ - ;; captured - +init-bindings+] - )) - -(do-template [ ] - (do (def - (fn [compiler] - (|case (get$ $host compiler) - ( host-data) - (return* compiler host-data) - - _ - ((fail-with-loc (str "[Error] Wrong host.\nExpected: " )) - compiler)))) - - (def - (fn [compiler] - (|case (get$ $host compiler) - ( host-data) - (return* compiler true) - - _ - (return* compiler false)))) - - (defn [slot updater] - (|do [host ] - (fn [compiler] - (return* (set$ $host ( (update$ slot updater host)) compiler) - (get$ slot host))))) - - (defn [slot updater body] - (|do [old-val ( slot updater) - ?output-val body - new-val ( slot (fn [_] old-val))] - (return ?output-val)))) - - $Jvm "JVM" jvm-host jvm? change-jvm-host-slot with-jvm-host-slot - $Js "JS" js-host js? change-js-host-slot with-js-host-slot - ) - -(do-template [ ] - (def - (|do [host jvm-host] - (return (get$ host)))) - - loader $loader - classes $classes - get-type-env $type-env - ) - -(def get-writer - (|do [host jvm-host] - (|case (get$ $writer host) - ($Some writer) - (return writer) - - _ - (fail-with-loc "[Error] Writer has not been set.")))) - -(defn with-writer [writer body] - (with-jvm-host-slot $writer (fn [_] ($Some writer)) body)) - -(defn with-type-env - "(All [a] (-> TypeEnv (Meta a) (Meta a)))" - [type-env body] - (with-jvm-host-slot $type-env (partial |++ type-env) body)) - -(defn push-dummy-name [real-name store-name] - (change-jvm-host-slot $dummy-mappings (partial $Item (T [real-name store-name])))) - -(def pop-dummy-name - (change-jvm-host-slot $dummy-mappings |tail)) - -(defn de-alias-class [class-name] - (|do [host jvm-host] - (return (|case (|some #(|let [[real-name store-name] %] - (if (= real-name class-name) - ($Some store-name) - $None)) - (get$ $dummy-mappings host)) - ($Some store-name) - store-name - - _ - class-name)))) - -(defn default-info [target mode] - (T [;; target - target - ;; version - version - ;; mode - mode - ;; configuration - $End] - )) - -(defn init-state [name mode host-data] - (T [;; "lux;info" - (default-info name mode) - ;; "lux;source" - $End - ;; "lux;location" - (T ["" -1 -1]) - ;; "current-module" - $None - ;; "lux;modules" - (|table) - ;; "lux;scopes" - $End - ;; "lux;type-context" - +init-type-context+ - ;; "lux;expected" - $None - ;; "lux;seed" - 0 - ;; scope-type-vars - $End - ;; extensions - "" ;; This is an invalid value. But I don't expect extensions to be used with the bootstrapping compiler. - ;; eval - "" ;; This is an invalid value. But I don't expect eval to be used with the bootstrapping compiler. - ;; "lux;host" - host-data] - )) - -(defn save-module [body] - (fn [state] - (|case (body state) - ($Right state* output) - (return* (->> state* - (set$ $scopes (get$ $scopes state)) - (set$ $source (get$ $source state))) - output) - - ($Left msg) - (fail* msg)))) - -(do-template [ ] - (defn - "(-> CompilerMode Bit)" - [mode] - (|case mode - () true - _ false)) - - in-eval? $Eval - in-repl? $REPL - ) - -(defn with-eval [body] - (fn [state] - (let [old-mode (->> state (get$ $info) (get$ $mode))] - (|case (body (update$ $info #(set$ $mode $Eval %) state)) - ($Right state* output) - (return* (update$ $info #(set$ $mode old-mode %) state*) output) - - ($Left msg) - (fail* msg))))) - -(def get-eval - (fn [state] - (return* state (->> state (get$ $info) (get$ $mode) in-eval?)))) - -(def get-mode - (fn [state] - (return* state (->> state (get$ $info) (get$ $mode))))) - -(def get-top-local-env - (fn [state] - (try (let [top (|head (get$ $scopes state))] - (return* state top)) - (catch Throwable _ - ((fail-with-loc "[Error] No local environment.") - state))))) - -(def gen-id - (fn [state] - (let [seed (get$ $seed state)] - (return* (set$ $seed (inc seed) state) seed)))) - -(defn ->seq [xs] - (|case xs - ($End) - (list) - - ($Item x xs*) - (cons x (->seq xs*)))) - -(defn ->list [seq] - (if (empty? seq) - $End - ($Item (first seq) (->list (rest seq))))) - -(defn |repeat [n x] - (if (> n 0) - ($Item x (|repeat (dec n) x)) - $End)) - -(def get-module-name - (fn [state] - (|case (get$ $current-module state) - ($None) - ((fail-with-loc "[Analyser Error] Cannot get the module-name without a module.") - state) - - ($Some module-name) - (return* state module-name)))) - -(defn find-module - "(-> Text (Meta (Module Lux)))" - [name] - (fn [state] - (if-let [module (|get name (get$ $modules state))] - (return* state module) - ((fail-with-loc (str "[Error] Unknown module: " name)) - state)))) - -(def ^{:doc "(Meta (Module Lux))"} - get-current-module - (|do [module-name get-module-name] - (find-module module-name))) - -(defn with-scope [name body] - (fn [state] - (let [old-name (->> state (get$ $scopes) |head (get$ $name)) - output (body (update$ $scopes #($Item (env name old-name) %) state))] - (|case output - ($Right state* datum) - (return* (update$ $scopes |tail state*) datum) - - _ - output)))) - -(defn without-scope [body] - (fn [state] - (|case (body (set$ $scopes (|list (env "WITHOUT-SCOPE" "")) state)) - ($Right state* datum) - (return* (set$ $scopes (get$ $scopes state) state*) - datum) - - output - output))) - -(defn run-state [monad state] - (monad state)) - -(defn with-closure [body] - (|do [closure-name (|do [top get-top-local-env] - (return (->> top (get$ $inner) str)))] - (fn [state] - (let [body* (with-scope closure-name body)] - (run-state body* (update$ $scopes #($Item (update$ $inner inc (|head %)) - (|tail %)) - state)))))) - -(let [!out! *out*] - (defn |log! [& parts] - (binding [*out* !out!] - (do (print (str (apply str parts) "\n")) - (flush))))) - -(defn |last [xs] - (|case xs - ($Item x ($End)) - x - - ($Item x xs*) - (|last xs*) - - _ - (assert false (adt->text xs)))) - -(def get-scope-name - (fn [state] - (return* state (->> state (get$ $scopes) |head (get$ $name))))) - -(defn without-repl-closure [body] - (|do [_mode get-mode - current-scope get-scope-name] - (fn [state] - (let [output (body (if (and (in-repl? _mode) - (->> current-scope |last (= "REPL"))) - (update$ $scopes |tail state) - state))] - (|case output - ($Right state* datum) - (return* (set$ $scopes (get$ $scopes state) state*) datum) - - _ - output))))) - -(defn without-repl [body] - (|do [_mode get-mode] - (fn [state] - (let [output (body (if (in-repl? _mode) - (update$ $info #(set$ $mode $Build %) state) - state))] - (|case output - ($Right state* datum) - (return* (update$ $info #(set$ $mode _mode %) state*) datum) - - _ - output))))) - -(defn with-expected-type - "(All [a] (-> Type (Meta a)))" - [type body] - (fn [state] - (let [output (body (set$ $expected ($Some type) state))] - (|case output - ($Right ?state ?value) - (return* (set$ $expected (get$ $expected state) ?state) - ?value) - - _ - output)))) - -(defn with-location - "(All [a] (-> Location (Meta a)))" - [^objects location body] - (|let [[_file-name _ _] location] - (if (= "" _file-name) - body - (fn [state] - (let [output (body (set$ $location location state))] - (|case output - ($Right ?state ?value) - (return* (set$ $location (get$ $location state) ?state) - ?value) - - _ - output)))))) - -(defn with-analysis-meta - "(All [a] (-> Location Type (Meta a)))" - [^objects location type body] - (|let [[_file-name _ _] location] - (if (= "" _file-name) - (fn [state] - (let [output (body (->> state - (set$ $expected ($Some type))))] - (|case output - ($Right ?state ?value) - (return* (->> ?state - (set$ $expected (get$ $expected state))) - ?value) - - _ - output))) - (fn [state] - (let [output (body (->> state - (set$ $location location) - (set$ $expected ($Some type))))] - (|case output - ($Right ?state ?value) - (return* (->> ?state - (set$ $location (get$ $location state)) - (set$ $expected (get$ $expected state))) - ?value) - - _ - output)))))) - -(def ^{:doc "(Meta Any)"} - ensure-declaration - (fn [state] - (|case (get$ $expected state) - ($None) - (return* state unit-tag) - - ($Some _) - ((fail-with-loc "[Error] All declarations must be top-level forms.") - state)))) - -(def location - ;; (Meta Location) - (fn [state] - (return* state (get$ $location state)))) - -(def rev-bits 64) - -(let [clean-separators (fn [^String input] - (.replaceAll input "_" "")) - rev-text-to-digits (fn [^String input] - (loop [output (vec (repeat rev-bits 0)) - index (dec (.length input))] - (if (>= index 0) - (let [digit (Byte/parseByte (.substring input index (inc index)))] - (recur (assoc output index digit) - (dec index))) - output))) - times5 (fn [index digits] - (loop [index index - carry 0 - digits digits] - (if (>= index 0) - (let [raw (->> (get digits index) (* 5) (+ carry))] - (recur (dec index) - (int (/ raw 10)) - (assoc digits index (rem raw 10)))) - digits))) - rev-digit-power (fn [level] - (loop [output (-> (vec (repeat rev-bits 0)) - (assoc level 1)) - times level] - (if (>= times 0) - (recur (times5 level output) - (dec times)) - output))) - rev-digits-lt (fn rev-digits-lt - ([subject param index] - (and (< index rev-bits) - (or (< (get subject index) - (get param index)) - (and (= (get subject index) - (get param index)) - (rev-digits-lt subject param (inc index)))))) - ([subject param] - (rev-digits-lt subject param 0))) - rev-digits-sub-once (fn [subject param-digit index] - (if (>= (get subject index) - param-digit) - (update-in subject [index] #(- % param-digit)) - (recur (update-in subject [index] #(- 10 (- param-digit %))) - 1 - (dec index)))) - rev-digits-sub (fn [subject param] - (loop [target subject - index (dec rev-bits)] - (if (>= index 0) - (recur (rev-digits-sub-once target (get param index) index) - (dec index)) - target))) - rev-digits-to-text (fn [digits] - (loop [output "" - index (dec rev-bits)] - (if (>= index 0) - (recur (-> (get digits index) - (Character/forDigit 10) - (str output)) - (dec index)) - output))) - add-rev-digit-powers (fn [dl dr] - (loop [index (dec rev-bits) - output (vec (repeat rev-bits 0)) - carry 0] - (if (>= index 0) - (let [raw (+ carry - (get dl index) - (get dr index))] - (recur (dec index) - (assoc output index (rem raw 10)) - (int (/ raw 10)))) - output)))] - ;; Based on the Runtime.encode_rev method - (defn encode-rev [input] - (if (= 0 input) - ".0" - (loop [index (dec rev-bits) - output (vec (repeat rev-bits 0))] - (if (>= index 0) - (recur (dec index) - (if (bit-test input index) - (->> (- (dec rev-bits) index) - rev-digit-power - (add-rev-digit-powers output)) - output)) - (-> output rev-digits-to-text - (->> (str ".")) - (.split "0*$") - (aget 0)))))) - - ;; Based on the Runtime.decode_rev method - (defn decode-rev [^String input] - (if (and (.startsWith input ".") - (<= (.length input) (inc rev-bits))) - (loop [digits-left (-> input - (.substring 1) - clean-separators - rev-text-to-digits) - index 0 - ouput 0] - (if (< index rev-bits) - (let [power-slice (rev-digit-power index)] - (if (not (rev-digits-lt digits-left power-slice)) - (recur (rev-digits-sub digits-left power-slice) - (inc index) - (bit-set ouput (- (dec rev-bits) index))) - (recur digits-left - (inc index) - ouput))) - ouput)) - (throw (new java.lang.Exception (str "Bad format for Rev number: " input))))) - ) - -(defn show-ast [ast] - (|case ast - [_ ($Bit ?value)] - (pr-str ?value) - - [_ ($Nat ?value)] - (Long/toUnsignedString ?value) - - [_ ($Int ?value)] - (if (< ?value 0) - (pr-str ?value) - (str "+" (pr-str ?value))) - - [_ ($Rev ?value)] - (encode-rev ?value) - - [_ ($Dec ?value)] - (pr-str ?value) - - [_ ($Text ?value)] - (str "\"" ?value "\"") - - [_ ($Identifier ?module ?name)] - (if (.equals "" ?module) - ?name - (str ?module +name-separator+ ?name)) - - [_ ($Variant ?elems)] - (str "{" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "}") - - [_ ($Tuple ?elems)] - (str "[" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) "]") - - [_ ($Form ?elems)] - (str "(" (->> ?elems (|map show-ast) (|interpose " ") (fold str "")) ")") - - _ - (assert false (prn-str 'show-ast (adt->text ast))) - )) - -(defn ident->text [ident] - (|let [[?module ?name] ident] - (if (= "" ?module) - ?name - (str ?module +name-separator+ ?name)))) - -(defn fold2% [f init xs ys] - (|case [xs ys] - [($Item x xs*) ($Item y ys*)] - (|do [init* (f init x y)] - (fold2% f init* xs* ys*)) - - [($End) ($End)] - (return init) - - [_ _] - (assert false "Lists do not match in size."))) - -(defn map2% [f xs ys] - (|case [xs ys] - [($Item x xs*) ($Item y ys*)] - (|do [z (f x y) - zs (map2% f xs* ys*)] - (return ($Item z zs))) - - [($End) ($End)] - (return $End) - - [_ _] - (assert false "Lists do not match in size."))) - -(defn map2 [f xs ys] - (|case [xs ys] - [($Item x xs*) ($Item y ys*)] - ($Item (f x y) (map2 f xs* ys*)) - - [_ _] - $End)) - -(defn fold2 [f init xs ys] - (|case [xs ys] - [($Item x xs*) ($Item y ys*)] - (and init - (fold2 f (f init x y) xs* ys*)) - - [($End) ($End)] - init - - [_ _] - init - ;; (assert false) - )) - -(defn ^:private enumerate* - "(All [a] (-> Int (List a) (List (, Int a))))" - [idx xs] - (|case xs - ($Item x xs*) - ($Item (T [idx x]) - (enumerate* (inc idx) xs*)) - - ($End) - xs - )) - -(defn enumerate - "(All [a] (-> (List a) (List (, Int a))))" - [xs] - (enumerate* 0 xs)) - -(def ^{:doc "(Meta (List Text))"} - modules - (fn [state] - (return* state (|keys (get$ $modules state))))) - -(defn when% - "(-> Bit (Meta Any) (Meta Any))" - [test body] - (if test - body - (return unit-tag))) - -(defn |at - "(All [a] (-> Int (List a) (Maybe a)))" - [idx xs] - (|case xs - ($Item x xs*) - (cond (< idx 0) - $None - - (= idx 0) - ($Some x) - - :else ;; > 1 - (|at (dec idx) xs*)) - - ($End) - $None)) - -(defn normalize - "(-> Ident (Meta Ident))" - [ident] - (|case ident - ["" name] (|do [module get-module-name] - (return (T [module name]))) - _ (return ident))) - -(defn ident= [x y] - (|let [[xmodule xname] x - [ymodule yname] y] - (and (= xmodule ymodule) - (= xname yname)))) - -(defn |list-put [idx val xs] - (|case xs - ($End) - $None - - ($Item x xs*) - (if (= idx 0) - ($Some ($Item val xs*)) - (|case (|list-put (dec idx) val xs*) - ($None) $None - ($Some xs**) ($Some ($Item x xs**))) - ))) - -(do-template [ ] - (defn - "(All [a] (-> (-> a Bit) (List a) Bit))" - [p xs] - (|case xs - ($End) - - - ($Item x xs*) - ( (p x) ( p xs*)))) - - |every? true and - |any? false or) - -(defn m-comp - "(All [a b c] (-> (-> b (Meta c)) (-> a (Meta b)) (-> a (Meta c))))" - [f g] - (fn [x] - (|do [y (g x)] - (f y)))) - -(defn with-attempt - "(All [a] (-> (Meta a) (-> Text (Meta a)) (Meta a)))" - [m-value on-error] - (fn [state] - (|case (m-value state) - ($Left msg) - ((on-error msg) state) - - output - output))) - -(defn |take [n xs] - (|case (T [n xs]) - [0 _] $End - [_ ($End)] $End - [_ ($Item x xs*)] ($Item x (|take (dec n) xs*)) - )) - -(defn |drop [n xs] - (|case (T [n xs]) - [0 _] xs - [_ ($End)] $End - [_ ($Item x xs*)] (|drop (dec n) xs*) - )) - -(defn |but-last [xs] - (|case xs - ($End) - $End - - ($Item x ($End)) - $End - - ($Item x xs*) - ($Item x (|but-last xs*)) - - _ - (assert false (adt->text xs)))) - -(defn |partition [n xs] - (->> xs ->seq (partition-all n) (map ->list) ->list)) - -(defn with-scope-type-var [id body] - (fn [state] - (|case (body (set$ $scope-type-vars - ($Item id (get$ $scope-type-vars state)) - state)) - ($Right [state* output]) - ($Right (T [(set$ $scope-type-vars - (get$ $scope-type-vars state) - state*) - output])) - - ($Left msg) - ($Left msg)))) - -(defn with-module [name body] - (fn [state] - (|case (body (set$ $current-module ($Some name) state)) - ($Right [state* output]) - ($Right (T [(set$ $current-module (get$ $current-module state) state*) - output])) - - ($Left msg) - ($Left msg)))) - -(defn |eitherL [left right] - (fn [compiler] - (|case (run-state left compiler) - ($Left _error) - (run-state right compiler) - - _output - _output))) - -(defn timed% [what when operation] - (fn [state] - (let [pre (System/currentTimeMillis)] - (|case (operation state) - ($Right state* output) - (let [post (System/currentTimeMillis) - duration (- post pre) - _ (|log! (str what " [" when "]: +" duration "ms"))] - ($Right (T [state* output]))) - - ($Left ^String msg) - (fail* msg))))) - -(defn all_maybe - "(All (_ value) - (-> (List (Maybe value)) - (Maybe (List value))))" - [it] - (|case it - ($Item head tail) - (|case head - ($Some head*) - (|case (all_maybe tail) - ($Some tail*) - ($Some ($Item head* tail*)) - - ($None) - $None) - - ($None) - $None) - - ($End) - ($Some $End))) diff --git a/lux-bootstrapper/src/lux/compiler.clj b/lux-bootstrapper/src/lux/compiler.clj deleted file mode 100644 index 0b0275fed8..0000000000 --- a/lux-bootstrapper/src/lux/compiler.clj +++ /dev/null @@ -1,32 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler - (:refer-clojure :exclude [compile]) - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]]) - (lux.compiler [core :as &&core] - [io :as &&io] - [parallel :as &¶llel] - [jvm :as &&jvm]))) - -(defn init! [dependencies ^String target-dir] - (do (reset! &&core/!output-dir target-dir) - (&¶llel/setup!) - (&&io/init-libs! dependencies) - (.mkdirs (new java.io.File target-dir)) - (&&jvm/init!))) - -(def all-compilers - &&jvm/all-compilers) - -(defn eval! [expr] - (&&jvm/eval! expr)) - -(defn compile-module [source-dirs name] - (&&jvm/compile-module source-dirs name)) - -(defn compile-program [mode program-module program-definition dependencies source-dirs target-dir] - (init! dependencies target-dir) - (&&jvm/compile-program mode program-module program-definition source-dirs)) diff --git a/lux-bootstrapper/src/lux/compiler/cache.clj b/lux-bootstrapper/src/lux/compiler/cache.clj deleted file mode 100644 index b07843bb3c..0000000000 --- a/lux-bootstrapper/src/lux/compiler/cache.clj +++ /dev/null @@ -1,211 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.cache - (:refer-clojure :exclude [load]) - (:require [clojure.string :as string] - [clojure.java.io :as io] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler [core :as &&core] - [io :as &&io]) - (lux.compiler.cache [type :as &&&type])) - (:import (java.io File) - )) - -;; [Resources] -(defn ^:private delete-all-module-files [^File file] - (doseq [^File f (seq (.listFiles file)) - :when (not (.isDirectory f))] - (.delete f))) - -(defn ^:private ^String module-path [module] - (str @&&core/!output-dir - java.io.File/separator - (.replace ^String (&host/->module-class module) "/" java.io.File/separator))) - -(defn cached? - "(-> Text Bit)" - [module] - (.exists (new File (str (module-path module) java.io.File/separator &&core/lux-module-descriptor-name)))) - -(defn delete - "(-> Text (Lux Null))" - [module] - (fn [state] - (do (delete-all-module-files (new File (module-path module))) - (return* state nil)))) - -(defn ^:private module-dirs - "(-> File (clojure.Seq File))" - [^File module] - (->> module - .listFiles - (filter #(.isDirectory ^File %)) - (map module-dirs) - (apply concat) - (list* module))) - -(defn clean - "(-> Lux Null)" - [state] - (let [needed-modules (->> state (&/get$ &/$modules) &/|keys &/->seq set) - output-dir-prefix (str (.getAbsolutePath (new File ^String @&&core/!output-dir)) java.io.File/separator) - outdated? #(->> % (contains? needed-modules) not) - outdated-modules (->> (new File ^String @&&core/!output-dir) - .listFiles (filter #(.isDirectory ^File %)) - (map module-dirs) doall (apply concat) - (map (fn [^File dir-file] - (let [^String dir-module (-> dir-file - .getAbsolutePath - (string/replace output-dir-prefix "")) - corrected-dir-module (.replace dir-module java.io.File/separator "/")] - corrected-dir-module))) - (filter outdated?))] - (doseq [^String f outdated-modules] - (delete-all-module-files (new File (str output-dir-prefix f)))) - nil)) - -(defn make-identifier [ident] - (&/T [(&/T ["" 0 0]) (&/$Identifier ident)])) - -(defn ^:private process-def-entry [load-def-value module ^String _def-entry] - (let [parts (.split _def-entry &&core/datum-separator)] - (case (first parts) - "A" (let [[_ _name _exported? ^String _alias] parts - [__module __name] (.split _alias &/+name-separator+)] - (&a-module/define-alias module _name (= "1" _exported?) (&/T [__module __name]))) - "D" (let [[_ _name _exported? _type] parts - [def-type _] (&&&type/deserialize-type _type)] - (|do [def-value (load-def-value module _name)] - (&a-module/define module _name (= "1" _exported?) def-type def-value))) - ))) - -(defn ^:private uninstall-cache [module] - (|do [_ (delete module)] - (return false))) - -(defn ^:private install-module [load-def-value module module-hash imports def-entries] - (|do [_ (&a-module/create-module module module-hash) - _ (&a-module/flag-cached-module module) - _ (&a-module/set-imports imports) - _ (&/map% (partial process-def-entry load-def-value module) - def-entries)] - (return nil))) - -(defn ^:private process-module [pre-load! source-dirs cache-table module-name module-hash - _imports-section _defs-section - load-def-value install-all-defs-in-module uninstall-all-defs-in-module] - (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [imports (let [imports (vec (.split ^String _imports-section &&core/entry-separator)) - imports (if (= [""] imports) - &/$End - (&/->list imports))] - (&/|map #(first (vec (.split ^String % &&core/datum-separator 2))) imports))] - cache-table* (&/fold% (fn [cache-table* _module] - (|do [[file-name file-content] (&&io/read-file source-dirs _module) - output (pre-load! source-dirs cache-table* _module (hash file-content) - load-def-value install-all-defs-in-module uninstall-all-defs-in-module)] - (return output))) - cache-table - imports)] - (if (&/|every? (fn [_module] (contains? cache-table* _module)) - imports) - (let [def-entries (let [def-entries (vec (.split ^String _defs-section &&core/entry-separator))] - (if (= [""] def-entries) - &/$End - (&/->list def-entries)))] - (|do [_ (install-all-defs-in-module module-name) - _ (install-module load-def-value module-name module-hash imports def-entries) - =module (&/find-module module-name)] - (return (&/T [true (assoc cache-table* module-name =module)])))) - (return (&/T [false cache-table*]))))) - -(defn ^:private enumerate-cached-modules!* [^File parent] - (if (.isDirectory parent) - (let [children (for [^File child (seq (.listFiles parent)) - entry (enumerate-cached-modules!* child)] - entry)] - (if (.exists (new File parent &&core/lux-module-descriptor-name)) - (list* (.getAbsolutePath parent) - children) - children)) - (list))) - -(defn ^:private enumerate-cached-modules! [] - (let [output-dir (new File ^String @&&core/!output-dir) - prefix-to-subtract (inc (.length (.getAbsolutePath output-dir)))] - (->> output-dir - enumerate-cached-modules!* - rest - (map #(-> ^String % - (.replace java.io.File/separator "/") - (.substring prefix-to-subtract))) - &/->list))) - -(defn ^:private pre-load! [source-dirs cache-table module-name module-hash - load-def-value install-all-defs-in-module uninstall-all-defs-in-module] - (cond (contains? cache-table module-name) - (return cache-table) - - (not (cached? module-name)) - (return cache-table) - - :else - (|do [^String descriptor (&&core/read-module-descriptor! module-name) - :let [[_compiler _hash _imports-section _defs-section] (.split descriptor &&core/section-separator) - drop-cache! (|do [_ (uninstall-cache module-name) - _ (uninstall-all-defs-in-module module-name)] - (return cache-table))]] - (if (and (= module-hash (Long/parseUnsignedLong ^String _hash)) - (= &/version _compiler)) - (|do [[success? cache-table*] (process-module pre-load! source-dirs cache-table module-name module-hash - _imports-section _defs-section - load-def-value install-all-defs-in-module uninstall-all-defs-in-module) - _ (if success? - (return nil) - drop-cache!)] - (return cache-table*)) - drop-cache!)))) - -(def ^:private !pre-loaded-cache (atom nil)) -(defn pre-load-cache! [source-dirs - load-def-value install-all-defs-in-module uninstall-all-defs-in-module] - (|do [:let [fs-cached-modules (enumerate-cached-modules!)] - pre-loaded-modules (&/fold% (fn [cache-table module-name] - (fn [_compiler] - (|case ((&&io/read-file source-dirs module-name) - _compiler) - (&/$Left error) - (return* _compiler cache-table) - - (&/$Right _compiler* [file-name file-content]) - ((pre-load! source-dirs cache-table module-name (hash file-content) - load-def-value install-all-defs-in-module uninstall-all-defs-in-module) - _compiler*)))) - {} - fs-cached-modules) - :let [_ (reset! !pre-loaded-cache pre-loaded-modules)]] - (return nil))) - -(defn ^:private inject-module - "(-> Module Lux (Lux Null))" - [module-name module] - (fn [compiler] - (return* (&/update$ &/$modules - #(&/|put module-name module %) - compiler) - nil))) - -(defn load - "(-> Text (Lux Null))" - [module-name] - (if-let [module-struct (get @!pre-loaded-cache module-name)] - (|do [_ (inject-module module-name module-struct)] - (return nil)) - (&/fail (str "[Cache Error] Module is not cached: " module-name)))) diff --git a/lux-bootstrapper/src/lux/compiler/cache/ann.clj b/lux-bootstrapper/src/lux/compiler/cache/ann.clj deleted file mode 100644 index d07ba52bfd..0000000000 --- a/lux-bootstrapper/src/lux/compiler/cache/ann.clj +++ /dev/null @@ -1,127 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.cache.ann - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]]))) - -(def ^:private stop (->> 7 char str)) -(def ^:private cons-signal (->> 5 char str)) -(def ^:private nil-signal (->> 6 char str)) - -(defn ^:private serialize-seq [serialize params] - (str (&/fold (fn [so-far param] - (str so-far cons-signal (serialize param))) - "" - params) - nil-signal)) - -(defn ^:private serialize-ident [ident] - (|let [[module name] ident] - (str module &/+name-separator+ name))) - -(defn serialize - "(-> Code Text)" - [ann] - (|case ann - [_ (&/$Bit value)] - (str "B" value stop) - - [_ (&/$Nat value)] - (str "N" value stop) - - [_ (&/$Int value)] - (str "I" value stop) - - [_ (&/$Rev value)] - (str "R" value stop) - - [_ (&/$Dec value)] - (str "D" value stop) - - [_ (&/$Text value)] - (str "T" value stop) - - [_ (&/$Identifier ident)] - (str "@" (serialize-ident ident) stop) - - [_ (&/$Form elems)] - (str "(" (serialize-seq serialize elems)) - - [_ (&/$Tuple elems)] - (str "[" (serialize-seq serialize elems)) - - [_ (&/$Variant kvs)] - (str "{" (serialize-seq serialize elems)) - - _ - (assert false) - )) - -(declare deserialize) - -(def dummy-location - (&/T ["" 0 0])) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (let [[value* ^String input*] (.split (.substring input 1) stop 2)] - [(&/T [dummy-location ( ( value*))]) input*]))) - - ^:private deserialize-bit "B" &/$Bit Boolean/parseBoolean - ^:private deserialize-nat "N" &/$Nat Long/parseLong - ^:private deserialize-int "I" &/$Int Long/parseLong - ^:private deserialize-rev "R" &/$Rev Long/parseLong - ^:private deserialize-dec "D" &/$Dec Double/parseDouble - ^:private deserialize-text "T" &/$Text identity - ) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (let [[^String ident* ^String input*] (.split (.substring input 1) stop 2) - [_module _name] (.split ident* "\\." 2)] - [(&/T [dummy-location ( (&/T [_module _name]))]) input*]))) - - ^:private deserialize-identifier "@" &/$Identifier) - -(defn ^:private deserialize-seq [deserializer ^String input] - (cond (.startsWith input nil-signal) - [&/$End (.substring input 1)] - - (.startsWith input cons-signal) - (when-let [[head ^String input*] (deserializer (.substring input 1))] - (when-let [[tail ^String input*] (deserialize-seq deserializer input*)] - [(&/$Item head tail) input*])) - )) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (when-let [[elems ^String input*] (deserialize-seq - (.substring input 1))] - [(&/T [dummy-location ( elems)]) input*]))) - - ^:private deserialize-form "(" &/$Form deserialize - ^:private deserialize-tuple "[" &/$Tuple deserialize - ^:private deserialize-variant "{" &/$Variant deserialize - ) - -(defn deserialize - "(-> Text V[Code Text])" - [input] - (or (deserialize-bit input) - (deserialize-nat input) - (deserialize-int input) - (deserialize-rev input) - (deserialize-dec input) - (deserialize-text input) - (deserialize-identifier input) - (deserialize-form input) - (deserialize-variant input) - (deserialize-tuple input) - (assert false "[Cache Error] Cannot deserialize annocation."))) diff --git a/lux-bootstrapper/src/lux/compiler/cache/type.clj b/lux-bootstrapper/src/lux/compiler/cache/type.clj deleted file mode 100644 index 7bd5c92a7c..0000000000 --- a/lux-bootstrapper/src/lux/compiler/cache/type.clj +++ /dev/null @@ -1,146 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.cache.type - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]] - [type :as &type]))) - -(def ^:private stop (->> 7 char str)) -(def ^:private cons-signal (->> 5 char str)) -(def ^:private nil-signal (->> 6 char str)) - -(defn ^:private serialize-list [serialize-type params] - (str (&/fold (fn [so-far param] - (str so-far cons-signal (serialize-type param))) - "" - params) - nil-signal)) - -(defn serialize-type - "(-> Type Text)" - [type] - (if (&type/type= &type/Type type) - "T" - (|case type - (&/$Nominal name params) - (str "^" name stop (serialize-list serialize-type params)) - - (&/$Product left right) - (str "*" (serialize-type left) (serialize-type right)) - - (&/$Sum left right) - (str "+" (serialize-type left) (serialize-type right)) - - (&/$Function left right) - (str ">" (serialize-type left) (serialize-type right)) - - (&/$Universal env body) - (str "U" (serialize-list serialize-type env) (serialize-type body)) - - (&/$Existential env body) - (str "E" (serialize-list serialize-type env) (serialize-type body)) - - (&/$Parameter idx) - (str "$" idx stop) - - (&/$Opaque idx) - (str "!" idx stop) - - (&/$Var idx) - (str "?" idx stop) - - (&/$Apply left right) - (str "%" (serialize-type left) (serialize-type right)) - - (&/$Named [module name] type*) - (str "@" module &/+name-separator+ name stop (serialize-type type*)) - - _ - (assert false (prn 'serialize-type (&type/show-type type))) - ))) - -(declare deserialize-type) - -(defn ^:private deserialize-list [^String input] - (cond (.startsWith input nil-signal) - [&/$End (.substring input 1)] - - (.startsWith input cons-signal) - (when-let [[head ^String input*] (deserialize-type (.substring input 1))] - (when-let [[tail ^String input*] (deserialize-list input*)] - [(&/$Item head tail) input*])) - )) - -(defn ^:private deserialize-type* [^String input] - (when (.startsWith input "T") - [&type/Type (.substring input 1)])) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (when-let [[left ^String input*] (deserialize-type (.substring input 1))] - (when-let [[right ^String input*] (deserialize-type input*)] - [( left right) input*])) - )) - - ^:private deserialize-sum "+" &/$Sum - ^:private deserialize-prod "*" &/$Product - ^:private deserialize-lambda ">" &/$Function - ^:private deserialize-app "%" &/$Apply - ) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (let [[idx ^String input*] (.split (.substring input 1) stop 2)] - [( (Long/parseLong idx)) input*]))) - - ^:private deserialize-parameter "$" &/$Parameter - ^:private deserialize-ex "!" &/$Opaque - ^:private deserialize-var "?" &/$Var - ) - -(defn ^:private deserialize-named [^String input] - (when (.startsWith input "@") - (let [[^String module+name ^String input*] (.split (.substring input 1) stop 2) - [module name] (.split module+name "\\." 2)] - (when-let [[type* ^String input*] (deserialize-type input*)] - [(&/$Named (&/T [module name]) type*) input*])))) - -(do-template [ ] - (defn [^String input] - (when (.startsWith input ) - (when-let [[env ^String input*] (deserialize-list (.substring input 1))] - (when-let [[body ^String input*] (deserialize-type input*)] - [( env body) input*])))) - - ^:private deserialize-univq "U" &/$Universal - ^:private deserialize-exq "E" &/$Existential - ) - -(defn ^:private deserialize-host [^String input] - (when (.startsWith input "^") - (let [[name ^String input*] (.split (.substring input 1) stop 2)] - (when-let [[params ^String input*] (deserialize-list input*)] - [(&/$Nominal name params) input*])))) - -(defn deserialize-type - "(-> Text Type)" - [input] - (or (deserialize-type* input) - (deserialize-sum input) - (deserialize-prod input) - (deserialize-lambda input) - (deserialize-app input) - (deserialize-parameter input) - (deserialize-ex input) - (deserialize-var input) - (deserialize-named input) - (deserialize-univq input) - (deserialize-exq input) - (deserialize-host input) - (assert false (str "[Cache error] Cannot deserialize type. --- " input)))) diff --git a/lux-bootstrapper/src/lux/compiler/core.clj b/lux-bootstrapper/src/lux/compiler/core.clj deleted file mode 100644 index 3d4a389e4c..0000000000 --- a/lux-bootstrapper/src/lux/compiler/core.clj +++ /dev/null @@ -1,83 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.core - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|case |let |do return* return fail*]]) - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler.cache [type :as &&&type])) - (:import (java.io File - BufferedOutputStream - FileOutputStream))) - -;; [Constants] -(def !output-dir (atom nil)) - -(def ^:const section-separator (->> 29 char str)) -(def ^:const datum-separator (->> 31 char str)) -(def ^:const entry-separator (->> 30 char str)) - -;; [Utils] -(defn write-file [^String file-name ^bytes data] - (do (assert (not (.exists (File. file-name))) (str "Cannot overwrite file: " file-name)) - (with-open [stream (BufferedOutputStream. (FileOutputStream. file-name))] - (.write stream data) - (.flush stream)))) - -;; [Exports] -(def ^String lux-module-descriptor-name "lux_module_descriptor") - -(defn write-module-descriptor! [^String name ^String descriptor] - (|do [_ (return nil) - :let [lmd-dir (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator)) - _ (.mkdirs (File. lmd-dir)) - _ (write-file (str lmd-dir java.io.File/separator lux-module-descriptor-name) (.getBytes descriptor java.nio.charset.StandardCharsets/UTF_8))]] - (return nil))) - -(defn read-module-descriptor! [^String name] - (|do [_ (return nil)] - (return (slurp (str @!output-dir java.io.File/separator (.replace name "/" java.io.File/separator) java.io.File/separator lux-module-descriptor-name) - :encoding "UTF-8")))) - -(defn generate-module-descriptor [file-hash] - (|do [module-name &/get-module-name - defs &a-module/defs - imports &a-module/imports - :let [def-entries (&/fold (fn [def-entries _def] - (|let [[?name [exported? _definition]] _def] - (|case _definition - (&/$AliasG [_dmodule _dname]) - (str "A" - datum-separator ?name - datum-separator (if exported? "1" "0") - datum-separator _dmodule &/+name-separator+ _dname - ;; Next - entry-separator def-entries) - - (&/$DefinitionG [?def-type ?def-value]) - (str "D" - datum-separator ?name - datum-separator (if exported? "1" "0") - datum-separator (&&&type/serialize-type ?def-type) - ;; Next - entry-separator def-entries)))) - "" - defs) - import-entries (->> imports - (&/|map (fn [import] - (|let [[_module _hash] import] - (str _module datum-separator _hash)))) - (&/|interpose entry-separator) - (&/fold str "")) - module-descriptor (->> (&/|list &/version - (Long/toUnsignedString file-hash) - import-entries - def-entries) - (&/|interpose section-separator) - (&/fold str ""))]] - (return module-descriptor))) diff --git a/lux-bootstrapper/src/lux/compiler/io.clj b/lux-bootstrapper/src/lux/compiler/io.clj deleted file mode 100644 index e62b08be64..0000000000 --- a/lux-bootstrapper/src/lux/compiler/io.clj +++ /dev/null @@ -1,39 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.io - (:require (lux [base :as & :refer [|case |let |do return* return fail*]]) - (lux.compiler.jvm [base :as &&]) - [lux.lib.loader :as &lib])) - -;; [Utils] -(def ^:private !libs (atom nil)) - -;; [Resources] -(defn init-libs! [dependencies] - (reset! !libs (&lib/load dependencies))) - -(defn read-file [source-dirs module-name] - (let [^String host-file-name (str module-name ".old.lux") - ^String lux-file-name (str module-name ".lux")] - (|case (&/|some (fn [^String source-dir] - (let [host-file (new java.io.File source-dir host-file-name) - lux-file (new java.io.File source-dir lux-file-name)] - (cond (.exists host-file) - (&/$Some (&/T [host-file-name host-file])) - - (.exists lux-file) - (&/$Some (&/T [lux-file-name lux-file])) - - :else - &/$None))) - source-dirs) - (&/$Some [file-name file]) - (return (&/T [file-name (slurp file)])) - - (&/$None) - (if-let [code (get @!libs host-file-name)] - (return (&/T [host-file-name code])) - (if-let [code (get @!libs lux-file-name)] - (return (&/T [lux-file-name code])) - (&/fail-with-loc (str "[I/O Error] Module does not exist: " module-name))))))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm.clj b/lux-bootstrapper/src/lux/compiler/jvm.clj deleted file mode 100644 index 1c7bf33b9e..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm.clj +++ /dev/null @@ -1,273 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm - (:refer-clojure :exclude [compile]) - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]] - [type :as &type] - [reader :as &reader] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &optimizer] - [host :as &host]) - [lux.host.generics :as &host-generics] - [lux.optimizer :as &o] - [lux.analyser.base :as &a] - [lux.analyser.module :as &a-module] - (lux.compiler [core :as &&core] - [io :as &&io] - [cache :as &&cache] - [parallel :as &¶llel]) - (lux.compiler.jvm [base :as &&] - [lux :as &&lux] - [case :as &&case] - [function :as &&function] - [rt :as &&rt] - [cache :as &&jvm-cache]) - (lux.compiler.jvm.proc [common :as &&proc-common] - [host :as &&proc-host])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Resources] -(def ^:private !source->last-line (atom nil)) - -(defn ^:private compile-expression [$begin syntax] - (|let [[[?type [_file-name _line _]] ?form] syntax] - (|do [^MethodVisitor *writer* &/get-writer - :let [debug-label (new Label) - _ (when (not= _line (get @!source->last-line _file-name)) - (doto *writer* - (.visitLabel debug-label) - (.visitLineNumber (int _line) debug-label)) - (swap! !source->last-line assoc _file-name _line))]] - (|case ?form - (&o/$bit ?value) - (&&lux/compile-bit ?value) - - (&o/$nat ?value) - (&&lux/compile-nat ?value) - - (&o/$int ?value) - (&&lux/compile-int ?value) - - (&o/$rev ?value) - (&&lux/compile-rev ?value) - - (&o/$dec ?value) - (&&lux/compile-dec ?value) - - (&o/$text ?value) - (&&lux/compile-text ?value) - - (&o/$tuple ?elems) - (&&lux/compile-tuple (partial compile-expression $begin) ?elems) - - (&o/$var (&/$Local ?idx)) - (&&lux/compile-local (partial compile-expression $begin) ?idx) - - (&o/$captured ?scope ?captured-id ?source) - (&&lux/compile-captured (partial compile-expression $begin) ?scope ?captured-id ?source) - - (&o/$def ?owner-class ?name) - (&&lux/compile-global (partial compile-expression $begin) ?owner-class ?name) - - (&o/$apply ?fn ?args) - (&&lux/compile-apply (partial compile-expression $begin) ?fn ?args) - - (&o/$loop _register-offset _inits _body) - (&&lux/compile-loop compile-expression _register-offset _inits _body) - - (&o/$iter _register-offset ?args) - (&&lux/compile-iter (partial compile-expression $begin) $begin _register-offset ?args) - - (&o/$variant ?tag ?tail ?members) - (&&lux/compile-variant (partial compile-expression $begin) ?tag ?tail ?members) - - (&o/$case ?value [?pm ?bodies]) - (&&case/compile-case (partial compile-expression $begin) ?value ?pm ?bodies) - - (&o/$let _value _register _body) - (&&lux/compile-let (partial compile-expression $begin) _value _register _body) - - (&o/$record-get _value _path) - (&&lux/compile-record-get (partial compile-expression $begin) _value _path) - - (&o/$if _test _then _else) - (&&lux/compile-if (partial compile-expression $begin) _test _then _else) - - (&o/$function _register-offset ?arity ?scope ?env ?body) - (&&function/compile-function compile-expression &/$None ?arity ?scope ?env ?body) - - (&o/$ann ?value-ex ?type-ex) - (compile-expression $begin ?value-ex) - - (&o/$proc [?proc-category ?proc-name] ?args special-args) - (if (= "jvm" ?proc-category) - (&&proc-host/compile-proc (partial compile-expression $begin) ?proc-name ?args special-args) - (&&proc-common/compile-proc (partial compile-expression $begin) ?proc-category ?proc-name ?args special-args)) - - _ - (assert false (prn-str 'compile-expression (&o/show syntax))) - )) - )) - -(defn init! - "(-> Null)" - [] - (reset! !source->last-line {})) - -(defn eval! [expr] - (&/with-eval - (|do [module &/get-module-name - id &/gen-id - [file-name _ _] &/location - :let [class-name (str (&host/->module-class module) "/" id) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - class-name nil "java/lang/Object" nil) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) &/value-field "Ljava/lang/Object;" nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitCode *writer*)] - _ (compile-expression nil expr) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/PUTSTATIC class-name &/value-field "Ljava/lang/Object;") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [bytecode (.toByteArray (doto =class - .visitEnd))] - _ (&&/save-class! (str id) bytecode) - loader &/loader] - (-> (.loadClass ^ClassLoader loader (str (&host-generics/->class-name module) "." id)) - (.getField &/value-field) - (.get nil) - return)))) - -(def all-compilers - (&/T [(partial &&lux/compile-def compile-expression) - (fn [macro args state] (.apply macro args state)) - (partial &&proc-host/compile-jvm-class (partial compile-expression nil)) - &&proc-host/compile-jvm-interface])) - -(defn ^:private activate-module! [name file-hash] - (|do [_ (&&cache/delete name) - _ (&a-module/create-module name file-hash)] - (&a-module/flag-active-module name))) - -(defn ^:private save-module! [name file-hash class-bytes] - (|do [_ (&a-module/flag-compiled-module name) - _ (&&/save-class! &/module-class-name class-bytes) - module-descriptor (&&core/generate-module-descriptor file-hash)] - (&&core/write-module-descriptor! name module-descriptor))) - -(let [+field-flags+ (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC) - +datum-sig+ "Ljava/lang/Object;"] - (defn compile-module [source-dirs name next] - (|do [[file-name file-content] (&&io/read-file source-dirs name) - :let [file-hash (hash file-content) - compile-module!! (&¶llel/parallel-compilation (fn [sub_module] (compile-module source-dirs sub_module nil)))]] - (&/|eitherL (&&cache/load name) - (|do [module-exists? (&a-module/exists? name)] - (if module-exists? - (&/fail-with-loc (str "[Compiler Error] Cannot re-define a module: " name)) - (|do [_ (activate-module! name file-hash) - :let [module-class-name (str (&host/->module-class name) "/_") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - module-class-name nil "java/lang/Object" nil) - (.visitSource file-name nil))] - _ (if (= &/prelude name) - (|do [;; _ &&rt/compile-Function-class - _ &&rt/compile-Runtime-class] - (return nil)) - (return nil)) - :let [compiler-step (&analyser/analyse &optimizer/optimize eval! compile-module!! all-compilers)]] - (fn [state] - (|case ((&/with-writer =class - (&/exhaust% compiler-step)) - (&/set$ &/$source (&reader/from name file-content) state)) - (&/$Right ?state _) - (&/run-state (|do [_ (if next - (&/with-writer =class - next) - (return nil)) - :let [_ (.visitEnd =class)] - _ (save-module! name file-hash (.toByteArray =class)) - :let [_ (println 'MODULE name)]] - (return file-hash)) - ?state) - - (&/$Left ?message) - (&/fail* ?message))))))) - ))) - -(let [define-class (doto (.getDeclaredMethod java.lang.ClassLoader "defineClass" (into-array [String - (class (byte-array [])) - Integer/TYPE - Integer/TYPE])) - (.setAccessible true))] - (defn memory-class-loader [store] - (proxy [java.lang.ClassLoader] - [] - (findClass [^String class-name] - (if-let [^bytes bytecode (get @store class-name)] - (.invoke define-class this (to-array [class-name bytecode (int 0) (int (alength bytecode))])) - (throw (new IllegalStateException - (str "[Class Loader] Unknown class: " class-name)))))))) - -(defn jvm-host [] - (let [store (atom {})] - (&/$Jvm (&/T [;; "lux;writer" - &/$None - ;; "lux;loader" - (memory-class-loader store) - ;; "lux;classes" - store - ;; lux;type-env - (&/|table) - ;; lux;dummy-mappings - (&/|table) - ])))) - -(def program-type - (&/$Function (&/$Apply &type/Text &type/List) - (&/$Apply &type/Any &type/IO))) - -(let [!err! *err*] - (defn compile-program [mode program-module program-definition source-dirs] - (let [m-action (|do [_ (&&cache/pre-load-cache! source-dirs - &&jvm-cache/load-def-value - &&jvm-cache/install-all-defs-in-module - &&jvm-cache/uninstall-all-defs-in-module) - _ (compile-module source-dirs &/prelude nil)] - (compile-module source-dirs program-module - (|do [[de_aliased_symbol [exported? [actual-type ?value]]] (&a-module/find-def "" program-module program-definition) - _ (&type/check program-type actual-type) - here &/location] - (&&lux/compile-program (partial compile-expression nil) - (&a/|meta program-type here - (&o/$def de_aliased_symbol))))))] - (|case (m-action (&/init-state "{old}" mode (jvm-host))) - (&/$Right ?state _) - (do (println "Compilation complete!") - (&&cache/clean ?state)) - - (&/$Left ?message) - (binding [*out* !err!] - (do (println (str "Compilation failed:\n" ?message)) - (flush) - (System/exit 1))) - )))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/base.clj b/lux-bootstrapper/src/lux/compiler/jvm/base.clj deleted file mode 100644 index cb225ab2f8..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/base.clj +++ /dev/null @@ -1,95 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.base - (:require (clojure [template :refer [do-template]] - [string :as string]) - [clojure.java.io :as io] - [clojure.core.match :as M :refer [matchv]] - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return fail*]] - [type :as &type] - [host :as &host]) - (lux.analyser [base :as &a] - [module :as &a-module]) - [lux.host.generics :as &host-generics] - [lux.compiler.core :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - (java.io File - BufferedOutputStream - FileOutputStream) - (java.lang.reflect Field))) - -;; [Constants] -(def ^:const ^String function-class - (&host/internal &host/function-class)) - -(def ^:const ^String lux-utils-class - (&host/internal &host/lux-utils-class)) - -(def ^:const ^String unit-tag-field "unit_tag") - -;; Formats -(def ^:const ^String local-prefix "l") -(def ^:const ^String partial-prefix "p") -(def ^:const ^String closure-prefix "c") -(def ^:const ^String apply-method "apply") -(defn ^String apply-signature [n] - (str "(" (apply str (repeat n "Ljava/lang/Object;")) ")Ljava/lang/Object;")) -(def ^:const num-apply-variants 8) -(def ^:const arity-field "_arity_") -(def ^:const partials-field "partials") - -;; [Utils] -(defn ^:private write-output [module name data] - (let [^String module* (&host/->module-class module) - module-dir (str @&&/!output-dir java.io.File/separator (.replace module* "/" java.io.File/separator))] - (.mkdirs (File. module-dir)) - (&&/write-file (str module-dir java.io.File/separator name ".class") data))) - -(defn class-exists? - "(-> Text Text (IO Bit))" - [^String module ^String class-name] - (|do [_ (return nil) - :let [full-path (str @&&/!output-dir java.io.File/separator module java.io.File/separator class-name ".class") - exists? (.exists (File. full-path))]] - (return exists?))) - -;; [Exports] -(defn ^Class load-class! [^ClassLoader loader name] - (.loadClass loader name)) - -(defn save-class! [name bytecode] - (|do [eval? &/get-eval - module &/get-module-name - loader &/loader - !classes &/classes - :let [real-name (str (&host-generics/->class-name module) "." name) - _ (swap! !classes assoc real-name bytecode) - _ (when (not eval?) - (write-output module name bytecode)) - ;; _ (load-class! loader real-name) - ]] - (return nil))) - -(do-template [ ] - (do (defn [^MethodVisitor writer] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))) - (defn [^MethodVisitor writer] - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST ) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL (str "()" ))))) - - wrap-boolean unwrap-boolean "java/lang/Boolean" "booleanValue" "Z" Opcodes/DUP_X1 - wrap-byte unwrap-byte "java/lang/Byte" "byteValue" "B" Opcodes/DUP_X1 - wrap-short unwrap-short "java/lang/Short" "shortValue" "S" Opcodes/DUP_X1 - wrap-int unwrap-int "java/lang/Integer" "intValue" "I" Opcodes/DUP_X1 - wrap-long unwrap-long "java/lang/Long" "longValue" "J" Opcodes/DUP_X2 - wrap-float unwrap-float "java/lang/Float" "floatValue" "F" Opcodes/DUP_X1 - wrap-double unwrap-double "java/lang/Double" "doubleValue" "D" Opcodes/DUP_X2 - wrap-char unwrap-char "java/lang/Character" "charValue" "C" Opcodes/DUP_X1 - ) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/cache.clj b/lux-bootstrapper/src/lux/compiler/jvm/cache.clj deleted file mode 100644 index 640efe5479..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/cache.clj +++ /dev/null @@ -1,66 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.cache - (:refer-clojure :exclude [load]) - (:require [clojure.string :as string] - [clojure.java.io :as io] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [host :as &host]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler [core :as &&core] - [io :as &&io]) - (lux.compiler.jvm [base :as &&])) - (:import (java.io File) - (java.lang.reflect Field) - )) - -;; [Utils] -(defn ^:private read-file [^File file] - "(-> File (Array Byte))" - (with-open [reader (io/input-stream file)] - (let [length (.length file) - buffer (byte-array length)] - (.read reader buffer 0 length) - buffer))) - -(defn ^:private get-field [^String field-name ^Class class] - "(-> Text Class Object)" - (-> class ^Field (.getField field-name) (.get nil))) - -;; [Resources] -(defn load-def-value [module name] - (|do [loader &/loader - :let [def-class (&&/load-class! loader (str (&host-generics/->class-name module) "." (&host/def-name name)))]] - (return (get-field &/value-field def-class)))) - -(defn install-all-defs-in-module [module-name] - (|do [!classes &/classes - :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) - file-name+content (for [^File file (seq (.listFiles (new File module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)]] - [(second (re-find #"^(.*)\.class$" file-name)) - (read-file file)]) - _ (doseq [[file-name content] file-name+content] - (swap! !classes assoc (str (&host-generics/->class-name module-name) - "." - file-name) - content))]] - (return (map first file-name+content)))) - -(defn uninstall-all-defs-in-module [module-name] - (|do [!classes &/classes - :let [module-path (str @&&core/!output-dir java.io.File/separator module-name) - installed-files (for [^File file (seq (.listFiles (new File module-path))) - :when (not (.isDirectory file)) - :let [file-name (.getName file)]] - (second (re-find #"^(.*)\.class$" file-name))) - _ (swap! !classes (fn [_classes-dict] - (reduce dissoc _classes-dict installed-files)))]] - (return nil))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/case.clj b/lux-bootstrapper/src/lux/compiler/jvm/case.clj deleted file mode 100644 index 5dbb9d3511..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/case.clj +++ /dev/null @@ -1,210 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.case - (:require (clojure [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.analyser.case :as &a-case] - [lux.compiler.jvm.base :as &&] - [lux.compiler.jvm.rt :as &rt]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(defn ^:private pop-alt-stack [^MethodVisitor writer stack-depth] - (cond (= 0 stack-depth) - writer - - (= 1 stack-depth) - (doto writer - (.visitInsn Opcodes/POP)) - - (= 2 stack-depth) - (doto writer - (.visitInsn Opcodes/POP2)) - - :else ;; > 2 - (doto writer - (.visitInsn Opcodes/POP2) - (pop-alt-stack (- stack-depth 2))))) - -(defn ^:private stack-peek [^MethodVisitor writer] - (doto writer - (.visitInsn Opcodes/DUP) - &rt/peekI)) - -(defn ^:private compile-pattern* - "(-> MethodVisitor Case-Pattern (List Label) Int Label MethodVisitor)" - [^MethodVisitor writer bodies stack-depth $else pm] - (|case pm - (&o/$ExecPM _body-idx) - (|case (&/|at _body-idx bodies) - (&/$Some $body) - (doto writer - (pop-alt-stack stack-depth) - (.visitJumpInsn Opcodes/GOTO $body)) - - (&/$None) - (assert false)) - - (&o/$PopPM) - (&rt/popI writer) - - (&o/$BindPM _var-id) - (doto writer - stack-peek - (.visitVarInsn Opcodes/ASTORE _var-id) - &rt/popI) - - (&o/$BitPM _value) - (doto writer - stack-peek - &&/unwrap-boolean - (.visitJumpInsn (if _value Opcodes/IFEQ Opcodes/IFNE) $else)) - - (&o/$NatPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$IntPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$RevPM _value) - (doto writer - stack-peek - &&/unwrap-long - (.visitLdcInsn (long _value)) - (.visitInsn Opcodes/LCMP) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$DecPM _value) - (doto writer - stack-peek - &&/unwrap-double - (.visitLdcInsn (double _value)) - (.visitInsn Opcodes/DCMPL) - (.visitJumpInsn Opcodes/IFNE $else)) - - (&o/$TextPM _value) - (doto writer - stack-peek - (.visitLdcInsn _value) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (.visitJumpInsn Opcodes/IFEQ $else)) - - (&o/$TuplePM (&/$Left lefts)) - (let [accessI (if (= 0 lefts) - #(doto ^MethodVisitor % - (.visitInsn Opcodes/AALOAD)) - #(doto ^MethodVisitor % - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;")))] - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int lefts)) - accessI - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) - - (&o/$TuplePM (&/$Right _idx)) - (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int (dec _idx))) - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;") - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - - (&o/$VariantPM _idx+) - (|let [$success (new Label) - $fail (new Label) - [_lefts _right?] (|case _idx+ - (&/$Left _idx) - (&/T [_idx false]) - - (&/$Right _idx) - (&/T [(dec _idx) true])) - _ (doto writer - stack-peek - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int _lefts))) - _ (if _right? - (.visitLdcInsn writer "") - (.visitInsn writer Opcodes/ACONST_NULL))] - (doto writer - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;") - (.visitInsn Opcodes/DUP) - (.visitJumpInsn Opcodes/IFNULL $fail) - (.visitJumpInsn Opcodes/GOTO $success) - (.visitLabel $fail) - (.visitInsn Opcodes/POP) - (.visitJumpInsn Opcodes/GOTO $else) - (.visitLabel $success) - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;"))) - - (&o/$SeqPM _left-pm _right-pm) - (doto writer - (compile-pattern* bodies stack-depth $else _left-pm) - (compile-pattern* bodies stack-depth $else _right-pm)) - - (&o/$AltPM _left-pm _right-pm) - (|let [$alt-else (new Label)] - (doto writer - (.visitInsn Opcodes/DUP) - (compile-pattern* bodies (inc stack-depth) $alt-else _left-pm) - (.visitLabel $alt-else) - (.visitInsn Opcodes/POP) - (compile-pattern* bodies stack-depth $else _right-pm))) - )) - -(defn ^:private compile-pattern [^MethodVisitor writer bodies pm $end] - (|let [$else (new Label)] - (doto writer - (compile-pattern* bodies 1 $else pm) - (.visitLabel $else) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "pm_fail" "()V") - (.visitInsn Opcodes/ACONST_NULL) - (.visitJumpInsn Opcodes/GOTO $end)))) - -(defn ^:private compile-bodies [^MethodVisitor writer compile bodies-labels ?bodies $end] - (&/map% (fn [label+body] - (|let [[_label _body] label+body] - (|do [:let [_ (.visitLabel writer _label)] - _ (compile _body) - :let [_ (.visitJumpInsn writer Opcodes/GOTO $end)]] - (return nil)))) - (&/zip2 bodies-labels ?bodies))) - -;; [Resources] -(defn compile-case [compile ?value ?pm ?bodies] - (|do [^MethodVisitor *writer* &/get-writer - :let [$end (new Label) - bodies-labels (&/|map (fn [_] (new Label)) ?bodies)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ACONST_NULL))] - _ (compile ?value) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - _ (compile-pattern *writer* bodies-labels ?pm $end)] - _ (compile-bodies *writer* compile bodies-labels ?bodies $end) - :let [_ (.visitLabel *writer* $end)]] - (return nil))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/function.clj b/lux-bootstrapper/src/lux/compiler/jvm/function.clj deleted file mode 100644 index fb1b35a3d4..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/function.clj +++ /dev/null @@ -1,281 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.function - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |case |let]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - (lux.compiler.jvm [base :as &&])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Utils] -(def ^:private field-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private function-return-sig (&host-generics/->type-signature "java.lang.Object")) -(def ^:private -return "V") - -(defn ^:private ^String reset-signature [function-class] - (str "()" (&host-generics/->type-signature function-class))) - -(defn ^:private ^MethodVisitor get-num-partials! [^MethodVisitor method-writer] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD &&/function-class &&/partials-field "I"))) - -(defn ^:private ^MethodVisitor inc-int! [^MethodVisitor method-writer by] - (doto method-writer - (.visitLdcInsn (int by)) - (.visitInsn Opcodes/IADD))) - -(defn ^:private ^MethodVisitor get-field! [^MethodVisitor method-writer class-name field-name] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor put-field! [^MethodVisitor method-writer class-name field-name field-sig value-thunk] - (doto method-writer - (.visitVarInsn Opcodes/ALOAD 0) - value-thunk - (.visitFieldInsn Opcodes/PUTFIELD class-name field-name field-sig))) - -(defn ^:private ^MethodVisitor fill-nulls! [^MethodVisitor method-writer amount] - (doto method-writer - (-> (.visitInsn Opcodes/ACONST_NULL) - (->> (dotimes [_ amount]))))) - -(defn ^:private ^MethodVisitor consecutive-args [^MethodVisitor method-writer start amount] - (doto method-writer - (-> (.visitVarInsn Opcodes/ALOAD (+ start idx)) - (->> (dotimes [idx amount]))))) - -(defn ^:private ^MethodVisitor consecutive-applys [^MethodVisitor method-writer start amount] - (let [max-args-num (min amount &&/num-apply-variants)] - (doto method-writer - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (consecutive-args start max-args-num) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature max-args-num)) - (-> (consecutive-applys (+ start &&/num-apply-variants) (- amount &&/num-apply-variants)) - (->> (when (> amount &&/num-apply-variants))))))) - -(defn ^:private function-impl-signature [arity] - (str "(" (&/fold str "" (&/|repeat arity field-sig)) ")" function-return-sig)) - -(defn ^:private function--signature [env arity] - (if (> arity 1) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) "I" (&/fold str "" (&/|repeat (dec arity) field-sig)) ")" - -return) - (str "(" (&/fold str "" (&/|repeat (&/|length env) field-sig)) ")" - -return))) - -(defn ^:private init-function [^MethodVisitor method-writer arity closure-length] - (if (= 1 arity) - (doto method-writer - (.visitLdcInsn (int 0)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")) - (doto method-writer - (.visitVarInsn Opcodes/ILOAD (inc closure-length)) - (.visitMethodInsn Opcodes/INVOKESPECIAL &&/function-class "" "(I)V")))) - -(defn ^:private add-function- [^ClassWriter class class-name arity env] - (let [closure-length (&/|length env)] - (doto (.visitMethod class Opcodes/ACC_PUBLIC "" (function--signature env arity) nil nil) - (.visitCode) - ;; Do normal object initialization - (.visitVarInsn Opcodes/ALOAD 0) - (init-function arity closure-length) - ;; Add all of the closure variables - (-> (put-field! class-name (str &&/closure-prefix ?captured-id) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD (inc ?captured-id))) - (->> (|let [[?name [_ (&o/$captured _ ?captured-id ?source)]] ?name+?captured]) - (doseq [?name+?captured (&/->seq env)]))) - ;; Add all the partial arguments - (-> (put-field! class-name (str &&/partial-prefix idx*) field-sig #(.visitVarInsn ^MethodVisitor % Opcodes/ALOAD partial-register)) - (->> (|let [partial-register (+ (inc idx*) (inc closure-length))]) - (dotimes [idx* (dec arity)]))) - ;; Finish - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(let [impl-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STRICT)] - (defn ^:private add-function-impl [^ClassWriter class class-name compile arity impl-body] - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod class impl-flags "impl" (function-impl-signature arity) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))))) - -(defn ^:private instance-closure [compile function-class arity closed-over] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW function-class) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [?name+?captured] - (|case ?name+?captured - [?name [_ (&o/$captured _ _ ?source)]] - (compile nil ?source))) - closed-over) - :let [_ (when (> arity 1) - (doto *writer* - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity))))] - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESPECIAL function-class "" (function--signature closed-over arity))]] - (return nil))) - -(defn ^:private add-function-reset [^ClassWriter class-writer class-name arity env] - (if (> arity 1) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - (.visitLdcInsn (int 0)) - (fill-nulls! (dec arity)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (function--signature env arity)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - (doto (.visitMethod class-writer Opcodes/ACC_PUBLIC "reset" (reset-signature class-name) nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))) - -(defn ^:private add-function-apply-n [^ClassWriter class-writer +degree+ class-name arity env compile impl-body] - (if (> arity 1) - (let [num-partials (dec arity) - $default (new Label) - $labels* (map (fn [_] (new Label)) (repeat num-partials nil)) - $labels (vec (concat $labels* (list $default))) - method-writer (.visitMethod class-writer (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STRICT) &&/apply-method (&&/apply-signature +degree+) nil nil) - frame-locals (to-array (list class-name "java/lang/Object" "java/lang/Object")) - frame-stack (to-array [Opcodes/INTEGER]) - arity-over-extent (- arity +degree+)] - (do (doto method-writer - (.visitCode) - get-num-partials! - (.visitTableSwitchInsn 0 (dec num-partials) $default (into-array Label $labels*)) - ;; (< stage (- arity +degree+)) - (-> (doto (.visitLabel $label) - (.visitTypeInsn Opcodes/NEW class-name) - (.visitInsn Opcodes/DUP) - (-> (get-field! class-name (str &&/closure-prefix cidx)) - (->> (dotimes [cidx (&/|length env)]))) - get-num-partials! - (inc-int! +degree+) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (fill-nulls! (- (- num-partials +degree+) stage)) - (.visitMethodInsn Opcodes/INVOKESPECIAL class-name "" (function--signature env arity)) - (.visitInsn Opcodes/ARETURN)) - (->> (cond (= stage arity-over-extent) - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (-> (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (->> (when (not= 0 stage)))) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 +degree+) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (function-impl-signature arity)) - (.visitInsn Opcodes/ARETURN)) - - (> stage arity-over-extent) - (let [args-to-completion (- arity stage) - args-left (- +degree+ args-to-completion)] - (doto method-writer - (.visitLabel $label) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "reset" (reset-signature class-name)) - (-> (get-field! class-name (str &&/partial-prefix idx)) - (->> (dotimes [idx stage]))) - (consecutive-args 1 args-to-completion) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL class-name "impl" (function-impl-signature arity)) - (consecutive-applys (+ 1 args-to-completion) args-left) - (.visitInsn Opcodes/ARETURN))) - - :else) - (doseq [[stage $label] (map vector (range arity) $labels)]))) - (.visitMaxs 0 0) - (.visitEnd)) - (return nil))) - (let [$begin (new Label)] - (&/with-writer (doto (.visitMethod ^ClassWriter class-writer (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STRICT) &&/apply-method (&&/apply-signature 1) nil nil) - (.visitCode) - (.visitLabel $begin)) - (|do [^MethodVisitor *writer* &/get-writer - ret (compile $begin impl-body) - :let [_ (doto *writer* - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return ret)))) - )) - -;; [Exports] -(let [function-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - datum-flags (+ Opcodes/ACC_PRIVATE Opcodes/ACC_FINAL)] - (defn compile-function [compile ?prev-writer arity ?scope ?env ?body] - (|do [[file-name _ _] &/location - :let [??scope (&/|reverse ?scope) - name (&host/location (&/|tail ??scope)) - class-name (str (&host/->module-class (&/|head ??scope)) "/" name) - [^ClassWriter =class save?] (|case ?prev-writer - (&/$Some _writer) - (&/T [_writer false]) - - (&/$None) - (&/T [(doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version function-flags - class-name nil &&/function-class (into-array String []))) - true])) - _ (doto =class - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) &&/arity-field "I" nil (int arity)) - (doto (.visitEnd))) - (-> (doto (.visitField datum-flags captured-name field-sig nil nil) - (.visitEnd)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq ?env)]))) - (-> (.visitField datum-flags (str &&/partial-prefix idx) field-sig nil nil) - (doto (.visitEnd)) - (->> (dotimes [idx (dec arity)]))) - (-> (.visitSource file-name nil) - (when save?)) - (add-function- class-name arity ?env) - (add-function-reset class-name arity ?env) - )] - _ (if (> arity 1) - (add-function-impl =class class-name compile arity ?body) - (return nil)) - _ (&/map% #(add-function-apply-n =class % class-name arity ?env compile ?body) - (&/|range* 1 (min arity &&/num-apply-variants))) - :let [_ (.visitEnd =class)] - _ (if save? - (&&/save-class! name (.toByteArray =class)) - (return nil))] - (if save? - (instance-closure compile class-name arity ?env) - (return (instance-closure compile class-name arity ?env)))))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj b/lux-bootstrapper/src/lux/compiler/jvm/lux.clj deleted file mode 100644 index 43e71db7b1..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/lux.clj +++ /dev/null @@ -1,406 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.lux - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [host :as &host] - [optimizer :as &o]) - [lux.host.generics :as &host-generics] - (lux.analyser [base :as &a] - [module :as &a-module]) - (lux.compiler.jvm [base :as &&] - [function :as &&function] - [rt :as &rt])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor) - java.lang.reflect.Field)) - -;; [Exports] -(defn compile-bit [?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC "java/lang/Boolean" (if ?value "TRUE" "FALSE") "Ljava/lang/Boolean;")]] - (return nil))) - -(do-template [ ] - (defn [value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitLdcInsn ( value)) - (.visitMethodInsn Opcodes/INVOKESTATIC "valueOf" (str "(" ")" (&host-generics/->type-signature ))))]] - (return nil))) - - compile-nat "java/lang/Long" "J" long - compile-int "java/lang/Long" "J" long - compile-rev "java/lang/Long" "J" long - compile-dec "java/lang/Double" "D" double - ) - -(defn compile-text [?value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitLdcInsn *writer* ?value)]] - (return nil))) - -(defn compile-tuple [compile ?elems] - (|do [^MethodVisitor *writer* &/get-writer - :let [num-elems (&/|length ?elems)]] - (|case num-elems - 0 - (|do [:let [_ (.visitLdcInsn *writer* &/unit-tag)]] - (return nil)) - - 1 - (compile (&/|head ?elems)) - - _ - (|do [:let [_ (doto *writer* - (.visitLdcInsn (int num-elems)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object"))] - _ (&/map2% (fn [idx elem] - (|do [:let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int idx)))] - ret (compile elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return ret))) - (&/|range num-elems) ?elems)] - (return nil))))) - -(defn compile-variant [compile tag tail? value] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitLdcInsn *writer* (int (if tail? - (dec tag) - tag))) - _ (if tail? - (.visitLdcInsn *writer* "") - (.visitInsn *writer* Opcodes/ACONST_NULL))] - _ (compile value) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKESTATIC &rt/runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")]] - (return nil))) - -(defn compile-local [compile ?idx] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitVarInsn *writer* Opcodes/ALOAD (int ?idx))]] - (return nil))) - -(defn compile-captured [compile ?scope ?captured-id ?source] - (|do [:let [??scope (&/|reverse ?scope)] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitVarInsn Opcodes/ALOAD 0) - (.visitFieldInsn Opcodes/GETFIELD - (str (&host/->module-class (&/|head ??scope)) "/" (&host/location (&/|tail ??scope))) - (str &&/closure-prefix ?captured-id) - "Ljava/lang/Object;"))]] - (return nil))) - -(defn compile-global [compile ?owner-class ?name] - (|do [^MethodVisitor *writer* &/get-writer - :let [_ (.visitFieldInsn *writer* Opcodes/GETSTATIC (str (&host/->module-class ?owner-class) "/" (&host/def-name ?name)) &/value-field "Ljava/lang/Object;")]] - (return nil))) - -(defn ^:private compile-apply* [compile ?args] - (|do [^MethodVisitor *writer* &/get-writer - _ (&/map% (fn [?args] - (|do [:let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST &&/function-class)] - _ (&/map% compile ?args) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (&/|length ?args)))]] - (return nil))) - (&/|partition &&/num-apply-variants ?args))] - (return nil))) - -(defn compile-apply [compile ?fn ?args] - (|case ?fn - [_ (&o/$def ?module ?name)] - (|do [[_ [_ [_ func-obj]]] (&a-module/find-def! ?module ?name) - class-loader &/loader - :let [func-class (class func-obj) - func-arity (.get ^Field (.getDeclaredField func-class &&/arity-field) nil) - func-partials (.get ^Field (.getDeclaredField (Class/forName &host/function-class true class-loader) &&/partials-field) func-obj) - num-args (&/|length ?args) - func-class-name (->> func-class .getName &host-generics/->bytecode-class-name)]] - (if (and (= 0 func-partials) - (>= num-args func-arity)) - (|do [_ (compile ?fn) - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST func-class-name)] - _ (&/map% compile (&/|take func-arity ?args)) - :let [_ (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL func-class-name (if (= 1 func-arity) &&/apply-method "impl") (&&/apply-signature func-arity))] - _ (if (= num-args func-arity) - (return nil) - (compile-apply* compile (&/|drop func-arity ?args)))] - (return nil)) - (|do [_ (compile ?fn)] - (compile-apply* compile ?args)))) - - _ - (|do [_ (compile ?fn)] - (compile-apply* compile ?args)) - )) - -(defn compile-loop [compile-expression register-offset inits body] - (|do [^MethodVisitor *writer* &/get-writer - :let [idxs+inits (&/zip2 (&/|range* 0 (dec (&/|length inits))) - inits)] - _ (&/map% (fn [idx+_init] - (|do [:let [[idx _init] idx+_init - idx+ (+ register-offset idx)] - _ (compile-expression nil _init) - :let [_ (.visitVarInsn *writer* Opcodes/ASTORE idx+)]] - (return nil))) - idxs+inits) - :let [$begin (new Label) - _ (.visitLabel *writer* $begin)]] - (compile-expression $begin body) - )) - -(defn compile-iter [compile $begin register-offset ?args] - (|do [^MethodVisitor *writer* &/get-writer - :let [idxs+args (&/zip2 (&/|range* 0 (dec (&/|length ?args))) - ?args)] - _ (&/map% (fn [idx+?arg] - (|do [:let [[idx ?arg] idx+?arg - idx+ (+ register-offset idx) - already-set? (|case ?arg - [_ (&o/$var (&/$Local l-idx))] - (= idx+ l-idx) - - _ - false)]] - (if already-set? - (return nil) - (compile ?arg)))) - idxs+args) - _ (&/map% (fn [idx+?arg] - (|do [:let [[idx ?arg] idx+?arg - idx+ (+ register-offset idx) - already-set? (|case ?arg - [_ (&o/$var (&/$Local l-idx))] - (= idx+ l-idx) - - _ - false)] - :let [_ (when (not already-set?) - (.visitVarInsn *writer* Opcodes/ASTORE idx+))]] - (return nil))) - (&/|reverse idxs+args)) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $begin)]] - (return nil))) - -(defn compile-let [compile _value _register _body] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _value) - :let [_ (.visitVarInsn *writer* Opcodes/ASTORE _register)] - _ (compile _body)] - (return nil))) - -(defn compile-record-get [compile _value _path] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _value) - :let [_ (&/|map (fn [step] - (|let [[idx tail?] step] - (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitLdcInsn (int (if tail? - (dec idx) - idx))) - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class - (if tail? "tuple_right" "tuple_left") - "([Ljava/lang/Object;I)Ljava/lang/Object;")))) - _path)]] - (return nil))) - -(defn compile-if [compile _test _then _else] - (|do [^MethodVisitor *writer* &/get-writer - _ (compile _test) - :let [$else (new Label) - $end (new Label) - _ (doto *writer* - &&/unwrap-boolean - (.visitJumpInsn Opcodes/IFEQ $else))] - _ (compile _then) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end)] - :let [_ (.visitLabel *writer* $else)] - _ (compile _else) - :let [_ (.visitJumpInsn *writer* Opcodes/GOTO $end) - _ (.visitLabel *writer* $end)]] - (return nil))) - -(defn ^:private de-ann [optim] - (|case optim - [_ (&o/$ann value-expr _)] - value-expr - - _ - optim)) - -(defn ^:private throwable->text [^Throwable t] - (let [base (->> t - .getStackTrace - (map str) - (cons (.getMessage t)) - (interpose "\n") - (apply str))] - (if-let [cause (.getCause t)] - (str base "\n\n" "Caused by: " (throwable->text cause)) - base))) - -(defn ^:private install-def! [class-loader current-class module-name ?name ?body exported?] - (|do [_ (return nil) - :let [def-class (&&/load-class! class-loader (&host-generics/->class-name current-class)) - def-type (&a/expr-type* ?body)] - def-value (try (return (-> def-class (.getField &/value-field) (.get nil))) - (catch Throwable t - (&/assert! false - (str "Error during value initialization:\n" - (throwable->text t))))) - _ (&/without-repl-closure - (&a-module/define module-name ?name exported? def-type def-value))] - (return def-value))) - -(let [class-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - field-flags (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_STATIC)] - (defn compile-def [compile ?name ?body exported?] - (|do [module-name &/get-module-name - class-loader &/loader] - (|case (de-ann ?body) - [_ (&o/$function _ _ __scope _ _)] - (|let [[_ (&o/$function _ _arity _scope _captured ?body+)] (&o/shift-function-body (&/|tail __scope) __scope - false - (de-ann ?body))] - (|do [[file-name _ _] &/location - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil &&/function-class (into-array String [])) - (-> (.visitField field-flags &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - instancer (&&function/compile-function compile (&/$Some =class) _arity _scope _captured ?body+) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ instancer - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] - _ (&&/save-class! def-name (.toByteArray =class)) - def-value (install-def! class-loader current-class module-name ?name ?body exported?)] - (return def-value))) - - _ - (|do [[file-name _ _] &/location - :let [datum-sig "Ljava/lang/Object;" - def-name (&host/def-name ?name) - current-class (str (&host/->module-class module-name) "/" def-name) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version class-flags - current-class nil "java/lang/Object" (into-array String [])) - (-> (.visitField field-flags &/value-field datum-sig nil nil) - (doto (.visitEnd))) - (.visitSource file-name nil))] - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor **writer** &/get-writer - :let [_ (.visitCode **writer**)] - _ (compile nil ?body) - :let [_ (.visitFieldInsn **writer** Opcodes/PUTSTATIC current-class &/value-field datum-sig)] - :let [_ (doto **writer** - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))) - :let [_ (.visitEnd =class)] - _ (&&/save-class! def-name (.toByteArray =class)) - def-value (install-def! class-loader current-class module-name ?name ?body exported?)] - (return def-value)))))) - -(defn compile-program [compile ?program] - (|do [module-name &/get-module-name - ^ClassWriter *writer* &/get-writer] - (&/with-writer (doto (.visitMethod *writer* (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "main" "([Ljava/lang/String;)V" nil nil) - (.visitCode)) - (|do [^MethodVisitor main-writer &/get-writer - _ (compile ?program) - :let [_ (.visitTypeInsn main-writer Opcodes/CHECKCAST &&/function-class)] - :let [$loop (new Label) - $end (new Label) - _ (doto main-writer - ;; Tail: Begin - (.visitLdcInsn (->> #'&/$End meta ::&/lefts int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; V - ;; Tail: End - ;; Size: Begin - (.visitVarInsn Opcodes/ALOAD 0) ;; VA - (.visitInsn Opcodes/ARRAYLENGTH) ;; VI - ;; Size: End - ;; Loop: Begin - (.visitLabel $loop) - (.visitLdcInsn (int 1)) ;; VII - (.visitInsn Opcodes/ISUB) ;; VI - (.visitInsn Opcodes/DUP) ;; VII - (.visitJumpInsn Opcodes/IFLT $end) ;; VI - ;; Head: Begin - (.visitInsn Opcodes/DUP) ;; VII - (.visitVarInsn Opcodes/ALOAD 0) ;; VIIA - (.visitInsn Opcodes/SWAP) ;; VIAI - (.visitInsn Opcodes/AALOAD) ;; VIO - (.visitInsn Opcodes/SWAP) ;; VOI - (.visitInsn Opcodes/DUP_X2) ;; IVOI - (.visitInsn Opcodes/POP) ;; IVO - ;; Head: End - ;; Tuple: Begin - (.visitLdcInsn (int 2)) ;; IVOS - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") ;; IVO2 - (.visitInsn Opcodes/DUP_X1) ;; IV2O2 - (.visitInsn Opcodes/SWAP) ;; IV22O - (.visitLdcInsn (int 0)) ;; IV22OI - (.visitInsn Opcodes/SWAP) ;; IV22IO - (.visitInsn Opcodes/AASTORE) ;; IV2 - (.visitInsn Opcodes/DUP_X1) ;; I2V2 - (.visitInsn Opcodes/SWAP) ;; I22V - (.visitLdcInsn (int 1)) ;; I22VI - (.visitInsn Opcodes/SWAP) ;; I22IV - (.visitInsn Opcodes/AASTORE) ;; I2 - ;; Tuple: End - ;; Item: Begin - (.visitLdcInsn (->> #'&/$Item meta ::&/lefts int)) ;; I2I - (.visitLdcInsn "") ;; I2I? - (.visitInsn Opcodes/DUP2_X1) ;; II?2I? - (.visitInsn Opcodes/POP2) ;; II?2 - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") ;; IV - ;; Item: End - (.visitInsn Opcodes/SWAP) ;; VI - (.visitJumpInsn Opcodes/GOTO $loop) - ;; Loop: End - (.visitLabel $end) ;; VI - (.visitInsn Opcodes/POP) ;; V - )] - :let [_ (doto main-writer - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)))] - :let [_ (doto main-writer - (.visitInsn Opcodes/POP) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj deleted file mode 100644 index 6f1511e2fe..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/proc/common.clj +++ /dev/null @@ -1,447 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.proc.common - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - (lux.compiler.jvm [base :as &&] - [rt :as &rt])) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Resources] -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?input (&/$Item ?mask (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?mask) - :let [_ (&&/unwrap-long *writer*)] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - ^:private compile-i64-and Opcodes/LAND - ^:private compile-i64-or Opcodes/LOR - ^:private compile-i64-xor Opcodes/LXOR - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?input (&/$Item ?shift (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (&&/unwrap-long *writer*)] - _ (compile ?shift) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - &&/wrap-long)]] - (return nil))) - - Opcodes/LSHL ^:private compile-i64-left-shift - Opcodes/LUSHR ^:private compile-i64-right-shift - ) - -(defn ^:private compile-lux-is [compile ?values special-args] - (|do [:let [(&/$Item ?left (&/$Item ?right (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?left) - _ (compile ?right) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IF_ACMPEQ $then) - ;; else - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "FALSE" "Ljava/lang/Boolean;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/Boolean" "TRUE" "Ljava/lang/Boolean;") - (.visitLabel $end))]] - (return nil))) - -(defn ^:private compile-lux-try [compile ?values special-args] - (|do [:let [(&/$Item ?op (&/$End)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?op) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST &rt/function-class) - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "runTry" (str "(L" &rt/function-class ";)[Ljava/lang/Object;")))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - _ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-i64-add Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-i64-sub Opcodes/LSUB &&/unwrap-long &&/wrap-long - - ^:private compile-int-mul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-int-div Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-int-rem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-dec-add Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-dec-sub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-dec-mul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-dec-div Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-dec-rem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn ) - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-i64-eq Opcodes/LCMP 0 &&/unwrap-long - - ^:private compile-int-lt Opcodes/LCMP -1 &&/unwrap-long - - ^:private compile-dec-eq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-dec-lt Opcodes/DCMPG -1 &&/unwrap-double - ) - -(defn ^:private compile-int-char [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$End)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/I2C) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/String" "valueOf" "(C)Ljava/lang/String;"))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?input (&/$End)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?input) - :let [_ (doto *writer* - - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-dec-int &&/unwrap-double Opcodes/D2L &&/wrap-long - ^:private compile-int-dec &&/unwrap-long Opcodes/L2D &&/wrap-double - ) - -(defn ^:private compile-text-eq [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - _ (compile ?y) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Object" "equals" "(Ljava/lang/Object;)Z") - (&&/wrap-boolean))]] - (return nil))) - -(defn ^:private compile-text-lt [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?y) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "compareTo" "(Ljava/lang/String;)I") - (.visitJumpInsn Opcodes/IFLT $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(defn compile-text-concat [compile ?values special-args] - (|do [^MethodVisitor *writer* &/get-writer - =values (&/map% (fn [it] - (|do [_ (compile it)] - (return (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))))) - ?values)] - (return (|case =values - (&/$End) - (.visitLdcInsn *writer* "") - - (&/$Item head tail) - (loop [tail tail] - (|case tail - (&/$End) - nil - - (&/$Item head* tail*) - (do (.visitMethodInsn *writer* Opcodes/INVOKEVIRTUAL "java/lang/String" "concat" "(Ljava/lang/String;)Ljava/lang/String;") - (recur tail*)))))))) - -(defn compile-text-clip [compile ?values special-args] - (|do [:let [(&/$Item ?text (&/$Item ?offset (&/$Item ?length (&/$End)))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?offset) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/DUP))] - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn Opcodes/IADD))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "substring" "(II)Ljava/lang/String;"))]] - (return nil))) - -(defn ^:private compile-text-index [compile ?values special-args] - (|do [:let [(&/$Item ?text (&/$Item ?part (&/$Item ?start (&/$End)))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?part) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?start) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "indexOf" "(Ljava/lang/String;I)I"))] - :let [$not-found (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int -1)) - (.visitJumpInsn Opcodes/IF_ICMPEQ $not-found) - (.visitInsn Opcodes/I2L) - &&/wrap-long - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $not-found) - (.visitInsn Opcodes/POP) - (.visitMethodInsn Opcodes/INVOKESTATIC &rt/runtime-class "make_none" "()[Ljava/lang/Object;") - (.visitLabel $end))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?text (&/$End)) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "()I") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - - ^:private compile-text-size "java/lang/String" "length" - ) - -(defn ^:private compile-text-char [compile ?values special-args] - (|do [:let [(&/$Item ?text (&/$Item ?idx (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?text) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String"))] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "charAt" "(I)C") - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-io-log [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$End)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;"))] - _ (compile ?x) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") - (.visitLdcInsn &/unit-tag))]] - (return nil))) - -(defn ^:private compile-io-error [compile ?values special-args] - (|do [:let [(&/$Item ?message (&/$End)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/NEW "java/lang/Error") - (.visitInsn Opcodes/DUP))] - _ (compile ?message) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST "java/lang/String") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/Error" "" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW))]] - (return nil))) - -(defn ^:private compile-io-current-time [compile ?values special-args] - (|do [:let [(&/$End) ?values] - ^MethodVisitor *writer* &/get-writer - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/System" "currentTimeMillis" "()J") - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-syntax-char-case! [compile ?values ?patterns] - (|do [:let [(&/$Item ?input (&/$Item ?else ?matches)) ?values] - ^MethodVisitor *writer* &/get-writer - :let [pattern-labels (&/|map (fn [_] (new Label)) ?patterns) - matched-patterns (&/fold (fn [matches chars+label] - (|let [[chars label] chars+label] - (&/fold (fn [matches char] - (assoc matches char label)) - matches - chars))) - {} - (&/zip2 ?patterns pattern-labels)) - end-label (new Label) - else-label (new Label) - match-keys (keys matched-patterns) - min (apply min match-keys) - max (apply max match-keys) - capacity (inc (- max min)) - switch (map-indexed (fn [index label] - (get matched-patterns (+ min index) else-label)) - (repeat capacity else-label))] - _ (compile ?input) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitTableSwitchInsn (int min) - (int max) - else-label - (into-array switch)))] - _ (&/map% (fn [?label+?match] - (|let [[?label ?match] ?label+?match] - (|do [:let [_ (doto *writer* - (.visitLabel ?label))] - _ (compile ?match) - :let [_ (doto *writer* - (.visitJumpInsn Opcodes/GOTO end-label))]] - (return nil)))) - (&/zip2 pattern-labels ?matches)) - :let [_ (doto *writer* - (.visitLabel else-label))] - _ (compile ?else) - :let [_ (doto *writer* - (.visitLabel end-label))]] - (return nil))) - -(defn compile-proc [compile category proc ?values special-args] - (case category - "lux" - (case proc - "is" (compile-lux-is compile ?values special-args) - "try" (compile-lux-try compile ?values special-args) - ;; TODO: Special extensions for performance reasons - ;; Will be replaced by custom extensions in the future. - "syntax char case!" (compile-syntax-char-case! compile ?values special-args)) - - "io" - (case proc - "log" (compile-io-log compile ?values special-args) - "error" (compile-io-error compile ?values special-args) - "current-time" (compile-io-current-time compile ?values special-args) - ) - - "text" - (case proc - "=" (compile-text-eq compile ?values special-args) - "<" (compile-text-lt compile ?values special-args) - "concat" (compile-text-concat compile ?values special-args) - "clip" (compile-text-clip compile ?values special-args) - "index" (compile-text-index compile ?values special-args) - "size" (compile-text-size compile ?values special-args) - "char" (compile-text-char compile ?values special-args) - ) - - "i64" - (case proc - "and" (compile-i64-and compile ?values special-args) - "or" (compile-i64-or compile ?values special-args) - "xor" (compile-i64-xor compile ?values special-args) - "left-shift" (compile-i64-left-shift compile ?values special-args) - "right-shift" (compile-i64-right-shift compile ?values special-args) - "=" (compile-i64-eq compile ?values special-args) - "+" (compile-i64-add compile ?values special-args) - "-" (compile-i64-sub compile ?values special-args) - "*" (compile-int-mul compile ?values special-args) - "/" (compile-int-div compile ?values special-args) - "%" (compile-int-rem compile ?values special-args) - "<" (compile-int-lt compile ?values special-args) - "f64" (compile-int-dec compile ?values special-args) - "char" (compile-int-char compile ?values special-args) - ) - - "f64" - (case proc - "+" (compile-dec-add compile ?values special-args) - "-" (compile-dec-sub compile ?values special-args) - "*" (compile-dec-mul compile ?values special-args) - "/" (compile-dec-div compile ?values special-args) - "%" (compile-dec-rem compile ?values special-args) - "=" (compile-dec-eq compile ?values special-args) - "<" (compile-dec-lt compile ?values special-args) - "i64" (compile-dec-int compile ?values special-args) - ) - - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown procedure: " [category proc])))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj b/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj deleted file mode 100644 index da0c1e75a9..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/proc/host.clj +++ /dev/null @@ -1,1142 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.proc.host - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - [lux.compiler.jvm.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -;; [Utils] -(def init-method "") - -(let [class+method+sig {"boolean" &&/unwrap-boolean - "byte" &&/unwrap-byte - "short" &&/unwrap-short - "int" &&/unwrap-int - "long" &&/unwrap-long - "float" &&/unwrap-float - "double" &&/unwrap-double - "char" &&/unwrap-char}] - (defn ^:private prepare-arg! [^MethodVisitor *writer* class-name] - (if-let [unwrap (get class+method+sig class-name)] - (doto *writer* - unwrap) - (.visitTypeInsn *writer* Opcodes/CHECKCAST (&host-generics/->bytecode-class-name class-name))))) - -(let [boolean-class "java.lang.Boolean" - byte-class "java.lang.Byte" - short-class "java.lang.Short" - int-class "java.lang.Integer" - long-class "java.lang.Long" - float-class "java.lang.Float" - double-class "java.lang.Double" - char-class "java.lang.Character"] - (defn prepare-return! [^MethodVisitor *writer* *type*] - (if (&type/type= &type/Any *type*) - (.visitLdcInsn *writer* &/unit-tag) - (|case *type* - (&/$Nominal "boolean" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name boolean-class) "valueOf" (str "(Z)" (&host-generics/->type-signature boolean-class))) - - (&/$Nominal "byte" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name byte-class) "valueOf" (str "(B)" (&host-generics/->type-signature byte-class))) - - (&/$Nominal "short" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name short-class) "valueOf" (str "(S)" (&host-generics/->type-signature short-class))) - - (&/$Nominal "int" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name int-class) "valueOf" (str "(I)" (&host-generics/->type-signature int-class))) - - (&/$Nominal "long" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name long-class) "valueOf" (str "(J)" (&host-generics/->type-signature long-class))) - - (&/$Nominal "float" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name float-class) "valueOf" (str "(F)" (&host-generics/->type-signature float-class))) - - (&/$Nominal "double" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name double-class) "valueOf" (str "(D)" (&host-generics/->type-signature double-class))) - - (&/$Nominal "char" (&/$End)) - (.visitMethodInsn *writer* Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name char-class) "valueOf" (str "(C)" (&host-generics/->type-signature char-class))) - - (&/$Nominal _ _) - nil - - (&/$Named ?name ?type) - (prepare-return! *writer* ?type) - - (&/$Opaque _) - nil - - ;; &type/Any - (&/$Existential _ (&/$Parameter 1)) - (.visitLdcInsn *writer* &/unit-tag) - - _ - (assert false (str 'prepare-return! " " (&type/show-type *type*))))) - *writer*)) - -;; [Resources] -(defn ^:private compile-annotation [^ClassWriter writer ann] - (doto ^AnnotationVisitor (.visitAnnotation writer (&host-generics/->type-signature (:name ann)) true) - (-> (.visit param-name param-value) - (->> (|let [[param-name param-value] param]) - (doseq [param (&/->seq (:params ann))]))) - (.visitEnd)) - nil) - -(defn ^:private compile-field [^ClassWriter writer field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (|let [=field (.visitField writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) - ?name - (&host-generics/gclass->simple-signature ?gclass) - (&host-generics/gclass->signature ?gclass) nil)] - (do (&/|map (partial compile-annotation =field) ?anns) - (.visitEnd =field) - nil)) - - (&/$VariableFieldSyntax =name =privacy-modifier =state-modifier =anns =type) - (|let [=field (.visitField writer - (+ (&host/privacy-modifier->flag =privacy-modifier) - (&host/state-modifier->flag =state-modifier)) - =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) nil)] - (do (&/|map (partial compile-annotation =field) =anns) - (.visitEnd =field) - nil)) - )) - -(defn ^:private compile-method-return [^MethodVisitor writer output] - (|case output - (&/$GenericClass "void" (&/$End)) - (.visitInsn writer Opcodes/RETURN) - - (&/$GenericClass "boolean" (&/$End)) - (doto writer - &&/unwrap-boolean - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "byte" (&/$End)) - (doto writer - &&/unwrap-byte - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "short" (&/$End)) - (doto writer - &&/unwrap-short - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "int" (&/$End)) - (doto writer - &&/unwrap-int - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "long" (&/$End)) - (doto writer - &&/unwrap-long - (.visitInsn Opcodes/LRETURN)) - - (&/$GenericClass "float" (&/$End)) - (doto writer - &&/unwrap-float - (.visitInsn Opcodes/FRETURN)) - - (&/$GenericClass "double" (&/$End)) - (doto writer - &&/unwrap-double - (.visitInsn Opcodes/DRETURN)) - - (&/$GenericClass "char" (&/$End)) - (doto writer - &&/unwrap-char - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass _class-name _) - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name _class-name)) - (.visitInsn Opcodes/ARETURN)) - - _ - (.visitInsn writer Opcodes/ARETURN))) - -(defn ^:private prepare-method-input - "(-> Int [Text GenericClass] MethodVisitor (Lux FrameTag))" - [idx input ^MethodVisitor method-visitor] - (|case input - [_ (&/$GenericClass name params)] - (case name - "boolean" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-boolean - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Boolean" (&/|list))))]))) - "byte" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-byte - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Byte" (&/|list))))]))) - "short" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-short - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Short" (&/|list))))]))) - "int" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-int - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Integer" (&/|list))))]))) - "long" (do (doto method-visitor - (.visitVarInsn Opcodes/LLOAD idx) - &&/wrap-long - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Long" (&/|list))) Opcodes/TOP)]))) - "float" (do (doto method-visitor - (.visitVarInsn Opcodes/FLOAD idx) - &&/wrap-float - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Float" (&/|list))))]))) - "double" (do (doto method-visitor - (.visitVarInsn Opcodes/DLOAD idx) - &&/wrap-double - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(+ 2 idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Double" (&/|list))) Opcodes/TOP)]))) - "char" (do (doto method-visitor - (.visitVarInsn Opcodes/ILOAD idx) - &&/wrap-char - (.visitVarInsn Opcodes/ASTORE idx)) - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass "java.lang.Character" (&/|list))))]))) - ;; else - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name (&/$GenericClass name params)))]))) - - [_ gclass] - (return (&/T [(inc idx) (&/|list (&host-generics/gclass->class-name gclass))])) - )) - -(defn ^:private prepare-method-inputs - "(-> Int (List GenericClass) MethodVisitor (Lux (List FrameTag)))" - [idx inputs method-visitor] - (|case inputs - (&/$End) - (return &/$End) - - (&/$Item input inputs*) - (|do [[_ outputs*] (&/fold% (fn [idx+outputs input] - (|do [:let [[_idx _outputs] idx+outputs] - [idx* output] (prepare-method-input _idx input method-visitor)] - (return (&/T [idx* (&/$Item output _outputs)])))) - (&/T [idx &/$End]) - inputs)] - (return (&/list-join (&/|reverse outputs*)))) - )) - -(defn ^:private compile-method-def [compile ^ClassWriter class-writer bytecode-class-name ?super-class method-def] - (|case method-def - (&/$ConstructorMethodAnalysis ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?ctor-args ?body) - (|let [?output (&/$GenericClass "void" (&/|list)) - =method-decl (&/T [init-method ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0)) - init-method - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [[super-class-name super-class-params] ?super-class - init-types (->> ?ctor-args (&/|map (comp &host-generics/gclass->signature &/|first)) (&/fold str "")) - init-sig (str "(" init-types ")" "V") - _ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - :let [_ (.visitVarInsn =method Opcodes/ALOAD 0)] - _ (->> ?ctor-args (&/|map &/|second) (&/map% compile)) - :let [_ (.visitMethodInsn =method Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method init-sig)] - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$VirtualMethodAnalysis ?name ?privacy-modifier =final? ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if =final? Opcodes/ACC_FINAL 0) - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$OverridenMethodAnalysis ?class-decl ?name ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC - (if ?strict Opcodes/ACC_STRICT 0)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 1 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$StaticMethodAnalysis ?name ?privacy-modifier ?strict ?anns ?gvars ?exceptions ?inputs ?output ?body) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ (&host/privacy-modifier->flag ?privacy-modifier) - (if ?strict Opcodes/ACC_STRICT 0) - Opcodes/ACC_STATIC) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitCode =method)] - =input-tags (prepare-method-inputs 0 ?inputs =method) - _ (compile (&o/optimize ?body)) - :let [_ (doto =method - (compile-method-return ?output) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))) - - (&/$AbstractMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_ABSTRACT - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - - (&/$NativeMethodSyntax ?name ?privacy-modifier ?anns ?gvars ?exceptions ?inputs ?output) - (|let [=method-decl (&/T [?name ?anns ?gvars ?exceptions (&/|map &/|second ?inputs) ?output]) - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl)] - (&/with-writer (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE - (&host/privacy-modifier->flag ?privacy-modifier)) - ?name - simple-signature - generic-signature - (->> ?exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - (|do [^MethodVisitor =method &/get-writer - :let [_ (&/|map (partial compile-annotation =method) ?anns) - _ (.visitEnd =method)]] - (return nil)))) - )) - -(defn ^:private compile-method-decl [^ClassWriter class-writer =method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] =method-decl - [simple-signature generic-signature] (&host-generics/method-signatures =method-decl) - =method (.visitMethod class-writer - (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->class-name) &/->seq (into-array java.lang.String))) - _ (&/|map (partial compile-annotation =method) =anns) - _ (.visitEnd =method)] - nil)) - -(defn ^:private prepare-ctor-arg [^MethodVisitor writer type] - (case type - "boolean" (doto writer - &&/unwrap-boolean) - "byte" (doto writer - &&/unwrap-byte) - "short" (doto writer - &&/unwrap-short) - "int" (doto writer - &&/unwrap-int) - "long" (doto writer - &&/unwrap-long) - "float" (doto writer - &&/unwrap-float) - "double" (doto writer - &&/unwrap-double) - "char" (doto writer - &&/unwrap-char) - ;; else - (doto writer - (.visitTypeInsn Opcodes/CHECKCAST (&host-generics/->bytecode-class-name type))))) - -(let [clo-field-sig (&host-generics/->type-signature "java.lang.Object") - -return "V"] - (defn ^:private anon-class--signature [env] - (str "(" (->> clo-field-sig (&/|repeat (&/|length env)) (&/fold str "")) ")" - -return)) - - (defn ^:private add-anon-class- [^ClassWriter class-writer compile class-name super-class env ctor-args] - (|let [[super-class-name super-class-params] super-class - init-types (->> ctor-args - (&/|map (comp &host-generics/gclass->signature &/|first)) - (&/fold str ""))] - (&/with-writer (.visitMethod class-writer Opcodes/ACC_PUBLIC init-method (anon-class--signature env) nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0))] - _ (&/map% (fn [type+term] - (|let [[type term] type+term] - (|do [_ (compile term) - :let [_ (prepare-ctor-arg =method (&host-generics/gclass->class-name type))]] - (return nil)))) - ctor-args) - :let [_ (doto =method - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name super-class-name) init-method (str "(" init-types ")" -return)) - (-> (doto (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ALOAD (inc ?captured-id)) - (.visitFieldInsn Opcodes/PUTFIELD class-name captured-name clo-field-sig)) - (->> (let [captured-name (str &&/closure-prefix ?captured-id)]) - (|case ?name+?captured - [?name [_ (&o/$captured _ ?captured-id ?source)]]) - (doseq [?name+?captured (&/->seq env)]))) - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil))))) - ) - -(defn ^:private constant-inits - "(-> (List FieldAnalysis) (List [Text GenericClass Analysis]))" - [fields] - (&/fold &/|++ - &/$End - (&/|map (fn [field] - (|case field - (&/$ConstantFieldSyntax ?name ?anns ?gclass ?value) - (&/|list (&/T [?name ?gclass ?value])) - - (&/$VariableFieldSyntax _) - (&/|list) - )) - fields))) - -(declare compile-jvm-putstatic) -(defn compile-jvm-class [compile class-decl ?super-class ?interfaces ?inheritance-modifier ?anns ?fields ?methods env ??ctor-args] - (|do [module &/get-module-name - [file-name line column] &/location - :let [[?name ?params] class-decl - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Item ?super-class ?interfaces)) - full-name (str module "/" ?name) - super-class* (&host-generics/->bytecode-class-name (&host-generics/super-class-name ?super-class)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - (&host/inheritance-modifier->flag ?inheritance-modifier)) - full-name (if (= "" class-signature) nil class-signature) super-class* (->> ?interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =class) ?anns) - _ (&/|map (partial compile-field =class) - ?fields)] - _ (&/map% (partial compile-method-def compile =class full-name ?super-class) ?methods) - _ (|case ??ctor-args - (&/$Some ctor-args) - (add-anon-class- =class compile full-name ?super-class env ctor-args) - - _ - (return nil)) - _ (&/with-writer (.visitMethod =class Opcodes/ACC_STATIC "" "()V" nil nil) - (|do [^MethodVisitor =method &/get-writer - :let [_ (doto =method - (.visitCode))] - _ (&/map% (fn [ftriple] - (|let [[fname fgclass fvalue] ftriple] - (compile-jvm-putstatic compile (&/|list (&o/optimize fvalue)) (&/|list ?name fname fgclass)))) - (constant-inits ?fields)) - :let [_ (doto =method - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd))]] - (return nil)))] - (&&/save-class! ?name (.toByteArray (doto =class .visitEnd))))) - -(defn compile-jvm-interface [interface-decl ?supers ?anns ?methods] - (|do [:let [[interface-name interface-vars] interface-decl] - module &/get-module-name - [file-name _ _] &/location - :let [interface-signature (&host-generics/gclass-decl->signature interface-decl ?supers) - =interface (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT Opcodes/ACC_INTERFACE) - (str module "/" interface-name) - (if (= "" interface-signature) nil interface-signature) - "java/lang/Object" - (->> ?supers (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String))) - (.visitSource file-name nil)) - _ (&/|map (partial compile-annotation =interface) ?anns) - _ (do (&/|map (partial compile-method-decl =interface) ?methods) - (.visitEnd =interface))]] - (&&/save-class! interface-name (.toByteArray =interface)))) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Item ?value (&/$End)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-double-to-float Opcodes/D2F &&/unwrap-double &&/wrap-float - ^:private compile-jvm-double-to-int Opcodes/D2I &&/unwrap-double &&/wrap-int - ^:private compile-jvm-double-to-long Opcodes/D2L &&/unwrap-double &&/wrap-long - - ^:private compile-jvm-float-to-double Opcodes/F2D &&/unwrap-float &&/wrap-double - ^:private compile-jvm-float-to-int Opcodes/F2I &&/unwrap-float &&/wrap-int - ^:private compile-jvm-float-to-long Opcodes/F2L &&/unwrap-float &&/wrap-long - - ^:private compile-jvm-int-to-byte Opcodes/I2B &&/unwrap-int &&/wrap-byte - ^:private compile-jvm-int-to-char Opcodes/I2C &&/unwrap-int &&/wrap-char - ^:private compile-jvm-int-to-double Opcodes/I2D &&/unwrap-int &&/wrap-double - ^:private compile-jvm-int-to-float Opcodes/I2F &&/unwrap-int &&/wrap-float - ^:private compile-jvm-int-to-long Opcodes/I2L &&/unwrap-int &&/wrap-long - ^:private compile-jvm-int-to-short Opcodes/I2S &&/unwrap-int &&/wrap-short - - ^:private compile-jvm-long-to-double Opcodes/L2D &&/unwrap-long &&/wrap-double - ^:private compile-jvm-long-to-float Opcodes/L2F &&/unwrap-long &&/wrap-float - ^:private compile-jvm-long-to-int Opcodes/L2I &&/unwrap-long &&/wrap-int - - ^:private compile-jvm-char-to-byte Opcodes/I2B &&/unwrap-char &&/wrap-byte - ^:private compile-jvm-char-to-short Opcodes/I2S &&/unwrap-char &&/wrap-short - ^:private compile-jvm-char-to-int Opcodes/NOP &&/unwrap-char &&/wrap-int - ^:private compile-jvm-char-to-long Opcodes/I2L &&/unwrap-char &&/wrap-long - - ^:private compile-jvm-short-to-long Opcodes/I2L &&/unwrap-short &&/wrap-long - - ^:private compile-jvm-byte-to-long Opcodes/I2L &&/unwrap-byte &&/wrap-long - ) - -(do-template [ ] - (defn [compile _?value special-args] - (|do [:let [(&/$Item ?value (&/$End)) _?value] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I) - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-long-to-short Opcodes/I2S &&/wrap-short - ^:private compile-jvm-long-to-byte Opcodes/I2B &&/wrap-byte - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - )] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - ^:private compile-jvm-iand Opcodes/IAND &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ior Opcodes/IOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ixor Opcodes/IXOR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishl Opcodes/ISHL &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-ishr Opcodes/ISHR &&/unwrap-int &&/unwrap-int &&/wrap-int - ^:private compile-jvm-iushr Opcodes/IUSHR &&/unwrap-int &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-land Opcodes/LAND &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lor Opcodes/LOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lxor Opcodes/LXOR &&/unwrap-long &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lshl Opcodes/LSHL &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lshr Opcodes/LSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ^:private compile-jvm-lushr Opcodes/LUSHR &&/unwrap-long &&/unwrap-int &&/wrap-long - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - _ (doto *writer* - (.visitInsn ) - ())]] - (return nil))) - - ^:private compile-jvm-iadd Opcodes/IADD &&/unwrap-int &&/wrap-int - ^:private compile-jvm-isub Opcodes/ISUB &&/unwrap-int &&/wrap-int - ^:private compile-jvm-imul Opcodes/IMUL &&/unwrap-int &&/wrap-int - ^:private compile-jvm-idiv Opcodes/IDIV &&/unwrap-int &&/wrap-int - ^:private compile-jvm-irem Opcodes/IREM &&/unwrap-int &&/wrap-int - - ^:private compile-jvm-ladd Opcodes/LADD &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lsub Opcodes/LSUB &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lmul Opcodes/LMUL &&/unwrap-long &&/wrap-long - ^:private compile-jvm-ldiv Opcodes/LDIV &&/unwrap-long &&/wrap-long - ^:private compile-jvm-lrem Opcodes/LREM &&/unwrap-long &&/wrap-long - - ^:private compile-jvm-fadd Opcodes/FADD &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fsub Opcodes/FSUB &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fmul Opcodes/FMUL &&/unwrap-float &&/wrap-float - ^:private compile-jvm-fdiv Opcodes/FDIV &&/unwrap-float &&/wrap-float - ^:private compile-jvm-frem Opcodes/FREM &&/unwrap-float &&/wrap-float - - ^:private compile-jvm-dadd Opcodes/DADD &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dsub Opcodes/DSUB &&/unwrap-double &&/wrap-double - ^:private compile-jvm-dmul Opcodes/DMUL &&/unwrap-double &&/wrap-double - ^:private compile-jvm-ddiv Opcodes/DDIV &&/unwrap-double &&/wrap-double - ^:private compile-jvm-drem Opcodes/DREM &&/unwrap-double &&/wrap-double - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-ieq Opcodes/IF_ICMPEQ &&/unwrap-int - ^:private compile-jvm-ilt Opcodes/IF_ICMPLT &&/unwrap-int - ^:private compile-jvm-igt Opcodes/IF_ICMPGT &&/unwrap-int - - ^:private compile-jvm-ceq Opcodes/IF_ICMPEQ &&/unwrap-char - ^:private compile-jvm-clt Opcodes/IF_ICMPLT &&/unwrap-char - ^:private compile-jvm-cgt Opcodes/IF_ICMPGT &&/unwrap-char - ) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?x (&/$Item ?y (&/$End))) ?values] - ^MethodVisitor *writer* &/get-writer - _ (compile ?x) - :let [_ (doto *writer* - )] - _ (compile ?y) - :let [_ (doto *writer* - ) - $then (new Label) - $end (new Label) - _ (doto *writer* - (.visitInsn ) - (.visitLdcInsn (int )) - (.visitJumpInsn Opcodes/IF_ICMPEQ $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - - ^:private compile-jvm-leq Opcodes/LCMP 0 &&/unwrap-long - ^:private compile-jvm-llt Opcodes/LCMP -1 &&/unwrap-long - ^:private compile-jvm-lgt Opcodes/LCMP 1 &&/unwrap-long - - ^:private compile-jvm-feq Opcodes/FCMPG 0 &&/unwrap-float - ^:private compile-jvm-flt Opcodes/FCMPG -1 &&/unwrap-float - ^:private compile-jvm-fgt Opcodes/FCMPG 1 &&/unwrap-float - - ^:private compile-jvm-deq Opcodes/DCMPG 0 &&/unwrap-double - ^:private compile-jvm-dlt Opcodes/DCMPG -1 &&/unwrap-double - ^:private compile-jvm-dgt Opcodes/DCMPG 1 &&/unwrap-double - ) - -(do-template [ ] - (do (defn [compile ?values special-args] - (|do [:let [(&/$Item ?length (&/$End)) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitIntInsn *writer* Opcodes/NEWARRAY )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?array (&/$Item ?idx (&/$End))) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (doto *writer* - (.visitInsn ) - )]] - (return nil))) - - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?array (&/$Item ?idx (&/$Item ?elem (&/$End)))) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST )] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (doto *writer* - - (.visitInsn ))]] - (return nil))) - ) - - Opcodes/T_BOOLEAN "[Z" ^:private compile-jvm-znewarray compile-jvm-zaload Opcodes/BALOAD compile-jvm-zastore Opcodes/BASTORE &&/wrap-boolean &&/unwrap-boolean - Opcodes/T_BYTE "[B" ^:private compile-jvm-bnewarray compile-jvm-baload Opcodes/BALOAD compile-jvm-bastore Opcodes/BASTORE &&/wrap-byte &&/unwrap-byte - Opcodes/T_SHORT "[S" ^:private compile-jvm-snewarray compile-jvm-saload Opcodes/SALOAD compile-jvm-sastore Opcodes/SASTORE &&/wrap-short &&/unwrap-short - Opcodes/T_INT "[I" ^:private compile-jvm-inewarray compile-jvm-iaload Opcodes/IALOAD compile-jvm-iastore Opcodes/IASTORE &&/wrap-int &&/unwrap-int - Opcodes/T_LONG "[J" ^:private compile-jvm-lnewarray compile-jvm-laload Opcodes/LALOAD compile-jvm-lastore Opcodes/LASTORE &&/wrap-long &&/unwrap-long - Opcodes/T_FLOAT "[F" ^:private compile-jvm-fnewarray compile-jvm-faload Opcodes/FALOAD compile-jvm-fastore Opcodes/FASTORE &&/wrap-float &&/unwrap-float - Opcodes/T_DOUBLE "[D" ^:private compile-jvm-dnewarray compile-jvm-daload Opcodes/DALOAD compile-jvm-dastore Opcodes/DASTORE &&/wrap-double &&/unwrap-double - Opcodes/T_CHAR "[C" ^:private compile-jvm-cnewarray compile-jvm-caload Opcodes/CALOAD compile-jvm-castore Opcodes/CASTORE &&/wrap-char &&/unwrap-char - ) - -(defn ^:private compile-jvm-anewarray [compile ?values special-args] - (|do [:let [(&/$Item ?length (&/$End)) ?values - (&/$Item ?gclass (&/$Item type-env (&/$End))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?length) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitTypeInsn *writer* Opcodes/ANEWARRAY (&host-generics/gclass->bytecode-class-name* ?gclass type-env))]] - (return nil))) - -(defn ^:private compile-jvm-aaload [compile ?values special-args] - (|do [:let [(&/$Item ?array (&/$Item ?idx (&/$End))) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - normal_array_type (&type/normal (&a/expr-type* ?array)) - :let [(&/$Nominal "#Array" (&/$Item mutable_type (&/$End))) normal_array_type - (&/$Nominal "#Mutable" (&/$Item type_variance (&/$End))) mutable_type - (&/$Function write_type read_type) type_variance] - array-type (&host/->java-sig (&/$Nominal "#Array" (&/|list read_type))) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - :let [_ (.visitInsn *writer* Opcodes/AALOAD)]] - (return nil))) - -(defn ^:private compile-jvm-aastore [compile ?values special-args] - (|do [:let [(&/$Item ?array (&/$Item ?idx (&/$Item ?elem (&/$End)))) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - normal_array_type (&type/normal (&a/expr-type* ?array)) - :let [(&/$Nominal "#Array" (&/$Item mutable_type (&/$End))) normal_array_type - (&/$Nominal "#Mutable" (&/$Item type_variance (&/$End))) mutable_type - (&/$Function write_type read_type) type_variance] - array-type (&host/->java-sig (&/$Nominal "#Array" (&/|list write_type))) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (.visitInsn *writer* Opcodes/DUP)] - _ (compile ?idx) - :let [_ (doto *writer* - &&/unwrap-long - (.visitInsn Opcodes/L2I))] - _ (compile ?elem) - :let [_ (.visitInsn *writer* Opcodes/AASTORE)]] - (return nil))) - -(defn ^:private compile-jvm-arraylength [compile ?values special-args] - (|do [:let [(&/$Item ?array (&/$End)) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - normal_array_type (&type/normal (&a/expr-type* ?array)) - array-type (|case normal_array_type - (&/$Nominal ?name (&/$End)) - (&host/->java-sig normal_array_type) - - (&/$Nominal "#Array" (&/$Item mutable_type (&/$End))) - (|let [(&/$Nominal "#Mutable" (&/$Item type_variance (&/$End))) mutable_type - (&/$Function write_type read_type) type_variance] - (&host/->java-sig (&/$Nominal "#Array" (&/|list read_type))))) - _ (compile ?array) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST array-type)] - :let [_ (doto *writer* - (.visitInsn Opcodes/ARRAYLENGTH) - (.visitInsn Opcodes/I2L) - &&/wrap-long)]] - (return nil))) - -(defn ^:private compile-jvm-object-null [compile ?values special-args] - (|do [:let [;; (&/$End) ?values - (&/$End) special-args] - ^MethodVisitor *writer* &/get-writer - :let [_ (.visitInsn *writer* Opcodes/ACONST_NULL)]] - (return nil))) - -(defn ^:private compile-jvm-object-null? [compile ?values special-args] - (|do [:let [(&/$Item ?object (&/$End)) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [$then (new Label) - $end (new Label) - _ (doto *writer* - (.visitJumpInsn Opcodes/IFNULL $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "FALSE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitJumpInsn Opcodes/GOTO $end) - (.visitLabel $then) - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name "java.lang.Boolean") "TRUE" (&host-generics/->type-signature "java.lang.Boolean")) - (.visitLabel $end))]] - (return nil))) - -(defn compile-jvm-object-synchronized [compile ?values special-args] - (|do [:let [(&/$Item ?monitor (&/$Item ?expr (&/$End))) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?monitor) - :let [_ (doto *writer* - (.visitInsn Opcodes/DUP) - (.visitInsn Opcodes/MONITORENTER))] - _ (compile ?expr) - :let [_ (doto *writer* - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/MONITOREXIT))]] - (return nil))) - -(defn ^:private compile-jvm-throw [compile ?values special-args] - (|do [:let [(&/$Item ?ex (&/$End)) ?values - ;; (&/$End) special-args - ] - ^MethodVisitor *writer* &/get-writer - _ (compile ?ex) - :let [_ (.visitInsn *writer* Opcodes/ATHROW)]] - (return nil))) - -(defn ^:private compile-jvm-getstatic [compile ?values special-args] - (|do [:let [;; (&/$End) ?values - (&/$Item ?class (&/$Item ?field (&/$Item ?output-type* (&/$End)))) special-args] - ^MethodVisitor *writer* &/get-writer - ?output-type (&type/normal ?output-type*) - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitFieldInsn Opcodes/GETSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-getfield [compile ?values special-args] - (|do [:let [(&/$Item ?object (&/$End)) ?values - (&/$Item ?class (&/$Item ?field (&/$Item ?output-type* (&/$End)))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - ?output-type (&type/normal ?output-type*) - =output-type (&host/->java-sig ?output-type) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/CHECKCAST class*) - (.visitFieldInsn Opcodes/GETFIELD class* ?field =output-type) - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-putstatic [compile ?values special-args] - (|do [:let [(&/$Item ?value (&/$End)) ?values - (&/$Item ?class (&/$Item ?field (&/$Item input-gclass (&/$End)))) special-args] - ^MethodVisitor *writer* &/get-writer - _ (compile ?value) - :let [=input-sig (&host-type/gclass->sig input-gclass) - _ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTSTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-putfield [compile ?values special-args] - (|do [:let [(&/$Item ?object (&/$Item ?value (&/$End))) ?values - (&/$Item ?class (&/$Item ?field (&/$Item input-gclass (&/$Item ?input-type (&/$End))))) special-args] - :let [class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - _ (compile ?object) - :let [_ (.visitTypeInsn *writer* Opcodes/CHECKCAST class*)] - _ (compile ?value) - =input-sig (&host/->java-sig ?input-type) - :let [_ (doto *writer* - (prepare-arg! (&host-generics/gclass->class-name input-gclass)) - (.visitFieldInsn Opcodes/PUTFIELD class* ?field =input-sig) - (.visitInsn Opcodes/ACONST_NULL))]] - (return nil))) - -(defn ^:private compile-jvm-invokestatic [compile ?values special-args] - (|do [:let [?args ?values - (&/$Item ?class (&/$Item ?method (&/$Item ?classes (&/$Item ?output-type* (&/$Item ?gret (&/$End)))))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - ?output-type (&type/normal ?output-type*) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESTATIC (&host-generics/->bytecode-class-name (&host-type/as-obj ?class)) ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - -(do-template [ ] - (defn [compile ?values special-args] - (|do [:let [(&/$Item ?object ?args) ?values - (&/$Item ?class (&/$Item ?method (&/$Item ?classes (&/$Item ?output-type* (&/$Item ?gret (&/$End)))))) special-args] - :let [?class* (&host-generics/->bytecode-class-name (&host-type/as-obj ?class))] - ^MethodVisitor *writer* &/get-writer - :let [method-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")" (&host-type/principal-class ?gret))] - _ (compile ?object) - :let [_ (when (not= "" ?method) - (.visitTypeInsn *writer* Opcodes/CHECKCAST ?class*))] - _ (&/map2% (fn [class-name arg] - (|do [ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - ?classes ?args) - ?output-type (&type/normal ?output-type*) - :let [_ (doto *writer* - (.visitMethodInsn ?class* ?method method-sig) - (prepare-return! ?output-type))]] - (return nil))) - - ^:private compile-jvm-invokevirtual Opcodes/INVOKEVIRTUAL - ^:private compile-jvm-invokeinterface Opcodes/INVOKEINTERFACE - ^:private compile-jvm-invokespecial Opcodes/INVOKESPECIAL - ) - -(defn ^:private compile-jvm-new [compile ?values special-args] - (|do [:let [?args ?values - (&/$Item ?class (&/$Item ?classes (&/$End))) special-args] - ^MethodVisitor *writer* &/get-writer - :let [init-sig (str "(" (&/fold str "" (&/|map &host-generics/->type-signature ?classes)) ")V") - class* (&host-generics/->bytecode-class-name ?class) - _ (doto *writer* - (.visitTypeInsn Opcodes/NEW class*) - (.visitInsn Opcodes/DUP))] - _ (&/map% (fn [class-name+arg] - (|do [:let [[class-name arg] class-name+arg] - ret (compile arg) - :let [_ (prepare-arg! *writer* class-name)]] - (return ret))) - (&/zip2 ?classes ?args)) - :let [_ (doto *writer* - (.visitMethodInsn Opcodes/INVOKESPECIAL class* "" init-sig))]] - (return nil))) - -(defn ^:private compile-jvm-object-class [compile ?values special-args] - (|do [:let [(&/$Item _class-name (&/$Item ?output-type* (&/$End))) special-args] - ^MethodVisitor *writer* &/get-writer - ?output-type (&type/normal ?output-type*) - :let [_ (doto *writer* - (.visitLdcInsn _class-name) - (.visitMethodInsn Opcodes/INVOKESTATIC "java/lang/Class" "forName" "(Ljava/lang/String;)Ljava/lang/Class;") - (prepare-return! ?output-type))]] - (return nil))) - -(defn ^:private compile-jvm-instanceof [compile ?values special-args] - (|do [:let [(&/$Item object (&/$End)) ?values - (&/$Item class (&/$End)) special-args] - :let [class* (&host-generics/->bytecode-class-name class)] - ^MethodVisitor *writer* &/get-writer - _ (compile object) - :let [_ (doto *writer* - (.visitTypeInsn Opcodes/INSTANCEOF class*) - (&&/wrap-boolean))]] - (return nil))) - -(defn compile-proc [compile proc-name ?values special-args] - (case proc-name - "object synchronized" (compile-jvm-object-synchronized compile ?values special-args) - "object class" (compile-jvm-object-class compile ?values special-args) - "instanceof" (compile-jvm-instanceof compile ?values special-args) - "new" (compile-jvm-new compile ?values special-args) - "invokestatic" (compile-jvm-invokestatic compile ?values special-args) - "invokeinterface" (compile-jvm-invokeinterface compile ?values special-args) - "invokevirtual" (compile-jvm-invokevirtual compile ?values special-args) - "invokespecial" (compile-jvm-invokespecial compile ?values special-args) - "getstatic" (compile-jvm-getstatic compile ?values special-args) - "getfield" (compile-jvm-getfield compile ?values special-args) - "putstatic" (compile-jvm-putstatic compile ?values special-args) - "putfield" (compile-jvm-putfield compile ?values special-args) - "throw" (compile-jvm-throw compile ?values special-args) - "object null?" (compile-jvm-object-null? compile ?values special-args) - "object null" (compile-jvm-object-null compile ?values special-args) - "anewarray" (compile-jvm-anewarray compile ?values special-args) - "aaload" (compile-jvm-aaload compile ?values special-args) - "aastore" (compile-jvm-aastore compile ?values special-args) - "arraylength" (compile-jvm-arraylength compile ?values special-args) - "znewarray" (compile-jvm-znewarray compile ?values special-args) - "bnewarray" (compile-jvm-bnewarray compile ?values special-args) - "snewarray" (compile-jvm-snewarray compile ?values special-args) - "inewarray" (compile-jvm-inewarray compile ?values special-args) - "lnewarray" (compile-jvm-lnewarray compile ?values special-args) - "fnewarray" (compile-jvm-fnewarray compile ?values special-args) - "dnewarray" (compile-jvm-dnewarray compile ?values special-args) - "cnewarray" (compile-jvm-cnewarray compile ?values special-args) - "zaload" (compile-jvm-zaload compile ?values special-args) - "zastore" (compile-jvm-zastore compile ?values special-args) - "baload" (compile-jvm-baload compile ?values special-args) - "bastore" (compile-jvm-bastore compile ?values special-args) - "saload" (compile-jvm-saload compile ?values special-args) - "sastore" (compile-jvm-sastore compile ?values special-args) - "iaload" (compile-jvm-iaload compile ?values special-args) - "iastore" (compile-jvm-iastore compile ?values special-args) - "laload" (compile-jvm-laload compile ?values special-args) - "lastore" (compile-jvm-lastore compile ?values special-args) - "faload" (compile-jvm-faload compile ?values special-args) - "fastore" (compile-jvm-fastore compile ?values special-args) - "daload" (compile-jvm-daload compile ?values special-args) - "dastore" (compile-jvm-dastore compile ?values special-args) - "caload" (compile-jvm-caload compile ?values special-args) - "castore" (compile-jvm-castore compile ?values special-args) - "iadd" (compile-jvm-iadd compile ?values special-args) - "isub" (compile-jvm-isub compile ?values special-args) - "imul" (compile-jvm-imul compile ?values special-args) - "idiv" (compile-jvm-idiv compile ?values special-args) - "irem" (compile-jvm-irem compile ?values special-args) - "ieq" (compile-jvm-ieq compile ?values special-args) - "ilt" (compile-jvm-ilt compile ?values special-args) - "igt" (compile-jvm-igt compile ?values special-args) - "ceq" (compile-jvm-ceq compile ?values special-args) - "clt" (compile-jvm-clt compile ?values special-args) - "cgt" (compile-jvm-cgt compile ?values special-args) - "ladd" (compile-jvm-ladd compile ?values special-args) - "lsub" (compile-jvm-lsub compile ?values special-args) - "lmul" (compile-jvm-lmul compile ?values special-args) - "ldiv" (compile-jvm-ldiv compile ?values special-args) - "lrem" (compile-jvm-lrem compile ?values special-args) - "leq" (compile-jvm-leq compile ?values special-args) - "llt" (compile-jvm-llt compile ?values special-args) - "lgt" (compile-jvm-lgt compile ?values special-args) - "fadd" (compile-jvm-fadd compile ?values special-args) - "fsub" (compile-jvm-fsub compile ?values special-args) - "fmul" (compile-jvm-fmul compile ?values special-args) - "fdiv" (compile-jvm-fdiv compile ?values special-args) - "frem" (compile-jvm-frem compile ?values special-args) - "feq" (compile-jvm-feq compile ?values special-args) - "flt" (compile-jvm-flt compile ?values special-args) - "fgt" (compile-jvm-fgt compile ?values special-args) - "dadd" (compile-jvm-dadd compile ?values special-args) - "dsub" (compile-jvm-dsub compile ?values special-args) - "dmul" (compile-jvm-dmul compile ?values special-args) - "ddiv" (compile-jvm-ddiv compile ?values special-args) - "drem" (compile-jvm-drem compile ?values special-args) - "deq" (compile-jvm-deq compile ?values special-args) - "dlt" (compile-jvm-dlt compile ?values special-args) - "dgt" (compile-jvm-dgt compile ?values special-args) - "iand" (compile-jvm-iand compile ?values special-args) - "ior" (compile-jvm-ior compile ?values special-args) - "ixor" (compile-jvm-ixor compile ?values special-args) - "ishl" (compile-jvm-ishl compile ?values special-args) - "ishr" (compile-jvm-ishr compile ?values special-args) - "iushr" (compile-jvm-iushr compile ?values special-args) - "land" (compile-jvm-land compile ?values special-args) - "lor" (compile-jvm-lor compile ?values special-args) - "lxor" (compile-jvm-lxor compile ?values special-args) - "lshl" (compile-jvm-lshl compile ?values special-args) - "lshr" (compile-jvm-lshr compile ?values special-args) - "lushr" (compile-jvm-lushr compile ?values special-args) - "double-to-float" (compile-jvm-double-to-float compile ?values special-args) - "double-to-int" (compile-jvm-double-to-int compile ?values special-args) - "double-to-long" (compile-jvm-double-to-long compile ?values special-args) - "float-to-double" (compile-jvm-float-to-double compile ?values special-args) - "float-to-int" (compile-jvm-float-to-int compile ?values special-args) - "float-to-long" (compile-jvm-float-to-long compile ?values special-args) - "int-to-byte" (compile-jvm-int-to-byte compile ?values special-args) - "int-to-char" (compile-jvm-int-to-char compile ?values special-args) - "int-to-double" (compile-jvm-int-to-double compile ?values special-args) - "int-to-float" (compile-jvm-int-to-float compile ?values special-args) - "int-to-long" (compile-jvm-int-to-long compile ?values special-args) - "int-to-short" (compile-jvm-int-to-short compile ?values special-args) - "long-to-double" (compile-jvm-long-to-double compile ?values special-args) - "long-to-float" (compile-jvm-long-to-float compile ?values special-args) - "long-to-int" (compile-jvm-long-to-int compile ?values special-args) - "long-to-short" (compile-jvm-long-to-short compile ?values special-args) - "long-to-byte" (compile-jvm-long-to-byte compile ?values special-args) - "char-to-byte" (compile-jvm-char-to-byte compile ?values special-args) - "char-to-short" (compile-jvm-char-to-short compile ?values special-args) - "char-to-int" (compile-jvm-char-to-int compile ?values special-args) - "char-to-long" (compile-jvm-char-to-long compile ?values special-args) - "short-to-long" (compile-jvm-short-to-long compile ?values special-args) - "byte-to-long" (compile-jvm-byte-to-long compile ?values special-args) - ;; else - (&/fail-with-loc (str "[Compiler Error] Unknown host procedure: " ["jvm" proc-name])))) diff --git a/lux-bootstrapper/src/lux/compiler/jvm/rt.clj b/lux-bootstrapper/src/lux/compiler/jvm/rt.clj deleted file mode 100644 index 7b06608b36..0000000000 --- a/lux-bootstrapper/src/lux/compiler/jvm/rt.clj +++ /dev/null @@ -1,409 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.jvm.rt - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type] - [lexer :as &lexer] - [parser :as &parser] - [analyser :as &analyser] - [optimizer :as &o] - [host :as &host]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics] - [lux.analyser.base :as &a] - [lux.compiler.jvm.base :as &&]) - (:import (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor - AnnotationVisitor))) - -(def ^:const ^String runtime-class - &&/lux-utils-class) - -(def ^:const ^String function-class - &&/function-class) - -;; [Utils] -(def init-method "") - -;; [Resources] -;; Functions -;; NOT BEING USED ANYMORE... -;; But keeping it here just in case... -(def compile-Function-class - (|do [_ (return nil) - :let [super-class "java/lang/Object" - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER - Opcodes/ACC_ABSTRACT - ;; Opcodes/ACC_INTERFACE - ) - &&/function-class nil super-class (into-array String [])) - (-> (.visitField (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL) &&/partials-field "I" nil nil) - (doto (.visitEnd)))) - =init-method (doto (.visitMethod =class Opcodes/ACC_PUBLIC init-method "(I)V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitVarInsn Opcodes/ILOAD 1) - (.visitFieldInsn Opcodes/PUTFIELD &&/function-class &&/partials-field "I") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (dotimes [arity* &&/num-apply-variants] - (let [arity (inc arity*)] - (if (= 1 arity) - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) &&/apply-method (&&/apply-signature arity) nil nil) - (.visitEnd)) - (doto (.visitMethod =class Opcodes/ACC_PUBLIC &&/apply-method (&&/apply-signature arity) nil nil) - (.visitCode) - (-> (.visitVarInsn Opcodes/ALOAD idx) - (->> (dotimes [idx arity]))) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature (dec arity))) - (.visitTypeInsn Opcodes/CHECKCAST &&/function-class) - (.visitVarInsn Opcodes/ALOAD arity) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL &&/function-class &&/apply-method (&&/apply-signature 1)) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)))))]] - (&&/save-class! (-> &&/function-class (string/split #"/") (nth 2)) - (.toByteArray (doto =class .visitEnd))))) - -(defmacro [& instructions] - `(fn [^MethodVisitor writer#] - (doto writer# - ~@instructions))) - -;; Runtime infrastructure -(defn ^:private compile-Runtime-adt-methods [^ClassWriter =class] - (|let [lefts #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ILOAD 1)) - tuple-size #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARRAYLENGTH)) - last-right #(doto ^MethodVisitor % - tuple-size - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB)) - sub-lefts #(doto ^MethodVisitor % - lefts - last-right - (.visitInsn Opcodes/ISUB)) - sub-tuple #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - last-right - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;")) - recurI (fn [$begin] - #(doto ^MethodVisitor % - sub-lefts (.visitVarInsn Opcodes/ISTORE 1) - sub-tuple (.visitVarInsn Opcodes/ASTORE 0) - (.visitJumpInsn Opcodes/GOTO $begin))) - _ (let [$begin (new Label) - $recursive (new Label) - left-index lefts - left-access #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - left-index - (.visitInsn Opcodes/AALOAD))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "tuple_left" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - lefts last-right (.visitJumpInsn Opcodes/IF_ICMPGE $recursive) - left-access - (.visitInsn Opcodes/ARETURN) - (.visitLabel $recursive) - ((recurI $begin)) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$begin (new Label) - $not-last (new Label) - $must-copy (new Label) - right-index #(doto ^MethodVisitor % - lefts - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/IADD)) - right-access #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/AALOAD)) - sub-right #(doto ^MethodVisitor % - (.visitVarInsn Opcodes/ALOAD 0) - right-index - tuple-size - (.visitMethodInsn Opcodes/INVOKESTATIC "java/util/Arrays" "copyOfRange" "([Ljava/lang/Object;II)[Ljava/lang/Object;"))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "tuple_right" "([Ljava/lang/Object;I)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLabel $begin) - last-right right-index - (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPNE $not-last) - right-access - (.visitInsn Opcodes/ARETURN) - (.visitLabel $not-last) - (.visitJumpInsn Opcodes/IF_ICMPGT $must-copy) - ;; Must recurse - ((recurI $begin)) - (.visitLabel $must-copy) - sub-right - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (let [$loop (new Label) - $perfect-match! (new Label) - $lefts-match! (new Label) - $maybe-nested (new Label) - $mismatch! (new Label) - - !variant ( (.visitVarInsn Opcodes/ALOAD 0)) - !lefts ( (.visitVarInsn Opcodes/ILOAD 1)) - !right? ( (.visitVarInsn Opcodes/ALOAD 2)) - - <>lefts ( (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD) - &&/unwrap-int) - <>right? ( (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD)) - <>value ( (.visitLdcInsn (int 2)) - (.visitInsn Opcodes/AALOAD)) - - not-found ( (.visitInsn Opcodes/ACONST_NULL)) - - super-nested-lefts ( (.visitInsn Opcodes/SWAP) - (.visitInsn Opcodes/ISUB) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB)) - super-nested ( super-nested-lefts ;; super-lefts - !variant <>right? ;; super-lefts, super-right? - !variant <>value ;; super-lefts, super-right?, super-value - (.visitMethodInsn Opcodes/INVOKESTATIC runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;")) - - update-!variant ( !variant <>value - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;") - (.visitVarInsn Opcodes/ASTORE 0)) - update-!lefts ( (.visitInsn Opcodes/ISUB) - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/ISUB)) - iterate! (fn [^Label $loop] - ( update-!variant - update-!lefts - (.visitJumpInsn Opcodes/GOTO $loop)))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_get" "([Ljava/lang/Object;ILjava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - !lefts ;; lefts - (.visitLabel $loop) - !variant <>lefts ;; lefts, variant::lefts - (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPEQ $lefts-match!) ;; lefts, variant::lefts - (.visitInsn Opcodes/DUP2) (.visitJumpInsn Opcodes/IF_ICMPGT $maybe-nested) ;; lefts, variant::lefts - !right? (.visitJumpInsn Opcodes/IFNULL $mismatch!) ;; lefts, variant::lefts - super-nested ;; super-variant - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;; $lefts-match! ;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $lefts-match!) ;; lefts, variant::lefts - !right? ;; lefts, variant::lefts, right? - !variant <>right? ;; lefts, variant::lefts, right?, variant::right? - (.visitJumpInsn Opcodes/IF_ACMPEQ $perfect-match!) - ;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;; $mismatch! ;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $mismatch!) ;; lefts, variant::lefts - ;; (.visitInsn Opcodes/POP2) - not-found - (.visitInsn Opcodes/ARETURN) - ;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;; $maybe-nested ;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $maybe-nested) ;; lefts, variant::lefts - !variant <>right? ;; lefts, variant::lefts, variant::right? - (.visitJumpInsn Opcodes/IFNULL $mismatch!) ;; lefts, variant::lefts - ((iterate! $loop)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;;;;;; $perfect-match! ;;;;;; - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (.visitLabel $perfect-match!) ;; lefts, variant::lefts - ;; (.visitInsn Opcodes/POP2) ;; - !variant <>value - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (int 3)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ILOAD 0) - (&&/wrap-int) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 2)) - (.visitVarInsn Opcodes/ALOAD 2) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - -(defn ^:private swap2x1 [^MethodVisitor =method] - (doto =method - ;; X1, Y2 - (.visitInsn Opcodes/DUP2_X1) ;; Y2, X1, Y2 - (.visitInsn Opcodes/POP2) ;; Y2, X1 - )) - -(defn peekI [^MethodVisitor writer] - (doto writer - (.visitLdcInsn (int 0)) - (.visitInsn Opcodes/AALOAD))) - -(defn popI [^MethodVisitor writer] - (doto writer - (.visitLdcInsn (int 1)) - (.visitInsn Opcodes/AALOAD) - (.visitTypeInsn Opcodes/CHECKCAST "[Ljava/lang/Object;"))) - -(defn ^:private compile-Runtime-pm-methods [^ClassWriter =class] - (|let [_ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_fail" "()V" nil nil) - (.visitCode) - (.visitTypeInsn Opcodes/NEW "java/lang/IllegalStateException") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn "Invalid expression for pattern-matching.") - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/lang/IllegalStateException" "" "(Ljava/lang/String;)V") - (.visitInsn Opcodes/ATHROW) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "pm_stack_push" "([Ljava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (int 2)) - (.visitTypeInsn Opcodes/ANEWARRAY "java/lang/Object") - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 1)) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/DUP) - (.visitLdcInsn (int 0)) - (.visitVarInsn Opcodes/ALOAD 1) - (.visitInsn Opcodes/AASTORE) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))] - nil)) - -(def compile-Runtime-class - (|do [_ (return nil) - :let [full-name &&/lux-utils-class - super-class (&host-generics/->bytecode-class-name "java.lang.Object") - tag-sig (&host-generics/->type-signature "java.lang.String") - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit &host/bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_FINAL Opcodes/ACC_SUPER) - full-name nil super-class (into-array String []))) - =unit-tag (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) &&/unit-tag-field tag-sig nil &/unit-tag) - (.visitEnd)) - =init-method (doto (.visitMethod =class Opcodes/ACC_PRIVATE init-method "()V" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKESPECIAL super-class init-method "()V") - (.visitInsn Opcodes/RETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "log" "(Ljava/lang/Object;)Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitLdcInsn "LOG: ") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "print" "(Ljava/lang/Object;)V") - (.visitFieldInsn Opcodes/GETSTATIC "java/lang/System" "out" "Ljava/io/PrintStream;") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/PrintStream" "println" "(Ljava/lang/Object;)V") - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_none" "()[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$None meta ::&/lefts int)) ;; I - (.visitInsn Opcodes/ACONST_NULL) ;; I? - (.visitLdcInsn &/unit-tag) ;; I?U - (.visitMethodInsn Opcodes/INVOKESTATIC runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;" nil nil) - (.visitCode) - (.visitLdcInsn (->> #'&/$Some meta ::&/lefts int)) ;; I - (.visitLdcInsn "") ;; I? - (.visitVarInsn Opcodes/ALOAD 0) ;; I?O - (.visitMethodInsn Opcodes/INVOKESTATIC runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "clean_separators" "(Ljava/lang/String;)Ljava/lang/String;" nil nil) - (.visitCode) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitLdcInsn "_") - (.visitLdcInsn "") - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/String" "replaceAll" "(Ljava/lang/String;Ljava/lang/String;)Ljava/lang/String;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd)) - _ (let [$from (new Label) - $to (new Label) - $handler (new Label) - make-string-writerI (fn [^MethodVisitor _method_] - (doto _method_ - (.visitTypeInsn Opcodes/NEW "java/io/StringWriter") - (.visitInsn Opcodes/DUP) - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/StringWriter" "" "()V"))) - make-print-writerI (fn [^MethodVisitor _method_] - (doto _method_ - ;; W - (.visitTypeInsn Opcodes/NEW "java/io/PrintWriter") ;; WP - (.visitInsn Opcodes/SWAP) ;; PW - (.visitInsn Opcodes/DUP2) ;; PWPW - (.visitInsn Opcodes/POP) ;; PWP - (.visitInsn Opcodes/SWAP) ;; PPW - (.visitLdcInsn true) ;; PPW? - (.visitMethodInsn Opcodes/INVOKESPECIAL "java/io/PrintWriter" "" "(Ljava/io/Writer;Z)V") - ;; P - ))] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) "runTry" (str "(L" function-class ";)[Ljava/lang/Object;") nil nil) - (.visitCode) - (.visitTryCatchBlock $from $to $handler "java/lang/Throwable") - (.visitLabel $from) - (.visitVarInsn Opcodes/ALOAD 0) - (.visitInsn Opcodes/ACONST_NULL) - (.visitMethodInsn Opcodes/INVOKEVIRTUAL function-class &&/apply-method (&&/apply-signature 1)) - (.visitMethodInsn Opcodes/INVOKESTATIC runtime-class "make_some" "(Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitLabel $to) - (.visitLabel $handler) ;; T - make-string-writerI ;; TW - (.visitInsn Opcodes/DUP2) ;; TWTW - make-print-writerI ;; TWTP - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/lang/Throwable" "printStackTrace" "(Ljava/io/PrintWriter;)V") ;; TW - (.visitMethodInsn Opcodes/INVOKEVIRTUAL "java/io/StringWriter" "toString" "()Ljava/lang/String;") ;; TS - (.visitInsn Opcodes/SWAP) (.visitInsn Opcodes/POP) ;; S - (.visitLdcInsn (->> #'&/$Left meta ::&/lefts int)) ;; SI - (.visitInsn Opcodes/ACONST_NULL) ;; SI? - swap2x1 ;; I?S - (.visitMethodInsn Opcodes/INVOKESTATIC runtime-class "sum_make" "(ILjava/lang/Object;Ljava/lang/Object;)[Ljava/lang/Object;") - (.visitInsn Opcodes/ARETURN) - (.visitMaxs 0 0) - (.visitEnd))) - _ (doto =class - (compile-Runtime-pm-methods) - (compile-Runtime-adt-methods))]] - (&&/save-class! (-> &&/lux-utils-class (string/split #"/") (nth 2)) - (.toByteArray (doto =class .visitEnd))))) diff --git a/lux-bootstrapper/src/lux/compiler/parallel.clj b/lux-bootstrapper/src/lux/compiler/parallel.clj deleted file mode 100644 index 44a7db3a3f..0000000000 --- a/lux-bootstrapper/src/lux/compiler/parallel.clj +++ /dev/null @@ -1,48 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.compiler.parallel - (:require (clojure [string :as string] - [set :as set] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]]))) - -;; [Utils] -(def ^:private !state! (ref {})) - -(def ^:private get-compiler - (fn [compiler] - (return* compiler compiler))) - -;; [Exports] -(defn setup! - "Must always call this function before using parallel compilation to make sure that the state that is being tracked is in proper shape." - [] - (dosync (ref-set !state! {}))) - -(defn parallel-compilation [compile-module*] - (fn [module-name] - (|do [compiler get-compiler - :let [[task new?] (dosync (if-let [existing-task (get @!state! module-name)] - (&/T [existing-task false]) - (let [new-task (promise)] - (do (alter !state! assoc module-name new-task) - (&/T [new-task true]))))) - _ (when new? - (.start (new Thread - (fn [] - (let [out-str (with-out-str - (try (|case (&/run-state (compile-module* module-name) - compiler) - (&/$Right post-compiler _) - (deliver task (&/$Right post-compiler)) - - (&/$Left ?error) - (deliver task (&/$Left ?error))) - (catch Throwable ex - (.printStackTrace ex) - (deliver task (&/$Left "")))))] - (&/|log! out-str))))))]] - (return task)))) diff --git a/lux-bootstrapper/src/lux/host.clj b/lux-bootstrapper/src/lux/host.clj deleted file mode 100644 index 6ec6b20f50..0000000000 --- a/lux-bootstrapper/src/lux/host.clj +++ /dev/null @@ -1,488 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.host - (:require (clojure [string :as string] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]] - [type :as &type]) - [lux.type.host :as &host-type] - [lux.host.generics :as &host-generics]) - (:import (java.lang.reflect Field Method Constructor Modifier Type - GenericArrayType ParameterizedType TypeVariable) - (org.objectweb.asm Opcodes - Label - ClassWriter - MethodVisitor))) - -;; [Constants] -(def module-separator "/") -(def class-name-separator ".") -(def class-separator "/") -(def bytecode-version Opcodes/V1_6) - -(defn ^String external [^String internal] - (.replace internal class-separator class-name-separator)) - -(defn ^String internal [^String external] - (.replace external class-name-separator class-separator)) - -(defn ^String fundamental-class [^String name] - (str (external &/prelude) class-name-separator name)) - -(def ^:const ^String function-class - (fundamental-class "Function")) - -(def ^:const ^String lux-utils-class - (fundamental-class "Runtime")) - -;; [Resources] -(defn ^String ->module-class [old] - old) - -(def ->package ->module-class) - -(defn unfold-array - "(-> Type [Nat Type])" - [type] - (|case type - (&/$Nominal "#Array" (&/$Item (&/$Nominal "#Mutable" (&/$Item (&/$Function _ param) - (&/$End))) - (&/$End))) - (|let [[count inner] (unfold-array param)] - (&/T [(inc count) inner])) - - (&/$Nominal "#Array" (&/$Item param (&/$End))) - (|let [[count inner] (unfold-array param)] - (&/T [(inc count) inner])) - - _ - (&/T [0 type]))) - -(let [ex-type-class (str "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";") - object-array (str "[" "L" (&host-generics/->bytecode-class-name "java.lang.Object") ";")] - (defn ->java-sig - "(-> Type (Lux Text))" - [^objects type] - (|case type - (&/$Nominal ?name params) - (cond (= &host-type/array-data-tag ?name) (|do [normal_type (&type/normal type) - :let [[level base] (unfold-array normal_type)] - base-sig (|case base - (&/$Nominal base-class _) - (return (&host-generics/->type-signature base-class)) - - _ - (->java-sig base))] - (return (str (->> (&/|repeat level "[") (&/fold str "")) - base-sig))) - (= &host-type/null-data-tag ?name) (return (&host-generics/->type-signature "java.lang.Object")) - :else (return (&host-generics/->type-signature ?name))) - - (&/$Function _ _) - (return (&host-generics/->type-signature function-class)) - - (&/$Sum _) - (return object-array) - - (&/$Product _) - (return object-array) - - (&/$Named ?name ?type) - (->java-sig ?type) - - (&/$Apply ?A ?F) - (|do [type* (&type/apply-type ?F ?A)] - (->java-sig type*)) - - (&/$Opaque _) - (return ex-type-class) - - _ - (if (&type/type= &type/Any type) - (return "V") - (assert false (str '->java-sig " " (&type/show-type type)))) - ))) - -(do-template [ ] - (defn [class-loader target field] - (|let [target-class (Class/forName target true class-loader)] - (if-let [^Type gtype (first (for [^Field =field (seq (.getDeclaredFields target-class)) - :when (and (.equals ^Object field (.getName =field)) - (.equals ^Object (Modifier/isStatic (.getModifiers =field))))] - (.getGenericType =field)))] - (|let [gvars (->> target-class .getTypeParameters seq &/->list)] - (return (&/T [gvars gtype]))) - (&/fail-with-loc (str "[Host Error] Field does not exist: " target "." field))))) - - lookup-static-field true - lookup-field false - ) - -(do-template [ ] - (defn [class-loader target method-name args] - (|let [target-class (Class/forName target true class-loader)] - (if-let [[^Method method ^Class declarer] (first (for [^Method =method ( target-class) - :when (and (.equals ^Object method-name (.getName =method)) - (.equals ^Object (Modifier/isStatic (.getModifiers =method))) - (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types)))))] - [=method - (.getDeclaringClass =method)]))] - (|let [parent-gvars (->> target-class .getTypeParameters seq &/->list) - gvars (->> method .getTypeParameters seq &/->list) - gargs (->> method .getGenericParameterTypes seq &/->list) - _ (when (.getAnnotation method java.lang.Deprecated) - (println (str "[Host Warning] Deprecated method: " target "." method-name " " (->> args &/->seq print-str))))] - (return (&/T [(.getGenericReturnType method) - (->> method .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) - parent-gvars - gvars - gargs]))) - (&/fail-with-loc (str "[Host Error] " " method does not exist: " target "." method-name " " "(" (->> args (&/|interpose ", ") (&/fold str "")) ")"))))) - - lookup-static-method true "Static" .getDeclaredMethods - lookup-virtual-method false "Virtual" .getMethods - ) - -(defn lookup-constructor [class-loader target args] - (let [target-class (Class/forName target true class-loader)] - (if-let [^Constructor ctor (first (for [^Constructor =method (.getDeclaredConstructors target-class) - :when (let [param-types (&/->list (seq (.getParameterTypes =method)))] - (and (= (&/|length args) (&/|length param-types)) - (&/fold2 #(and %1 (.equals ^Object %2 %3)) - true - args - (&/|map #(.getName ^Class %) param-types))))] - =method))] - (|let [gvars (->> target-class .getTypeParameters seq &/->list) - gargs (->> ctor .getGenericParameterTypes seq &/->list) - exs (->> ctor .getExceptionTypes &/->list (&/|map #(.getName ^Class %))) - _ (when (.getAnnotation ctor java.lang.Deprecated) - (println (str "[Host Warning] Deprecated constructor: " target " " (->> args &/->seq print-str))))] - (return (&/T [exs gvars gargs]))) - (&/fail-with-loc (str "[Host Error] Constructor does not exist: " target " " (->> args &/->seq print-str)))))) - -(defn abstract-methods - "(-> ClassLoader SuperClassDecl (Lux (List (, Text (List Text)))))" - [class-loader super-class] - (|let [[super-name super-params] super-class] - (return (&/->list (for [^Method =method (.getDeclaredMethods (Class/forName super-name true class-loader)) - :when (Modifier/isAbstract (.getModifiers =method))] - (&/T [(.getName =method) (&/|map #(.getName ^Class %) (&/->list (seq (.getParameterTypes =method))))])))))) - -(defn def-name [name] - (str (&/normalize-name name) "_" (Long/toUnsignedString (hash name)))) - -(defn location [scope] - (let [scope (&/$Item (def-name (&/|head scope)) - (&/|map &/normalize-name (&/|tail scope)))] - (->> scope - (&/|interpose "$") - (&/fold str "")))) - -(defn primitive-jvm-type? [type] - (case type - ("boolean" "byte" "short" "int" "long" "float" "double" "char") - true - ;; else - false)) - -(defn dummy-value [^MethodVisitor writer class] - (|case class - (&/$GenericClass "boolean" (&/$End)) - (doto writer - (.visitLdcInsn false)) - - (&/$GenericClass "byte" (&/$End)) - (doto writer - (.visitLdcInsn (byte 0))) - - (&/$GenericClass "short" (&/$End)) - (doto writer - (.visitLdcInsn (short 0))) - - (&/$GenericClass "int" (&/$End)) - (doto writer - (.visitLdcInsn (int 0))) - - (&/$GenericClass "long" (&/$End)) - (doto writer - (.visitLdcInsn (long 0))) - - (&/$GenericClass "float" (&/$End)) - (doto writer - (.visitLdcInsn (float 0.0))) - - (&/$GenericClass "double" (&/$End)) - (doto writer - (.visitLdcInsn (double 0.0))) - - (&/$GenericClass "char" (&/$End)) - (doto writer - (.visitLdcInsn (char 0))) - - _ - (doto writer - (.visitInsn Opcodes/ACONST_NULL)))) - -(defn ^:private dummy-return [^MethodVisitor writer output] - (|case output - (&/$GenericClass "void" (&/$End)) - (.visitInsn writer Opcodes/RETURN) - - (&/$GenericClass "boolean" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "byte" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "short" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "int" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - (&/$GenericClass "long" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/LRETURN)) - - (&/$GenericClass "float" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/FRETURN)) - - (&/$GenericClass "double" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/DRETURN)) - - (&/$GenericClass "char" (&/$End)) - (doto writer - (dummy-value output) - (.visitInsn Opcodes/IRETURN)) - - _ - (doto writer - (dummy-value output) - (.visitInsn Opcodes/ARETURN)))) - -(defn ^:private ->dummy-type [real-name store-name gclass] - (|case gclass - (&/$GenericClass _name _params) - (if (= real-name _name) - (&/$GenericClass store-name (&/|map (partial ->dummy-type real-name store-name) _params)) - gclass) - - _ - gclass)) - -(def init-method-name "") - -(defn ^:private dummy-ctor [^MethodVisitor writer real-name store-name super-class ctor-args] - (|let [ctor-arg-types (->> ctor-args - (&/|map (comp &host-generics/gclass->signature (comp (partial ->dummy-type real-name store-name) &/|first))) - (&/fold str ""))] - (doto writer - (.visitVarInsn Opcodes/ALOAD 0) - (-> (doto (dummy-value arg-type) - (-> (.visitTypeInsn Opcodes/CHECKCAST arg-type) - (->> (when (not (primitive-jvm-type? arg-type)))))) - (->> (doseq [ctor-arg (&/->seq ctor-args) - :let [arg-type (->> ctor-arg - &/|first - (->dummy-type real-name store-name) - &host-generics/gclass->class-name)]]))) - (.visitMethodInsn Opcodes/INVOKESPECIAL (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) init-method-name (str "(" ctor-arg-types ")V")) - (.visitInsn Opcodes/RETURN)))) - -(defn ^:private compile-dummy-method [^ClassWriter =class real-name store-name super-class method-def] - (|case method-def - (&/$ConstructorMethodSyntax =privacy-modifier ?strict =anns =gvars =exceptions =inputs =ctor-args body) - (|let [=output (&/$GenericClass "void" (&/|list)) - method-decl [init-method-name - =anns - =gvars - (&/|map (partial ->dummy-type real-name store-name) =exceptions) - (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) - (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class Opcodes/ACC_PUBLIC - init-method-name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-ctor real-name store-name super-class =ctor-args) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$VirtualMethodSyntax =name =privacy-modifier =final? ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name - =anns - =gvars - (&/|map (partial ->dummy-type real-name store-name) =exceptions) - (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) - (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC - (if =final? Opcodes/ACC_FINAL 0)) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return =output) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$OverridenMethodSyntax =class-decl =name ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name - =anns - =gvars - (&/|map (partial ->dummy-type real-name store-name) =exceptions) - (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) - (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class Opcodes/ACC_PUBLIC - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return =output) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$StaticMethodSyntax =name =privacy-modifier ?strict =anns =gvars =exceptions =inputs =output body) - (|let [method-decl [=name - =anns - =gvars - (&/|map (partial ->dummy-type real-name store-name) =exceptions) - (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) - (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - .visitCode - (dummy-return =output) - (.visitMaxs 0 0) - (.visitEnd))) - - (&/$AbstractMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name - =anns - =gvars - (&/|map (partial ->dummy-type real-name store-name) =exceptions) - (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) - (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_ABSTRACT) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - (.visitEnd))) - - (&/$NativeMethodSyntax =name =privacy-modifier =anns =gvars =exceptions =inputs =output) - (|let [method-decl [=name - =anns - =gvars - (&/|map (partial ->dummy-type real-name store-name) =exceptions) - (&/|map (comp (partial ->dummy-type real-name store-name) &/|second) =inputs) - (->dummy-type real-name store-name =output)] - [simple-signature generic-signature] (&host-generics/method-signatures method-decl)] - (doto (.visitMethod =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_NATIVE) - =name - simple-signature - generic-signature - (->> =exceptions (&/|map &host-generics/gclass->bytecode-class-name) &/->seq (into-array java.lang.String))) - (.visitEnd))) - - _ - (assert false (println-str 'compile-dummy-method (&/adt->text method-def))) - )) - -(defn privacy-modifier->flag - "(-> PrivacyModifier Int)" - [privacy-modifier] - (|case privacy-modifier - (&/$PublicPM) Opcodes/ACC_PUBLIC - (&/$PrivatePM) Opcodes/ACC_PRIVATE - (&/$ProtectedPM) Opcodes/ACC_PROTECTED - (&/$DefaultPM) 0 - )) - -(defn state-modifier->flag - "(-> StateModifier Int)" - [state-modifier] - (|case state-modifier - (&/$DefaultSM) 0 - (&/$VolatileSM) Opcodes/ACC_VOLATILE - (&/$FinalSM) Opcodes/ACC_FINAL)) - -(defn inheritance-modifier->flag - "(-> InheritanceModifier Int)" - [inheritance-modifier] - (|case inheritance-modifier - (&/$DefaultIM) 0 - (&/$AbstractIM) Opcodes/ACC_ABSTRACT - (&/$FinalIM) Opcodes/ACC_FINAL)) - -(defn use-dummy-class [class-decl super-class interfaces ctor-args fields methods] - (|do [module &/get-module-name - :let [[?name ?params] class-decl - dummy-name ?name;; (str ?name "__DUMMY__") - dummy-full-name (str module "/" dummy-name) - real-name (str (&host-generics/->class-name module) "." ?name) - store-name (str (&host-generics/->class-name module) "." dummy-name) - class-signature (&host-generics/gclass-decl->signature class-decl (&/$Item super-class interfaces)) - =class (doto (new ClassWriter ClassWriter/COMPUTE_MAXS) - (.visit bytecode-version (+ Opcodes/ACC_PUBLIC Opcodes/ACC_SUPER) - dummy-full-name - (if (= "" class-signature) nil class-signature) - (&host-generics/->bytecode-class-name (&host-generics/super-class-name super-class)) - (->> interfaces (&/|map (comp &host-generics/->bytecode-class-name &host-generics/super-class-name)) &/->seq (into-array String)))) - _ (&/|map (fn [field] - (|case field - (&/$ConstantFieldAnalysis =name =anns =type ?value) - (doto (.visitField =class (+ Opcodes/ACC_PUBLIC Opcodes/ACC_STATIC Opcodes/ACC_FINAL) =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) - nil) - (.visitEnd)) - - (&/$VariableFieldAnalysis =name =privacy-modifier =state-modifier =anns =type) - (doto (.visitField =class (+ Opcodes/ACC_PUBLIC (state-modifier->flag =state-modifier)) =name - (&host-generics/gclass->simple-signature =type) - (&host-generics/gclass->signature =type) - nil) - (.visitEnd)) - )) - fields) - _ (&/|map (partial compile-dummy-method =class real-name store-name super-class) methods) - bytecode (.toByteArray (doto =class .visitEnd))] - ^ClassLoader loader &/loader - !classes &/classes - :let [_ (swap! !classes assoc store-name bytecode) - _ (.loadClass loader store-name)] - _ (&/push-dummy-name real-name store-name)] - (return nil))) diff --git a/lux-bootstrapper/src/lux/host/generics.clj b/lux-bootstrapper/src/lux/host/generics.clj deleted file mode 100644 index c9f1289a85..0000000000 --- a/lux-bootstrapper/src/lux/host/generics.clj +++ /dev/null @@ -1,210 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.host.generics - (:require (clojure [string :as string] - [template :refer [do-template]]) - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return |let |case]])) - (:import java.util.regex.Pattern)) - -(declare gclass->signature) - -(do-template [ ] - (let [regex (-> Pattern/quote re-pattern)] - (defn [old] - (string/replace old regex ))) - - ;; ->class - ^String ->bytecode-class-name "." "/" - ;; ->class-name - ^String ->class-name "/" "." - ) - -;; ->type-signature -(defn ->type-signature [class] - (case class - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ;; else - (let [class* (->bytecode-class-name class)] - (if (.startsWith class* "[") - class* - (str "L" class* ";"))) - )) - -(defn super-class-name [super] - "(-> GenericSuperClassDecl Text)" - (|let [[super-name super-params] super] - super-name)) - -(defn formal-type-parameter->signature [param] - (|let [[pname pbounds] param] - (|case pbounds - (&/$End) - pname - - _ - (->> pbounds - (&/|map (fn [pbound] (str ": " (gclass->signature pbound)))) - (&/|interpose " ") - (str pname " ")) - ))) - -(defn formal-type-parameters->signature [params] - (if (&/|empty? params) - "" - (str "<" (->> params (&/|map formal-type-parameter->signature) (&/|interpose " ") (&/fold str "")) ">"))) - -(defn gclass->signature [super] - "(-> GenericClass Text)" - (|case super - (&/$GenericTypeVar name) - (str "T" name ";") - - (&/$GenericWildcard (&/$None)) - "*" - - (&/$GenericWildcard (&/$Some [(&/$UpperBound) ?bound])) - (str "+" (gclass->signature ?bound)) - - (&/$GenericWildcard (&/$Some [(&/$LowerBound) ?bound])) - (str "-" (gclass->signature ?bound)) - - (&/$GenericClass ^String name params) - (case name - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ;; else - (if (.startsWith name "[") - name - (let [params* (if (&/|empty? params) - "" - (str "<" (->> params (&/|map gclass->signature) (&/|interpose "") (&/fold str "")) ">"))] - (str "L" (->bytecode-class-name name) params* ";")))) - - (&/$GenericArray param) - (str "[" (gclass->signature param)))) - -(defn gsuper-decl->signature [super] - "(-> GenericSuperClassDecl Text)" - (|let [[super-name super-params] super - params* (if (&/|empty? super-params) - "" - (str "<" (->> super-params (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")) ">"))] - (str "L" (->bytecode-class-name super-name) params* ";"))) - -(defn gclass-decl->signature [class-decl supers] - "(-> GenericClassDecl (List GenericSuperClassDecl) Text)" - (|let [[class-name class-vars] class-decl - vars-section (formal-type-parameters->signature class-vars) - super-section (->> (&/|map gsuper-decl->signature supers) (&/|interpose " ") (&/fold str ""))] - (str vars-section super-section))) - -(let [object-simple-signature (->type-signature "java.lang.Object")] - (defn gclass->simple-signature [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - object-simple-signature - - (&/$GenericWildcard _) - object-simple-signature - - (&/$GenericClass name params) - (->type-signature name) - - (&/$GenericArray param) - (str "[" (gclass->simple-signature param)) - - _ - (assert false (str 'gclass->simple-signature " " (&/adt->text gclass)))))) - -(defn gclass->class-name [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - (->bytecode-class-name "java.lang.Object") - - (&/$GenericWildcard _) - (->bytecode-class-name "java.lang.Object") - - (&/$GenericClass name params) - (->bytecode-class-name name) - - (&/$GenericArray (&/$GenericClass name params)) - (case name - ("void" "boolean" "byte" "short" "int" "long" "float" "double" "char") - (str "[" (->type-signature name)) - ;; else - (str "[L" (->bytecode-class-name name) ";")) - - (&/$GenericArray param) - (str "[" (gclass->class-name param)) - - _ - (assert false (str 'gclass->class-name " " (&/adt->text gclass))))) - -(let [object-bc-name (->bytecode-class-name "java.lang.Object")] - (defn gclass->bytecode-class-name* [gclass type-env] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - object-bc-name - - (&/$GenericWildcard _) - object-bc-name - - (&/$GenericClass name params) - ;; When referring to type-parameters during class or method - ;; definition, a type-environment is set for storing the names - ;; of such parameters. - ;; When a "class" shows up with the name of one of those - ;; parameters, it must be detected, and the bytecode class-name - ;; must correspond to Object's. - (if (&/|get name type-env) - object-bc-name - (->bytecode-class-name name)) - - (&/$GenericArray param) - (assert false "gclass->bytecode-class-name* does not work on arrays.")))) - -(let [object-bc-name (->bytecode-class-name "java.lang.Object")] - (defn gclass->bytecode-class-name [gclass] - "(-> GenericClass Text)" - (|case gclass - (&/$GenericTypeVar name) - object-bc-name - - (&/$GenericWildcard _) - object-bc-name - - (&/$GenericClass name params) - (->bytecode-class-name name) - - (&/$GenericArray param) - (assert false "gclass->bytecode-class-name does not work on arrays.")))) - -(defn method-signatures [method-decl] - (|let [[=name =anns =gvars =exceptions =inputs =output] method-decl - simple-signature (str "(" (&/fold str "" (&/|map gclass->simple-signature =inputs)) ")" (gclass->simple-signature =output)) - generic-signature (str (formal-type-parameters->signature =gvars) - "(" (&/fold str "" (&/|map gclass->signature =inputs)) ")" - (gclass->signature =output) - (->> =exceptions (&/|map gclass->signature) (&/|interpose " ") (&/fold str "")))] - (&/T [simple-signature generic-signature]))) diff --git a/lux-bootstrapper/src/lux/lexer.clj b/lux-bootstrapper/src/lux/lexer.clj deleted file mode 100644 index 01bebc3440..0000000000 --- a/lux-bootstrapper/src/lux/lexer.clj +++ /dev/null @@ -1,133 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.lexer - (:require (clojure [template :refer [do-template]] - [string :as string]) - (lux [base :as & :refer [defvariant |do return* return |case]] - [reader :as &reader]) - [lux.analyser.module :as &module])) - -;; [Tags] -(defvariant - ("White_Space" 1) - ("Comment" 1) - ("Bit" 1) - ("Nat" 1) - ("Int" 1) - ("Rev" 1) - ("Dec" 1) - ("Text" 1) - ("Identifier" 1) - ("Open_Paren" 0) - ("Close_Paren" 0) - ("Open_Bracket" 0) - ("Close_Bracket" 0) - ("Open_Brace" 0) - ("Close_Brace" 0) - ) - -;; [Utils] -(def lex-text - (|do [[meta _ _] (&reader/read-text "\"") - :let [[_ _ _column] meta] - [_ _ ^String content] (&reader/read-regex #"^([^\"]*)") - _ (&reader/read-text "\"")] - (return (&/T [meta ($Text content)])))) - -(def +ident-re+ - #"^([^0-9\[\]\{\}\(\)\s\".][^\[\]\{\}\(\)\s\".]*)") - -;; [Lexers] -(def ^:private lex-white-space - (|do [[meta _ white-space] (&reader/read-regex #"^(\s+|$)")] - (return (&/T [meta ($White_Space white-space)])))) - -(def ^:private lex-comment - (|do [_ (&reader/read-text "...") - [meta _ comment] (&reader/read-regex #"^(.*)$")] - (return (&/T [meta ($Comment comment)])))) - -(do-template [ ] - (def - (|do [[meta _ token] (&reader/read-regex )] - (return (&/T [meta ( token)])))) - - lex-bit $Bit #"^#(0|1)" - ) - -(do-template [ ] - (def - (|do [[meta _ token] (&reader/read-regex )] - (return (&/T [meta ( (string/replace token #"," ""))])))) - - lex-nat $Nat #"^[0-9][0-9,]*" - lex-int $Int #"^(-|\+)[0-9][0-9,]*" - lex-rev $Rev #"^\.[0-9][0-9,]*" - lex-dec $Dec #"^(-|\+)[0-9][0-9,]*\.[0-9][0-9,]*((e|E)(-|\+)[0-9][0-9,]*)?" - ) - -(def +same-module-mark+ (str &/+name-separator+ &/+name-separator+)) - -(def ^:private lex-ident - (&/try-all-% "[Reader Error]" - (&/|list (|do [[meta _ token] (&reader/read-regex +ident-re+) - [_ _ got-it?] (&reader/read-text? &/+name-separator+)] - (|case got-it? - (&/$Some _) - (|do [[_ _ local-token] (&reader/read-regex +ident-re+) - ? (&module/exists? token)] - (if ? - (return (&/T [meta (&/T [token local-token])])) - (|do [unaliased (&module/dealias token)] - (return (&/T [meta (&/T [unaliased local-token])]))))) - - (&/$None) - (return (&/T [meta (&/T ["" token])])))) - (|do [[meta _ _] (&reader/read-text +same-module-mark+) - [_ _ token] (&reader/read-regex +ident-re+) - module-name &/get-module-name] - (return (&/T [meta (&/T [module-name token])]))) - (|do [[meta _ _] (&reader/read-text &/+name-separator+) - [_ _ token] (&reader/read-regex +ident-re+)] - (return (&/T [meta (&/T [&/prelude token])]))) - ))) - -(def ^:private lex-identifier - (|do [[meta ident] lex-ident] - (return (&/T [meta ($Identifier ident)])))) - -(do-template [ ] - (def - (|do [[meta _ _] (&reader/read-text )] - (return (&/T [meta ])))) - - ^:private lex-open-paren "(" $Open_Paren - ^:private lex-close-paren ")" $Close_Paren - ^:private lex-open-bracket "[" $Open_Bracket - ^:private lex-close-bracket "]" $Close_Bracket - ^:private lex-open-brace "{" $Open_Brace - ^:private lex-close-brace "}" $Close_Brace - ) - -(def ^:private lex-delimiter - (&/try-all% (&/|list lex-open-paren - lex-close-paren - lex-open-bracket - lex-close-bracket - lex-open-brace - lex-close-brace))) - -;; [Exports] -(def lex - (&/try-all-% "[Reader Error]" - (&/|list lex-white-space - lex-comment - lex-bit - lex-nat - lex-dec - lex-rev - lex-int - lex-text - lex-identifier - lex-delimiter))) diff --git a/lux-bootstrapper/src/lux/lib/loader.clj b/lux-bootstrapper/src/lux/lib/loader.clj deleted file mode 100644 index 16cb385267..0000000000 --- a/lux-bootstrapper/src/lux/lib/loader.clj +++ /dev/null @@ -1,45 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.lib.loader - (:refer-clojure :exclude [load]) - (:require (lux [base :as & :refer [|let |do return return* |case]])) - (:import (java.io InputStream - File - FileInputStream - ByteArrayInputStream - ByteArrayOutputStream) - java.util.jar.JarInputStream)) - -;; [Utils] -(let [init-capacity (* 100 1024) - buffer-size 1024] - (defn ^:private ^"[B" read-stream [^InputStream is] - (let [buffer (byte-array buffer-size)] - (with-open [os (new ByteArrayOutputStream init-capacity)] - (loop [bytes-read (.read is buffer 0 buffer-size)] - (when (not= -1 bytes-read) - (do (.write os buffer 0 bytes-read) - (recur (.read is buffer 0 buffer-size))))) - (.toByteArray os))))) - -(defn ^:private unpackage [^File lib-file] - (let [is (->> lib-file - (new FileInputStream) - (new JarInputStream))] - (loop [lib-data {} - entry (.getNextJarEntry is)] - (if entry - (if (.endsWith (.getName entry) ".lux") - (recur (assoc lib-data (.getName entry) (new String (read-stream is))) - (.getNextJarEntry is)) - (recur lib-data - (.getNextJarEntry is))) - lib-data)))) - -;; [Exports] -(defn load [dependencies] - (->> dependencies - &/->seq - (map #(->> ^String % (new File) unpackage)) - (reduce merge {}))) diff --git a/lux-bootstrapper/src/lux/optimizer.clj b/lux-bootstrapper/src/lux/optimizer.clj deleted file mode 100644 index 6b5119ef6f..0000000000 --- a/lux-bootstrapper/src/lux/optimizer.clj +++ /dev/null @@ -1,1207 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.optimizer - (:require (lux [base :as & :refer [|let |do return return* |case defvariant]]) - (lux.analyser [base :as &a] - [case :as &a-case]))) - -;; [Tags] -(defvariant - ;; These tags just have a one-to-one correspondence with Analysis data-structures. - ("bit" 1) - ("nat" 1) - ("int" 1) - ("rev" 1) - ("dec" 1) - ("text" 1) - ("variant" 3) - ("tuple" 1) - ("apply" 2) - ("case" 2) - ("function" 5) - ("ann" 2) - ("def" 1) - ("var" 1) - ("captured" 3) - ("proc" 3) - - ;; These other tags represent higher-order constructs that manifest - ;; themselves as patterns in the code. - ;; Lux does not formally provide these features, but some macros - ;; expose ways to implement them in terms of the other (primitive) - ;; features. - ;; The optimizer looks for those usage patterns and transforms them - ;; into explicit constructs, which are then subject to specialized optimizations. - - ;; Loop scope, for doing loop inlining - ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized} - ;; This is loop iteration, as expected in imperative programming. - ("iter" 2) ;; {register-offset Int, vals (List Optimized)} - ;; This is a simple let-expression, as opposed to the more general pattern-matching. - ("let" 3) - ;; This is an access to a record's member. It can be multi-level: - ;; e.g. record.l1.l2.l3 - ;; The record-get token stores the path, for simpler compilation. - ("record-get" 2) - ;; Regular, run-of-the-mill if expressions. - ("if" 3) - ) - -;; [Utils] - -;; [[Pattern-Matching Traversal Optimization]] - -;; This represents an alternative way to view pattern-matching. -;; The PM that Lux provides has declarative semantics, with the user -;; specifying how his data is shaped, but not how to traverse it. -;; The optimizer's PM is operational in nature, and relies on -;; specifying a path of traversal, with a variety of operations that -;; can be done along the way. -;; The algorithm relies on looking at pattern-matching as traversing a -;; (possibly) branching path, where each step along the path -;; corresponds to a value, the ends of the path are the jumping-off -;; points for the bodies of branches, and branching decisions can be -;; backtracked, if they do not result in a valid jump. -(defvariant - ;; Throw away the current data-node (CDN). It's useless. - ("PopPM" 0) - ;; Store the CDN in a register. - ("BindPM" 1) - ;; Compare the CDN with a bit value. - ("BitPM" 1) - ;; Compare the CDN with a natural value. - ("NatPM" 1) - ;; Compare the CDN with an integer value. - ("IntPM" 1) - ;; Compare the CDN with a revolution value. - ("RevPM" 1) - ;; Compare the CDN with a dec value. - ("DecPM" 1) - ;; Compare the CDN with a text value. - ("TextPM" 1) - ;; Compare the CDN with a variant value. If valid, proceed to test - ;; the variant's inner value. - ("VariantPM" 1) - ;; Access a tuple value at a given index, for further examination. - ("TuplePM" 1) - ;; Creates an instance of the backtracking info, as a preparatory - ;; step to exploring one of the branching paths. - ("AltPM" 2) - ;; Allows to test the CDN, while keeping a copy of it for more - ;; tasting later on. - ;; If necessary when doing multiple tests on a single value, like - ;; when testing multiple parts of a tuple. - ("SeqPM" 2) - ;; This is the jumping-off point for the PM part, where the PM - ;; data-structure is thrown away and the program jumps to the - ;; branch's body. - ("ExecPM" 1)) - -(defn de-meta - "(-> Optimized Optimized)" - [optim] - (|let [[meta optim-] optim] - (|case optim- - ($variant idx is-last? value) - ($variant idx is-last? (de-meta value)) - - ($tuple elems) - ($tuple (&/|map de-meta elems)) - - ($case value [_pm _bodies]) - ($case (de-meta value) - (&/T [_pm (&/|map de-meta _bodies)])) - - ($function _register-offset arity scope captured body*) - ($function _register-offset - arity - scope - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - (&/T [_name ($captured _scope _idx (de-meta _source))]))) - captured) - (de-meta body*)) - - ($ann value-expr type-expr) - (de-meta value-expr) - - ($apply func args) - ($apply (de-meta func) - (&/|map de-meta args)) - - ($captured scope idx source) - ($captured scope idx (de-meta source)) - - ($proc proc-ident args special-args) - ($proc proc-ident (&/|map de-meta args) special-args) - - ($loop _register-offset _inits _body) - ($loop _register-offset - (&/|map de-meta _inits) - (de-meta _body)) - - ($iter _iter-register-offset args) - ($iter _iter-register-offset - (&/|map de-meta args)) - - ($let _value _register _body) - ($let (de-meta _value) - _register - (de-meta _body)) - - ($record-get _value _path) - ($record-get (de-meta _value) - _path) - - ($if _test _then _else) - ($if (de-meta _test) - (de-meta _then) - (de-meta _else)) - - _ - optim- - ))) - -;; This function does a simple transformation from the declarative -;; model of PM of the analyser, to the operational model of PM of the -;; optimizer. -;; You may notice that all branches end in PopPM. -;; The reason is that testing does not immediately imply throwing away -;; the data to be tested, which is why a popping step must immediately follow. -(defn ^:private transform-pm* [test] - (|case test - (&a-case/$NoTestAC) - (&/|list $PopPM) - - (&a-case/$StoreTestAC _register) - (&/|list ($BindPM _register)) - - (&a-case/$BitTestAC _value) - (&/|list ($BitPM _value) - $PopPM) - - (&a-case/$NatTestAC _value) - (&/|list ($NatPM _value) - $PopPM) - - (&a-case/$IntTestAC _value) - (&/|list ($IntPM _value) - $PopPM) - - (&a-case/$RevTestAC _value) - (&/|list ($RevPM _value) - $PopPM) - - (&a-case/$DecTestAC _value) - (&/|list ($DecPM _value) - $PopPM) - - (&a-case/$TextTestAC _value) - (&/|list ($TextPM _value) - $PopPM) - - (&a-case/$VariantTestAC lefts right? _sub-test) - (&/|++ (&/|list ($VariantPM (if right? - (&/$Right (inc lefts)) - (&/$Left lefts)))) - (&/|++ (transform-pm* _sub-test) - (&/|list $PopPM))) - - (&a-case/$TupleTestAC _sub-tests) - (|case _sub-tests - ;; An empty tuple corresponds to unit, which cannot be tested in - ;; any meaningful way, so it's just popped. - (&/$End) - (&/|list $PopPM) - - ;; A tuple of a single element is equivalent to the element - ;; itself, to the element's PM is generated. - (&/$Item _only-test (&/$End)) - (transform-pm* _only-test) - - ;; Single tuple PM features the tests of each tuple member - ;; inlined, it's operational equivalent is interleaving the - ;; access to each tuple member, followed by the testing of said - ;; member. - ;; That is way each sequence of access+subtesting gets generated - ;; and later they all get concatenated. - _ - (|let [tuple-size (&/|length _sub-tests)] - (&/|++ (&/flat-map (fn [idx+test*] - (|let [[idx test*] idx+test*] - (&/$Item ($TuplePM (if (< idx (dec tuple-size)) - (&/$Left idx) - (&/$Right idx))) - (transform-pm* test*)))) - (&/zip2 (&/|range tuple-size) - _sub-tests)) - (&/|list $PopPM)))))) - -;; It will be common for pattern-matching on a very nested -;; data-structure to require popping all the intermediate -;; data-structures that were visited once it's all done. -;; However, the PM infrastructure employs a single data-stack to keep -;; all data nodes in the trajectory, and that data-stack can just be -;; thrown again entirely, in just one step. -;; Because of that, any ending POPs prior to throwing away the -;; data-stack would be completely useless. -;; This function cleans them all up, to avoid wasteful computation later. -(defn ^:private clean-unnecessary-pops [steps] - (|case steps - (&/$Item ($PopPM) _steps) - (clean-unnecessary-pops _steps) - - _ - steps)) - -;; This transforms a single branch of a PM tree into it's operational -;; equivalent, while also associating the PM of the branch with the -;; jump to the branch's body. -(defn ^:private transform-pm [test body-id] - (&/fold (fn [right left] ($SeqPM left right)) - ($ExecPM body-id) - (clean-unnecessary-pops (&/|reverse (transform-pm* test))))) - -;; This function fuses together the paths of the PM traversal, adding -;; branching AltPMs where necessary, and fusing similar paths together -;; as much as possible, when early parts of them coincide. -;; The goal is to minimize rework as much as possible by sharing as -;; much of each path as possible. -(defn ^:private fuse-pms [pre post] - (|case (&/T [pre post]) - [($PopPM) ($PopPM)] - $PopPM - - [($BindPM _pre-var-id) ($BindPM _post-var-id)] - (if (= _pre-var-id _post-var-id) - ($BindPM _pre-var-id) - ($AltPM pre post)) - - [($BitPM _pre-value) ($BitPM _post-value)] - (if (= _pre-value _post-value) - ($BitPM _pre-value) - ($AltPM pre post)) - - [($NatPM _pre-value) ($NatPM _post-value)] - (if (= _pre-value _post-value) - ($NatPM _pre-value) - ($AltPM pre post)) - - [($IntPM _pre-value) ($IntPM _post-value)] - (if (= _pre-value _post-value) - ($IntPM _pre-value) - ($AltPM pre post)) - - [($RevPM _pre-value) ($RevPM _post-value)] - (if (= _pre-value _post-value) - ($RevPM _pre-value) - ($AltPM pre post)) - - [($DecPM _pre-value) ($DecPM _post-value)] - (if (= _pre-value _post-value) - ($DecPM _pre-value) - ($AltPM pre post)) - - [($TextPM _pre-value) ($TextPM _post-value)] - (if (= _pre-value _post-value) - ($TextPM _pre-value) - ($AltPM pre post)) - - [($TuplePM (&/$Left _pre-idx)) ($TuplePM (&/$Left _post-idx))] - (if (= _pre-idx _post-idx) - ($TuplePM (&/$Left _pre-idx)) - ($AltPM pre post)) - - [($TuplePM (&/$Right _pre-idx)) ($TuplePM (&/$Right _post-idx))] - (if (= _pre-idx _post-idx) - ($TuplePM (&/$Right _pre-idx)) - ($AltPM pre post)) - - [($VariantPM (&/$Left _pre-idx)) ($VariantPM (&/$Left _post-idx))] - (if (= _pre-idx _post-idx) - ($VariantPM (&/$Left _pre-idx)) - ($AltPM pre post)) - - [($VariantPM (&/$Right _pre-idx)) ($VariantPM (&/$Right _post-idx))] - (if (= _pre-idx _post-idx) - ($VariantPM (&/$Right _pre-idx)) - ($AltPM pre post)) - - [($SeqPM _pre-pre _pre-post) ($SeqPM _post-pre _post-post)] - (|case (fuse-pms _pre-pre _post-pre) - ($AltPM _ _) - ($AltPM pre post) - - fused-pre - ($SeqPM fused-pre (fuse-pms _pre-post _post-post))) - - _ - ($AltPM pre post) - )) - -(defn ^:private pattern-vars [pattern] - (|case pattern - ($BindPM _id) - (&/|list (&/T [_id false])) - - ($SeqPM _left _right) - (&/|++ (pattern-vars _left) (pattern-vars _right)) - - _ - (&/|list) - - ;; $AltPM is not considered because it's not supposed to be - ;; present anywhere at this point in time. - )) - -(defn ^:private find-unused-vars [var-table body] - (|let [[meta body-] body] - (|case body- - ($var (&/$Local _idx)) - (&/|update _idx (fn [_] true) var-table) - - ($captured _scope _c-idx [_ ($var (&/$Local _idx))]) - (&/|update _idx (fn [_] true) var-table) - - ($variant _idx _is-last? _value) - (find-unused-vars var-table _value) - - ($tuple _elems) - (&/fold find-unused-vars var-table _elems) - - ($ann _value-expr _type-expr) - (find-unused-vars var-table _value-expr) - - ($apply _func _args) - (&/fold find-unused-vars - (find-unused-vars var-table _func) - _args) - - ($proc _proc-ident _args _special-args) - (&/fold find-unused-vars var-table _args) - - ($loop _register-offset _inits _body) - (&/|++ (&/fold find-unused-vars var-table _inits) - (find-unused-vars var-table _body)) - - ($iter _ _args) - (&/fold find-unused-vars var-table _args) - - ($let _value _register _body) - (-> var-table - (find-unused-vars _value) - (find-unused-vars _body)) - - ($record-get _value _path) - (find-unused-vars var-table _value) - - ($if _test _then _else) - (-> var-table - (find-unused-vars _test) - (find-unused-vars _then) - (find-unused-vars _else)) - - ($case _value [_pm _bodies]) - (&/fold find-unused-vars - (find-unused-vars var-table _value) - _bodies) - - ($function _ _ _ _captured _) - (->> _captured - (&/|map &/|second) - (&/fold find-unused-vars var-table)) - - _ - var-table - ))) - -(defn ^:private clean-unused-pattern-registers [var-table pattern] - (|case pattern - ($BindPM _idx) - (|let [_new-idx (&/|get _idx var-table)] - (cond (= _idx _new-idx) - pattern - - (>= _new-idx 0) - ($BindPM _new-idx) - - :else - $PopPM)) - - ($SeqPM _left _right) - ($SeqPM (clean-unused-pattern-registers var-table _left) - (clean-unused-pattern-registers var-table _right)) - - _ - pattern - - ;; $AltPM is not considered because it's not supposed to be - ;; present anywhere at this point in time. - )) - -;; This function assumes that the var-table has an ascending index -;; order. -;; For example: (2 3 4 5 6 7 8), instead of (8 7 6 5 4 3 2) -(defn ^:private adjust-register-indexes* [offset var-table] - (|case var-table - (&/$End) - (&/|list) - - (&/$Item [_idx _used?] _tail) - (if _used? - (&/$Item (&/T [_idx (- _idx offset)]) - (adjust-register-indexes* offset _tail)) - (&/$Item (&/T [_idx -1]) - (adjust-register-indexes* (inc offset) _tail)) - ))) - -(defn ^:private adjust-register-indexes [var-table] - (adjust-register-indexes* 0 var-table)) - -(defn ^:private clean-unused-body-registers [var-table body] - (|let [[meta body-] body] - (|case body- - ($var (&/$Local _idx)) - (|let [new-idx (or (&/|get _idx var-table) - _idx)] - (&/T [meta ($var (&/$Local new-idx))])) - - ($captured _scope _c-idx [_sub-meta ($var (&/$Local _idx))]) - (|let [new-idx (or (&/|get _idx var-table) - _idx)] - (&/T [meta ($captured _scope _c-idx (&/T [_sub-meta ($var (&/$Local new-idx))]))])) - - ($variant _idx _is-last? _value) - (&/T [meta ($variant _idx _is-last? (clean-unused-body-registers var-table _value))]) - - ($tuple _elems) - (&/T [meta ($tuple (&/|map (partial clean-unused-body-registers var-table) - _elems))]) - - ($ann _value-expr _type-expr) - (&/T [meta ($ann (clean-unused-body-registers var-table _value-expr) _type-expr)]) - - ($apply _func _args) - (&/T [meta ($apply (clean-unused-body-registers var-table _func) - (&/|map (partial clean-unused-body-registers var-table) - _args))]) - - ($proc _proc-ident _args _special-args) - (&/T [meta ($proc _proc-ident - (&/|map (partial clean-unused-body-registers var-table) - _args) - _special-args)]) - - ($loop _register-offset _inits _body) - (&/T [meta ($loop _register-offset - (&/|map (partial clean-unused-body-registers var-table) - _inits) - (clean-unused-body-registers var-table _body))]) - - ($iter _iter-register-offset _args) - (&/T [meta ($iter _iter-register-offset - (&/|map (partial clean-unused-body-registers var-table) - _args))]) - - ($let _value _register _body) - (&/T [meta ($let (clean-unused-body-registers var-table _value) - _register - (clean-unused-body-registers var-table _body))]) - - ($record-get _value _path) - (&/T [meta ($record-get (clean-unused-body-registers var-table _value) - _path)]) - - ($if _test _then _else) - (&/T [meta ($if (clean-unused-body-registers var-table _test) - (clean-unused-body-registers var-table _then) - (clean-unused-body-registers var-table _else))]) - - ($case _value [_pm _bodies]) - (&/T [meta ($case (clean-unused-body-registers var-table _value) - (&/T [_pm - (&/|map (partial clean-unused-body-registers var-table) - _bodies)]))]) - - ($function _register-offset _arity _scope _captured _body) - (&/T [meta ($function _register-offset - _arity - _scope - (&/|map (fn [capture] - (|let [[_name __var] capture] - (&/T [_name (clean-unused-body-registers var-table __var)]))) - _captured) - _body)]) - - _ - body - ))) - -(defn ^:private simplify-pattern [pattern] - (|case pattern - ($SeqPM ($TuplePM _idx) ($SeqPM ($PopPM) pattern*)) - (simplify-pattern pattern*) - - ($SeqPM ($TuplePM _idx) _right) - (|case (simplify-pattern _right) - ($SeqPM ($PopPM) pattern*) - pattern* - - _right* - ($SeqPM ($TuplePM _idx) _right*)) - - ($SeqPM _left _right) - ($SeqPM _left (simplify-pattern _right)) - - _ - pattern)) - -(defn ^:private optimize-register-use [pattern body] - (|let [p-vars (pattern-vars pattern) - p-vars* (find-unused-vars p-vars body) - adjusted-vars (adjust-register-indexes p-vars*) - clean-pattern (clean-unused-pattern-registers adjusted-vars pattern) - simple-pattern (simplify-pattern clean-pattern) - clean-body (clean-unused-body-registers adjusted-vars body)] - (&/T [simple-pattern clean-body]))) - -;; This is the top-level function for optimizing PM, which transforms -;; each branch and then fuses them together. -(defn ^:private optimize-pm [branches] - (|let [;; branches (&/|reverse branches*) - pms+bodies (&/map2 (fn [branch _body-id] - (|let [[_pattern _body] branch] - (optimize-register-use (transform-pm _pattern _body-id) - _body))) - branches - (&/|range (&/|length branches))) - pms (&/|map &/|first pms+bodies) - bodies (&/|map &/|second pms+bodies)] - (|case (&/|reverse pms) - (&/$End) - (assert false) - - (&/$Item _head-pm _tail-pms) - (&/T [(&/fold fuse-pms _head-pm _tail-pms) - bodies]) - ))) - -;; [[Function-Folding Optimization]] - -;; The semantics of Lux establish that all functions are of a single -;; argument and the multi-argument functions are actually nested -;; functions being generated and then applied. -;; This, of course, would generate a lot of waste. -;; To avoid it, Lux actually folds function definitions together, -;; thereby creating functions that can be used both -;; one-argument-at-a-time, and also being called with all, or just a -;; partial amount of their arguments. -;; This avoids generating too many artifacts during compilation, since -;; they get "compressed", and it can also lead to faster execution, by -;; enabling optimized function calls later. - -;; Functions and captured variables have "scopes", which tell which -;; function they are, or to which function they belong. -;; During the folding, inner functions dissapear, since their bodies -;; are merged into their outer "parent" functions. -;; Their scopes must change accordingy. -(defn ^:private de-scope - "(-> Scope Scope Scope Scope)" - [old-scope new-scope scope] - (if (identical? new-scope scope) - old-scope - scope)) - -;; Also, it must be noted that when folding functions, the indexes of -;; the registers have to be changed accodingly. -;; That is what the following "shifting" functions are for. - -;; Shifts the registers for PM operations. -(defn ^:private shift-pattern [pattern] - (|case pattern - ($BindPM _var-id) - ($BindPM (inc _var-id)) - - ($SeqPM _left-pm _right-pm) - ($SeqPM (shift-pattern _left-pm) (shift-pattern _right-pm)) - - ($AltPM _left-pm _right-pm) - ($AltPM (shift-pattern _left-pm) (shift-pattern _right-pm)) - - _ - pattern - )) - -;; Shifts the body of a function after a folding is performed. -(defn shift-function-body - "(-> Scope Scope Bit Optimized Optimized)" - [old-scope new-scope own-body? body] - (|let [[meta body-] body] - (|case body- - ($variant idx is-last? value) - (&/T [meta ($variant idx is-last? (shift-function-body old-scope new-scope own-body? value))]) - - ($tuple elems) - (&/T [meta ($tuple (&/|map (partial shift-function-body old-scope new-scope own-body?) elems))]) - - ($case value [_pm _bodies]) - (&/T [meta ($case (shift-function-body old-scope new-scope own-body? value) - (&/T [(if own-body? - (shift-pattern _pm) - _pm) - (&/|map (partial shift-function-body old-scope new-scope own-body?) _bodies)]))]) - - ($function _register-offset arity scope captured body*) - (|let [scope* (de-scope old-scope new-scope scope)] - (&/T [meta ($function _register-offset - arity - scope* - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - (&/T [_name (&/T [_meta ($captured scope* _idx (shift-function-body old-scope new-scope own-body? _source))])]))) - captured) - (shift-function-body old-scope new-scope false body*))])) - - ($ann value-expr type-expr) - (&/T [meta ($ann (shift-function-body old-scope new-scope own-body? value-expr) - type-expr)]) - - ($var var-kind) - (if own-body? - (|case var-kind - (&/$Local 0) - (&/T [meta ($apply body - (&/|list (&/T [meta ($var (&/$Local 1))])))]) - - (&/$Local idx) - (&/T [meta ($var (&/$Local (inc idx)))])) - body) - - ;; This special "apply" rule is for handling recursive calls better. - ($apply [meta-0 ($var (&/$Local 0))] args) - (if own-body? - (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) - (&/$Item (&/T [meta-0 ($var (&/$Local 1))]) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args)))]) - (&/T [meta ($apply (&/T [meta-0 ($var (&/$Local 0))]) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args))])) - - ($apply func args) - (&/T [meta ($apply (shift-function-body old-scope new-scope own-body? func) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) - - ($captured scope idx source) - (if own-body? - source - (|case scope - (&/$Item _ (&/$Item _ (&/$End))) - source - - _ - (&/T [meta ($captured (de-scope old-scope new-scope scope) idx (shift-function-body old-scope new-scope own-body? source))]))) - - ($proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial shift-function-body old-scope new-scope own-body?) args) special-args)]) - - ($loop _register-offset _inits _body) - (&/T [meta ($loop (if own-body? - (inc _register-offset) - _register-offset) - (&/|map (partial shift-function-body old-scope new-scope own-body?) - _inits) - (shift-function-body old-scope new-scope own-body? _body))]) - - ($iter _iter-register-offset args) - (&/T [meta ($iter (if own-body? - (inc _iter-register-offset) - _iter-register-offset) - (&/|map (partial shift-function-body old-scope new-scope own-body?) args))]) - - ($let _value _register _body) - (&/T [meta ($let (shift-function-body old-scope new-scope own-body? _value) - (if own-body? - (inc _register) - _register) - (shift-function-body old-scope new-scope own-body? _body))]) - - ($record-get _value _path) - (&/T [meta ($record-get (shift-function-body old-scope new-scope own-body? _value) - _path)]) - - ($if _test _then _else) - (&/T [meta ($if (shift-function-body old-scope new-scope own-body? _test) - (shift-function-body old-scope new-scope own-body? _then) - (shift-function-body old-scope new-scope own-body? _else))]) - - _ - body - ))) - -;; [[Record-Manipulation Optimizations]] - -;; If a pattern-matching tree with a single branch is found, and that -;; branch corresponds to a tuple PM, and the body corresponds to a -;; local variable, it's likely that the local refers to some member of -;; the tuple that is being extracted. -;; That is the pattern that is to be expected of record read-access, -;; so this function tries to extract the (possibly nested) path -;; necessary, ending in the data-node of the wanted member. -(defn ^:private record-read-path - "(-> (List PM) Idx (List Idx))" - [pms member-idx] - (loop [current-idx 0 - pms pms] - (|case pms - (&/$End) - &/$None - - (&/$Item _pm _pms) - (|case _pm - (&a-case/$NoTestAC) - (recur (inc current-idx) - _pms) - - (&a-case/$StoreTestAC _register) - (if (= member-idx _register) - (&/|list (&/T [current-idx (&/|empty? _pms)])) - (recur (inc current-idx) - _pms)) - - (&a-case/$TupleTestAC _sub-tests) - (let [sub-path (record-read-path _sub-tests member-idx)] - (if (not (&/|empty? sub-path)) - (&/$Item (&/T [current-idx (&/|empty? _pms)]) sub-path) - (recur (inc current-idx) - _pms) - )) - - _ - (&/|list)) - ))) - -;; [[Loop Optimizations]] - -;; Lux does not offer any looping constructs, relying instead on -;; recursion. -;; Some common usages of recursion can be written more efficiently -;; just using regular loops/iteration. -;; This optimization looks for tail-calls in the function body, -;; rewriting them as jumps to the beginning of the function, while -;; they also updated the necessary local variables for the next iteration. -(defn ^:private optimize-iter - "(-> Int Optimized Optimized)" - [arity optim] - (|let [[meta optim-] optim] - (|case optim- - ($apply [meta-0 ($var (&/$Local 0))] _args) - (if (= arity (&/|length _args)) - (&/T [meta ($iter 1 _args)]) - optim) - - ($case _value [_pattern _bodies]) - (&/T [meta ($case _value - (&/T [_pattern - (&/|map (partial optimize-iter arity) - _bodies)]))]) - - ($let _value _register _body) - (&/T [meta ($let _value _register (optimize-iter arity _body))]) - - ($if _test _then _else) - (&/T [meta ($if _test - (optimize-iter arity _then) - (optimize-iter arity _else))]) - - ($ann _value-expr _type-expr) - (&/T [meta ($ann (optimize-iter arity _value-expr) _type-expr)]) - - ($proc ["lux" "syntax char case!"] (&/$Item ?input (&/$Item ?else ?matches)) ?special-args) - (&/T [meta ($proc (&/T ["lux" "syntax char case!"]) - (&/$Item ?input - (&/$Item (optimize-iter arity ?else) - (&/|map (partial optimize-iter arity) - ?matches))) - ?special-args)]) - - _ - optim - ))) - -(defn ^:private contains-self-reference? - "(-> Optimized Bit)" - [body] - (|let [[meta body-] body - stepwise-test (fn [base arg] (or base (contains-self-reference? arg)))] - (|case body- - ($variant idx is-last? value) - (contains-self-reference? value) - - ($tuple elems) - (&/fold stepwise-test false elems) - - ($case value [_pm _bodies]) - (or (contains-self-reference? value) - (&/fold stepwise-test false _bodies)) - - ($function _ _ _ captured _) - (->> captured - (&/|map (fn [capture] - (|let [[_name [_meta ($captured _scope _idx _source)]] capture] - _source))) - (&/fold stepwise-test false)) - - ($ann value-expr type-expr) - (contains-self-reference? value-expr) - - ($var (&/$Local 0)) - true - - ($apply func args) - (or (contains-self-reference? func) - (&/fold stepwise-test false args)) - - ($proc ["lux" "syntax char case!"] (&/$Item ?input (&/$Item ?else ?matches)) ?special-args) - (or (contains-self-reference? ?input) - (contains-self-reference? ?else) - (&/fold stepwise-test false ?matches)) - - ($proc proc-ident args special-args) - (&/fold stepwise-test false args) - - ($loop _register-offset _inits _body) - (or (&/fold stepwise-test false _inits) - (contains-self-reference? _body)) - - ($iter _ args) - (&/fold stepwise-test false args) - - ($let _value _register _body) - (or (contains-self-reference? _value) - (contains-self-reference? _body)) - - ($record-get _value _path) - (contains-self-reference? _value) - - ($if _test _then _else) - (or (contains-self-reference? _test) - (contains-self-reference? _then) - (contains-self-reference? _else)) - - _ - false - ))) - -(defn ^:private pm-loop-transform [register-offset direct? pattern] - (|case pattern - ($BindPM _var-id) - ($BindPM (+ register-offset (if direct? - (- _var-id 2) - (- _var-id 1)))) - - ($SeqPM _left-pm _right-pm) - ($SeqPM (pm-loop-transform register-offset direct? _left-pm) - (pm-loop-transform register-offset direct? _right-pm)) - - ($AltPM _left-pm _right-pm) - ($AltPM (pm-loop-transform register-offset direct? _left-pm) - (pm-loop-transform register-offset direct? _right-pm)) - - _ - pattern - )) - -;; This function must be run STRICTLY before shift-function body, as -;; the transformation assumes that SFB will be invoke after it. -(defn ^:private loop-transform [register-offset direct? body] - (|let [adjust-direct (fn [register] - ;; The register must be decreased once, since - ;; it will be re-increased in - ;; shift-function-body. - ;; The decrease is meant to keep things stable. - (if direct? - ;; And, if this adjustment is done - ;; directly during a loop-transform (and - ;; not indirectly if transforming an inner - ;; loop), then it must be decreased again - ;; because the 0/self var will no longer - ;; exist in the loop's context. - (- register 2) - (- register 1))) - [meta body-] body] - (|case body- - ($variant idx is-last? value) - (&/T [meta ($variant idx is-last? (loop-transform register-offset direct? value))]) - - ($tuple elems) - (&/T [meta ($tuple (&/|map (partial loop-transform register-offset direct?) elems))]) - - ($case value [_pm _bodies]) - (&/T [meta ($case (loop-transform register-offset direct? value) - (&/T [(pm-loop-transform register-offset direct? _pm) - (&/|map (partial loop-transform register-offset direct?) - _bodies)]))]) - - ;; Functions are ignored because they'll be handled properly at shift-function-body - - ($ann value-expr type-expr) - (&/T [meta ($ann (loop-transform register-offset direct? value-expr) - type-expr)]) - - ($var (&/$Local idx)) - ;; The index must be decreased once, because the var index is - ;; 1-based (since 0 is reserved for self-reference). - ;; Then it must be decreased again, since it will be increased - ;; in the shift-function-body call. - ;; Then, I add the offset to ensure the var points to the right register. - (&/T [meta ($var (&/$Local (-> (adjust-direct idx) - (+ register-offset))))]) - - ($apply func args) - (&/T [meta ($apply (loop-transform register-offset direct? func) - (&/|map (partial loop-transform register-offset direct?) args))]) - - ;; Captured-vars are ignored because they'll be handled properly at shift-function-body - - ($proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial loop-transform register-offset direct?) args) special-args)]) - - ($loop _register-offset _inits _body) - (&/T [meta ($loop (+ register-offset (adjust-direct _register-offset)) - (&/|map (partial loop-transform register-offset direct?) _inits) - (loop-transform register-offset direct? _body))]) - - ($iter _iter-register-offset args) - (&/T [meta ($iter (+ register-offset (adjust-direct _iter-register-offset)) - (&/|map (partial loop-transform register-offset direct?) args))]) - - ($let _value _register _body) - (&/T [meta ($let (loop-transform register-offset direct? _value) - (+ register-offset (adjust-direct _register)) - (loop-transform register-offset direct? _body))]) - - ($record-get _value _path) - (&/T [meta ($record-get (loop-transform register-offset direct? _value) - _path)]) - - ($if _test _then _else) - (&/T [meta ($if (loop-transform register-offset direct? _test) - (loop-transform register-offset direct? _then) - (loop-transform register-offset direct? _else))]) - - _ - body - ))) - -(defn ^:private inline-loop [meta register-offset scope captured args body] - (->> body - (loop-transform register-offset true) - (shift-function-body scope (&/|tail scope) true) - ($loop register-offset args) - (list meta) - (&/T))) - -;; [[Initial Optimization]] - -;; Before any big optimization can be done, the incoming Analysis nodes -;; must be transformed into Optimized nodes, amenable to further transformations. -;; This function does the job, while also detecting (and optimizing) -;; some simple surface patterns it may encounter. -(let [optimize-closure (fn [optimize closure] - (&/|map (fn [capture] - (|let [[_name _analysis] capture] - (&/T [_name (optimize _analysis)]))) - closure))] - (defn ^:private pass-0 - "(-> Bit Analysis Optimized)" - [top-level-func? analysis] - (|let [[meta analysis-] analysis] - (|case analysis- - (&a/$bit value) - (&/T [meta ($bit value)]) - - (&a/$nat value) - (&/T [meta ($nat value)]) - - (&a/$int value) - (&/T [meta ($int value)]) - - (&a/$rev value) - (&/T [meta ($rev value)]) - - (&a/$dec value) - (&/T [meta ($dec value)]) - - (&a/$text value) - (&/T [meta ($text value)]) - - (&a/$variant idx is-last? value) - (&/T [meta ($variant idx is-last? (pass-0 top-level-func? value))]) - - (&a/$tuple elems) - (&/T [meta ($tuple (&/|map (partial pass-0 top-level-func?) elems))]) - - (&a/$apply func args) - (|let [=func (pass-0 top-level-func? func) - =args (&/|map (partial pass-0 top-level-func?) args)] - (&/T [meta ($apply =func =args)]) - ;; (|case =func - ;; [_ ($ann [_ ($function _register-offset _arity _scope _captured _body)] - ;; _)] - ;; (if (and (= _arity (&/|length =args)) - ;; (not (contains-self-reference? _body))) - ;; (inline-loop meta _register-offset _scope _captured =args _body) - ;; (&/T [meta ($apply =func =args)])) - - ;; _ - ;; (&/T [meta ($apply =func =args)])) - ) - - (&a/$case value branches) - (let [normal-case-optim (fn [] - (&/T [meta ($case (pass-0 top-level-func? value) - (optimize-pm (&/|map (fn [branch] - (|let [[_pattern _body] branch] - (&/T [_pattern (pass-0 top-level-func? _body)]))) - branches)))]))] - (|case branches - ;; The pattern for a let-expression is a single branch, - ;; tying the value to a register. - (&/$Item [(&a-case/$StoreTestAC _register) _body] (&/$End)) - (&/T [meta ($let (pass-0 top-level-func? value) _register (pass-0 top-level-func? _body))]) - - (&/$Item [(&a-case/$BitTestAC true) _then] - (&/$Item [(&a-case/$BitTestAC false) _else] - (&/$End))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - (&/$Item [(&a-case/$BitTestAC true) _then] - (&/$Item [(&a-case/$NoTestAC false) _else] - (&/$End))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - (&/$Item [(&a-case/$BitTestAC false) _else] - (&/$Item [(&a-case/$BitTestAC true) _then] - (&/$End))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - (&/$Item [(&a-case/$BitTestAC false) _else] - (&/$Item [(&a-case/$NoTestAC) _then] - (&/$End))) - (&/T [meta ($if (pass-0 top-level-func? value) (pass-0 top-level-func? _then) (pass-0 top-level-func? _else))]) - - ;; The pattern for a record-get is a single branch, with a - ;; tuple pattern and a body corresponding to a - ;; local-variable extracted from the tuple. - (&/$Item [(&a-case/$TupleTestAC _sub-tests) [_ (&a/$var (&/$Local _member-idx))]] (&/$End)) - (|let [_path (record-read-path _sub-tests _member-idx)] - (if (&/|empty? _path) - ;; If the path is empty, that means it was a - ;; false-positive and normal PM optimization should be - ;; done instead. - (normal-case-optim) - ;; Otherwise, we've got ourselves a record-get expression. - (&/T [meta ($record-get (pass-0 top-level-func? value) _path)]))) - - ;; If no special patterns are found, just do normal PM optimization. - _ - (normal-case-optim))) - - (&a/$function _register-offset scope captured body) - (|let [inner-func? (|case body - [_ (&a/$function _ _ _ _)] - true - - _ - false)] - (|case (pass-0 (not inner-func?) body) - ;; If the body of a function is another function, that means - ;; no work was done in-between and both layers can be folded - ;; into one. - [_ ($function _ _arity _scope _captured _body)] - (|let [new-arity (inc _arity) - collapsed-body (shift-function-body scope _scope true _body)] - (&/T [meta ($function _register-offset - new-arity - scope - (optimize-closure (partial pass-0 top-level-func?) captured) - (if top-level-func? - (optimize-iter new-arity collapsed-body) - collapsed-body))])) - - ;; Otherwise, they're nothing to be done and we've got a - ;; 1-arity function. - =body - (&/T [meta ($function _register-offset - 1 scope - (optimize-closure (partial pass-0 top-level-func?) captured) - (if top-level-func? - (optimize-iter 1 =body) - =body))]))) - - (&a/$ann value-expr type-expr) - (&/T [meta ($ann (pass-0 top-level-func? value-expr) type-expr)]) - - (&a/$def def-name) - (&/T [meta ($def def-name)]) - - (&a/$var var-kind) - (&/T [meta ($var var-kind)]) - - (&a/$captured scope idx source) - (&/T [meta ($captured scope idx (pass-0 top-level-func? source))]) - - (&a/$proc proc-ident args special-args) - (&/T [meta ($proc proc-ident (&/|map (partial pass-0 top-level-func?) args) special-args)]) - - _ - (assert false (prn-str 'pass-0 top-level-func? (&/adt->text analysis))) - )))) - -;; [Exports] -(defn optimize - "(-> Analysis Optimized)" - [analysis] - (->> analysis - (pass-0 true))) - -(defn show [synthesis] - (|let [[[?type [_file-name _line _]] ?form] synthesis] - (|case ?form - ;; 0 - ($bit it) `(~'$bit ~it) - ;; 1 - ($nat it) `(~'$nat ~it) - ;; 2 - ($int it) `(~'$int ~it) - ;; 3 - ($rev it) `(~'$rev ~it) - ;; 4 - ($dec it) `(~'$dec ~it) - ;; 5 - ($text it) `(~'$text ~it) - ;; 6 - ($variant idx is-last? value) `(~'$variant ~idx ~is-last? ~(show value)) - ;; 7 - ($tuple it) `[~@(&/->seq (&/|map show it))] - ;; 8 - ($apply func args) `(~(show func) ~@(&/->seq (&/|map show args))) - ;; 9 - ($case ?value [?pm ?bodies]) `(~'$case ~(show ?value) [?pm ?bodies]) - ;; 10 - ($function _register-offset arity scope captured body*) `(~'$function ~_register-offset ~arity ~(show body*)) - ;; 11 - ($ann value-expr type-expr) `(~'$ann ~(show value-expr) ~(show type-expr)) - ;; 12 - ($var (&/$Local ?idx)) `(~'$var ~?idx) - ;; ("captured" 3) - ;; ("proc" 3) - ;; ("loop" 3) ;; {register-offset Int, inits (List Optimized), body Optimized} - ;; ("iter" 2) ;; {register-offset Int, vals (List Optimized)} - ($let value register body) `(~'$let ~(show value) ~register ~(show body)) - ;; ("record-get" 2) - ($if test then else) `(~'$if ~(show test) ~(show then) ~(show else)) - - _ - (&/adt->text synthesis) - ))) diff --git a/lux-bootstrapper/src/lux/parser.clj b/lux-bootstrapper/src/lux/parser.clj deleted file mode 100644 index 84c5db86f4..0000000000 --- a/lux-bootstrapper/src/lux/parser.clj +++ /dev/null @@ -1,88 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.parser - (:require [clojure.template :refer [do-template]] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return |case]] - [lexer :as &lexer]))) - -;; [Utils] -(defn ^:private repeat% [action] - (fn [state] - (|case (action state) - (&/$Left ^String error) - (if (.contains error "[Parser Error]") - (&/$Right (&/T [state &/$End])) - (&/$Left error)) - - (&/$Right state* head) - ((|do [tail (repeat% action)] - (return (&/$Item head tail))) - state*)))) - -(do-template [ ] - (defn [parse] - (|do [elems (repeat% parse) - token &lexer/lex] - (|case token - [meta ( _)] - (return ( (&/fold &/|++ &/$End elems))) - - _ - (&/fail-with-loc (str "[Parser Error] Unbalanced " ".")) - ))) - - ^:private parse-form &lexer/$Close_Paren "parantheses" &/$Form - ^:private parse-variant &lexer/$Close_Brace "braces" &/$Variant - ^:private parse-tuple &lexer/$Close_Bracket "brackets" &/$Tuple - ) - -;; [Interface] -(def parse - (|do [token &lexer/lex - :let [[meta token*] token]] - (|case token* - (&lexer/$White_Space _) - (return &/$End) - - (&lexer/$Comment _) - (return &/$End) - - (&lexer/$Bit ?value) - (return (&/|list (&/T [meta (&/$Bit (.equals ^String ?value "#1"))]))) - - (&lexer/$Nat ?value) - (return (&/|list (&/T [meta (&/$Nat (Long/parseUnsignedLong ?value))]))) - - (&lexer/$Int ?value) - (return (&/|list (&/T [meta (&/$Int (Long/parseLong ?value))]))) - - (&lexer/$Rev ?value) - (return (&/|list (&/T [meta (&/$Rev (&/decode-rev ?value))]))) - - (&lexer/$Dec ?value) - (return (&/|list (&/T [meta (&/$Dec (Double/parseDouble ?value))]))) - - (&lexer/$Text ?value) - (return (&/|list (&/T [meta (&/$Text ?value)]))) - - (&lexer/$Identifier ?ident) - (return (&/|list (&/T [meta (&/$Identifier ?ident)]))) - - (&lexer/$Open_Paren _) - (|do [syntax (parse-form parse)] - (return (&/|list (&/T [meta syntax])))) - - (&lexer/$Open_Brace _) - (|do [syntax (parse-variant parse)] - (return (&/|list (&/T [meta syntax])))) - - (&lexer/$Open_Bracket _) - (|do [syntax (parse-tuple parse)] - (return (&/|list (&/T [meta syntax])))) - - _ - (&/fail-with-loc "[Parser Error] Unknown lexer token.") - ))) diff --git a/lux-bootstrapper/src/lux/reader.clj b/lux-bootstrapper/src/lux/reader.clj deleted file mode 100644 index 40d17feab5..0000000000 --- a/lux-bootstrapper/src/lux/reader.clj +++ /dev/null @@ -1,156 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.reader - (:require [clojure.string :as string] - clojure.core.match - clojure.core.match.array - [lux.base :as & :refer [defvariant |do return* return |let |case]])) - -;; [Tags] -(defvariant - ("No" 1) - ("Done" 1) - ("Yes" 2)) - -;; [Utils] -(defn- with-line [body] - (fn [state] - (|case (&/get$ &/$source state) - (&/$End) - ((&/fail-with-loc "[Reader Error] EOF") state) - - (&/$Item [[file-name line-num column-num] line] - more) - (|case (body file-name line-num column-num line) - ($No msg) - ((&/fail-with-loc msg) state) - - ($Done output) - (return* (&/set$ &/$source more state) - output) - - ($Yes output line*) - (return* (&/set$ &/$source (&/$Item line* more) state) - output)) - ))) - -(defn- with-lines [body] - (fn [state] - (|case (body (&/get$ &/$source state)) - (&/$Right reader* match) - (return* (&/set$ &/$source reader* state) - match) - - (&/$Left msg) - ((&/fail-with-loc msg) state) - ))) - -(defn- re-find! [^java.util.regex.Pattern regex column ^String line] - (let [matcher (doto (.matcher regex line) - (.region column (.length line)) - (.useAnchoringBounds true))] - (when (.find matcher) - (.group matcher 0)))) - -;; [Exports] -(defn read-regex [regex] - (with-line - (fn [file-name line-num column-num ^String line] - (if-let [^String match (re-find! regex column-num line)] - (let [match-length (.length match) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true match])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false match]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($No (str "[Reader Error] Pattern failed: " regex)))))) - -(defn read-regex? - "(-> Regex (Reader (Maybe Text)))" - [regex] - (with-line - (fn [file-name line-num column-num ^String line] - (if-let [^String match (re-find! regex column-num line)] - (let [match-length (.length match) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some match)])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some match)]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) - (&/T [(&/T [file-name line-num column-num]) line])))))) - -(defn read-regex+ [regex] - (with-lines - (fn [reader] - (loop [prefix "" - reader* reader] - (|case reader* - (&/$End) - (&/$Left "[Reader Error] EOF") - - (&/$Item [[file-name line-num column-num] ^String line] - reader**) - (if-let [^String match (re-find! regex column-num line)] - (let [match-length (.length match) - column-num* (+ column-num match-length) - prefix* (if (= 0 column-num) - (str prefix "\n" match) - (str prefix match))] - (if (= column-num* (.length line)) - (recur prefix* reader**) - (&/$Right (&/T [(&/$Item (&/T [(&/T [file-name line-num column-num*]) line]) - reader**) - (&/T [(&/T [file-name line-num column-num]) prefix*])])))) - (&/$Left (str "[Reader Error] Pattern failed: " regex)))))))) - -(defn read-text - "(-> Text (Reader Text))" - [^String text] - (with-line - (fn [file-name line-num column-num ^String line] - (if (.startsWith line text column-num) - (let [match-length (.length text) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true text])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false text]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($No (str "[Reader Error] Text failed: " text)))))) - -(defn read-text? - "(-> Text (Reader (Maybe Text)))" - [^String text] - (with-line - (fn [file-name line-num column-num ^String line] - (if (.startsWith line text column-num) - (let [match-length (.length text) - column-num* (+ column-num match-length)] - (if (= column-num* (.length line)) - ($Done (&/T [(&/T [file-name line-num column-num]) true (&/$Some text)])) - ($Yes (&/T [(&/T [file-name line-num column-num]) false (&/$Some text)]) - (&/T [(&/T [file-name line-num column-num*]) line])))) - ($Yes (&/T [(&/T [file-name line-num column-num]) false &/$None]) - (&/T [(&/T [file-name line-num column-num]) line])))))) - -(defn from [^String name ^String source-code] - (let [lines (string/split-lines source-code) - indexed-lines (map (fn [line line-num] - (&/T [(&/T [name (inc line-num) 0]) - line])) - lines - (range (count lines)))] - (reduce (fn [tail head] (&/$Item head tail)) - &/$End - (reverse indexed-lines)))) - -(defn with-source [name content body] - (fn [state] - (|let [old-source (&/get$ &/$source state)] - (|case (body (&/set$ &/$source (from name content) state)) - (&/$Left error) - ((&/fail-with-loc error) state) - - (&/$Right state* output) - (&/$Right (&/T [(&/set$ &/$source old-source state*) output])))))) diff --git a/lux-bootstrapper/src/lux/repl.clj b/lux-bootstrapper/src/lux/repl.clj deleted file mode 100644 index af22811553..0000000000 --- a/lux-bootstrapper/src/lux/repl.clj +++ /dev/null @@ -1,90 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.repl - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|let |do return* return |case]] - [type :as &type] - [analyser :as &analyser] - [optimizer :as &optimizer] - [compiler :as &compiler]) - [lux.compiler.cache :as &cache] - (lux.analyser [base :as &a-base] - [lux :as &a-lux] - [module :as &module])) - (:import (java.io InputStreamReader - BufferedReader))) - -;; [Utils] -(def ^:private repl-module "REPL") - -(defn ^:private repl-location [repl-line] - (&/T [repl-module repl-line 0])) - -(defn ^:private init [source-dirs] - (do (&compiler/init!) - (|case ((|do [_ (&compiler/compile-module source-dirs &/prelude) - _ (&cache/delete repl-module) - _ (&module/create-module repl-module 0) - _ (fn [?state] - (return* (&/set$ &/$source - (&/|list (&/T [(repl-location -1) "(;module: lux)"])) - ?state) - nil)) - analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) - eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!))] - (return nil)) - (&/init-state &/$REPL)) - (&/$Right ?state _) - (do (println) - (println "Welcome to the REPL!") - (println "Type \"exit\" to leave.") - (println) - ?state) - - (&/$Left ?message) - (do (println (str "Initialization failed:\n" ?message)) - (flush) - (System/exit 1))) - )) - -;; [Values] -(defn repl [dependencies source-dirs target-dir] - (with-open [input (->> System/in (new InputStreamReader) (new BufferedReader))] - (loop [state (init source-dirs) - repl-line 0 - multi-line? false] - (let [_ (if (not multi-line?) - (.print System/out "> ") - (.print System/out " ")) - line (.readLine input)] - (if (= "exit" line) - (println "Till next time...") - (let [line* (&/|list (&/T [(repl-location repl-line) line])) - state* (&/update$ &/$source - (fn [_source] (&/|++ _source line*)) - state)] - (|case ((|do [analysed-tokens (&analyser/repl-analyse &optimizer/optimize &compiler/eval! (partial &compiler/compile-module source-dirs) &compiler/all-compilers) - eval-values (->> analysed-tokens (&/|map &optimizer/optimize) (&/map% &compiler/eval!)) - :let [outputs (map (fn [analysis value] - (|let [[[_type _location] _term] analysis] - [_type value])) - (&/->seq analysed-tokens) - (&/->seq eval-values))]] - (return outputs)) - state*) - (&/$Right state** outputs) - (do (doseq [[_type _value] outputs] - (.println System/out (str ": " (&type/show-type _type) "\n" - "=> " (pr-str _value) "\n"))) - (recur state** (inc repl-line) false)) - - (&/$Left ^String ?message) - (if (or (= "[Reader Error] EOF" ?message) - (.contains ?message "[Parser Error] Unbalanced ")) - (recur state* (inc repl-line) true) - (do (println ?message) - (recur state (inc repl-line) false))) - )))) - ))) diff --git a/lux-bootstrapper/src/lux/type.clj b/lux-bootstrapper/src/lux/type.clj deleted file mode 100644 index a6bf13f66c..0000000000 --- a/lux-bootstrapper/src/lux/type.clj +++ /dev/null @@ -1,963 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.type - (:refer-clojure :exclude [deref apply merge bound?]) - (:require [clojure.template :refer [do-template]] - clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return assert! |let |case]]) - [lux.type.host :as &&host])) - -(declare show-type - type=) - -;; [Utils] -(defn |list? [xs] - (|case xs - (&/$End) - true - - (&/$Item x xs*) - (|list? xs*) - - _ - false)) - -(def max-stack-size - (->> 1 - (* 2) - (* 2) - (* 2) - (* 2) - (* 2) - (* 2) - (* 2) - (* 2))) - -(def empty-env &/$End) - -(def I64 (&/$Named (&/T [&/prelude "I64"]) - (&/$Universal empty-env - (&/$Nominal "#I64" (&/|list (&/$Parameter 1)))))) -(def Bit (&/$Named (&/T [&/prelude "Bit"]) (&/$Nominal "#Bit" &/$End))) -(def Nat (&/$Named (&/T [&/prelude "Nat"]) (&/$Nominal "#I64" (&/|list (&/$Nominal &&host/nat-data-tag &/$End))))) -(def Int (&/$Named (&/T [&/prelude "Int"]) (&/$Nominal "#I64" (&/|list (&/$Nominal &&host/int-data-tag &/$End))))) -(def Rev (&/$Named (&/T [&/prelude "Rev"]) (&/$Nominal "#I64" (&/|list (&/$Nominal &&host/rev-data-tag &/$End))))) -(def Dec (&/$Named (&/T [&/prelude "Dec"]) (&/$Nominal "#Dec" &/$End))) -(def Text (&/$Named (&/T [&/prelude "Text"]) (&/$Nominal "#Text" &/$End))) -(def Symbol (&/$Named (&/T [&/prelude "Symbol"]) (&/$Product Text Text))) - -(def Array &&host/Array) - -(def Nothing - (&/$Named (&/T [&/prelude "Nothing"]) - (&/$Universal empty-env - (&/$Parameter 1)))) - -(def Any - (&/$Named (&/T [&/prelude "Any"]) - (&/$Existential empty-env - (&/$Parameter 1)))) - -(def IO - (&/$Named (&/T [(str &/prelude "/control/io") "IO"]) - (&/$Universal empty-env - (&/$Nominal (str &/prelude "/control/io.IO") - (&/|list (&/$Parameter 1)))))) - -(def List - (&/$Named (&/T [&/prelude "List"]) - (&/$Universal empty-env - (&/$Sum - ;; .End - Any - ;; .Item - (&/$Product (&/$Parameter 1) - (&/$Apply (&/$Parameter 1) - (&/$Parameter 0))))))) - -(def Maybe - (&/$Named (&/T [&/prelude "Maybe"]) - (&/$Universal empty-env - (&/$Sum - ;; .None - Any - ;; .Some - (&/$Parameter 1)) - ))) - -(def Type - (&/$Named (&/T [&/prelude "Type"]) - (let [Type (&/$Apply (&/$Nominal "" &/$End) (&/$Parameter 0)) - TypeList (&/$Apply Type List) - TypePair (&/$Product Type Type)] - (&/$Apply (&/$Nominal "" &/$End) - (&/$Universal empty-env - (&/$Sum - ;; Nominal - (&/$Product Text TypeList) - (&/$Sum - ;; Sum - TypePair - (&/$Sum - ;; Product - TypePair - (&/$Sum - ;; Function - TypePair - (&/$Sum - ;; Parameter - Nat - (&/$Sum - ;; Var - Nat - (&/$Sum - ;; Ex - Nat - (&/$Sum - ;; Universal - (&/$Product TypeList Type) - (&/$Sum - ;; Existential - (&/$Product TypeList Type) - (&/$Sum - ;; App - TypePair - ;; Named - (&/$Product Symbol Type))))))))))) - ))))) - -(def Macro - (&/$Named (&/T [&/prelude "Macro"]) - (&/$Nominal "#Macro" &/$End))) - -(def Tag - (&/$Named (&/T [&/prelude "Tag"]) - (&/$Nominal "#Tag" &/$End))) - -(def Slot - (&/$Named (&/T [&/prelude "Slot"]) - (&/$Nominal "#Slot" &/$End))) - -(defn bound? [id] - (fn [state] - (if-let [type (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (|case type - (&/$Some type*) - (return* state true) - - (&/$None) - (return* state false)) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id)) - state)))) - -(defn deref [id] - (fn [state] - (if-let [type* (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (|case type* - (&/$Some type) - (return* state type) - - (&/$None) - ((&/fail-with-loc (str "[Type Error] Un-bound type-var: " id)) - state)) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id)) - state)))) - -(defn deref+ [type] - (|case type - (&/$Var id) - (deref id) - - _ - (&/fail-with-loc (str "[Type Error] Type is not a variable: " (show-type type))) - )) - -(defn set-var [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (|case tvar - (&/$Some bound) - (if (type= type bound) - (return* state nil) - ((&/fail-with-loc (str "[Type Error] Cannot re-bind type var: " id " | Current type: " (show-type bound))) - state)) - - (&/$None) - (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) - ts)) - state) - nil)) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) - state)))) - -(defn reset-var [id type] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id (&/$Some type) %) - ts)) - state) - nil) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) - state)))) - -(defn unset-var [id] - (fn [state] - (if-let [tvar (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) (&/|get id))] - (return* (&/update$ &/$type-context (fn [ts] (&/update$ &/$var-bindings #(&/|put id &/$None %) - ts)) - state) - nil) - ((&/fail-with-loc (str "[Type Error] Unknown type-var: " id " | " (->> state (&/get$ &/$type-context) (&/get$ &/$var-bindings) &/|length))) - state)))) - -;; [Exports] -;; Type vars -(def reset-mappings - (fn [state] - (return* (&/update$ &/$type-context #(->> % - (&/set$ &/$var-counter 0) - (&/set$ &/$var-bindings (&/|table))) - state) - nil))) - -(def create-var - (fn [state] - (let [id (->> state (&/get$ &/$type-context) (&/get$ &/$var-counter))] - (return* (&/update$ &/$type-context #(->> % - (&/update$ &/$var-counter inc) - (&/update$ &/$var-bindings (fn [ms] (&/|put id &/$None ms)))) - state) - id)))) - -(def existential - ;; (Lux Type) - (fn [compiler] - (return* (&/update$ &/$type-context - (fn [context] - (&/update$ &/$ex-counter inc context)) - compiler) - (->> compiler - (&/get$ &/$type-context) - (&/get$ &/$ex-counter) - &/$Opaque)))) - -(defn with-var [k] - (|do [id create-var] - (k (&/$Var id)))) - -(defn clean* [?tid type] - (|case type - (&/$Var ?id) - (if (= ?tid ?id) - (|do [? (bound? ?id)] - (if ? - (deref ?id) - (return type))) - (|do [? (bound? ?id)] - (if ? - (|do [=type (deref ?id) - ==type (clean* ?tid =type)] - (|case ==type - (&/$Var =id) - (if (= ?tid =id) - (|do [_ (unset-var ?id)] - (return type)) - (|do [_ (reset-var ?id ==type)] - (return type))) - - _ - (|do [_ (reset-var ?id ==type)] - (return ==type)))) - (return type))) - ) - - (&/$Nominal ?name ?params) - (|do [=params (&/map% (partial clean* ?tid) ?params)] - (return (&/$Nominal ?name =params))) - - (&/$Function ?arg ?return) - (|do [=arg (clean* ?tid ?arg) - =return (clean* ?tid ?return)] - (return (&/$Function =arg =return))) - - (&/$Apply ?param ?lambda) - (|do [=lambda (clean* ?tid ?lambda) - =param (clean* ?tid ?param)] - (return (&/$Apply =param =lambda))) - - (&/$Product ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (&/$Product =left =right))) - - (&/$Sum ?left ?right) - (|do [=left (clean* ?tid ?left) - =right (clean* ?tid ?right)] - (return (&/$Sum =left =right))) - - (&/$Universal ?env ?body) - (|do [=env (&/map% (partial clean* ?tid) ?env) - body* (clean* ?tid ?body)] ;; TODO: DO NOT CLEAN THE BODY - (return (&/$Universal =env body*))) - - (&/$Existential ?env ?body) - (|do [=env (&/map% (partial clean* ?tid) ?env) - body* (clean* ?tid ?body)] ;; TODO: DO NOT CLEAN THE BODY - (return (&/$Existential =env body*))) - - _ - (return type) - )) - -(defn clean [tvar type] - (|case tvar - (&/$Var ?id) - (clean* ?id type) - - _ - (&/fail-with-loc (str "[Type Error] Not type-var: " (show-type tvar))))) - -(defn ^:private unravel-fun [type] - (|case type - (&/$Function ?in ?out) - (|let [[??out ?args] (unravel-fun ?out)] - (&/T [??out (&/$Item ?in ?args)])) - - _ - (&/T [type &/$End]))) - -(defn ^:private unravel-app - ([fun-type tail] - (|case fun-type - (&/$Apply ?arg ?func) - (unravel-app ?func (&/$Item ?arg tail)) - - _ - (&/T [fun-type tail]))) - ([fun-type] - (unravel-app fun-type &/$End))) - -(do-template [ ] - (do (defn - "(-> Type (List Type))" - [type] - (|case type - ( left right) - (&/$Item left ( right)) - - _ - (&/|list type))) - - (defn - "(-> Int Type (Lux Type))" - [tag type] - (|case type - (&/$Named ?name ?type) - ( tag ?type) - - ( ?left ?right) - (|case (&/T [tag ?right]) - [0 _] (return ?left) - [1 ( ?left* _)] (return ?left*) - [1 _] (return ?right) - [_ ( _ _)] ( (dec tag) ?right) - _ (&/fail-with-loc (str "[Type Error] " " lacks member: " tag " | " (show-type type)))) - - _ - (&/fail-with-loc (str "[Type Error] Type is not a " ": " (show-type type)))))) - - &/$Sum flatten-sum sum-at "Sum" - &/$Product flatten-prod prod-at "Product" - ) - -(do-template [ ] - (defn - "(-> (List Type) Type)" - [types] - (|case (&/|reverse types) - (&/$Item last prevs) - (&/fold (fn [right left] ( left right)) last prevs) - - (&/$End) - )) - - Variant$ &/$Sum Nothing - Tuple$ &/$Product Any - ) - -(defn show-type [^objects type] - (|case type - (&/$Nominal name params) - (|case params - (&/$End) - (str "(Nominal " (pr-str name) ")") - - _ - (str "(Nominal " (pr-str name) " " (->> params (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$Product _) - (str "[" (->> (flatten-prod type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) "]") - - (&/$Sum _) - (str "(| " (->> (flatten-sum type) (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")") - - (&/$Function input output) - (|let [[?out ?ins] (unravel-fun type)] - (str "(-> " (->> ?ins (&/|map show-type) (&/|interpose " ") (&/fold str "")) " " (show-type ?out) ")")) - - (&/$Var id) - (str "-" id) - - (&/$Opaque ?id) - (str "+" ?id) - - (&/$Parameter idx) - (str idx) - - (&/$Apply _ _) - (|let [[?call-fun ?call-args] (unravel-app type)] - (str "(" (show-type ?call-fun) " " (->> ?call-args (&/|map show-type) (&/|interpose " ") (&/fold str "")) ")")) - - (&/$Universal ?env ?body) - (str "(All " "{" (->> ?env (&/|map show-type) (&/|interpose " ") (&/fold str "")) "} " - (show-type ?body) ")") - - (&/$Existential ?env ?body) - (str "(Ex " "{" (->> ?env (&/|map show-type) (&/|interpose " ") (&/fold str "")) "} " - (show-type ?body) ")") - - (&/$Named ?name ?type) - (&/ident->text ?name) - - _ - (assert false (prn-str 'show-type (&/adt->text type))))) - -(defn type= [x y] - (or (clojure.lang.Util/identical x y) - (let [output (|case [x y] - [(&/$Named [?xmodule ?xname] ?xtype) (&/$Named [?ymodule ?yname] ?ytype)] - (and (= ?xmodule ?ymodule) - (= ?xname ?yname)) - - [(&/$Nominal xname xparams) (&/$Nominal yname yparams)] - (and (.equals ^Object xname yname) - (= (&/|length xparams) (&/|length yparams)) - (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) - - [(&/$Product xL xR) (&/$Product yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Sum xL xR) (&/$Sum yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Function xinput xoutput) (&/$Function yinput youtput)] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [(&/$Var xid) (&/$Var yid)] - (= xid yid) - - [(&/$Parameter xidx) (&/$Parameter yidx)] - (= xidx yidx) - - [(&/$Opaque xid) (&/$Opaque yid)] - (= xid yid) - - [(&/$Apply xparam xlambda) (&/$Apply yparam ylambda)] - (and (type= xparam yparam) (type= xlambda ylambda)) - - [(&/$Universal xenv xbody) (&/$Universal yenv ybody)] - (type= xbody ybody) - - [(&/$Named ?xname ?xtype) _] - (type= ?xtype y) - - [_ (&/$Named ?yname ?ytype)] - (type= x ?ytype) - - [_ _] - false - )] - output))) - -(defn ^:private fp-get [k fixpoints] - (|let [[e a] k] - (|case fixpoints - (&/$End) - &/$None - - (&/$Item [[e* a*] v*] fixpoints*) - (if (and (type= e e*) - (type= a a*)) - (&/$Some v*) - (fp-get k fixpoints*)) - ))) - -(defn ^:private fp-put [k v fixpoints] - (&/$Item (&/T [k v]) fixpoints)) - -(defn show-type+ [type] - (|case type - (&/$Var ?id) - (fn [state] - (|case ((deref ?id) state) - (&/$Right state* bound) - (return* state (str (show-type type) " = " (show-type bound))) - - (&/$Left _) - (return* state (show-type type)))) - - _ - (return (show-type type)))) - -(defn ^:private check-error [err expected actual] - (|do [=expected (show-type+ expected) - =actual (show-type+ actual)] - (&/fail-with-loc (str (if (= "" err) err (str err "\n")) - "[Type Checker Error]\n" - "Expected: " =expected "\n\n" - " Actual: " =actual - "\n")))) - -(defn beta-reduce [env type] - (|case type - (&/$Nominal ?name ?params) - (&/$Nominal ?name (&/|map (partial beta-reduce env) ?params)) - - (&/$Sum ?left ?right) - (&/$Sum (beta-reduce env ?left) (beta-reduce env ?right)) - - (&/$Product ?left ?right) - (&/$Product (beta-reduce env ?left) (beta-reduce env ?right)) - - (&/$Apply ?type-arg ?type-fn) - (&/$Apply (beta-reduce env ?type-arg) (beta-reduce env ?type-fn)) - - (&/$Universal ?local-env ?local-def) - (|case ?local-env - (&/$End) - (&/$Universal env ?local-def) - - _ - type) - - (&/$Existential ?local-env ?local-def) - (|case ?local-env - (&/$End) - (&/$Existential env ?local-def) - - _ - type) - - (&/$Function ?input ?output) - (&/$Function (beta-reduce env ?input) (beta-reduce env ?output)) - - (&/$Parameter ?idx) - (|case (&/|at ?idx env) - (&/$Some parameter) - (beta-reduce env parameter) - - _ - (assert false (str "[Type Error] Unknown var: " ?idx " | " (&/->seq (&/|map show-type env))))) - - _ - type - )) - -(defn apply-type [type-fn param] - (|case type-fn - (&/$Universal local-env local-def) - (return (beta-reduce (->> local-env - (&/$Item param) - (&/$Item type-fn)) - local-def)) - - (&/$Existential local-env local-def) - (return (beta-reduce (->> local-env - (&/$Item param) - (&/$Item type-fn)) - local-def)) - - (&/$Apply A F) - (|do [type-fn* (apply-type F A)] - (apply-type type-fn* param)) - - (&/$Named ?name ?type) - (apply-type ?type param) - - ;; TODO: This one must go... - (&/$Opaque id) - (return (&/$Apply param type-fn)) - - (&/$Var id) - (|do [=type-fun (deref id)] - (apply-type =type-fun param)) - - _ - (&/fail-with-loc (str "[Type System] Not a type function:\n" (show-type type-fn) "\n" - "for arg: " (show-type param))))) - -(def ^:private init-fixpoints &/$End) - -(defn ^:private check* [fixpoints invariant?? expected actual] - (if (clojure.lang.Util/identical expected actual) - (return fixpoints) - (&/with-attempt - (|case [expected actual] - [(&/$Var ?eid) (&/$Var ?aid)] - (if (= ?eid ?aid) - (return fixpoints) - (|do [ebound (fn [state] - (|case ((deref ?eid) state) - (&/$Right state* ebound) - (return* state* (&/$Some ebound)) - - (&/$Left _) - (return* state &/$None))) - abound (fn [state] - (|case ((deref ?aid) state) - (&/$Right state* abound) - (return* state* (&/$Some abound)) - - (&/$Left _) - (return* state &/$None)))] - (|case [ebound abound] - [(&/$None _) (&/$None _)] - (|do [_ (set-var ?eid actual)] - (return fixpoints)) - - [(&/$Some etype) (&/$None _)] - (check* fixpoints invariant?? etype actual) - - [(&/$None _) (&/$Some atype)] - (check* fixpoints invariant?? expected atype) - - [(&/$Some etype) (&/$Some atype)] - (check* fixpoints invariant?? etype atype)))) - - [(&/$Var ?id) _] - (fn [state] - (|case ((set-var ?id actual) state) - (&/$Right state* _) - (return* state* fixpoints) - - (&/$Left _) - ((|do [bound (deref ?id)] - (check* fixpoints invariant?? bound actual)) - state))) - - [_ (&/$Var ?id)] - (fn [state] - (|case ((set-var ?id expected) state) - (&/$Right state* _) - (return* state* fixpoints) - - (&/$Left _) - ((|do [bound (deref ?id)] - (check* fixpoints invariant?? expected bound)) - state))) - - [(&/$Apply eA (&/$Opaque eid)) (&/$Apply aA (&/$Opaque aid))] - (if (= eid aid) - (check* fixpoints invariant?? eA aA) - (check-error "" expected actual)) - - [(&/$Apply A1 (&/$Var ?id)) (&/$Apply A2 F2)] - (fn [state] - (|case ((|do [F1 (deref ?id)] - (check* fixpoints invariant?? (&/$Apply A1 F1) actual)) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - (|case F2 - (&/$Universal (&/$Item _) _) - ((|do [actual* (apply-type F2 A2)] - (check* fixpoints invariant?? expected actual*)) - state) - - (&/$Opaque _) - ((|do [fixpoints* (check* fixpoints invariant?? (&/$Var ?id) F2)] - (check* fixpoints* invariant?? A1 A2)) - state) - - _ - ((|do [fixpoints* (check* fixpoints invariant?? (&/$Var ?id) F2) - e* (apply-type F2 A1) - a* (apply-type F2 A2)] - (check* fixpoints* invariant?? e* a*)) - state)))) - - [(&/$Apply A1 F1) (&/$Apply A2 (&/$Var ?id))] - (fn [state] - (|case ((|do [F2 (deref ?id)] - (check* fixpoints invariant?? expected (&/$Apply A2 F2))) - state) - (&/$Right state* output) - (return* state* output) - - (&/$Left _) - ((|do [fixpoints* (check* fixpoints invariant?? F1 (&/$Var ?id)) - e* (apply-type F1 A1) - a* (apply-type F1 A2)] - (check* fixpoints* invariant?? e* a*)) - state))) - - [(&/$Apply A F) _] - (let [fp-pair (&/T [expected actual]) - _ (when (> (&/|length fixpoints) max-stack-size) - (&/|log! (print-str 'FIXPOINTS (->> (&/|keys fixpoints) - (&/|map (fn [pair] - (|let [[e a] pair] - (str (show-type e) ":+:" - (show-type a))))) - (&/|interpose "\n\n") - (&/fold str "")))) - (assert false (prn-str 'check* '[(&/$Apply A F) _] (&/|length fixpoints) (show-type expected) (show-type actual))))] - (|case (fp-get fp-pair fixpoints) - (&/$Some ?) - (if ? - (return fixpoints) - (check-error "" expected actual)) - - (&/$None) - (|do [expected* (apply-type F A)] - (check* (fp-put fp-pair true fixpoints) invariant?? expected* actual)))) - - [_ (&/$Apply A (&/$Opaque aid))] - (check-error "" expected actual) - - [_ (&/$Apply A F)] - (|do [actual* (apply-type F A)] - (check* fixpoints invariant?? expected actual*)) - - [(&/$Universal _) _] - (|do [$arg existential - expected* (apply-type expected $arg)] - (check* fixpoints invariant?? expected* actual)) - - [_ (&/$Universal _)] - (with-var - (fn [$arg] - (|do [actual* (apply-type actual $arg) - =output (check* fixpoints invariant?? expected actual*) - _ (clean $arg expected)] - (return =output)))) - - [(&/$Existential e!env e!def) _] - (with-var - (fn [$arg] - (|do [expected* (apply-type expected $arg) - =output (check* fixpoints invariant?? expected* actual) - _ (clean $arg actual)] - (return =output)))) - - [_ (&/$Existential a!env a!def)] - (|do [$arg existential - actual* (apply-type actual $arg)] - (check* fixpoints invariant?? expected actual*)) - - [(&/$Nominal e!data) (&/$Nominal a!data)] - (|do [? &/jvm?] - (if ? - (|do [class-loader &/loader] - (&&host/check-host-types (partial check* fixpoints true) - check-error - fixpoints - existential - class-loader - invariant?? - e!data - a!data)) - (|let [[e!name e!params] e!data - [a!name a!params] a!data] - (if (and (= e!name a!name) - (= (&/|length e!params) (&/|length a!params))) - (|do [_ (&/map2% (partial check* fixpoints true) e!params a!params)] - (return fixpoints)) - (check-error "" expected actual))))) - - [(&/$Function eI eO) (&/$Function aI aO)] - (|do [fixpoints* (check* fixpoints invariant?? aI eI)] - (check* fixpoints* invariant?? eO aO)) - - [(&/$Product eL eR) (&/$Product aL aR)] - (|do [fixpoints* (check* fixpoints invariant?? eL aL)] - (check* fixpoints* invariant?? eR aR)) - - [(&/$Sum eL eR) (&/$Sum aL aR)] - (|do [fixpoints* (check* fixpoints invariant?? eL aL)] - (check* fixpoints* invariant?? eR aR)) - - [(&/$Opaque e!id) (&/$Opaque a!id)] - (if (= e!id a!id) - (return fixpoints) - (check-error "" expected actual)) - - [(&/$Named _ ?etype) _] - (check* fixpoints invariant?? ?etype actual) - - [_ (&/$Named _ ?atype)] - (check* fixpoints invariant?? expected ?atype) - - [_ _] - (&/fail "")) - (fn [err] - (check-error err expected actual))))) - -(defn check [expected actual] - (|do [_ (check* init-fixpoints false expected actual)] - (return nil))) - -(defn actual-type - "(-> Type (Lux Type))" - [type] - (|case type - (&/$Apply ?param ?all) - (|do [type* (apply-type ?all ?param)] - (actual-type type*)) - - (&/$Var id) - (|do [=type (deref id)] - (actual-type =type)) - - (&/$Named ?name ?type) - (actual-type ?type) - - _ - (return type) - )) - -(defn type-name - "(-> Type (Lux Symbol))" - [type] - (|case type - (&/$Named name _) - (return name) - - _ - (&/fail-with-loc (str "[Type Error] Type is not named: " (show-type type))) - )) - -(defn unknown? - "(-> Type (Lux Bit))" - [type] - (|case type - (&/$Var id) - (|do [? (bound? id)] - (return (not ?))) - - _ - (return false))) - -(defn resolve-type - "(-> Type (Lux Type))" - [type] - (|case type - (&/$Var id) - (|do [? (bound? id)] - (if ? - (deref id) - (return type))) - - _ - (return type))) - -(defn tuple-types-for - "(-> Int Type [Int (List Type)])" - [size-members type] - (|let [?member-types (flatten-prod type) - size-types (&/|length ?member-types)] - (if (>= size-types size-members) - (&/T [size-members (&/|++ (&/|take (dec size-members) ?member-types) - (&/|list (|case (->> ?member-types (&/|drop (dec size-members)) (&/|reverse)) - (&/$Item last prevs) - (&/fold (fn [right left] (&/$Product left right)) - last prevs))))]) - (&/T [size-types ?member-types]) - ))) - -(do-template [ ] - (defn [types] - (|case (&/|reverse types) - (&/$End) - - - (&/$Item type (&/$End)) - type - - (&/$Item last prevs) - (&/fold (fn [r l] ( l r)) last prevs))) - - fold-prod Any &/$Product - fold-sum Nothing &/$Sum - ) - -(def create-var+ - (|do [id create-var] - (return (&/$Var id)))) - -(defn ^:private push-app [inf-type inf-var] - (|case inf-type - (&/$Apply inf-var* inf-type*) - (&/$Apply inf-var* (push-app inf-type* inf-var)) - - _ - (&/$Apply inf-var inf-type))) - -(defn ^:private push-name [name inf-type] - (|case inf-type - (&/$Apply inf-var* inf-type*) - (&/$Apply inf-var* (push-name name inf-type*)) - - _ - (&/$Named name inf-type))) - -(defn ^:private push-univq [env inf-type] - (|case inf-type - (&/$Apply inf-var* inf-type*) - (&/$Apply inf-var* (push-univq env inf-type*)) - - _ - (&/$Universal env inf-type))) - -(defn instantiate-inference [type] - (|case type - (&/$Named ?name ?type) - (|do [output (instantiate-inference ?type)] - (return (push-name ?name output))) - - (&/$Universal _aenv _abody) - (|do [inf-var create-var - output (instantiate-inference _abody)] - (return (push-univq _aenv (push-app output (&/$Var inf-var))))) - - _ - (return type))) - -(defn normal - "(-> Type Type)" - [it] - (|case it - (&/$Named _ ?it) - (normal ?it) - - (&/$Nominal ?name ?parameters) - (|do [=parameters (&/map% normal ?parameters)] - (return (&/$Nominal ?name =parameters))) - - (&/$Apply ?parameter ?abstraction) - (|do [reification (apply-type ?abstraction ?parameter)] - (normal reification)) - - (&/$Var id) - (|do [referenced (deref id)] - (normal referenced)) - - _ - (return it))) diff --git a/lux-bootstrapper/src/lux/type/host.clj b/lux-bootstrapper/src/lux/type/host.clj deleted file mode 100644 index 5ba67d4fae..0000000000 --- a/lux-bootstrapper/src/lux/type/host.clj +++ /dev/null @@ -1,422 +0,0 @@ -;; This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -;; If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(ns lux.type.host - (:require clojure.core.match - clojure.core.match.array - (lux [base :as & :refer [|do return* return assert! |let |case]]) - [lux.host.generics :as &host-generics]) - (:import (java.lang.reflect GenericArrayType - ParameterizedType - TypeVariable - WildcardType))) - -(defn ^:private type= [x y] - (or (clojure.lang.Util/identical x y) - (let [output (|case [x y] - [(&/$Named [?xmodule ?xname] ?xtype) (&/$Named [?ymodule ?yname] ?ytype)] - (and (= ?xmodule ?ymodule) - (= ?xname ?yname)) - - [(&/$Nominal xname xparams) (&/$Nominal yname yparams)] - (and (.equals ^Object xname yname) - (= (&/|length xparams) (&/|length yparams)) - (&/fold2 #(and %1 (type= %2 %3)) true xparams yparams)) - - [(&/$Product xL xR) (&/$Product yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Sum xL xR) (&/$Sum yL yR)] - (and (type= xL yL) - (type= xR yR)) - - [(&/$Function xinput xoutput) (&/$Function yinput youtput)] - (and (type= xinput yinput) - (type= xoutput youtput)) - - [(&/$Var xid) (&/$Var yid)] - (= xid yid) - - [(&/$Parameter xidx) (&/$Parameter yidx)] - (= xidx yidx) - - [(&/$Opaque xid) (&/$Opaque yid)] - (= xid yid) - - [(&/$Apply xparam xlambda) (&/$Apply yparam ylambda)] - (and (type= xparam yparam) (type= xlambda ylambda)) - - [(&/$Universal xenv xbody) (&/$Universal yenv ybody)] - (type= xbody ybody) - - [(&/$Named ?xname ?xtype) _] - (type= ?xtype y) - - [_ (&/$Named ?yname ?ytype)] - (type= x ?ytype) - - [_ _] - false - )] - output))) - -(def ^:private Any - (&/$Named (&/T [&/prelude "Any"]) - (&/$Existential (&/|list) - (&/$Parameter 1)))) - -;; [Exports] -(def mutable-data-tag "#Mutable") -(def array-data-tag "#Array") -(defn Array [item] - (&/$Nominal array-data-tag (&/|list (&/$Nominal mutable-data-tag (&/|list (&/$Function item item)))))) - -(def null-data-tag "#Null") -(def i64-data-tag "#I64") -(def nat-data-tag "#Nat") -(def int-data-tag "#Int") -(def rev-data-tag "#Rev") - -;; [Utils] -(defn ^:private trace-lineage* - "(-> Class Class (List Class))" - [^Class super-class ^Class sub-class] - ;; Either they're both interfaces, or they're both classes - (let [valid-sub? #(if (or (= super-class %) - (.isAssignableFrom super-class %)) - % - nil)] - (if (or (.isInterface sub-class) - (.isInterface super-class)) - (loop [sub-class sub-class - stack (&/|list)] - (if-let [super-interface (some valid-sub? (.getInterfaces sub-class))] - (if (= super-class super-interface) - (&/$Item super-interface stack) - (recur super-interface (&/$Item super-interface stack))) - (if-let [super* (.getSuperclass sub-class)] - (recur super* (&/$Item super* stack)) - stack))) - (loop [sub-class sub-class - stack (&/|list)] - (let [super* (.getSuperclass sub-class)] - (if (= super* super-class) - (&/$Item super* stack) - (recur super* (&/$Item super* stack)))))))) - -(defn ^:private trace-lineage - "(-> Class Class (List Class))" - [^Class sub-class ^Class super-class] - (if (= sub-class super-class) - (&/|list) - (&/|reverse (trace-lineage* super-class sub-class)))) - -(let [matcher (fn [m ^TypeVariable jt lt] (&/$Item (&/T [(.getName jt) lt]) m))] - (defn ^:private match-params [sub-type-params params] - (assert (and (= (&/|length sub-type-params) (&/|length params)) - (&/|every? (partial instance? TypeVariable) sub-type-params))) - (&/fold2 matcher (&/|table) sub-type-params params))) - -;; [Exports] -(let [class-name-re #"((\[+)L([^\s]+);|([^\s]+)|(\[+)([ZBSIJFDC]))" - jprim->lprim (fn [prim] - (case prim - "Z" "boolean" - "B" "byte" - "S" "short" - "I" "int" - "J" "long" - "F" "float" - "D" "double" - "C" "char"))] - (defn class->type - "(-> Class Type)" - [^Class class] - (let [gclass-name (.getName class)] - (case gclass-name - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") - (&/$Nominal gclass-name (&/|list)) - ;; else - (if-let [[_ _ arr-obrackets arr-obase simple-base arr-pbrackets arr-pbase] (re-find class-name-re gclass-name)] - (let [base (or arr-obase simple-base (jprim->lprim arr-pbase))] - (if (.equals "void" base) - Any - (reduce (fn [inner _] (Array inner)) - (&/$Nominal base (try (-> (Class/forName base) .getTypeParameters - seq count (repeat (&/$Nominal "java.lang.Object" &/$End)) - &/->list) - (catch Exception e - (&/|list)))) - (range (count (or arr-obrackets arr-pbrackets ""))))) - )))))) - -(defn instance-param - "(-> (Lux Type) (List (, Text Type)) (^ java.lang.reflect.Type) (Lux Type))" - [existential matchings refl-type] - (cond (instance? Class refl-type) - (return (class->type refl-type)) - - (instance? GenericArrayType refl-type) - (|do [inner-type (instance-param existential matchings (.getGenericComponentType ^GenericArrayType refl-type))] - (return (Array inner-type))) - - (instance? ParameterizedType refl-type) - (|do [:let [refl-type* ^ParameterizedType refl-type] - params* (->> refl-type* - .getActualTypeArguments - seq &/->list - (&/map% (partial instance-param existential matchings)))] - (return (&/$Nominal (->> refl-type* ^Class (.getRawType) .getName) - params*))) - - (instance? TypeVariable refl-type) - (let [gvar (.getName ^TypeVariable refl-type)] - (if-let [m-type (&/|get gvar matchings)] - (return m-type) - (&/fail-with-loc (str "[Host Error] Unknown generic type-variable: " gvar "\n" - "Available type-variables: " (->> matchings - (&/|map &/|first) - &/->seq))))) - - (instance? WildcardType refl-type) - (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] - (instance-param existential matchings bound) - existential))) - -(defn principal-class [refl-type] - (cond (instance? Class refl-type) - (let [class-type (class->type refl-type)] - (if (type= Any class-type) - "V" - (|case class-type - (&/$Nominal "#Array" - (&/$Item (&/$Nominal "#Mutable" - (&/$Item (&/$Function _ (&/$Nominal class-name _)) - (&/$End))) - (&/$End))) - (str "[" (&host-generics/->type-signature class-name)) - - (&/$Nominal class-name _) - (&host-generics/->type-signature class-name)))) - - (instance? GenericArrayType refl-type) - (str "[" (principal-class (.getGenericComponentType ^GenericArrayType refl-type))) - - (instance? ParameterizedType refl-type) - (&host-generics/->type-signature (->> ^ParameterizedType refl-type ^Class (.getRawType) .getName)) - - (instance? TypeVariable refl-type) - (if-let [bound (->> ^TypeVariable refl-type .getBounds seq first)] - (principal-class bound) - (&host-generics/->type-signature "java.lang.Object")) - - (instance? WildcardType refl-type) - (if-let [bound (->> ^WildcardType refl-type .getUpperBounds seq first)] - (principal-class bound) - (&host-generics/->type-signature "java.lang.Object")))) - -(defn instance-gtype - "(-> (Lux Type) (List (, Text Type)) GenericType (Lux Type))" - [existential matchings gtype] - (|case gtype - (&/$GenericArray component-type) - (|do [inner-type (instance-gtype existential matchings component-type)] - (return (Array inner-type))) - - (&/$GenericClass type-name type-params) - ;; When referring to type-parameters during class or method - ;; definition, a type-environment is set for storing the names - ;; of such parameters. - ;; When a "class" shows up with the name of one of those - ;; parameters, it must be detected, and the bytecode class-name - ;; must correspond to Object's. - - (if-let [m-type (&/|get type-name matchings)] - (return m-type) - (|do [params* (&/map% (partial instance-gtype existential matchings) - type-params)] - (return (&/$Nominal type-name params*)))) - - (&/$GenericTypeVar var-name) - (if-let [m-type (&/|get var-name matchings)] - (return m-type) - (&/fail-with-loc (str "[Host Error] Unknown generic type-variable: " var-name "\n" - "Available type-variables: " (->> matchings - (&/|map &/|first) - &/->seq)))) - - (&/$GenericWildcard) - existential)) - -;; [Utils] -(defn ^:private translate-params - "(-> (List (^ java.lang.reflect.Type)) (List (^ java.lang.reflect.Type)) (List Type) (Lux (List Type)))" - [existential super-type-params sub-type-params params] - (|let [matchings (match-params sub-type-params params)] - (&/map% (partial instance-param existential matchings) super-type-params))) - -(defn ^:private raise* - "(-> (, Class (List Type)) Class (Lux (, Class (List Type))))" - [existential sub+params ^Class super] - (|let [[^Class sub params] sub+params] - (if (.isInterface super) - (|do [:let [super-params (->> sub - .getGenericInterfaces - (some #(if (= super (if (instance? Class %) % (.getRawType ^ParameterizedType %))) - (if (instance? Class %) - (&/|list) - (->> ^ParameterizedType % .getActualTypeArguments seq &/->list)) - nil)))] - params* (translate-params existential - (or super-params (&/|list)) - (->> sub .getTypeParameters seq &/->list) - params)] - (return (&/T [super params*]))) - (let [super* (.getGenericSuperclass sub)] - (cond (instance? Class super*) - (return (&/T [super* (&/|list)])) - - (instance? ParameterizedType super*) - (|do [params* (translate-params existential - (->> ^ParameterizedType super* .getActualTypeArguments seq &/->list) - (->> sub .getTypeParameters seq &/->list) - params)] - (return (&/T [super params*]))) - - :else - (assert false (prn-str super* (class super*) [sub super]))))))) - -(defn- raise - "(-> (List Class) Class (List Type) (Lux (, Class (List Type))))" - [existential lineage class params] - (&/fold% (partial raise* existential) (&/T [class params]) lineage)) - -;; [Exports] -(defn find-class! [class class-loader] - (try (return (Class/forName class true class-loader)) - (catch java.lang.ClassNotFoundException ex - (&/fail-with-loc (str "[Host Error] Cannot find class: " (pr-str class)))))) - -(defn ->super-type - "(-> Text Text (List Type) (Lux Type))" - [existential class-loader super-class sub-class sub-params] - (|do [^Class super-class+ (find-class! super-class class-loader) - ^Class sub-class+ (find-class! sub-class class-loader)] - (if (.isAssignableFrom super-class+ sub-class+) - (let [lineage (trace-lineage sub-class+ super-class+)] - (|do [[^Class sub-class* sub-params*] (raise existential lineage sub-class+ sub-params)] - (return (&/$Nominal (.getName sub-class*) sub-params*)))) - (&/fail-with-loc (str "[Host Error] Classes do not have a subtyping relationship: " sub-class " super-type existential class-loader e!name a!name a!params)] - (check (&/$Nominal e!name e!params) actual*)) - - :else - (check-error "" (&/$Nominal e!name e!params) (&/$Nominal a!name a!params)))) - (catch Exception e - (throw e))))) - -(defn gtype->gclass - "(-> GenericType GenericClass)" - [gtype] - (cond (instance? Class gtype) - (&/$GenericClass (.getName ^Class gtype) &/$End) - - (instance? GenericArrayType gtype) - (&/$GenericArray (gtype->gclass (.getGenericComponentType ^GenericArrayType gtype))) - - (instance? ParameterizedType gtype) - (let [type-name (->> ^ParameterizedType gtype ^Class (.getRawType) .getName) - type-params (->> ^ParameterizedType gtype - .getActualTypeArguments - seq &/->list - (&/|map gtype->gclass))] - (&/$GenericClass type-name type-params)) - - (instance? TypeVariable gtype) - (&/$GenericTypeVar (.getName ^TypeVariable gtype)) - - (instance? WildcardType gtype) - (if-let [bound (->> ^WildcardType gtype .getUpperBounds seq first)] - (&/$GenericWildcard (&/$Some (&/T &/$UpperBound (gtype->gclass bound)))) - (if-let [bound (->> ^WildcardType gtype .getLowerBounds seq first)] - (&/$GenericWildcard (&/$Some (&/T &/$LowerBound (gtype->gclass bound)))) - (&/$GenericWildcard &/$None))))) - -(let [generic-type-sig "Ljava/lang/Object;"] - (defn gclass->sig - "(-> GenericClass Text)" - [gclass] - (|case gclass - (&/$GenericClass gclass-name (&/$End)) - (case gclass-name - "void" "V" - "boolean" "Z" - "byte" "B" - "short" "S" - "int" "I" - "long" "J" - "float" "F" - "double" "D" - "char" "C" - ("[Z" "[B" "[S" "[I" "[J" "[F" "[D" "[C") gclass-name - ;; else - (str "L" (clojure.string/replace gclass-name #"\." "/") ";")) - - (&/$GenericArray inner-gtype) - (str "[" (gclass->sig inner-gtype)) - - (&/$GenericTypeVar ?vname) - generic-type-sig - - (&/$GenericWildcard _) - generic-type-sig - ))) diff --git a/lux-cl/source/program.lux b/lux-cl/source/program.lux index 38a1fa02f9..14b02ebbed 100644 --- a/lux-cl/source/program.lux +++ b/lux-cl/source/program.lux @@ -385,7 +385,7 @@ (_.list/* (list))))] (_.call/2 [(runtime.lux//program_args raw_inputs) _.nil] program))) -(for .old +(for .jvm (the extender Extender ... TODO: Stop relying on coercions ASAP. diff --git a/lux-lua/source/program.lux b/lux-lua/source/program.lux index 58e9c38f1b..15492aa3bf 100644 --- a/lux-lua/source/program.lux +++ b/lux-lua/source/program.lux @@ -72,806 +72,797 @@ [program ["/" compositor]]) -(expansion.let [ (these (ffi.import java/lang/String - "[1]::[0]") - - (ffi.import (java/lang/Class a) - "[1]::[0]") - - (ffi.import java/lang/Object - "[1]::[0]" - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))) - - (ffi.import java/lang/Integer - "[1]::[0]") - - (ffi.import java/lang/Long - "[1]::[0]" - (intValue [] int)) - - (ffi.import net/sandius/rembulan/StateContext - "[1]::[0]") - - (ffi.import net/sandius/rembulan/impl/StateContexts - "[1]::[0]" - ("static" newDefaultInstance [] net/sandius/rembulan/StateContext)) - - (ffi.import net/sandius/rembulan/env/RuntimeEnvironment - "[1]::[0]") - - (ffi.import net/sandius/rembulan/env/RuntimeEnvironments - "[1]::[0]" - ("static" system [] net/sandius/rembulan/env/RuntimeEnvironment)) - - (ffi.import net/sandius/rembulan/Table - "[1]::[0]" - (rawget "as" get_idx [long] "?" java/lang/Object) - (rawget "as" get_key [java/lang/Object] "?" java/lang/Object) - (rawlen [] long)) - - (ffi.import net/sandius/rembulan/ByteString - "[1]::[0]" - (decode [] java/lang/String)) - - (ffi.import net/sandius/rembulan/impl/DefaultTable - "[1]::[0]") - - (ffi.import net/sandius/rembulan/impl/ImmutableTable - "[1]::[0]") - - (ffi.import net/sandius/rembulan/impl/ImmutableTable$Builder - "[1]::[0]" - (new []) - (build [] net/sandius/rembulan/impl/ImmutableTable)) - - (ffi.import net/sandius/rembulan/lib/StandardLibrary - "[1]::[0]" - ("static" in [net/sandius/rembulan/env/RuntimeEnvironment] net/sandius/rembulan/lib/StandardLibrary) - (installInto [net/sandius/rembulan/StateContext] net/sandius/rembulan/Table)) - - (ffi.import net/sandius/rembulan/Variable - "[1]::[0]" - (new [java/lang/Object])) - - (ffi.import net/sandius/rembulan/runtime/ReturnBuffer - "[1]::[0]" - (setTo [java/lang/Object] void)) - - (ffi.import net/sandius/rembulan/runtime/ExecutionContext - "[1]::[0]" - (getReturnBuffer [] net/sandius/rembulan/runtime/ReturnBuffer)) - - (ffi.import net/sandius/rembulan/runtime/ResolvedControlThrowable - "[1]::[0]") - - (ffi.import net/sandius/rembulan/runtime/LuaFunction - "[1]::[0]") - - (ffi.import net/sandius/rembulan/load/ChunkLoader - "[1]::[0]" - (loadTextChunk [net/sandius/rembulan/Variable - java/lang/String - java/lang/String] - "try" net/sandius/rembulan/runtime/LuaFunction)) - - (ffi.import net/sandius/rembulan/compiler/CompilerChunkLoader - "[1]::[0]" - ("static" of [java/lang/String] net/sandius/rembulan/compiler/CompilerChunkLoader)) - - (ffi.import net/sandius/rembulan/runtime/SchedulingContext - "[1]::[0]") - - (ffi.import net/sandius/rembulan/runtime/SchedulingContextFactory - "[1]::[0]") - - (ffi.import net/sandius/rembulan/exec/DirectCallExecutor - "[1]::[0]" - ("static" newExecutor [] net/sandius/rembulan/exec/DirectCallExecutor) - (schedulingContextFactory [] net/sandius/rembulan/runtime/SchedulingContextFactory) - (call [net/sandius/rembulan/StateContext java/lang/Object [java/lang/Object]] "try" [java/lang/Object])) - - (exception.the (unknown_kind_of_object object) - (Exception java/lang/Object) - (exception.report - (list ["Class" (ffi.of_string (java/lang/Object::toString [] (java/lang/Object::getClass [] object)))] - ["Object" (ffi.of_string (java/lang/Object::toString [] object))]))) - - (ffi.interface LuxValue - (getValue [] java/lang/Object)) - - (ffi.import LuxValue - "[1]::[0]" - (getValue [] java/lang/Object)) - - (every Translator - (-> java/lang/Object (Try Any))) - - (the (read_variant read host_object) - (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) - (when [(net/sandius/rembulan/Table::get_key [(as java/lang/Object runtime.variant_tag_field)] host_object) - (net/sandius/rembulan/Table::get_key [(as java/lang/Object runtime.variant_flag_field)] host_object) - (net/sandius/rembulan/Table::get_key [(as java/lang/Object runtime.variant_value_field)] host_object)] - (^.multi [{.#Some tag} ?flag {.#Some value}] - [(read value) - {try.#Success value}]) - {try.#Success [(is Any (|> tag - (as Int) - ffi.as_long - (java/lang/Long::intValue []) - (is java/lang/Integer))) - (is Any (when ?flag - {.#Some _} (is Any "") - {.#None} (as Any (ffi.null)))) - (is Any value)]} - - _ - (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]))) - - (the (read_tuple read host_object) - (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) - (let [init_num_keys (.nat (ffi.of_long (net/sandius/rembulan/Table::rawlen [] host_object)))] - (loop (again [num_keys init_num_keys - idx 0 - output (is (Array java/lang/Object) - (array.empty init_num_keys))]) - (if (n.< num_keys idx) - (when (net/sandius/rembulan/Table::get_idx [(ffi.as_long (.int (++ idx)))] host_object) - {.#None} - (again num_keys (++ idx) output) - - {.#Some member} - (when (read member) - {try.#Success parsed_member} - (again num_keys (++ idx) (array.has! idx (as java/lang/Object parsed_member) output)) - - {try.#Failure error} - {try.#Failure error})) - {try.#Success output})))) - - (exception.the .public nil_has_no_lux_representation) - - (the (read host_object) - Translator - (`` (<| (if (ffi.null? host_object) - (exception.except ..nil_has_no_lux_representation [])) - (,, (template.with [ ] - [(when (ffi.as host_object) - {.#Some typed_object} - (|> typed_object ) - - _)] - - [LuxValue (<| {try.#Success} (LuxValue::getValue []))] - [java/lang/Boolean {try.#Success}] - [java/lang/Long {try.#Success}] - [java/lang/Double {try.#Success}] - [java/lang/String {try.#Success}] - [net/sandius/rembulan/ByteString (<| {try.#Success} (net/sandius/rembulan/ByteString::decode []))] - [net/sandius/rembulan/runtime/LuaFunction {try.#Success}] - )) - (when (ffi.as net/sandius/rembulan/impl/DefaultTable host_object) - {.#Some typed_object} - (when (read_variant read typed_object) - {try.#Failure error} - (read_tuple read typed_object) - - success - success) - - _) - (exception.except ..unknown_kind_of_object [host_object]) - ))) - - (the (return ec value) - (-> net/sandius/rembulan/runtime/ExecutionContext Any Any) - (|> ec - (net/sandius/rembulan/runtime/ExecutionContext::getReturnBuffer []) - (net/sandius/rembulan/runtime/ReturnBuffer::setTo [(as java/lang/Object value)]))) - - (the (function/* arity) - (-> Nat Code) - (` (.-> (,* (list.repeated arity (` .Any))) - .Any))) - - (the input/* - (-> Nat (List Code)) - (|>> list.indices - (list#each (|>> %.nat (%.message "input/") code.local)))) - - (the declaration/* - (-> Nat (List Code)) - (|>> ..input/* - (list#each (function (_ $input) - (list $input (' java/lang/Object)))) - list#conjoint)) - - (the read/* - (-> Nat (List Code)) - (|>> ..input/* - (list#each (function (_ $input) - (list $input (` (..read (, $input)))))) - list#conjoint)) - - (the (apply/* to_host self parameters abstraction) - (-> (-> Any java/lang/Object) net/sandius/rembulan/runtime/LuaFunction (List java/lang/Object) Any Any) - (<| try.trusted - (do [! try.monad] - [input/* (monad.each ! ..read parameters)] - (loop (again [lux_function abstraction - input/* input/*]) - (`` (`` (when input/* - (list) - (in self) - - (,, (template.with [] - [(list (,, (static.literals function.identity (..input/* )))) - (in (to_host ((as (,, (static.literal function.identity (..function/* ))) - lux_function) - (,, (static.literals function.identity (..input/* ))))))] - - [1] - [2] - [3] - [4] - [5] - )) - - (list.partial (,, (static.literals function.identity (..input/* 5))) input/+) - (again ((as (,, (static.literal function.identity (..function/* 5))) - lux_function) - (,, (static.literals function.identity (..input/* 5)))) - input/+) - ))))))) - - (the (lua_function to_host lux_function) - (-> (-> Any java/lang/Object) Any net/sandius/rembulan/runtime/LuaFunction) - (<| (as net/sandius/rembulan/runtime/LuaFunction) - (`` (`` (ffi.object [] net/sandius/rembulan/runtime/LuaFunction [LuxValue] - [] - ... Methods - (LuxValue - [] (getValue self []) java/lang/Object - (as java/lang/Object lux_function)) - - (net/sandius/rembulan/runtime/LuaFunction - [] (invoke self [% net/sandius/rembulan/runtime/ExecutionContext]) - void - "throws" [net/sandius/rembulan/runtime/ResolvedControlThrowable] - (<| (..return %) - self)) - - (,, (template.with [] - [(net/sandius/rembulan/runtime/LuaFunction - [] (invoke self [% net/sandius/rembulan/runtime/ExecutionContext - (,, (static.literals function.identity (..declaration/* )))]) - void - "throws" [net/sandius/rembulan/runtime/ResolvedControlThrowable] - (<| (..return %) - (apply/* to_host - (ffi.is net/sandius/rembulan/runtime/LuaFunction self) - (list (,, (static.literals function.identity (..input/* )))) - lux_function)))] - - [1] - [2] - [3] - [4] - [5] - )) - - (net/sandius/rembulan/runtime/LuaFunction - [] (invoke self [% net/sandius/rembulan/runtime/ExecutionContext - input/* [java/lang/Object]]) - void - "throws" [net/sandius/rembulan/runtime/ResolvedControlThrowable] - (<| (..return %) - (apply/* to_host - (ffi.is net/sandius/rembulan/runtime/LuaFunction self) - (array.list {.#None} input/*) - lux_function))) - ))))) - - (ffi.import library/lux/Function - "[1]::[0]") - - (the (lux_structure to_host value) - (-> (-> Any java/lang/Object) (Array java/lang/Object) LuxValue) - (<| (ffi.is LuxValue) - (ffi.object [] net/sandius/rembulan/impl/DefaultTable [LuxValue] - [] - ... Methods - (LuxValue - [] (getValue self []) java/lang/Object - (as java/lang/Object value)) - - (net/sandius/rembulan/impl/DefaultTable - [] (rawlen self []) long - (|> value array.size .int ffi.as_long)) - - (net/sandius/rembulan/impl/DefaultTable - [] (rawget self [idx long]) java/lang/Object - (|> value - (array.item (|> idx ffi.of_long .nat --)) - try.trusted - to_host)) - - (net/sandius/rembulan/impl/DefaultTable - [] (rawget self [field java/lang/Object]) - java/lang/Object - (when (ffi.as net/sandius/rembulan/ByteString field) - {.#Some field} - (when (ffi.of_string (net/sandius/rembulan/ByteString::decode [] field)) - runtime.variant_tag_field - (when (array.item 0 value) - {try.#Success it} - (|> it - (as java/lang/Integer) - (ffi.is java/lang/Object)) - - {try.#Failure _} - (undefined)) - - runtime.variant_flag_field - (when (array.item 1 value) - {try.#Success _} - (as java/lang/Object "") - - {try.#Failure _} - (ffi.null)) - - runtime.variant_value_field - (|> value - (array.item 2) - try.trusted - to_host) - - "n" - (|> value - array.size - .int - ffi.as_long - (ffi.is java/lang/Object)) - - _ - (panic! (exception.error ..unknown_kind_of_object [(as java/lang/Object field)]))) - - {.#None} - (when (ffi.as java/lang/Long field) - {.#Some idx} - (when (array.item (|> idx ffi.of_long .nat --) value) - {try.#Success it} - (to_host it) - - {try.#Failure _} - (is java/lang/Object (ffi.null))) - - {.#None} - (panic! (exception.error ..unknown_kind_of_object [(as java/lang/Object field)]))))) - ))) - - (exception.the (cannot_apply_a_non_function object) - (Exception java/lang/Object) - (exception.report - (list ["Non-function" (ffi.of_string (java/lang/Object::toString [] object))]))) - - (the ensure_function - (-> Macro (Maybe net/sandius/rembulan/runtime/LuaFunction)) - (|>> (as java/lang/Object) - (ffi.as net/sandius/rembulan/runtime/LuaFunction))) - - (every Baggage - [net/sandius/rembulan/StateContext - net/sandius/rembulan/exec/DirectCallExecutor]) - - (the (call_macro to_host [state_context executor] inputs lux macro) - (-> (-> Any java/lang/Object) Baggage (List Code) Lux net/sandius/rembulan/runtime/LuaFunction (Try Any)) - (do try.monad - [.let [inputs (is (ffi.type [java/lang/Object]) - (|> (array.empty 2) - (array.has! 0 ... (as java/lang/Object inputs) - ... (net/sandius/rembulan/impl/ImmutableTable$Builder::build [] (net/sandius/rembulan/impl/ImmutableTable$Builder::new [])) - (as java/lang/Object (lux_structure to_host (as (Array java/lang/Object) inputs)))) - (array.has! 1 ... (as java/lang/Object lux) - ... (net/sandius/rembulan/impl/ImmutableTable$Builder::build [] (net/sandius/rembulan/impl/ImmutableTable$Builder::new [])) - (as java/lang/Object (lux_structure to_host (as (Array java/lang/Object) lux))))))] - output (net/sandius/rembulan/exec/DirectCallExecutor::call [state_context (as java/lang/Object macro) inputs] executor)] - (|> output - (array.item 0) +(for .jvm (these (ffi.import java/lang/String + "[1]::[0]") + + (ffi.import (java/lang/Class a) + "[1]::[0]") + + (ffi.import java/lang/Object + "[1]::[0]" + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))) + + (ffi.import java/lang/Integer + "[1]::[0]") + + (ffi.import java/lang/Long + "[1]::[0]" + (intValue [] int)) + + (ffi.import net/sandius/rembulan/StateContext + "[1]::[0]") + + (ffi.import net/sandius/rembulan/impl/StateContexts + "[1]::[0]" + ("static" newDefaultInstance [] net/sandius/rembulan/StateContext)) + + (ffi.import net/sandius/rembulan/env/RuntimeEnvironment + "[1]::[0]") + + (ffi.import net/sandius/rembulan/env/RuntimeEnvironments + "[1]::[0]" + ("static" system [] net/sandius/rembulan/env/RuntimeEnvironment)) + + (ffi.import net/sandius/rembulan/Table + "[1]::[0]" + (rawget "as" get_idx [long] "?" java/lang/Object) + (rawget "as" get_key [java/lang/Object] "?" java/lang/Object) + (rawlen [] long)) + + (ffi.import net/sandius/rembulan/ByteString + "[1]::[0]" + (decode [] java/lang/String)) + + (ffi.import net/sandius/rembulan/impl/DefaultTable + "[1]::[0]") + + (ffi.import net/sandius/rembulan/impl/ImmutableTable + "[1]::[0]") + + (ffi.import net/sandius/rembulan/impl/ImmutableTable$Builder + "[1]::[0]" + (new []) + (build [] net/sandius/rembulan/impl/ImmutableTable)) + + (ffi.import net/sandius/rembulan/lib/StandardLibrary + "[1]::[0]" + ("static" in [net/sandius/rembulan/env/RuntimeEnvironment] net/sandius/rembulan/lib/StandardLibrary) + (installInto [net/sandius/rembulan/StateContext] net/sandius/rembulan/Table)) + + (ffi.import net/sandius/rembulan/Variable + "[1]::[0]" + (new [java/lang/Object])) + + (ffi.import net/sandius/rembulan/runtime/ReturnBuffer + "[1]::[0]" + (setTo [java/lang/Object] void)) + + (ffi.import net/sandius/rembulan/runtime/ExecutionContext + "[1]::[0]" + (getReturnBuffer [] net/sandius/rembulan/runtime/ReturnBuffer)) + + (ffi.import net/sandius/rembulan/runtime/ResolvedControlThrowable + "[1]::[0]") + + (ffi.import net/sandius/rembulan/runtime/LuaFunction + "[1]::[0]") + + (ffi.import net/sandius/rembulan/load/ChunkLoader + "[1]::[0]" + (loadTextChunk [net/sandius/rembulan/Variable + java/lang/String + java/lang/String] + "try" net/sandius/rembulan/runtime/LuaFunction)) + + (ffi.import net/sandius/rembulan/compiler/CompilerChunkLoader + "[1]::[0]" + ("static" of [java/lang/String] net/sandius/rembulan/compiler/CompilerChunkLoader)) + + (ffi.import net/sandius/rembulan/runtime/SchedulingContext + "[1]::[0]") + + (ffi.import net/sandius/rembulan/runtime/SchedulingContextFactory + "[1]::[0]") + + (ffi.import net/sandius/rembulan/exec/DirectCallExecutor + "[1]::[0]" + ("static" newExecutor [] net/sandius/rembulan/exec/DirectCallExecutor) + (schedulingContextFactory [] net/sandius/rembulan/runtime/SchedulingContextFactory) + (call [net/sandius/rembulan/StateContext java/lang/Object [java/lang/Object]] "try" [java/lang/Object])) + + (exception.the (unknown_kind_of_object object) + (Exception java/lang/Object) + (exception.report + (list ["Class" (ffi.of_string (java/lang/Object::toString [] (java/lang/Object::getClass [] object)))] + ["Object" (ffi.of_string (java/lang/Object::toString [] object))]))) + + (ffi.interface LuxValue + (getValue [] java/lang/Object)) + + (ffi.import LuxValue + "[1]::[0]" + (getValue [] java/lang/Object)) + + (every Translator + (-> java/lang/Object (Try Any))) + + (the (read_variant read host_object) + (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) + (when [(net/sandius/rembulan/Table::get_key [(as java/lang/Object runtime.variant_tag_field)] host_object) + (net/sandius/rembulan/Table::get_key [(as java/lang/Object runtime.variant_flag_field)] host_object) + (net/sandius/rembulan/Table::get_key [(as java/lang/Object runtime.variant_value_field)] host_object)] + (^.multi [{.#Some tag} ?flag {.#Some value}] + [(read value) + {try.#Success value}]) + {try.#Success [(is Any (|> tag + (as Int) + ffi.as_long + (java/lang/Long::intValue []) + (is java/lang/Integer))) + (is Any (when ?flag + {.#Some _} (is Any "") + {.#None} (as Any (ffi.null)))) + (is Any value)]} + + _ + (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]))) + + (the (read_tuple read host_object) + (-> Translator net/sandius/rembulan/impl/DefaultTable (Try Any)) + (let [init_num_keys (.nat (ffi.of_long (net/sandius/rembulan/Table::rawlen [] host_object)))] + (loop (again [num_keys init_num_keys + idx 0 + output (is (Array java/lang/Object) + (array.empty init_num_keys))]) + (if (n.< num_keys idx) + (when (net/sandius/rembulan/Table::get_idx [(ffi.as_long (.int (++ idx)))] host_object) + {.#None} + (again num_keys (++ idx) output) + + {.#Some member} + (when (read member) + {try.#Success parsed_member} + (again num_keys (++ idx) (array.has! idx (as java/lang/Object parsed_member) output)) + + {try.#Failure error} + {try.#Failure error})) + {try.#Success output})))) + + (exception.the .public nil_has_no_lux_representation) + + (the (read host_object) + Translator + (`` (<| (if (ffi.null? host_object) + (exception.except ..nil_has_no_lux_representation [])) + (,, (template.with [ ] + [(when (ffi.as host_object) + {.#Some typed_object} + (|> typed_object ) + + _)] + + [LuxValue (<| {try.#Success} (LuxValue::getValue []))] + [java/lang/Boolean {try.#Success}] + [java/lang/Long {try.#Success}] + [java/lang/Double {try.#Success}] + [java/lang/String {try.#Success}] + [net/sandius/rembulan/ByteString (<| {try.#Success} (net/sandius/rembulan/ByteString::decode []))] + [net/sandius/rembulan/runtime/LuaFunction {try.#Success}] + )) + (when (ffi.as net/sandius/rembulan/impl/DefaultTable host_object) + {.#Some typed_object} + (when (read_variant read typed_object) + {try.#Failure error} + (read_tuple read typed_object) + + success + success) + + _) + (exception.except ..unknown_kind_of_object [host_object]) + ))) + + (the (return ec value) + (-> net/sandius/rembulan/runtime/ExecutionContext Any Any) + (|> ec + (net/sandius/rembulan/runtime/ExecutionContext::getReturnBuffer []) + (net/sandius/rembulan/runtime/ReturnBuffer::setTo [(as java/lang/Object value)]))) + + (the (function/* arity) + (-> Nat Code) + (` (.-> (,* (list.repeated arity (` .Any))) + .Any))) + + (the input/* + (-> Nat (List Code)) + (|>> list.indices + (list#each (|>> %.nat (%.message "input/") code.local)))) + + (the declaration/* + (-> Nat (List Code)) + (|>> ..input/* + (list#each (function (_ $input) + (list $input (' java/lang/Object)))) + list#conjoint)) + + (the read/* + (-> Nat (List Code)) + (|>> ..input/* + (list#each (function (_ $input) + (list $input (` (..read (, $input)))))) + list#conjoint)) + + (the (apply/* to_host self parameters abstraction) + (-> (-> Any java/lang/Object) net/sandius/rembulan/runtime/LuaFunction (List java/lang/Object) Any Any) + (<| try.trusted + (do [! try.monad] + [input/* (monad.each ! ..read parameters)] + (loop (again [lux_function abstraction + input/* input/*]) + (`` (`` (when input/* + (list) + (in self) + + (,, (template.with [] + [(list (,, (static.literals function.identity (..input/* )))) + (in (to_host ((as (,, (static.literal function.identity (..function/* ))) + lux_function) + (,, (static.literals function.identity (..input/* ))))))] + + [1] + [2] + [3] + [4] + [5] + )) + + (list.partial (,, (static.literals function.identity (..input/* 5))) input/+) + (again ((as (,, (static.literal function.identity (..function/* 5))) + lux_function) + (,, (static.literals function.identity (..input/* 5)))) + input/+) + ))))))) + + (the (lua_function to_host lux_function) + (-> (-> Any java/lang/Object) Any net/sandius/rembulan/runtime/LuaFunction) + (<| (as net/sandius/rembulan/runtime/LuaFunction) + (`` (`` (ffi.object [] net/sandius/rembulan/runtime/LuaFunction [LuxValue] + [] + ... Methods + (LuxValue + [] (getValue self []) java/lang/Object + (as java/lang/Object lux_function)) + + (net/sandius/rembulan/runtime/LuaFunction + [] (invoke self [% net/sandius/rembulan/runtime/ExecutionContext]) + void + "throws" [net/sandius/rembulan/runtime/ResolvedControlThrowable] + (<| (..return %) + self)) + + (,, (template.with [] + [(net/sandius/rembulan/runtime/LuaFunction + [] (invoke self [% net/sandius/rembulan/runtime/ExecutionContext + (,, (static.literals function.identity (..declaration/* )))]) + void + "throws" [net/sandius/rembulan/runtime/ResolvedControlThrowable] + (<| (..return %) + (apply/* to_host + (ffi.is net/sandius/rembulan/runtime/LuaFunction self) + (list (,, (static.literals function.identity (..input/* )))) + lux_function)))] + + [1] + [2] + [3] + [4] + [5] + )) + + (net/sandius/rembulan/runtime/LuaFunction + [] (invoke self [% net/sandius/rembulan/runtime/ExecutionContext + input/* [java/lang/Object]]) + void + "throws" [net/sandius/rembulan/runtime/ResolvedControlThrowable] + (<| (..return %) + (apply/* to_host + (ffi.is net/sandius/rembulan/runtime/LuaFunction self) + (array.list {.#None} input/*) + lux_function))) + ))))) + + (ffi.import library/lux/Function + "[1]::[0]") + + (the (lux_structure to_host value) + (-> (-> Any java/lang/Object) (Array java/lang/Object) LuxValue) + (<| (ffi.is LuxValue) + (ffi.object [] net/sandius/rembulan/impl/DefaultTable [LuxValue] + [] + ... Methods + (LuxValue + [] (getValue self []) java/lang/Object + (as java/lang/Object value)) + + (net/sandius/rembulan/impl/DefaultTable + [] (rawlen self []) long + (|> value array.size .int ffi.as_long)) + + (net/sandius/rembulan/impl/DefaultTable + [] (rawget self [idx long]) java/lang/Object + (|> value + (array.item (|> idx ffi.of_long .nat --)) + try.trusted + to_host)) + + (net/sandius/rembulan/impl/DefaultTable + [] (rawget self [field java/lang/Object]) + java/lang/Object + (when (ffi.as net/sandius/rembulan/ByteString field) + {.#Some field} + (when (ffi.of_string (net/sandius/rembulan/ByteString::decode [] field)) + runtime.variant_tag_field + (when (array.item 0 value) + {try.#Success it} + (|> it + (as java/lang/Integer) + (ffi.is java/lang/Object)) + + {try.#Failure _} + (undefined)) + + runtime.variant_flag_field + (when (array.item 1 value) + {try.#Success _} + (as java/lang/Object "") + + {try.#Failure _} + (ffi.null)) + + runtime.variant_value_field + (|> value + (array.item 2) + try.trusted + to_host) + + "n" + (|> value + array.size + .int + ffi.as_long + (ffi.is java/lang/Object)) + + _ + (panic! (exception.error ..unknown_kind_of_object [(as java/lang/Object field)]))) + + {.#None} + (when (ffi.as java/lang/Long field) + {.#Some idx} + (when (array.item (|> idx ffi.of_long .nat --) value) + {try.#Success it} + (to_host it) + + {try.#Failure _} + (is java/lang/Object (ffi.null))) + + {.#None} + (panic! (exception.error ..unknown_kind_of_object [(as java/lang/Object field)]))))) + ))) + + (exception.the (cannot_apply_a_non_function object) + (Exception java/lang/Object) + (exception.report + (list ["Non-function" (ffi.of_string (java/lang/Object::toString [] object))]))) + + (the ensure_function + (-> Macro (Maybe net/sandius/rembulan/runtime/LuaFunction)) + (|>> (as java/lang/Object) + (ffi.as net/sandius/rembulan/runtime/LuaFunction))) + + (every Baggage + [net/sandius/rembulan/StateContext + net/sandius/rembulan/exec/DirectCallExecutor]) + + (the (call_macro to_host [state_context executor] inputs lux macro) + (-> (-> Any java/lang/Object) Baggage (List Code) Lux net/sandius/rembulan/runtime/LuaFunction (Try Any)) + (do try.monad + [.let [inputs (is (ffi.type [java/lang/Object]) + (|> (array.empty 2) + (array.has! 0 ... (as java/lang/Object inputs) + ... (net/sandius/rembulan/impl/ImmutableTable$Builder::build [] (net/sandius/rembulan/impl/ImmutableTable$Builder::new [])) + (as java/lang/Object (lux_structure to_host (as (Array java/lang/Object) inputs)))) + (array.has! 1 ... (as java/lang/Object lux) + ... (net/sandius/rembulan/impl/ImmutableTable$Builder::build [] (net/sandius/rembulan/impl/ImmutableTable$Builder::new [])) + (as java/lang/Object (lux_structure to_host (as (Array java/lang/Object) lux))))))] + output (net/sandius/rembulan/exec/DirectCallExecutor::call [state_context (as java/lang/Object macro) inputs] executor)] + (|> output + (array.item 0) + try.trusted + (as java/lang/Object) + ..read))) + + (the (expander to_host baggage macro inputs lux) + (-> (-> Any java/lang/Object) Baggage Expander) + (when (..ensure_function macro) + {.#Some macro} + (when (..call_macro to_host baggage inputs lux macro) + {try.#Success output} + (|> output + (as (Try [Lux (List Code)])) + {try.#Success}) + + {try.#Failure error} + {try.#Failure error}) + + {.#None} + (exception.except ..cannot_apply_a_non_function (as java/lang/Object macro))))) + + .lua + (the (expander macro inputs lux) + Expander + {try.#Success ((as Macro' macro) inputs lux)})) + +(for .jvm (these (expansion.let [$var_args (_.var "...") + $str_rel_to_abs (_.var "_utf8_str_rel_to_abs") + $decode (_.var "_utf8_decode")] + (local.let [!int (template.macro (_ ) + [(_.int (.int (hex )))]) + !&| (template.macro (_ ) + [(|> + (_.bit_and (!int )) + (_.bit_or (!int )))]) + !&|< (template.macro (_ ) + [(|> + (_.bit_shr (_.int )) + (_.bit_and (!int )) + (_.bit_or (!int )))])] + (these (the rembulan//char + (let [$buffer (_.var "buffer") + $k (_.var "k") + $v (_.var "v") + $b1 (_.var "b1") + $b2 (_.var "b2") + $b3 (_.var "b3") + $b4 (_.var "b4") + table/insert (function (_ in/0 in/1) (_.apply (list in/0 in/1) (_.var "table.insert")))] + (_.function (_.var "utf8.char") (list $var_args) + (all _.then + (_.local/1 $buffer (_.array (list))) + (<| (_.for_in (list $k $v) (_.ipairs/1 (_.array (list $var_args)))) + (all _.then + (_.when (_.or (_.< (_.int +0) $v) + (_.> (!int "10FFFF") $v)) + (_.statement (_.error/2 (|> (_.string "bad argument #") + (_.concat $k) + (_.concat (_.string " to char (out of range)"))) + (_.int +2)))) + (<| (_.if (_.< (!int "80") $v) + ... Single-byte sequence + (_.statement (|> (_.var "string.char") + (_.apply (list $v)) + (table/insert $buffer)))) + (_.if (_.< (!int "800") $v) + ... Two-byte sequence + (_.statement (|> (_.var "string.char") + (_.apply (list (!&|< "C0" "1F" +6 $v) + (!&| "80" "3F" $v))) + (table/insert $buffer)))) + (_.if (_.< (!int "10000") $v) + ... Three-byte sequence + (_.statement (|> (_.var "string.char") + (_.apply (list (!&|< "E0" "0F" +12 $v) + (!&|< "80" "3F" +6 $v) + (!&| "80" "3F" $v))) + (table/insert $buffer)))) + ... Four-byte sequence + (_.statement (|> (_.var "string.char") + (_.apply (list (!&|< "F0" "07" +18 $v) + (!&|< "80" "3F" +12 $v) + (!&|< "80" "3F" +6 $v) + (!&| "80" "3F" $v))) + (table/insert $buffer)))) + )) + (_.return (_.apply (list $buffer (_.string "")) (_.var "table.concat"))) + )))) + + ... (the rembulan//str_rel_to_abs + ... (let [$string (_.var "string") + ... $args (_.var "args") + ... $k (_.var "k") + ... $v (_.var "v")] + ... (<| (_.local_function $str_rel_to_abs (list $string $var_args)) + ... (all _.then + ... (_.local/1 $args (_.array (list $var_args))) + ... (<| (_.for_in (list $k $v) (_.ipairs/1 $args)) + ... (all _.then + ... (_.if (_.> (_.int +0) $v) + ... (_.set (list $v) $v) + ... (_.set (list $v) (|> $v (_.+ (_.length $string)) (_.+ (_.int +1))))) + ... (_.when (_.or (_.< (_.int +1) $v) + ... (_.> (_.length $string) $v)) + ... (_.statement (_.error/2 (_.string "bad index to string (out of range)") (_.int +3)))) + ... (_.set (list (_.nth $k $args)) $v))) + ... (_.return (_.apply (list $args) (_.var "table.unpack"))) + ... )))) + + ... (the rembulan//decode + ... (let [$string (_.var "string") + ... $start (_.var "start") + ... $b1 (_.var "b1") + ... $idx (_.var "idx") + ... $bx (_.var "bx") + ... $end (_.var "_end")] + ... (<| (_.local_function $decode (list $string $start)) + ... (all _.then + ... (_.set (list $start) (_.apply (list $string (_.or (_.int +1) $start)) $str_rel_to_abs)) + ... (_.local/1 $b1 (_.do "byte" (list $start $start) $string)) + ... (<| (_.if (_.< (!int "80") $b1) + ... ... Single-byte sequence + ... (_.return (_.multi (list $start $start)))) + ... ... Validate first byte of multi-byte sequence + ... (_.if (_.or (_.> (!int "F4") $b1) + ... (_.< (!int "C2") $b1)) + ... (_.return _.nil)) + ... ... Get 'supposed' amount of continuation bytes from primary byte + ... (all _.then + ... (_.local/1 $end (|> (|> $b1 (_.>= (!int "F0")) (_.and (_.int +3))) + ... (_.or (|> $b1 (_.>= (!int "E0")) (_.and (_.int +2)))) + ... (_.or (|> $b1 (_.>= (!int "C0")) (_.and (_.int +1)))) + ... (_.+ $start))) + ... ... Validate our continuation bytes + ... (<| (_.for_in (list $idx $bx) (_.ipairs/1 (_.array (list (_.do "byte" + ... (list (_.+ (_.int +1) $start) $end) + ... $string))))) + ... (_.when (|> $bx + ... (_.bit_and (!int "C0")) + ... (_.= (!int "80")) + ... _.not) + ... (_.return _.nil))) + ... (_.return (_.multi (list $start $end))) + ... )) + ... )))) + + ... (the rembulan//codes + ... (let [$string (_.var "string") + ... $i (_.var "i") + ... $start (_.var "start") + ... $end (_.var "_end")] + ... (_.function (_.var "utf8.codes") (list $string) + ... (all _.then + ... (_.local/1 $i (_.int +1)) + ... (_.return (<| (_.closure (list)) + ... (_.if (_.> (_.length $string) $i) + ... (_.return _.nil) + ... (all _.then + ... (_.let (list $start $end) (_.apply (list $string $i) $decode)) + ... (_.if (_.not $start) + ... (_.statement (_.error/2 (_.string "invalid UTF-8 code") (_.int +2))) + ... (all _.then + ... (_.set (list $i) (_.+ (_.int +1) $end)) + ... (_.return (_.multi (list $start (_.do "sub" (list $start $end) $string)))) + ... )) + ... )))) + ... )))) + + ... (the rembulan//len + ... (let [$string (_.var "string") + ... $start (_.var "start") + ... $end (_.var "_end") + ... $seq_start (_.var "seq_start") + ... $seq_end (_.var "seq_end") + ... $size (_.var "size")] + ... (_.function (_.var "utf8.len") (list $string $start $end) + ... (all _.then + ... (_.set (list $start $end) (_.apply (list $string (_.or (_.int +1) $start) (_.or (_.int -1) $end)) $str_rel_to_abs)) + ... (_.local/1 $size (_.int +0)) + ... (_.repeat (_.>= $end $seq_end) + ... (all _.then + ... (_.let (list $seq_start $seq_end) (_.apply (list $string $start) $decode)) + ... (_.if (_.not $seq_start) + ... ... Hit an invalid sequence! + ... (_.return (_.multi (list (_.boolean false) $start))) + ... (all _.then + ... (_.set (list $start) (_.+ (_.int +1) $seq_end)) + ... (_.set (list $size) (_.+ (_.int +1) $size)) + ... )) + ... )) + ... (_.return $size) + ... )))) + + ... (the rembulan//charpattern + ... (_.set (list (_.var "utf8.charpattern")) + ... (_.string "[%z\x01-\x7F\xC2-\xF4][\x80-\xBF]*"))) + + (the rembulan_prelude + _.Statement + (all _.then + (_.function (_.var "os.time") (list) + (_.return (_.int +0))) + + ... Ported from https://github.com/meepen/Lua-5.1-UTF-8 + ..rembulan//char + ... ..rembulan//str_rel_to_abs + ... ..rembulan//decode + ... ..rembulan//codes + ... ..rembulan//len + ... ..rembulan//charpattern + ))))) + + (the host + (IO [Baggage (Host _.Expression _.Statement)]) + (io (let [runtime_env (net/sandius/rembulan/env/RuntimeEnvironments::system []) + std_lib (net/sandius/rembulan/lib/StandardLibrary::in [runtime_env]) + state_context (net/sandius/rembulan/impl/StateContexts::newDefaultInstance []) + table (net/sandius/rembulan/lib/StandardLibrary::installInto [state_context] std_lib) + variable (net/sandius/rembulan/Variable::new [table]) + loader (net/sandius/rembulan/compiler/CompilerChunkLoader::of [(ffi.as_string "_lux_definition")]) + executor (net/sandius/rembulan/exec/DirectCallExecutor::newExecutor []) + scheduling_context (net/sandius/rembulan/exec/DirectCallExecutor::schedulingContextFactory [] executor) + value (is (-> _.Statement (Try Any)) + (function (_ code) + (do try.monad + [lua_function (net/sandius/rembulan/load/ChunkLoader::loadTextChunk [variable (ffi.as_string "lux compilation") (ffi.as_string (_.code code))] loader) + output (net/sandius/rembulan/exec/DirectCallExecutor::call [state_context (as java/lang/Object lua_function) (array.empty 0)] + executor)] + (when (array.item 0 output) + {try.#Failure _} + (in []) + + {try.#Success value} + (read value))))) + _ (try.trusted (value ..rembulan_prelude))] + [[state_context executor] + (is (Host _.Expression _.Statement) + (implementation + (the (evaluate [_ code]) + (value (_.return code))) + + (the execute value) + + (the (define context custom [_ input]) + (let [global (maybe.else (reference.artifact context) + custom) + @global (_.var global) + definition (_.set (list @global) input)] + (do try.monad + [_ (value definition) + value (value (_.return @global))] + (in [global value definition])))) + + (the (ingest context content) + (|> content + (of utf8.format projection) try.trusted - (as java/lang/Object) - ..read))) - - (the (expander to_host baggage macro inputs lux) - (-> (-> Any java/lang/Object) Baggage Expander) - (when (..ensure_function macro) - {.#Some macro} - (when (..call_macro to_host baggage inputs lux macro) - {try.#Success output} - (|> output - (as (Try [Lux (List Code)])) - {try.#Success}) - - {try.#Failure error} - {try.#Failure error}) - - {.#None} - (exception.except ..cannot_apply_a_non_function (as java/lang/Object macro)))))] - (for .old (these ) - .jvm (these ) - - .lua - (the (expander macro inputs lux) - Expander - {try.#Success ((as Macro' macro) inputs lux)}))) - -(expansion.let [ (these (expansion.let [$var_args (_.var "...") - $str_rel_to_abs (_.var "_utf8_str_rel_to_abs") - $decode (_.var "_utf8_decode")] - (local.let [!int (template.macro (_ ) - [(_.int (.int (hex )))]) - !&| (template.macro (_ ) - [(|> - (_.bit_and (!int )) - (_.bit_or (!int )))]) - !&|< (template.macro (_ ) - [(|> - (_.bit_shr (_.int )) - (_.bit_and (!int )) - (_.bit_or (!int )))])] - (these (the rembulan//char - (let [$buffer (_.var "buffer") - $k (_.var "k") - $v (_.var "v") - $b1 (_.var "b1") - $b2 (_.var "b2") - $b3 (_.var "b3") - $b4 (_.var "b4") - table/insert (function (_ in/0 in/1) (_.apply (list in/0 in/1) (_.var "table.insert")))] - (_.function (_.var "utf8.char") (list $var_args) - (all _.then - (_.local/1 $buffer (_.array (list))) - (<| (_.for_in (list $k $v) (_.ipairs/1 (_.array (list $var_args)))) - (all _.then - (_.when (_.or (_.< (_.int +0) $v) - (_.> (!int "10FFFF") $v)) - (_.statement (_.error/2 (|> (_.string "bad argument #") - (_.concat $k) - (_.concat (_.string " to char (out of range)"))) - (_.int +2)))) - (<| (_.if (_.< (!int "80") $v) - ... Single-byte sequence - (_.statement (|> (_.var "string.char") - (_.apply (list $v)) - (table/insert $buffer)))) - (_.if (_.< (!int "800") $v) - ... Two-byte sequence - (_.statement (|> (_.var "string.char") - (_.apply (list (!&|< "C0" "1F" +6 $v) - (!&| "80" "3F" $v))) - (table/insert $buffer)))) - (_.if (_.< (!int "10000") $v) - ... Three-byte sequence - (_.statement (|> (_.var "string.char") - (_.apply (list (!&|< "E0" "0F" +12 $v) - (!&|< "80" "3F" +6 $v) - (!&| "80" "3F" $v))) - (table/insert $buffer)))) - ... Four-byte sequence - (_.statement (|> (_.var "string.char") - (_.apply (list (!&|< "F0" "07" +18 $v) - (!&|< "80" "3F" +12 $v) - (!&|< "80" "3F" +6 $v) - (!&| "80" "3F" $v))) - (table/insert $buffer)))) - )) - (_.return (_.apply (list $buffer (_.string "")) (_.var "table.concat"))) - )))) - - ... (the rembulan//str_rel_to_abs - ... (let [$string (_.var "string") - ... $args (_.var "args") - ... $k (_.var "k") - ... $v (_.var "v")] - ... (<| (_.local_function $str_rel_to_abs (list $string $var_args)) - ... (all _.then - ... (_.local/1 $args (_.array (list $var_args))) - ... (<| (_.for_in (list $k $v) (_.ipairs/1 $args)) - ... (all _.then - ... (_.if (_.> (_.int +0) $v) - ... (_.set (list $v) $v) - ... (_.set (list $v) (|> $v (_.+ (_.length $string)) (_.+ (_.int +1))))) - ... (_.when (_.or (_.< (_.int +1) $v) - ... (_.> (_.length $string) $v)) - ... (_.statement (_.error/2 (_.string "bad index to string (out of range)") (_.int +3)))) - ... (_.set (list (_.nth $k $args)) $v))) - ... (_.return (_.apply (list $args) (_.var "table.unpack"))) - ... )))) - - ... (the rembulan//decode - ... (let [$string (_.var "string") - ... $start (_.var "start") - ... $b1 (_.var "b1") - ... $idx (_.var "idx") - ... $bx (_.var "bx") - ... $end (_.var "_end")] - ... (<| (_.local_function $decode (list $string $start)) - ... (all _.then - ... (_.set (list $start) (_.apply (list $string (_.or (_.int +1) $start)) $str_rel_to_abs)) - ... (_.local/1 $b1 (_.do "byte" (list $start $start) $string)) - ... (<| (_.if (_.< (!int "80") $b1) - ... ... Single-byte sequence - ... (_.return (_.multi (list $start $start)))) - ... ... Validate first byte of multi-byte sequence - ... (_.if (_.or (_.> (!int "F4") $b1) - ... (_.< (!int "C2") $b1)) - ... (_.return _.nil)) - ... ... Get 'supposed' amount of continuation bytes from primary byte - ... (all _.then - ... (_.local/1 $end (|> (|> $b1 (_.>= (!int "F0")) (_.and (_.int +3))) - ... (_.or (|> $b1 (_.>= (!int "E0")) (_.and (_.int +2)))) - ... (_.or (|> $b1 (_.>= (!int "C0")) (_.and (_.int +1)))) - ... (_.+ $start))) - ... ... Validate our continuation bytes - ... (<| (_.for_in (list $idx $bx) (_.ipairs/1 (_.array (list (_.do "byte" - ... (list (_.+ (_.int +1) $start) $end) - ... $string))))) - ... (_.when (|> $bx - ... (_.bit_and (!int "C0")) - ... (_.= (!int "80")) - ... _.not) - ... (_.return _.nil))) - ... (_.return (_.multi (list $start $end))) - ... )) - ... )))) - - ... (the rembulan//codes - ... (let [$string (_.var "string") - ... $i (_.var "i") - ... $start (_.var "start") - ... $end (_.var "_end")] - ... (_.function (_.var "utf8.codes") (list $string) - ... (all _.then - ... (_.local/1 $i (_.int +1)) - ... (_.return (<| (_.closure (list)) - ... (_.if (_.> (_.length $string) $i) - ... (_.return _.nil) - ... (all _.then - ... (_.let (list $start $end) (_.apply (list $string $i) $decode)) - ... (_.if (_.not $start) - ... (_.statement (_.error/2 (_.string "invalid UTF-8 code") (_.int +2))) - ... (all _.then - ... (_.set (list $i) (_.+ (_.int +1) $end)) - ... (_.return (_.multi (list $start (_.do "sub" (list $start $end) $string)))) - ... )) - ... )))) - ... )))) - - ... (the rembulan//len - ... (let [$string (_.var "string") - ... $start (_.var "start") - ... $end (_.var "_end") - ... $seq_start (_.var "seq_start") - ... $seq_end (_.var "seq_end") - ... $size (_.var "size")] - ... (_.function (_.var "utf8.len") (list $string $start $end) - ... (all _.then - ... (_.set (list $start $end) (_.apply (list $string (_.or (_.int +1) $start) (_.or (_.int -1) $end)) $str_rel_to_abs)) - ... (_.local/1 $size (_.int +0)) - ... (_.repeat (_.>= $end $seq_end) - ... (all _.then - ... (_.let (list $seq_start $seq_end) (_.apply (list $string $start) $decode)) - ... (_.if (_.not $seq_start) - ... ... Hit an invalid sequence! - ... (_.return (_.multi (list (_.boolean false) $start))) - ... (all _.then - ... (_.set (list $start) (_.+ (_.int +1) $seq_end)) - ... (_.set (list $size) (_.+ (_.int +1) $size)) - ... )) - ... )) - ... (_.return $size) - ... )))) - - ... (the rembulan//charpattern - ... (_.set (list (_.var "utf8.charpattern")) - ... (_.string "[%z\x01-\x7F\xC2-\xF4][\x80-\xBF]*"))) - - (the rembulan_prelude - _.Statement - (all _.then - (_.function (_.var "os.time") (list) - (_.return (_.int +0))) - - ... Ported from https://github.com/meepen/Lua-5.1-UTF-8 - ..rembulan//char - ... ..rembulan//str_rel_to_abs - ... ..rembulan//decode - ... ..rembulan//codes - ... ..rembulan//len - ... ..rembulan//charpattern - ))))) - - (the host - (IO [Baggage (Host _.Expression _.Statement)]) - (io (let [runtime_env (net/sandius/rembulan/env/RuntimeEnvironments::system []) - std_lib (net/sandius/rembulan/lib/StandardLibrary::in [runtime_env]) - state_context (net/sandius/rembulan/impl/StateContexts::newDefaultInstance []) - table (net/sandius/rembulan/lib/StandardLibrary::installInto [state_context] std_lib) - variable (net/sandius/rembulan/Variable::new [table]) - loader (net/sandius/rembulan/compiler/CompilerChunkLoader::of [(ffi.as_string "_lux_definition")]) - executor (net/sandius/rembulan/exec/DirectCallExecutor::newExecutor []) - scheduling_context (net/sandius/rembulan/exec/DirectCallExecutor::schedulingContextFactory [] executor) - value (is (-> _.Statement (Try Any)) - (function (_ code) - (do try.monad - [lua_function (net/sandius/rembulan/load/ChunkLoader::loadTextChunk [variable (ffi.as_string "lux compilation") (ffi.as_string (_.code code))] loader) - output (net/sandius/rembulan/exec/DirectCallExecutor::call [state_context (as java/lang/Object lua_function) (array.empty 0)] - executor)] - (when (array.item 0 output) - {try.#Failure _} - (in []) - - {try.#Success value} - (read value))))) - _ (try.trusted (value ..rembulan_prelude))] - [[state_context executor] - (is (Host _.Expression _.Statement) - (implementation - (the (evaluate [_ code]) - (value (_.return code))) - - (the execute value) - - (the (define context custom [_ input]) - (let [global (maybe.else (reference.artifact context) - custom) - @global (_.var global) - definition (_.set (list @global) input)] - (do try.monad - [_ (value definition) - value (value (_.return @global))] - (in [global value definition])))) - - (the (ingest context content) - (|> content - (of utf8.format projection) - try.trusted - (as _.Statement))) - - (the (re_learn context custom content) - (value content)) - - (the (re_load context custom content) - (do try.monad - [_ (value content)] - (value (_.return (_.var (reference.artifact context))))))))]))))] - (for .old (these ) - .jvm (these ) - .lua (these (ffi.import (load [ffi.String] "try" ffi.Function)) - (the host - (IO (Host _.Expression _.Statement)) - (io (let [value (is (-> _.Statement (Try Any)) - (function (_ code) - (do try.monad - [lua_function (..load (_.code code))] - (let [output ("lua apply" lua_function)] - {try.#Success (if ("lua object nil?" output) - [] - output)}))))] - (is (Host _.Expression _.Statement) - (implementation - (the (evaluate! context [_ code]) - (value (_.return code))) - - (the execute! value) - - (the (define! context custom [_ input]) - (let [global (maybe.else (reference.artifact context) - custom) - @global (_.var global)] - (do try.monad - [.let [definition (_.set (list @global) input)] - _ (value definition) - value (value (_.return @global))] - (in [global value definition])))) - - (the (ingest context content) - (|> content - (of utf8.format projection) - try.trusted - (as _.Statement))) - - (the (re_learn context custom content) - (value content)) - - (the (re_load context custom content) + (as _.Statement))) + + (the (re_learn context custom content) + (value content)) + + (the (re_load context custom content) + (do try.monad + [_ (value content)] + (value (_.return (_.var (reference.artifact context))))))))])))) + .lua (these (ffi.import (load [ffi.String] "try" ffi.Function)) + (the host + (IO (Host _.Expression _.Statement)) + (io (let [value (is (-> _.Statement (Try Any)) + (function (_ code) + (do try.monad + [lua_function (..load (_.code code))] + (let [output ("lua apply" lua_function)] + {try.#Success (if ("lua object nil?" output) + [] + output)}))))] + (is (Host _.Expression _.Statement) + (implementation + (the (evaluate! context [_ code]) + (value (_.return code))) + + (the execute! value) + + (the (define! context custom [_ input]) + (let [global (maybe.else (reference.artifact context) + custom) + @global (_.var global)] (do try.monad - [_ (value content)] - (value (_.return (_.var (reference.artifact context)))))))))))))) + [.let [definition (_.set (list @global) input)] + _ (value definition) + value (value (_.return @global))] + (in [global value definition])))) + + (the (ingest context content) + (|> content + (of utf8.format projection) + try.trusted + (as _.Statement))) + + (the (re_learn context custom content) + (value content)) + + (the (re_load context custom content) + (do try.monad + [_ (value content)] + (value (_.return (_.var (reference.artifact context))))))))))))) (the (phase_wrapper to_host) (-> (-> Any java/lang/Object) phase.Wrapper) - (for .old (..lua_function to_host) - .jvm (..lua_function to_host) + (for .jvm (..lua_function to_host) .lua (|>>))) -(expansion.let [ (these (the (to_host it) - (-> Any java/lang/Object) - (`` (<| (,, (template.with [ ] - [(when (ffi.as (as java/lang/Object it)) - {.#Some it} - (as java/lang/Object - ( [(as_expected it)])) - - {.#None})] - - [[java/lang/Object] (..lux_structure to_host)] - [library/lux/Function (..lua_function to_host)] - )) - (as java/lang/Object it)))) - - (the (extender [state_context executor]) - (-> Baggage Extender) - ... TODO: Stop relying on coercions ASAP. - (<| (as Extender) - (function (@self handler)) - (as Handler) - (function (@self phase)) - (as Phase) - (function (@self archive parameters)) - (as Operation) - (function (@self state)) - (as Try) - try.trusted - (as Try) - (do try.monad - [handler (try.of_maybe "Not an extension handler." - (..ensure_function handler)) - output (net/sandius/rembulan/exec/DirectCallExecutor::call [state_context - (as java/lang/Object handler) - (|> (array.empty 4) - (array.has! 0 (as java/lang/Object (phase_wrapper ..to_host phase))) - (array.has! 1 (..to_host archive)) - (array.has! 2 (..to_host parameters)) - (array.has! 3 (..to_host state)))] - executor)] - (|> output - (array.item 0) - try.trusted - (as java/lang/Object) - ..read)))))] - (for .old (these ) - .jvm (these ) - - .lua - (the extender - Extender - (|>> as_expected)))) - -(expansion.let [ (the platform - (IO [Baggage (Platform [Register _.Label] _.Expression _.Statement)]) - (do io.monad - [[baggage host] ..host] - (in [baggage - [platform.#file_system (file.async file.default) - platform.#host host - platform.#phase lua.expression - platform.#runtime runtime.translate - platform.#phase_wrapper (..phase_wrapper ..to_host) - platform.#write (|>> _.code (of utf8.format injection))]])))] - (for .old - .jvm - .lua (the platform - (IO (Platform [Register _.Label] _.Expression _.Statement)) - (do io.monad - [host ..host] - (in [platform.#file_system (file.async file.default) - platform.#host host - platform.#phase lua.expression - platform.#runtime runtime.translate - platform.#phase_wrapper (..phase_wrapper ..to_host) - platform.#write (|>> _.code (of utf8.format injection))]))))) +(for .jvm (these (the (to_host it) + (-> Any java/lang/Object) + (`` (<| (,, (template.with [ ] + [(when (ffi.as (as java/lang/Object it)) + {.#Some it} + (as java/lang/Object + ( [(as_expected it)])) + + {.#None})] + + [[java/lang/Object] (..lux_structure to_host)] + [library/lux/Function (..lua_function to_host)] + )) + (as java/lang/Object it)))) + + (the (extender [state_context executor]) + (-> Baggage Extender) + ... TODO: Stop relying on coercions ASAP. + (<| (as Extender) + (function (@self handler)) + (as Handler) + (function (@self phase)) + (as Phase) + (function (@self archive parameters)) + (as Operation) + (function (@self state)) + (as Try) + try.trusted + (as Try) + (do try.monad + [handler (try.of_maybe "Not an extension handler." + (..ensure_function handler)) + output (net/sandius/rembulan/exec/DirectCallExecutor::call [state_context + (as java/lang/Object handler) + (|> (array.empty 4) + (array.has! 0 (as java/lang/Object (phase_wrapper ..to_host phase))) + (array.has! 1 (..to_host archive)) + (array.has! 2 (..to_host parameters)) + (array.has! 3 (..to_host state)))] + executor)] + (|> output + (array.item 0) + try.trusted + (as java/lang/Object) + ..read))))) + + .lua + (the extender + Extender + (|>> as_expected))) + +(for .jvm (the platform + (IO [Baggage (Platform [Register _.Label] _.Expression _.Statement)]) + (do io.monad + [[baggage host] ..host] + (in [baggage + [platform.#file_system (file.async file.default) + platform.#host host + platform.#phase lua.expression + platform.#runtime runtime.translate + platform.#phase_wrapper (..phase_wrapper ..to_host) + platform.#write (|>> _.code (of utf8.format injection))]]))) + .lua (the platform + (IO (Platform [Register _.Label] _.Expression _.Statement)) + (do io.monad + [host ..host] + (in [platform.#file_system (file.async file.default) + platform.#host host + platform.#phase lua.expression + platform.#runtime runtime.translate + platform.#phase_wrapper (..phase_wrapper ..to_host) + platform.#write (|>> _.code (of utf8.format injection))])))) (the (lux_program context program) (Program _.Expression _.Statement) @@ -892,15 +883,13 @@ (program [service cli.service] (let [context (context.lua (cli.target service))] (do io.monad - [(,, (for .old [baggage platform] - .jvm [baggage platform] + [(,, (for .jvm [baggage platform] .lua platform)) ..platform] (exec (do async.monad [_ (/.compiler ..lux_compiler context - (for .old (..expander ..to_host baggage) - .jvm (..expander ..to_host baggage) + (for .jvm (..expander ..to_host baggage) .lua ..expander) analysis.bundle (io.io platform) @@ -908,8 +897,7 @@ extension.empty ..lux_program (reference.constant lua/reference.system) - (for .old (..extender baggage) - .jvm (..extender baggage) + (for .jvm (..extender baggage) .lua ..extender) service [(packager.package (_.manual "") diff --git a/lux-php/source/program.lux b/lux-php/source/program.lux index 780aa8af9d..7482044cb7 100644 --- a/lux-php/source/program.lux +++ b/lux-php/source/program.lux @@ -527,7 +527,7 @@ [(runtime.lux//program_args _.command_line_arguments) _.null]))) -(for .old +(for .jvm (the extender Extender ... TODO: Stop relying on coercions ASAP. diff --git a/lux-python/source/program.lux b/lux-python/source/program.lux index 5945bc35c3..36c57341f9 100644 --- a/lux-python/source/program.lux +++ b/lux-python/source/program.lux @@ -75,466 +75,460 @@ [program ["/" compositor]]) -(expansion.let [ (these (import java/lang/String - "[1]::[0]") - - (import (java/lang/Class a) - "[1]::[0]" - ("static" forName [java/lang/String] (java/lang/Class java/lang/Object)) - (getName [] java/lang/String)) - - (import java/lang/Object - "[1]::[0]" - (new []) - (toString [] java/lang/String) - (getClass [] (java/lang/Class java/lang/Object))) - - (import org/python/core/PyNone - "[1]::[0]") - - (import org/python/core/PyInteger - "[1]::[0]") - - (import org/python/core/PyTuple - "[1]::[0]") - - (import org/python/core/PyList - "[1]::[0]") - - (import org/python/core/PyBoolean - "[1]::[0]" - (new [boolean])) - - (import org/python/core/PyLong - "[1]::[0]" - (new [long])) - - (import org/python/core/PyFloat - "[1]::[0]" - (new [double])) - - (import org/python/core/PyString - "[1]::[0]" - (new [java/lang/String])) - - (import org/python/core/PyObject - "[1]::[0]" - (asInt [] java/lang/Integer) - (asLong [] long) - (asDouble [] double) - (asString [] java/lang/String) - (__nonzero__ [] boolean) - (__getitem__ [int] "try" org/python/core/PyObject) - (__getitem__ "as" __getitem__dict [org/python/core/PyObject] "try" org/python/core/PyObject) - (__len__ [] int)) - - (import org/python/core/PyFunction - "[1]::[0]" - (__call__ [[org/python/core/PyObject]] "try" org/python/core/PyObject)) - - (import org/python/core/ThreadState - "[1]::[0]") - - (import org/python/core/PyArray - "[1]::[0]" - (new [(java/lang/Class [? < java/lang/Object]) java/lang/Object]) - (getArray [] java/lang/Object)) - - (import org/python/util/PythonInterpreter - "[1]::[0]" - (new []) - (exec [java/lang/String] "try" void) - (eval [java/lang/String] "try" PyObject)) - - (every Translator - (-> org/python/core/PyObject (Try Any))) - - (the (read_tuple read host_object) - (-> Translator Translator) - (let [size (|> host_object - (org/python/core/PyObject::__len__ []) - ffi.of_int - .nat)] - (loop (again [idx 0 - output (as (Array Any) - (array.empty size))]) - (if (n.< size idx) - (when (org/python/core/PyObject::__getitem__ [(ffi.as_int (.int idx))] host_object) - {try.#Success value} - (when (read value) - {try.#Success lux_value} - (again (++ idx) (array.has! idx lux_value output)) - - failure - failure) - - failure - failure) - {try.#Success output})))) - - (exception.the (unknown_kind_of_object object) - (Exception java/lang/Object) - (exception.report - (list ["Object" (ffi.of_string (java/lang/Object::toString [] object))]))) - - (the (read_variant read host_object) - (-> Translator Translator) - (when [(org/python/core/PyObject::__getitem__ [(ffi.as_int +0)] host_object) - (org/python/core/PyObject::__getitem__ [(ffi.as_int +1)] host_object) - (org/python/core/PyObject::__getitem__ [(ffi.as_int +2)] host_object)] - (^.or [{try.#Failure try} _ _] - [_ {try.#Failure try} _] - [_ _ {try.#Failure try}]) - {try.#Failure try} - - (^.multi [{try.#Success tag} {try.#Success flag} {try.#Success value}] - [(read tag) - {try.#Success tag}] - [(read value) - {try.#Success value}]) - {try.#Success [tag - (is Any - (when (ffi.as org/python/core/PyNone - (as java/lang/Object flag)) - {.#Some _} - (as Any (ffi.null)) - - {.#None} - (as Any synthesis.unit))) - value]} - - _ - (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]))) - - (ffi.interface LuxValue - (value [] java/lang/Object)) - - (import LuxValue - "[1]::[0]" - (value [] java/lang/Object)) - - (the (read host_object) - Translator - (`` (<| (,, (template.with [ ] - [(when (ffi.as (as host_object)) - {.#Some host_object} - {try.#Success (`` (|> host_object (,, (template.spliced ))))} - - _)] - - [LuxValue [(LuxValue::value [])]] - [org/python/core/PyNone [(pipe.new [] [])]] - [org/python/core/PyBoolean [(org/python/core/PyObject::__nonzero__ [])]] - ... [org/python/core/PyInteger [(ffi.is org/python/core/PyObject) org/python/core/PyObject::asInt]] - [org/python/core/PyInteger [(ffi.is org/python/core/PyObject) - (.jvm_member_invoke_virtual# [] "org.python.core.PyObject" "asInt" []) - .jvm_object_cast# - (is (Nominal "java.lang.Integer"))]] - [org/python/core/PyLong [(org/python/core/PyObject::asLong [])]] - [org/python/core/PyFloat [(org/python/core/PyObject::asDouble [])]] - [org/python/core/PyString [(org/python/core/PyObject::asString [])]] - [org/python/core/PyFunction []] - [org/python/core/PyArray [(org/python/core/PyArray::getArray [])]] - [[java/lang/Object] [(|>)]] - )) - (,, (template.with [ ] - [(when (ffi.as host_object) - {.#Some host_object} - (<| (as org/python/core/PyObject) host_object) - - _)] - - [org/python/core/PyTuple (..read_variant read)] - [org/python/core/PyList (..read_tuple read)] - )) - ... (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]) - {try.#Success host_object}))) - - (the (function/? arity) - (-> Nat Code) - (` (.-> (,* (list.repeated arity (` .Any))) .Any))) - - (the (inputs/? arity) - (-> Nat (List Text)) - (|> (list.indices arity) - (list#each (|>> %.nat (%.message "input/"))))) - - (the (pseudo_function to_host it) - (-> (-> Any org/python/core/PyObject) Any org/python/core/PyObject) - (<| (as org/python/core/PyObject) - (ffi.object [] org/python/core/PyObject [LuxValue] - [] - ... Methods - (LuxValue [] (value self []) java/lang/Object (as java/lang/Object it)) - - (org/python/core/PyObject - [] (__call__ self [inputs [org/python/core/PyObject] - keywords [java/lang/String]]) - org/python/core/PyObject - (try.trusted - (do [! try.monad] - [inputs (monad.each ! ..read (array.list {.#None} inputs))] - (in (loop (again [it it - inputs inputs]) - (`` (`` (when inputs - (list) - (as org/python/core/PyObject self) - - (,, (template.with [] - [(list (,, (static.literals code.local (inputs/? )))) - (to_host ((as (,, (static.literal function.identity (function/? ))) it) - (,, (static.literals code.local (inputs/? )))))] - - [1] - [2] - [3] - [4] - [5] - [6] - [7] - [8])) - - (list.partial (,, (static.literals code.local (inputs/? 8))) - input/+) - (again ((as (,, (static.literal function.identity (function/? 8))) it) - (,, (static.literals code.local (inputs/? 8)))) - input/+)))))))))))) - - (the object_class - (java/lang/Class java/lang/Object) - (java/lang/Object::getClass [] (java/lang/Object::new []))) - - (import library/lux/Function - "[1]::[0]") - - (the (to_host|array to_host it) - (-> (-> Any org/python/core/PyObject) Any org/python/core/PyObject) - (as org/python/core/PyObject - (ffi.object [] org/python/core/PyArray [LuxValue] - [(java/lang/Class java/lang/Object) ..object_class - java/lang/Object (as java/lang/Object it)] - ... Methods - (LuxValue - [] (value self []) - java/lang/Object - (as java/lang/Object it)) - - (org/python/core/PyArray - [] (pyget self [index' int]) - org/python/core/PyObject - (when (|> it - (as (Array Any)) - (array.item (|> index' ffi.int_to_long (as Nat)))) - {try.#Failure _} - (ffi.super [index'] self) - - {try.#Success it} - (<| (when (ffi.as [java/lang/Object] (as java/lang/Object it)) - {.#Some it} - (to_host it) - - {.#None}) - (when (ffi.as library/lux/Function (as java/lang/Object it)) - {.#Some it} - (pseudo_function to_host it) - - {.#None}) - (ffi.super [index'] self)))) - ))) - - (the (to_host it) - (-> Any org/python/core/PyObject) - (`` (<| (,, (template.with [ ] - [(when (ffi.as (as java/lang/Object it)) - {.#Some it} - (as org/python/core/PyObject - ( [it])) - - {.#None})] - - [java/lang/Boolean org/python/core/PyBoolean::new] - [java/lang/Long org/python/core/PyLong::new] - [java/lang/Double org/python/core/PyFloat::new] - [java/lang/String org/python/core/PyString::new] - [library/lux/Function (pseudo_function to_host)] - [[java/lang/Object] (to_host|array to_host)] - )) - (as org/python/core/PyObject it)))) - )] - (for .old (these ) - .jvm (these ) - .python (these))) - -(expansion.let [ (these (the (call_macro inputs lux macro) - (-> (List Code) Lux org/python/core/PyFunction (Try (Try [Lux (List Code)]))) - (|> macro - (org/python/core/PyFunction::__call__ [(|> (ffi.array org/python/core/PyObject 2) - (ffi.write! 0 (..to_host inputs)) - (ffi.write! 1 (..to_host lux)))]) - (try#each ..read) - try#conjoint - as_expected)) - - (the python_function! - (-> Any (Maybe org/python/core/PyFunction)) - (|>> (as java/lang/Object) - (ffi.as org/python/core/PyFunction))) - - (exception.the (cannot_apply_a_non_function object) - (Exception java/lang/Object) - (exception.report - (list ["Object" (ffi.of_string (java/lang/Object::toString [] object))] - ["Class" (ffi.of_string (java/lang/Class::getName [] (java/lang/Object::getClass [] object)))]))) - - (the (expander macro inputs lux) - Expander - (when (python_function! macro) - {.#Some macro} - (when (..call_macro inputs lux macro) - {try.#Success output} - (|> output - (as org/python/core/PyObject) - ..read - (as (Try (Try [Lux (List Code)])))) - - {try.#Failure error} - {try.#Failure error}) - - {.#None} - (exception.except ..cannot_apply_a_non_function [(as java/lang/Object macro)]))))] - (for .old (these ) - .jvm (these ) - - .python - (the (expander macro inputs lux) - Expander - {try.#Success ((as Macro' macro) inputs lux)}))) - -(expansion.let [ (the host - (IO (Host _.Expression _.Statement)) - (io (let [interpreter (org/python/util/PythonInterpreter::new []) - evaluate! (is (-> [(Maybe unit.ID) _.Expression] (Try Any)) - (function (evaluate! [_ input]) - (do try.monad - [output (org/python/util/PythonInterpreter::eval [(ffi.as_string (_.code input))] interpreter)] - (..read output)))) - execute! (is (-> _.Statement (Try Any)) - (function (execute! input) - (when (org/python/util/PythonInterpreter::exec [(ffi.as_string (_.code input))] interpreter) - {try.#Failure error} - (if (text.contains? "maximum recursion depth exceeded" error) - (execute! input) - {try.#Failure error}) - - output - output)))] - (is (Host _.Expression _.Statement) - (implementation - (the evaluate evaluate!) - (the execute execute!) - (the (define context custom [@def input]) - (let [global (maybe.else (reference.artifact context) - custom) - @global (_.var global)] - (do try.monad - [.let [definition (_.set (list @global) input)] - _ (execute! definition) - value (evaluate! [@def @global])] - (in [global value definition])))) - - (the (ingest context content) - (|> content - (of utf8.format projection) - try.trusted - (as _.Statement))) - - (the (re_learn context custom content) - (execute! content)) - - (the (re_load context custom content) - (do try.monad - [_ (execute! content)] - (evaluate! [{.#None} (_.var (reference.artifact context))]))))))))] - (for .old - .jvm - - .python - (these (import (dict [] ffi.Dict)) - (import (eval [ffi.String ffi.Dict] "try" Any)) - - (the host - (IO (Host _.Expression _.Statement)) - (io (is (Host _.Expression _.Statement) - (let [globals (..dict []) - evaluate! (is (-> _.Expression (Try Any)) - (function (evaluate! input) - (..eval [(_.code input) globals]))) - execute! (is (-> _.Statement (Try Any)) - (function (execute! input) - (ffi.try (.python_exec# (_.code input) globals)))) - define! (is (-> unit.ID _.Expression (Try [Text Any _.Statement])) - (function (define! context input) - (let [global (reference.artifact context) - @global (_.var global)] - (do try.monad - [.let [definition (_.set (list @global) input)] - _ (execute! definition) - value (evaluate! @global)] - (in [global value definition])))))] - (implementation - (the evaluate! evaluate!) - (the execute! execute!) - (the define! define!) - - (the (ingest context content) - (|> content - (of utf8.format projection) - try.trusted - (as _.Statement))) - - (the (re_learn context content) - (execute! content)) - - (the (re_load context content) - (do try.monad - [_ (execute! content)] - (evaluate! (_.var (reference.artifact context))))))))))))) +(for .jvm (these (import java/lang/String + "[1]::[0]") + + (import (java/lang/Class a) + "[1]::[0]" + ("static" forName [java/lang/String] (java/lang/Class java/lang/Object)) + (getName [] java/lang/String)) + + (import java/lang/Object + "[1]::[0]" + (new []) + (toString [] java/lang/String) + (getClass [] (java/lang/Class java/lang/Object))) + + (import org/python/core/PyNone + "[1]::[0]") + + (import org/python/core/PyInteger + "[1]::[0]") + + (import org/python/core/PyTuple + "[1]::[0]") + + (import org/python/core/PyList + "[1]::[0]") + + (import org/python/core/PyBoolean + "[1]::[0]" + (new [boolean])) + + (import org/python/core/PyLong + "[1]::[0]" + (new [long])) + + (import org/python/core/PyFloat + "[1]::[0]" + (new [double])) + + (import org/python/core/PyString + "[1]::[0]" + (new [java/lang/String])) + + (import org/python/core/PyObject + "[1]::[0]" + (asInt [] java/lang/Integer) + (asLong [] long) + (asDouble [] double) + (asString [] java/lang/String) + (__nonzero__ [] boolean) + (__getitem__ [int] "try" org/python/core/PyObject) + (__getitem__ "as" __getitem__dict [org/python/core/PyObject] "try" org/python/core/PyObject) + (__len__ [] int)) + + (import org/python/core/PyFunction + "[1]::[0]" + (__call__ [[org/python/core/PyObject]] "try" org/python/core/PyObject)) + + (import org/python/core/ThreadState + "[1]::[0]") + + (import org/python/core/PyArray + "[1]::[0]" + (new [(java/lang/Class [? < java/lang/Object]) java/lang/Object]) + (getArray [] java/lang/Object)) + + (import org/python/util/PythonInterpreter + "[1]::[0]" + (new []) + (exec [java/lang/String] "try" void) + (eval [java/lang/String] "try" PyObject)) + + (every Translator + (-> org/python/core/PyObject (Try Any))) + + (the (read_tuple read host_object) + (-> Translator Translator) + (let [size (|> host_object + (org/python/core/PyObject::__len__ []) + ffi.of_int + .nat)] + (loop (again [idx 0 + output (as (Array Any) + (array.empty size))]) + (if (n.< size idx) + (when (org/python/core/PyObject::__getitem__ [(ffi.as_int (.int idx))] host_object) + {try.#Success value} + (when (read value) + {try.#Success lux_value} + (again (++ idx) (array.has! idx lux_value output)) + + failure + failure) + + failure + failure) + {try.#Success output})))) + + (exception.the (unknown_kind_of_object object) + (Exception java/lang/Object) + (exception.report + (list ["Object" (ffi.of_string (java/lang/Object::toString [] object))]))) + + (the (read_variant read host_object) + (-> Translator Translator) + (when [(org/python/core/PyObject::__getitem__ [(ffi.as_int +0)] host_object) + (org/python/core/PyObject::__getitem__ [(ffi.as_int +1)] host_object) + (org/python/core/PyObject::__getitem__ [(ffi.as_int +2)] host_object)] + (^.or [{try.#Failure try} _ _] + [_ {try.#Failure try} _] + [_ _ {try.#Failure try}]) + {try.#Failure try} + + (^.multi [{try.#Success tag} {try.#Success flag} {try.#Success value}] + [(read tag) + {try.#Success tag}] + [(read value) + {try.#Success value}]) + {try.#Success [tag + (is Any + (when (ffi.as org/python/core/PyNone + (as java/lang/Object flag)) + {.#Some _} + (as Any (ffi.null)) + + {.#None} + (as Any synthesis.unit))) + value]} + + _ + (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]))) + + (ffi.interface LuxValue + (value [] java/lang/Object)) + + (import LuxValue + "[1]::[0]" + (value [] java/lang/Object)) + + (the (read host_object) + Translator + (`` (<| (,, (template.with [ ] + [(when (ffi.as (as host_object)) + {.#Some host_object} + {try.#Success (`` (|> host_object (,, (template.spliced ))))} + + _)] + + [LuxValue [(LuxValue::value [])]] + [org/python/core/PyNone [(pipe.new [] [])]] + [org/python/core/PyBoolean [(org/python/core/PyObject::__nonzero__ [])]] + ... [org/python/core/PyInteger [(ffi.is org/python/core/PyObject) org/python/core/PyObject::asInt]] + [org/python/core/PyInteger [(ffi.is org/python/core/PyObject) + (.jvm_member_invoke_virtual# [] "org.python.core.PyObject" "asInt" []) + .jvm_object_cast# + (is (Nominal "java.lang.Integer"))]] + [org/python/core/PyLong [(org/python/core/PyObject::asLong [])]] + [org/python/core/PyFloat [(org/python/core/PyObject::asDouble [])]] + [org/python/core/PyString [(org/python/core/PyObject::asString [])]] + [org/python/core/PyFunction []] + [org/python/core/PyArray [(org/python/core/PyArray::getArray [])]] + [[java/lang/Object] [(|>)]] + )) + (,, (template.with [ ] + [(when (ffi.as host_object) + {.#Some host_object} + (<| (as org/python/core/PyObject) host_object) + + _)] + + [org/python/core/PyTuple (..read_variant read)] + [org/python/core/PyList (..read_tuple read)] + )) + ... (exception.except ..unknown_kind_of_object [(as java/lang/Object host_object)]) + {try.#Success host_object}))) + + (the (function/? arity) + (-> Nat Code) + (` (.-> (,* (list.repeated arity (` .Any))) .Any))) + + (the (inputs/? arity) + (-> Nat (List Text)) + (|> (list.indices arity) + (list#each (|>> %.nat (%.message "input/"))))) + + (the (pseudo_function to_host it) + (-> (-> Any org/python/core/PyObject) Any org/python/core/PyObject) + (<| (as org/python/core/PyObject) + (ffi.object [] org/python/core/PyObject [LuxValue] + [] + ... Methods + (LuxValue [] (value self []) java/lang/Object (as java/lang/Object it)) + + (org/python/core/PyObject + [] (__call__ self [inputs [org/python/core/PyObject] + keywords [java/lang/String]]) + org/python/core/PyObject + (try.trusted + (do [! try.monad] + [inputs (monad.each ! ..read (array.list {.#None} inputs))] + (in (loop (again [it it + inputs inputs]) + (`` (`` (when inputs + (list) + (as org/python/core/PyObject self) + + (,, (template.with [] + [(list (,, (static.literals code.local (inputs/? )))) + (to_host ((as (,, (static.literal function.identity (function/? ))) it) + (,, (static.literals code.local (inputs/? )))))] + + [1] + [2] + [3] + [4] + [5] + [6] + [7] + [8])) + + (list.partial (,, (static.literals code.local (inputs/? 8))) + input/+) + (again ((as (,, (static.literal function.identity (function/? 8))) it) + (,, (static.literals code.local (inputs/? 8)))) + input/+)))))))))))) + + (the object_class + (java/lang/Class java/lang/Object) + (java/lang/Object::getClass [] (java/lang/Object::new []))) + + (import library/lux/Function + "[1]::[0]") + + (the (to_host|array to_host it) + (-> (-> Any org/python/core/PyObject) Any org/python/core/PyObject) + (as org/python/core/PyObject + (ffi.object [] org/python/core/PyArray [LuxValue] + [(java/lang/Class java/lang/Object) ..object_class + java/lang/Object (as java/lang/Object it)] + ... Methods + (LuxValue + [] (value self []) + java/lang/Object + (as java/lang/Object it)) + + (org/python/core/PyArray + [] (pyget self [index' int]) + org/python/core/PyObject + (when (|> it + (as (Array Any)) + (array.item (|> index' ffi.int_to_long (as Nat)))) + {try.#Failure _} + (ffi.super [index'] self) + + {try.#Success it} + (<| (when (ffi.as [java/lang/Object] (as java/lang/Object it)) + {.#Some it} + (to_host it) + + {.#None}) + (when (ffi.as library/lux/Function (as java/lang/Object it)) + {.#Some it} + (pseudo_function to_host it) + + {.#None}) + (ffi.super [index'] self)))) + ))) + + (the (to_host it) + (-> Any org/python/core/PyObject) + (`` (<| (,, (template.with [ ] + [(when (ffi.as (as java/lang/Object it)) + {.#Some it} + (as org/python/core/PyObject + ( [it])) + + {.#None})] + + [java/lang/Boolean org/python/core/PyBoolean::new] + [java/lang/Long org/python/core/PyLong::new] + [java/lang/Double org/python/core/PyFloat::new] + [java/lang/String org/python/core/PyString::new] + [library/lux/Function (pseudo_function to_host)] + [[java/lang/Object] (to_host|array to_host)] + )) + (as org/python/core/PyObject it)))) + ) + .python (these)) + +(for .jvm (these (the (call_macro inputs lux macro) + (-> (List Code) Lux org/python/core/PyFunction (Try (Try [Lux (List Code)]))) + (|> macro + (org/python/core/PyFunction::__call__ [(|> (ffi.array org/python/core/PyObject 2) + (ffi.write! 0 (..to_host inputs)) + (ffi.write! 1 (..to_host lux)))]) + (try#each ..read) + try#conjoint + as_expected)) + + (the python_function! + (-> Any (Maybe org/python/core/PyFunction)) + (|>> (as java/lang/Object) + (ffi.as org/python/core/PyFunction))) + + (exception.the (cannot_apply_a_non_function object) + (Exception java/lang/Object) + (exception.report + (list ["Object" (ffi.of_string (java/lang/Object::toString [] object))] + ["Class" (ffi.of_string (java/lang/Class::getName [] (java/lang/Object::getClass [] object)))]))) + + (the (expander macro inputs lux) + Expander + (when (python_function! macro) + {.#Some macro} + (when (..call_macro inputs lux macro) + {try.#Success output} + (|> output + (as org/python/core/PyObject) + ..read + (as (Try (Try [Lux (List Code)])))) + + {try.#Failure error} + {try.#Failure error}) + + {.#None} + (exception.except ..cannot_apply_a_non_function [(as java/lang/Object macro)])))) + + .python + (the (expander macro inputs lux) + Expander + {try.#Success ((as Macro' macro) inputs lux)})) + +(for .jvm + (the host + (IO (Host _.Expression _.Statement)) + (io (let [interpreter (org/python/util/PythonInterpreter::new []) + evaluate! (is (-> [(Maybe unit.ID) _.Expression] (Try Any)) + (function (evaluate! [_ input]) + (do try.monad + [output (org/python/util/PythonInterpreter::eval [(ffi.as_string (_.code input))] interpreter)] + (..read output)))) + execute! (is (-> _.Statement (Try Any)) + (function (execute! input) + (when (org/python/util/PythonInterpreter::exec [(ffi.as_string (_.code input))] interpreter) + {try.#Failure error} + (if (text.contains? "maximum recursion depth exceeded" error) + (execute! input) + {try.#Failure error}) + + output + output)))] + (is (Host _.Expression _.Statement) + (implementation + (the evaluate evaluate!) + (the execute execute!) + (the (define context custom [@def input]) + (let [global (maybe.else (reference.artifact context) + custom) + @global (_.var global)] + (do try.monad + [.let [definition (_.set (list @global) input)] + _ (execute! definition) + value (evaluate! [@def @global])] + (in [global value definition])))) + + (the (ingest context content) + (|> content + (of utf8.format projection) + try.trusted + (as _.Statement))) + + (the (re_learn context custom content) + (execute! content)) + + (the (re_load context custom content) + (do try.monad + [_ (execute! content)] + (evaluate! [{.#None} (_.var (reference.artifact context))])))))))) + + .python + (these (import (dict [] ffi.Dict)) + (import (eval [ffi.String ffi.Dict] "try" Any)) + + (the host + (IO (Host _.Expression _.Statement)) + (io (is (Host _.Expression _.Statement) + (let [globals (..dict []) + evaluate! (is (-> _.Expression (Try Any)) + (function (evaluate! input) + (..eval [(_.code input) globals]))) + execute! (is (-> _.Statement (Try Any)) + (function (execute! input) + (ffi.try (.python_exec# (_.code input) globals)))) + define! (is (-> unit.ID _.Expression (Try [Text Any _.Statement])) + (function (define! context input) + (let [global (reference.artifact context) + @global (_.var global)] + (do try.monad + [.let [definition (_.set (list @global) input)] + _ (execute! definition) + value (evaluate! @global)] + (in [global value definition])))))] + (implementation + (the evaluate! evaluate!) + (the execute! execute!) + (the define! define!) + + (the (ingest context content) + (|> content + (of utf8.format projection) + try.trusted + (as _.Statement))) + + (the (re_learn context content) + (execute! content)) + + (the (re_load context content) + (do try.monad + [_ (execute! content)] + (evaluate! (_.var (reference.artifact context)))))))))))) (the phase_wrapper phase.Wrapper (..pseudo_function ..to_host)) -(expansion.let [ (these (the extender - Extender - ... TODO: Stop relying on coercions ASAP. - (<| (as Extender) - (function (_ handler)) - (as Handler) - (function (_ phase)) - (as Phase) - (function (_ archive parameters)) - (as Operation) - (function (_ state)) - (as Try) - try.trusted - (as Try) - (do try.monad - [handler (try.of_maybe "Not an extension handler." - (..python_function! handler)) - output (org/python/core/PyFunction::__call__ [(|> (ffi.array org/python/core/PyObject 4) - (ffi.write! 0 (as org/python/core/PyObject (phase_wrapper phase))) - (ffi.write! 1 (..to_host archive)) - (ffi.write! 2 (..to_host parameters)) - (ffi.write! 3 (..to_host state)))] - handler)] - (..read output)))))] - (for .old (these ) - .jvm (these ) - - .python - (the extender - Extender - (|>> as_expected)))) +(for .jvm + (these (the extender + Extender + ... TODO: Stop relying on coercions ASAP. + (<| (as Extender) + (function (_ handler)) + (as Handler) + (function (_ phase)) + (as Phase) + (function (_ archive parameters)) + (as Operation) + (function (_ state)) + (as Try) + try.trusted + (as Try) + (do try.monad + [handler (try.of_maybe "Not an extension handler." + (..python_function! handler)) + output (org/python/core/PyFunction::__call__ [(|> (ffi.array org/python/core/PyObject 4) + (ffi.write! 0 (as org/python/core/PyObject (phase_wrapper phase))) + (ffi.write! 1 (..to_host archive)) + (ffi.write! 2 (..to_host parameters)) + (ffi.write! 3 (..to_host state)))] + handler)] + (..read output))))) + + .python + (the extender + Extender + (|>> as_expected))) (the platform (IO (Platform Register _.Expression _.Statement)) diff --git a/lux-r/source/program.lux b/lux-r/source/program.lux index 6b2da12710..f44cee73c0 100644 --- a/lux-r/source/program.lux +++ b/lux-r/source/program.lux @@ -567,7 +567,7 @@ (Program _.Expression _.Expression) (_.apply/2 program [(runtime.lux::program_args (_.commandArgs/0 [])) _.null])) -(for .old +(for .jvm (the extender Extender ... TODO: Stop relying on coercions ASAP. diff --git a/lux-scheme/source/program.lux b/lux-scheme/source/program.lux index 76c96665eb..54ed8ac9f2 100644 --- a/lux-scheme/source/program.lux +++ b/lux-scheme/source/program.lux @@ -427,7 +427,7 @@ (runtime.lux//program_args _.nil) _.nil)) -(for .old +(for .jvm (the extender Extender ... TODO: Stop relying on coercions ASAP. diff --git a/stdlib/source/library/lux.lux b/stdlib/source/library/lux.lux index 8cd8228b9c..0fcafdc454 100644 --- a/stdlib/source/library/lux.lux +++ b/stdlib/source/library/lux.lux @@ -5969,9 +5969,7 @@ [(the .public Target )] - - ... TODO: Delete ASAP. - [old "{old}"] + ... Available. [js "JavaScript"] [jvm "JVM"] @@ -5986,33 +5984,6 @@ [scheme "Scheme"] ) -... TODO: Delete "scope_type_vars" (including the #scope_type_vars Lux state) and "parameter" ASAP. -(for .old (these (the (scope_type_vars state) - (Meta (List Nat)) - (when state - [..#info info ..#source source ..#current_module _ ..#modules modules - ..#scopes scopes ..#type_context types ..#host host - ..#seed seed ..#expected expected ..#location location ..#extensions extensions - ..#scope_type_vars scope_type_vars ..#eval _eval] - {#Right [state scope_type_vars]})) - - (the .public parameter - (macro (_ tokens) - (when tokens - (list [_ {#Nat idx}]) - (do meta#monad - [stvs ..scope_type_vars] - (when (..item idx (list#reversed stvs)) - {#Some var_id} - (in (list (` {.#Opaque (, (as_nat var_id))}))) - - {#None} - (failure (.text_composite# "Indexed-type does not exist: " (nat#injection idx))))) - - _ - (failure ..wrong_syntax))))) - (these (the .public parameter ""))) - (the .public require (let [refer_code (is (-> Text Text (List Referral) Code) diff --git a/stdlib/source/library/lux/abstract/apply.lux b/stdlib/source/library/lux/abstract/apply.lux index 2bd04f456a..fa7fe5dccb 100644 --- a/stdlib/source/library/lux/abstract/apply.lux +++ b/stdlib/source/library/lux/abstract/apply.lux @@ -29,14 +29,10 @@ (its ..functor inner_apply))) (the (on oix oif) ... TODO: Switch from this version to the one below (in comments) ASAP. - (for .old (let [oif' (of outer_apply on - oif - (of outer_monad in (function (_ if ix) (of inner_apply on ix if))))] - (as_expected (of outer_apply on (as_expected oix) (as_expected oif')))) - (let [oif' (of outer_apply on - oif - (of outer_monad in (function (_ if ix) (of inner_apply on ix if))))] - (of outer_apply on oix oif'))) + (let [oif' (of outer_apply on + oif + (of outer_monad in (function (_ if ix) (of inner_apply on ix if))))] + (of outer_apply on oix oif')) ... (let [outer_apply (of outer_apply on) ... inner_apply (of inner_apply on)] ... (all outer_apply diff --git a/stdlib/source/library/lux/abstract/functor.lux b/stdlib/source/library/lux/abstract/functor.lux index 8f68867470..c22a02caf8 100644 --- a/stdlib/source/library/lux/abstract/functor.lux +++ b/stdlib/source/library/lux/abstract/functor.lux @@ -64,17 +64,14 @@ (|>> it ((output value)))))) -(for .old - (these) - - (the .public (recursive body) - (for_any (_ of) - (-> (-> (Functor of) - (Functor of)) - (Functor of))) - (implementation - (the (each value it) - ((body each) value it))))) +(the .public (recursive body) + (for_any (_ of) + (-> (-> (Functor of) + (Functor of)) + (Functor of))) + (implementation + (the (each value it) + ((body each) value it)))) (every .public (Then outer inner) (for_any (_ of) diff --git a/stdlib/source/library/lux/algorithm/mix.lux b/stdlib/source/library/lux/algorithm/mix.lux index e39e5794f4..fcdebe7128 100644 --- a/stdlib/source/library/lux/algorithm/mix.lux +++ b/stdlib/source/library/lux/algorithm/mix.lux @@ -54,14 +54,10 @@ left_it) right_it))) -(for .old - (these) - - (the .public (recursive body) - (for_any (_ of) - (-> (-> (Mix of) - (Mix of)) - (Mix of))) - (function (recursion value init it) - ((body recursion) value init it))) - ) +(the .public (recursive body) + (for_any (_ of) + (-> (-> (Mix of) + (Mix of)) + (Mix of))) + (function (recursion value init it) + ((body recursion) value init it))) diff --git a/stdlib/source/library/lux/control/concurrency/atom.lux b/stdlib/source/library/lux/control/concurrency/atom.lux index 6ac85f044f..513e27e006 100644 --- a/stdlib/source/library/lux/control/concurrency/atom.lux +++ b/stdlib/source/library/lux/control/concurrency/atom.lux @@ -18,24 +18,18 @@ [meta [type ["[0]" nominal] - ["[0]" variance (.only Mutable)]] - [macro - ["[0]" expansion]]]]]) + ["[0]" variance (.only Mutable)]]]]]) -(expansion.let [ (these (ffi.import (java/util/concurrent/atomic/AtomicReference a) - "[1]::[0]" - (new [a]) - (get [] a) - (compareAndSet [a a] boolean)))] - (for .old - .jvm - (these))) +(for .jvm (ffi.import (java/util/concurrent/atomic/AtomicReference a) + "[1]::[0]" + (new [a]) + (get [] a) + (compareAndSet [a a] boolean)) + (these)) (nominal.every .public (Atom'' a) - (expansion.let [ (java/util/concurrent/atomic/AtomicReference a)] - (for .old - .jvm - (array.Array a))) + (for .jvm (java/util/concurrent/atomic/AtomicReference a) + (array.Array a)) (every .public (Atom' r w) (Atom'' (Mutable r w))) @@ -46,27 +40,17 @@ (the .public (atom value) (for_any (_ a) (-> a (Atom a))) (nominal.abstraction - (expansion.let [ (as_expected (java/util/concurrent/atomic/AtomicReference::new [value]))] - (for .old - .jvm - (array.has! 0 (variance.write value) (array.empty 1)))))) + (for .jvm (as_expected (java/util/concurrent/atomic/AtomicReference::new [value])) + (array.has! 0 (variance.write value) (array.empty 1))))) (the .public (read! atom) (for_any (_ r w) (-> (Atom' r w) (IO r))) - (expansion.let [ (java/util/concurrent/atomic/AtomicReference::get [] (nominal.representation atom))] - (io.io (for .old (variance.read ) - .jvm - (variance.read (array.item 0 (nominal.representation atom))))))) + (io.io (for .jvm (java/util/concurrent/atomic/AtomicReference::get [] (nominal.representation atom)) + (variance.read (array.item 0 (nominal.representation atom)))))) (the .public (compare_and_swap! current new atom) (for_any (_ r w) (-> r w (Atom' r w) (IO Bit))) - (io.io (for .old (ffi.of_boolean - (java/util/concurrent/atomic/AtomicReference::compareAndSet [(variance.write - (`` (as (,, (type_of new)) - current))) - (variance.write new)] - (nominal.representation atom))) - .jvm (ffi.of_boolean + (io.io (for .jvm (ffi.of_boolean (java/util/concurrent/atomic/AtomicReference::compareAndSet [current new] (nominal.representation atom))) (if (|> (nominal.representation atom) (array.item 0) diff --git a/stdlib/source/library/lux/control/concurrency/thread.lux b/stdlib/source/library/lux/control/concurrency/thread.lux index 86344669a7..41a22c3f65 100644 --- a/stdlib/source/library/lux/control/concurrency/thread.lux +++ b/stdlib/source/library/lux/control/concurrency/thread.lux @@ -32,83 +32,77 @@ ["[0]" atom (.only Atom)] ["[0]" event]]) -(expansion.let [ (these (ffi.import java/lang/Object - "[1]::[0]") - - (ffi.import java/lang/Long - "[1]::[0]") - - (ffi.import java/lang/Runtime - "[1]::[0]" - ("static" getRuntime [] java/lang/Runtime) - (availableProcessors [] int)) - - (ffi.import java/lang/Runnable - "[1]::[0]") - - (ffi.import java/util/concurrent/TimeUnit - "[1]::[0]" - ("enum" MILLISECONDS)) - - (ffi.import java/util/concurrent/Executor - "[1]::[0]" - (execute [java/lang/Runnable] "io" void)) - - (ffi.import (java/util/concurrent/ScheduledFuture a) - "[1]::[0]") - - (ffi.import java/util/concurrent/ScheduledThreadPoolExecutor - "[1]::[0]" - (new [int]) - (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] "io" (java/util/concurrent/ScheduledFuture java/lang/Object))))] - (for .old (these ) - .jvm (these ) +(for .jvm (these (ffi.import java/lang/Object + "[1]::[0]") + + (ffi.import java/lang/Long + "[1]::[0]") - .js - (these (ffi.import (setTimeout [ffi.Function ffi.Number] "io" Any))) + (ffi.import java/lang/Runtime + "[1]::[0]" + ("static" getRuntime [] java/lang/Runtime) + (availableProcessors [] int)) - .python - (these (ffi.import threading/Timer - "[1]::[0]" - (start [] "io" "?" Any)) - (ffi.import threading - "[1]::[0]" - ("static" Timer [ffi.Float ffi.Function] threading/Timer))) - - ... Default - (these) - )) + (ffi.import java/lang/Runnable + "[1]::[0]") + + (ffi.import java/util/concurrent/TimeUnit + "[1]::[0]" + ("enum" MILLISECONDS)) + + (ffi.import java/util/concurrent/Executor + "[1]::[0]" + (execute [java/lang/Runnable] "io" void)) + + (ffi.import (java/util/concurrent/ScheduledFuture a) + "[1]::[0]") + + (ffi.import java/util/concurrent/ScheduledThreadPoolExecutor + "[1]::[0]" + (new [int]) + (schedule [java/lang/Runnable long java/util/concurrent/TimeUnit] "io" (java/util/concurrent/ScheduledFuture java/lang/Object)))) + + .js + (these (ffi.import (setTimeout [ffi.Function ffi.Number] "io" Any))) + + .python + (these (ffi.import threading/Timer + "[1]::[0]" + (start [] "io" "?" Any)) + (ffi.import threading + "[1]::[0]" + ("static" Timer [ffi.Float ffi.Function] threading/Timer))) + + ... Default + (these) + ) (the .public parallelism Nat - (expansion.let [ 1 - (<| (configuration.for ["lua_compiler?" ""] - ... TODO: Remove this when Rembulan is no longer being used. - ) - (|> [] java/lang/Runtime::getRuntime - (java/lang/Runtime::availableProcessors []) - ffi.of_int - .nat))] - (for .old - .jvm + (expansion.let [ 1] + (for .jvm (<| (configuration.for ["lua_compiler?" ""] + ... TODO: Remove this when Rembulan is no longer being used. + ) + (|> [] java/lang/Runtime::getRuntime + (java/lang/Runtime::availableProcessors []) + ffi.of_int + .nat)) ... Default ))) -(expansion.let [ (these (the runner - java/util/concurrent/ScheduledThreadPoolExecutor - (|> ..parallelism - .int - ffi.as_int - [] java/util/concurrent/ScheduledThreadPoolExecutor::new)))] - (for .old - .jvm - .js (these) - .python (these) - - ... Default - (these (the schedule!,value - (let [[module _] (symbol .._)] - (event.loop module)))))) +(for .jvm (the runner + java/util/concurrent/ScheduledThreadPoolExecutor + (|> ..parallelism + .int + ffi.as_int + [] java/util/concurrent/ScheduledThreadPoolExecutor::new)) + .js (these) + .python (these) + + ... Default + (the schedule!,value + (let [[module _] (symbol .._)] + (event.loop module)))) (the (execute! action) (-> (IO Any) Any) @@ -143,35 +137,33 @@ (the .public (schedule! milli_seconds action) (-> Delay (IO Any) (IO Any)) - (expansion.let [ (let [runnable (ffi.object [] [java/lang/Runnable] - [] - (java/lang/Runnable [] (run self []) void - (..execute! action)))] - (when milli_seconds - 0 (java/util/concurrent/Executor::execute [runnable] runner) - _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule [runnable (.int milli_seconds) java/util/concurrent/TimeUnit::MILLISECONDS] - runner)))] - (for .old - .jvm - - .js - (..setTimeout [(ffi.function (_ []) Any (..execute! action)) - (n.dec milli_seconds)]) - - .python - (do io.monad - [_ (|> (ffi.function (_ []) Any (..execute! action)) - [(|> milli_seconds n.dec (d./ +1,000.0))] - threading::Timer - (threading/Timer::start []))] - (in [])) - - ... Default - (let [[schedule! value] ..schedule!,value] - (schedule! milli_seconds action))))) + (for .jvm + (let [runnable (ffi.object [] [java/lang/Runnable] + [] + (java/lang/Runnable [] (run self []) void + (..execute! action)))] + (when milli_seconds + 0 (java/util/concurrent/Executor::execute [runnable] runner) + _ (java/util/concurrent/ScheduledThreadPoolExecutor::schedule [runnable (.int milli_seconds) java/util/concurrent/TimeUnit::MILLISECONDS] + runner))) + + .js + (..setTimeout [(ffi.function (_ []) Any (..execute! action)) + (n.dec milli_seconds)]) + + .python + (do io.monad + [_ (|> (ffi.function (_ []) Any (..execute! action)) + [(|> milli_seconds n.dec (d./ +1,000.0))] + threading::Timer + (threading/Timer::start []))] + (in [])) + + ... Default + (let [[schedule! value] ..schedule!,value] + (schedule! milli_seconds action)))) -(for .old (these) - .jvm (these) +(for .jvm (these) .js (these) .python (these) diff --git a/stdlib/source/library/lux/control/writer.lux b/stdlib/source/library/lux/control/writer.lux index 08f51897ba..bd3cda5fba 100644 --- a/stdlib/source/library/lux/control/writer.lux +++ b/stdlib/source/library/lux/control/writer.lux @@ -74,15 +74,7 @@ (the (conjoint MlMla) (do monad - [[l0 Mla] (for .old - (is {.#Apply (Writer (parameter 1) - {.#Apply (Writer (parameter 1) - (parameter 2)) - (parameter 0)}) - (parameter 0)} - MlMla) - ... On new compiler - MlMla) + [[l0 Mla] MlMla [l1 a] Mla] (in [(of monoid composite l0 l1) a]))))) diff --git a/stdlib/source/library/lux/data/collection/list.lux b/stdlib/source/library/lux/data/collection/list.lux index e073645ed4..d7a148998b 100644 --- a/stdlib/source/library/lux/data/collection/list.lux +++ b/stdlib/source/library/lux/data/collection/list.lux @@ -687,11 +687,7 @@ (the (conjoint MlMla) (do [! monad] [lMla MlMla - ... TODO: Remove this version ASAP and use one below. - lla (for .old (is {.#Apply (List (List (parameter 1))) - (parameter 0)} - (monad.all ! lMla)) - (monad.all ! lMla))] + lla (monad.all ! lMla)] (in (..together lla)))))) (the .public (lifted monad) diff --git a/stdlib/source/library/lux/data/collection/tree/zipper.lux b/stdlib/source/library/lux/data/collection/tree/zipper.lux index ca2a30ec83..aa5f0e1b62 100644 --- a/stdlib/source/library/lux/data/collection/tree/zipper.lux +++ b/stdlib/source/library/lux/data/collection/tree/zipper.lux @@ -139,18 +139,11 @@ (do maybe.monad [family (its #family zipper)] (in (let [(open "_[0]") family] - (for .old - (revised #node (is (-> (Tree (parameter 0)) - (Tree (parameter 0))) - (has //.#children (list#composite (list.reversed _#lefts) - {.#Item (its #node zipper) - _#rights}))) - _#parent) - (has [#node //.#children] - (list#composite (list.reversed _#lefts) - {.#Item (its #node zipper) - _#rights}) - _#parent))))))) + (has [#node //.#children] + (list#composite (list.reversed _#lefts) + {.#Item (its #node zipper) + _#rights}) + _#parent)))))) (template.with [ ] [(the .public ( zipper) @@ -162,17 +155,12 @@ (when (its family) {.#Item next side'} {try.#Success - (for .old - [#family {.#Some (|> family - (has side') - (revised (|>> {.#Item (its #node zipper)})))} - #node next] - (let [move (is (for_any (_ of) (-> (List (Tree of)) (Zipper of) (Family Zipper of) (Family Zipper of))) - (function (_ side' zipper) - (|>> (has side') - (revised (|>> {.#Item (its #node zipper)})))))] - [#family {.#Some (move side' zipper family)} - #node next]))} + (let [move (is (for_any (_ of) (-> (List (Tree of)) (Zipper of) (Family Zipper of) (Family Zipper of))) + (function (_ side' zipper) + (|>> (has side') + (revised (|>> {.#Item (its #node zipper)})))))] + [#family {.#Some (move side' zipper family)} + #node next])} {.#End} {try.#Failure ..cannot_move}) @@ -189,18 +177,13 @@ (when (list.reversed (its family)) {.#Item last prevs} {try.#Success - (for .old [#family {.#Some (|> family - (has {.#End}) - (revised (|>> {.#Item (its #node zipper)} - (list#composite prevs))))} - #node last] - (let [move (is (for_any (_ of) (-> (List (Tree of)) (Zipper of) (Family Zipper of) (Family Zipper of))) - (function (_ prevs zipper) - (|>> (has {.#End}) - (revised (|>> {.#Item (its #node zipper)} - (list#composite prevs))))))] - [#family {.#Some (move prevs zipper family)} - #node last]))} + (let [move (is (for_any (_ of) (-> (List (Tree of)) (Zipper of) (Family Zipper of) (Family Zipper of))) + (function (_ prevs zipper) + (|>> (has {.#End}) + (revised (|>> {.#Item (its #node zipper)} + (list#composite prevs))))))] + [#family {.#Some (move prevs zipper family)} + #node last])} {.#End} {try.#Failure ..cannot_move}) diff --git a/stdlib/source/library/lux/data/text.lux b/stdlib/source/library/lux/data/text.lux index e6bd3a03b3..a6bdfa54d3 100644 --- a/stdlib/source/library/lux/data/text.lux +++ b/stdlib/source/library/lux/data/text.lux @@ -264,13 +264,7 @@ {.#None} (.text_composite# left right)))]) - (for .old - (as Text - ("jvm invokevirtual:java.lang.String:replace:java.lang.CharSequence,java.lang.CharSequence" - (as (Nominal "java.lang.String") template) - (as (Nominal "java.lang.CharSequence") pattern) - (as (Nominal "java.lang.CharSequence") replacement))) - .jvm + (for .jvm (as Text (.jvm_member_invoke_virtual# [] "java.lang.String" "replace" [] (as (Nominal "java.lang.String") template) @@ -328,14 +322,7 @@ (the equivalence ..equivalence) (the (hash input) - (for .old - (|> input - (is (Nominal "java.lang.Object")) - "jvm invokevirtual:java.lang.Object:hashCode:" - "jvm convert int-to-long" - (as Nat)) - - .jvm + (for .jvm (|> input (as (Nominal "java.lang.Object")) (.jvm_member_invoke_virtual# [] "java.lang.Object" "hashCode" []) @@ -403,11 +390,7 @@ (the .public (lower_cased value) (-> Text Text) - (for .old - (as Text - ("jvm invokevirtual:java.lang.String:toLowerCase:" - (as (Nominal "java.lang.String") value))) - .jvm + (for .jvm (as Text (.jvm_member_invoke_virtual# [] "java.lang.String" "toLowerCase" [] (as (Nominal "java.lang.String") value))) @@ -427,11 +410,7 @@ (the .public (upper_cased value) (-> Text Text) - (for .old - (as Text - ("jvm invokevirtual:java.lang.String:toUpperCase:" - (as (Nominal "java.lang.String") value))) - .jvm + (for .jvm (as Text (.jvm_member_invoke_virtual# [] "java.lang.String" "toUpperCase" [] (as (Nominal "java.lang.String") value))) diff --git a/stdlib/source/library/lux/data/text/buffer.lux b/stdlib/source/library/lux/data/text/buffer.lux index cf60f19b71..ddde5d02d2 100644 --- a/stdlib/source/library/lux/data/text/buffer.lux +++ b/stdlib/source/library/lux/data/text/buffer.lux @@ -24,47 +24,44 @@ ["[0]" expansion]]]]] ["[0]" //]) -(expansion.let [ (these (import java/lang/CharSequence - "[1]::[0]") +(`` (for .jvm (these (import java/lang/CharSequence + "[1]::[0]") - (import java/lang/Appendable - "[1]::[0]" - (append [java/lang/CharSequence] java/lang/Appendable)) + (import java/lang/Appendable + "[1]::[0]" + (append [java/lang/CharSequence] java/lang/Appendable)) - (import java/lang/String - "[1]::[0]") + (import java/lang/String + "[1]::[0]") - (import java/lang/StringBuilder - "[1]::[0]" - (new [int]) - (toString [] java/lang/String)))] - (`` (for .old (these ) - .jvm (these ) - .js (these (import (JS_Array a) - "[1]::[0]" - (push [a] a) - (join [Text] Text))) - .lua (these (import (table/concat [(array.Array Text) Text] Text)) - ...https://www.lua.org/manual/5.3/manual.html#pdf-table.concat - (import (table/insert [(array.Array Text) Text] "?" Nothing)) - ... https://www.lua.org/manual/5.3/manual.html#pdf-table.insert - ) - .python (these (import (Python_List of) - "[1]::[0]" - (append [of] "?" Any)) - (import Python_Text - "[1]::[0]" - (join [(Python_List Text)] Text))) - .ruby (these (import Ruby_Text + (import java/lang/StringBuilder + "[1]::[0]" + (new [int]) + (toString [] java/lang/String))) + .js (these (import (JS_Array a) + "[1]::[0]" + (push [a] a) + (join [Text] Text))) + .lua (these (import (table/concat [(array.Array Text) Text] Text)) + ...https://www.lua.org/manual/5.3/manual.html#pdf-table.concat + (import (table/insert [(array.Array Text) Text] "?" Nothing)) + ... https://www.lua.org/manual/5.3/manual.html#pdf-table.insert + ) + .python (these (import (Python_List of) "[1]::[0]" - (<< [Text] Ruby_Text))) - ... ... default - ... (these) - ))) + (append [of] "?" Any)) + (import Python_Text + "[1]::[0]" + (join [(Python_List Text)] Text))) + .ruby (these (import Ruby_Text + "[1]::[0]" + (<< [Text] Ruby_Text))) + ... ... default + ... (these) + )) (`` (nominal.every .public Buffer - (for .old [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] - .jvm [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] + (for .jvm [Nat (-> java/lang/StringBuilder java/lang/StringBuilder)] .js [Nat (-> (JS_Array Text) (JS_Array Text))] .lua [Nat (-> (array.Array Text) (array.Array Text))] .python [Nat (-> (Python_List Text) (Python_List Text))] @@ -76,120 +73,112 @@ (the .public empty Buffer (nominal.abstraction - (expansion.let [ [0 function.identity]] - (for .old - .jvm - .js [0 function.identity] - .lua [0 function.identity] - .python [0 function.identity] - .ruby [0 function.identity] - ... ... default - ... sequence.empty - )))) + (for .jvm [0 function.identity] + .js [0 function.identity] + .lua [0 function.identity] + .python [0 function.identity] + .ruby [0 function.identity] + ... ... default + ... sequence.empty + ))) (the .public (then chunk buffer) (-> Text Buffer Buffer) - (expansion.let [ (let [[capacity transform] (nominal.representation buffer) - then! (is (-> Text java/lang/StringBuilder java/lang/StringBuilder) - (function (_ chunk builder) - (exec - (java/lang/Appendable::append [(as java/lang/CharSequence chunk)] - builder) - builder)))] - (nominal.abstraction - [(n.+ (//.size chunk) capacity) - (|>> transform (then! chunk))]))] - (for .old - .jvm - .js (let [[capacity transform] (nominal.representation buffer) - then! (is (-> (JS_Array Text) (JS_Array Text)) - (function (_ array) - (exec - (JS_Array::push chunk array) - array)))] - (nominal.abstraction - [(n.+ (//.size chunk) capacity) - (|>> transform then!)])) - .lua (let [[capacity transform] (nominal.representation buffer) - then! (is (-> (array.Array Text) (array.Array Text)) - (function (_ array) - (exec - (table/insert [array chunk]) - array)))] - (nominal.abstraction - [(n.+ (//.size chunk) capacity) - (|>> transform then!)])) - .python (let [[capacity transform] (nominal.representation buffer) - then! (is (-> (Python_List Text) (Python_List Text)) - (function (_ array) - (exec - (Python_List::append chunk array) - array)))] - (nominal.abstraction - [(n.+ (//.size chunk) capacity) - (|>> transform then!)])) - .ruby (let [[capacity transform] (nominal.representation buffer) - then! (is (-> Ruby_Text Ruby_Text) - (function (_ it) + (for .jvm (let [[capacity transform] (nominal.representation buffer) + then! (is (-> Text java/lang/StringBuilder java/lang/StringBuilder) + (function (_ chunk builder) + (exec + (java/lang/Appendable::append [(as java/lang/CharSequence chunk)] + builder) + builder)))] + (nominal.abstraction + [(n.+ (//.size chunk) capacity) + (|>> transform (then! chunk))])) + .js (let [[capacity transform] (nominal.representation buffer) + then! (is (-> (JS_Array Text) (JS_Array Text)) + (function (_ array) + (exec + (JS_Array::push chunk array) + array)))] + (nominal.abstraction + [(n.+ (//.size chunk) capacity) + (|>> transform then!)])) + .lua (let [[capacity transform] (nominal.representation buffer) + then! (is (-> (array.Array Text) (array.Array Text)) + (function (_ array) + (exec + (table/insert [array chunk]) + array)))] + (nominal.abstraction + [(n.+ (//.size chunk) capacity) + (|>> transform then!)])) + .python (let [[capacity transform] (nominal.representation buffer) + then! (is (-> (Python_List Text) (Python_List Text)) + (function (_ array) (exec - (Ruby_Text::<< chunk (as Ruby_Text it)) - it)))] + (Python_List::append chunk array) + array)))] (nominal.abstraction [(n.+ (//.size chunk) capacity) (|>> transform then!)])) - ... ... default - ... (|> buffer nominal.representation (sequence.suffix chunk) nominal.abstraction) - ))) + .ruby (let [[capacity transform] (nominal.representation buffer) + then! (is (-> Ruby_Text Ruby_Text) + (function (_ it) + (exec + (Ruby_Text::<< chunk (as Ruby_Text it)) + it)))] + (nominal.abstraction + [(n.+ (//.size chunk) capacity) + (|>> transform then!)])) + ... ... default + ... (|> buffer nominal.representation (sequence.suffix chunk) nominal.abstraction) + )) (the .public size (-> Buffer Nat) - (expansion.let [ (|>> nominal.representation product.left)] - (for .old - .jvm - .js - .lua - .python - .ruby - ... ... default - ... (|>> nominal.representation - ... (sequence#mix (function (_ chunk total) - ... (n.+ (//.size chunk) total)) - ... 0)) - ))) + (for .jvm (|>> nominal.representation product.left) + .js (|>> nominal.representation product.left) + .lua (|>> nominal.representation product.left) + .python (|>> nominal.representation product.left) + .ruby (|>> nominal.representation product.left) + ... ... default + ... (|>> nominal.representation + ... (sequence#mix (function (_ chunk total) + ... (n.+ (//.size chunk) total)) + ... 0)) + )) (the .public (text buffer) (-> Buffer Text) - (expansion.let [ (let [[capacity transform] (nominal.representation buffer)] - (|> (java/lang/StringBuilder::new [(ffi.as_int (.int capacity))]) - transform - (java/lang/StringBuilder::toString []) - ffi.of_string))] - (for .old - .jvm - .js (let [[capacity transform] (nominal.representation buffer)] - (|> (array.empty 0) - (as (JS_Array Text)) + (for .jvm (let [[capacity transform] (nominal.representation buffer)] + (|> (java/lang/StringBuilder::new [(ffi.as_int (.int capacity))]) + transform + (java/lang/StringBuilder::toString []) + ffi.of_string)) + .js (let [[capacity transform] (nominal.representation buffer)] + (|> (array.empty 0) + (as (JS_Array Text)) + transform + (JS_Array::join ""))) + .lua (let [[capacity transform] (nominal.representation buffer)] + (table/concat [(transform (array.empty 0)) ""])) + .python (let [[capacity transform] (nominal.representation buffer)] + (Python_Text::join (|> (array.empty 0) + (as (Python_List Text)) + transform) + (as Python_Text ""))) + .ruby (let [[capacity transform] (nominal.representation buffer)] + (|> "" + (as Ruby_Text) transform - (JS_Array::join ""))) - .lua (let [[capacity transform] (nominal.representation buffer)] - (table/concat [(transform (array.empty 0)) ""])) - .python (let [[capacity transform] (nominal.representation buffer)] - (Python_Text::join (|> (array.empty 0) - (as (Python_List Text)) - transform) - (as Python_Text ""))) - .ruby (let [[capacity transform] (nominal.representation buffer)] - (|> "" - (as Ruby_Text) - transform - (as Text))) - ... ... default - ... (sequence#mix (function (_ chunk total) - ... (%.message total chunk)) - ... "" - ... (nominal.representation buffer)) - ))) + (as Text))) + ... ... default + ... (sequence#mix (function (_ chunk total) + ... (%.message total chunk)) + ... "" + ... (nominal.representation buffer)) + )) )) diff --git a/stdlib/source/library/lux/data/text/encoding/utf8.lux b/stdlib/source/library/lux/data/text/encoding/utf8.lux index 4ab9086c5e..b1bdda9a2b 100644 --- a/stdlib/source/library/lux/data/text/encoding/utf8.lux +++ b/stdlib/source/library/lux/data/text/encoding/utf8.lux @@ -16,65 +16,60 @@ ["[0]" expansion]]]]] ["[0]" //]) -(expansion.let [ (these (ffi.import java/lang/String - "[1]::[0]" - (new [[byte] java/lang/String]) - (getBytes [java/lang/String] [byte])))] - (for .old (these ) - .jvm (these ) - - .js - (these (ffi.import Uint8Array - "[1]::[0]") - - ... On Node - (ffi.import Buffer - "[1]::[0]" - ("static" from "as" from|injection [ffi.String ffi.String] Buffer) - ("static" from "as" from|projection [Uint8Array] Buffer) - (toString [ffi.String] ffi.String)) - - ... On the browser - (ffi.import TextEncoder - "[1]::[0]" - (new [ffi.String]) - (encode [ffi.String] Uint8Array)) - - (ffi.import TextDecoder - "[1]::[0]" - (new [ffi.String]) - (decode [Uint8Array] ffi.String))) - - .ruby - (these (ffi.import String - "[1]::[0]" - (encode [Text] String) - (force_encoding [Text] Text) - (bytes [] Binary)) - - (ffi.import Array - "[1]::[0]" - (pack [Text] String))) - - .php - (these (ffi.import Almost_Binary) - (ffi.import (unpack [ffi.String ffi.String] Almost_Binary)) - (ffi.import (array_values [Almost_Binary] Binary)) - (the php_byte_array_format "C*")) - - .scheme - ... https://srfi.schemers.org/srfi-140/srfi-140.html - (these (ffi.import (string->utf8 [Text] Binary)) - (ffi.import (utf8->string [Binary] Text))) - (these))) +(for .jvm + (ffi.import java/lang/String + "[1]::[0]" + (new [[byte] java/lang/String]) + (getBytes [java/lang/String] [byte])) + + .js + (these (ffi.import Uint8Array + "[1]::[0]") + + ... On Node + (ffi.import Buffer + "[1]::[0]" + ("static" from "as" from|injection [ffi.String ffi.String] Buffer) + ("static" from "as" from|projection [Uint8Array] Buffer) + (toString [ffi.String] ffi.String)) + + ... On the browser + (ffi.import TextEncoder + "[1]::[0]" + (new [ffi.String]) + (encode [ffi.String] Uint8Array)) + + (ffi.import TextDecoder + "[1]::[0]" + (new [ffi.String]) + (decode [Uint8Array] ffi.String))) + + .ruby + (these (ffi.import String + "[1]::[0]" + (encode [Text] String) + (force_encoding [Text] Text) + (bytes [] Binary)) + + (ffi.import Array + "[1]::[0]" + (pack [Text] String))) + + .php + (these (ffi.import Almost_Binary) + (ffi.import (unpack [ffi.String ffi.String] Almost_Binary)) + (ffi.import (array_values [Almost_Binary] Binary)) + (the php_byte_array_format "C*")) + + .scheme + ... https://srfi.schemers.org/srfi-140/srfi-140.html + (these (ffi.import (string->utf8 [Text] Binary)) + (ffi.import (utf8->string [Binary] Text))) + (these)) (the (injection value) (-> Text Binary) - (for .old - (java/lang/String::getBytes [(ffi.as_string (//.name //.utf_8))] - (ffi.as_string value)) - - .jvm + (for .jvm (java/lang/String::getBytes [(ffi.as_string (//.name //.utf_8))] (ffi.as_string value)) @@ -116,49 +111,50 @@ (the (projection value) (-> Binary (Try Text)) - (expansion.let [ {try.#Success (ffi.of_string (java/lang/String::new [value (ffi.as_string (//.name //.utf_8))]))}] - (for .old - .jvm - - .js - (cond ffi.on_nashorn? - (|> (.js_object_new# (.js_constant# "java.lang.String") [value "utf8"]) - (as Text) - {try.#Success}) - - ffi.on_node_js? - (|> (Buffer::from|projection [value]) - (Buffer::toString ["utf8"]) - {try.#Success}) - - ... On the browser - (|> (TextDecoder::new [(//.name //.utf_8)]) - (TextDecoder::decode [value]) - {try.#Success})) - - .python - (try (as Text (.python_object_do# "decode" (as_expected value) ["utf-8"]))) - - .lua - {try.#Success (.lua_utf8_projection# value)} - - .ruby - (|> value - (as Array) - (Array::pack ["C*"]) - (as String) - (String::force_encoding ["UTF-8"]) - {try.#Success}) - - .php - (|> value - ("php pack" ..php_byte_array_format) - {try.#Success}) - - .scheme - (|> value - ..utf8->string - {try.#Success})))) + (for .jvm + (|> (java/lang/String::new [value (ffi.as_string (//.name //.utf_8))]) + ffi.of_string + {try.#Success}) + + .js + (cond ffi.on_nashorn? + (|> (.js_object_new# (.js_constant# "java.lang.String") [value "utf8"]) + (as Text) + {try.#Success}) + + ffi.on_node_js? + (|> (Buffer::from|projection [value]) + (Buffer::toString ["utf8"]) + {try.#Success}) + + ... On the browser + (|> (TextDecoder::new [(//.name //.utf_8)]) + (TextDecoder::decode [value]) + {try.#Success})) + + .python + (try (as Text (.python_object_do# "decode" (as_expected value) ["utf-8"]))) + + .lua + {try.#Success (.lua_utf8_projection# value)} + + .ruby + (|> value + (as Array) + (Array::pack ["C*"]) + (as String) + (String::force_encoding ["UTF-8"]) + {try.#Success}) + + .php + (|> value + ("php pack" ..php_byte_array_format) + {try.#Success}) + + .scheme + (|> value + ..utf8->string + {try.#Success}))) (the .public format (Format Binary Text) diff --git a/stdlib/source/library/lux/debug.lux b/stdlib/source/library/lux/debug.lux index 12d6ff7f67..d883eb945f 100644 --- a/stdlib/source/library/lux/debug.lux +++ b/stdlib/source/library/lux/debug.lux @@ -39,76 +39,75 @@ ["[0]" type (.only) ["<[1]>" \\projection (.only Projection)]]]]]) -(expansion.let [ (these (import java/lang/String - "[1]::[0]") - - (import (java/lang/Class a) - "[1]::[0]") - - (import java/lang/Object - "[1]::[0]" - (toString [] java/lang/String)) - - (import java/lang/Integer - "[1]::[0]" - (longValue [] long)) - - (import java/lang/Long - "[1]::[0]") - - (import java/lang/Number - "[1]::[0]" - (doubleValue [] double)))] - (for .old (these ) - .jvm (these ) - - .js - (these (import JSON - "[1]::[0]" - ("static" stringify [.Any] ffi.String)) - (import Array - "[1]::[0]" - ("static" isArray [.Any] ffi.Boolean))) - - .python - (these (.every PyType - (Nominal "python_type")) - - (import (type [.Any] PyType)) - (import (str [.Any] ffi.String))) - - .lua - (these (import (type [.Any] ffi.String)) - (import (tostring [.Any] ffi.String)) - - (import math - "[1]::[0]" - ("static" type [.Any] "?" ffi.String))) - - .ruby - (these (import Class - "[1]::[0]") - - (import Object - "[1]::[0]" - (class [] Class) - (to_s [] ffi.String))) - - .php - (these (import (gettype [.Any] ffi.String)) - (import (strval [.Any] ffi.String))) - - .scheme - (these (import (boolean? [.Any] Bit)) - (import (integer? [.Any] Bit)) - (import (real? [.Any] Bit)) - (import (string? [.Any] Bit)) - (import (vector? [.Any] Bit)) - (import (pair? [.Any] Bit)) - (import (car [.Any] .Any)) - (import (cdr [.Any] .Any)) - (import (format [Text .Any] Text))) - )) +(for .jvm + (these (import java/lang/String + "[1]::[0]") + + (import (java/lang/Class a) + "[1]::[0]") + + (import java/lang/Object + "[1]::[0]" + (toString [] java/lang/String)) + + (import java/lang/Integer + "[1]::[0]" + (longValue [] long)) + + (import java/lang/Long + "[1]::[0]") + + (import java/lang/Number + "[1]::[0]" + (doubleValue [] double))) + + .js + (these (import JSON + "[1]::[0]" + ("static" stringify [.Any] ffi.String)) + (import Array + "[1]::[0]" + ("static" isArray [.Any] ffi.Boolean))) + + .python + (these (.every PyType + (Nominal "python_type")) + + (import (type [.Any] PyType)) + (import (str [.Any] ffi.String))) + + .lua + (these (import (type [.Any] ffi.String)) + (import (tostring [.Any] ffi.String)) + + (import math + "[1]::[0]" + ("static" type [.Any] "?" ffi.String))) + + .ruby + (these (import Class + "[1]::[0]") + + (import Object + "[1]::[0]" + (class [] Class) + (to_s [] ffi.String))) + + .php + (these (import (gettype [.Any] ffi.String)) + (import (strval [.Any] ffi.String))) + + .scheme + (these (import (boolean? [.Any] Bit)) + (import (integer? [.Any] Bit)) + (import (real? [.Any] Bit)) + (import (string? [.Any] Bit)) + (import (vector? [.Any] Bit)) + (import (pair? [.Any] Bit)) + (import (car [.Any] .Any)) + (import (cdr [.Any] .Any)) + (import (format [Text .Any] Text))) + ) (the Inspector (.type (text.Injection Any))) @@ -138,244 +137,243 @@ (the .public (inspection value) Inspector - (expansion.let [ (let [object (as java/lang/Object value)] - (`` (<| (,, (template.with [ ] - [(when (ffi.as object) - {.#Some value} - (`` (|> value (,, (template.spliced )))) - - {.#None})] - - [java/lang/Boolean [ffi.of_boolean %.bit]] - [java/lang/Long [ffi.of_long %.int]] - [java/lang/Number [(java/lang/Number::doubleValue []) ffi.of_double %.dec]] - [java/lang/String [ffi.of_string %.text]] - )) - (when (ffi.as [java/lang/Object] object) - {.#Some value} - (let [value (as (array.Array java/lang/Object) value)] - (when (array.item 0 value) - (^.multi {try.#Success tag} - [(ffi.as java/lang/Integer tag) - {.#Some tag}] - [[(array.item 1 value) (array.item 2 value)] - [last? {try.#Success choice}]]) - (let [last? (when last? - {try.#Success _} #1 - {try.#Failure _} #0)] - (|> (%.message (%.nat (.nat (ffi.of_long (java/lang/Integer::longValue [] tag)))) - " " (%.bit last?) - " " (inspection choice)) - (text.enclosed ["{" "}"]))) - - _ - (tuple_inspection inspection value))) - {.#None}) - (ffi.of_string (java/lang/Object::toString [] object)))))] - (for .old - .jvm - - .js - (`` (when (ffi.type_of value) - (,, (template.with [ ] - [ - (`` (|> value (,, (template.spliced ))))] - - ["boolean" [(as .Bit) %.bit]] - ["number" [(as .Dec) %.dec]] - ["string" [(as .Text) %.text]] - ["undefined" [JSON::stringify]])) - - "object" - (let [variant_tag (.js_object_get# "_lux_tag" value) - variant_flag (.js_object_get# "_lux_flag" value) - variant_value (.js_object_get# "_lux_value" value)] - (cond (not (or (.js_object_undefined?# variant_tag) - (.js_object_undefined?# variant_flag) - (.js_object_undefined?# variant_value))) - (|> (%.message (JSON::stringify variant_tag) - " " (%.bit (not (.js_object_null?# variant_flag))) - " " (inspection variant_value)) - (text.enclosed ["{" "}"])) + (for .jvm + (let [object (as java/lang/Object value)] + (`` (<| (,, (template.with [ ] + [(when (ffi.as object) + {.#Some value} + (`` (|> value (,, (template.spliced )))) + + {.#None})] + + [java/lang/Boolean [ffi.of_boolean %.bit]] + [java/lang/Long [ffi.of_long %.int]] + [java/lang/Number [(java/lang/Number::doubleValue []) ffi.of_double %.dec]] + [java/lang/String [ffi.of_string %.text]] + )) + (when (ffi.as [java/lang/Object] object) + {.#Some value} + (let [value (as (array.Array java/lang/Object) value)] + (when (array.item 0 value) + (^.multi {try.#Success tag} + [(ffi.as java/lang/Integer tag) + {.#Some tag}] + [[(array.item 1 value) (array.item 2 value)] + [last? {try.#Success choice}]]) + (let [last? (when last? + {try.#Success _} #1 + {try.#Failure _} #0)] + (|> (%.message (%.nat (.nat (ffi.of_long (java/lang/Integer::longValue [] tag)))) + " " (%.bit last?) + " " (inspection choice)) + (text.enclosed ["{" "}"]))) + + _ + (tuple_inspection inspection value))) + {.#None}) + (ffi.of_string (java/lang/Object::toString [] object))))) + + .js + (`` (when (ffi.type_of value) + (,, (template.with [ ] + [ + (`` (|> value (,, (template.spliced ))))] + + ["boolean" [(as .Bit) %.bit]] + ["number" [(as .Dec) %.dec]] + ["string" [(as .Text) %.text]] + ["undefined" [JSON::stringify]])) + + "object" + (let [variant_tag (.js_object_get# "_lux_tag" value) + variant_flag (.js_object_get# "_lux_flag" value) + variant_value (.js_object_get# "_lux_value" value)] + (cond (not (or (.js_object_undefined?# variant_tag) + (.js_object_undefined?# variant_flag) + (.js_object_undefined?# variant_value))) + (|> (%.message (JSON::stringify variant_tag) + " " (%.bit (not (.js_object_null?# variant_flag))) + " " (inspection variant_value)) + (text.enclosed ["{" "}"])) + + (not (or (.js_object_undefined?# (.js_object_get# "_lux_low" value)) + (.js_object_undefined?# (.js_object_get# "_lux_high" value)))) + (|> value (as .Int) %.int) + + (Array::isArray value) + (tuple_inspection inspection value) + + ... else + (JSON::stringify value))) + + _ + (JSON::stringify value))) - (not (or (.js_object_undefined?# (.js_object_get# "_lux_low" value)) - (.js_object_undefined?# (.js_object_get# "_lux_high" value)))) - (|> value (as .Int) %.int) + .python + (`` (when (..str (..type value)) + (,, (template.with [ ] + [(^.or ) + (`` (|> value (,, (template.spliced ))))] + + ["" "" [(as .Bit) %.bit]] + ["" "" [(as .Int) %.int]] + ["" "" [(as .Dec) %.dec]] + ["" "" [(as .Text) %.text]] + ["" "" [(as .Text) %.text]])) + + (^.or "" "") + (tuple_inspection inspection value) + + (^.or "" "") + (let [variant (as (array.Array Any) value)] + (when (array.size variant) + 3 (let [variant_tag (.python_array_read# 0 variant) + variant_flag (.python_array_read# 1 variant) + variant_value (.python_array_read# 2 variant)] + (if (or (.python_object_none?# variant_tag) + (.python_object_none?# variant_value)) + (..str value) + (|> (%.message (|> variant_tag (as .Nat) %.nat) + " " (|> variant_flag .python_object_none?# not %.bit) + " " (inspection variant_value)) + (text.enclosed ["{" "}"])))) + _ (..str value))) - (Array::isArray value) - (tuple_inspection inspection value) - - ... else - (JSON::stringify value))) + _ + (..str value))) + .lua + (`` (when (..type value) + (,, (template.with [ ] + [ + (`` (|> value (,, (template.spliced ))))] + + ["boolean" [(as .Bit) %.bit]] + ["string" [(as .Text) %.text]] + ["nil" [(pipe.new "nil" [])]])) + + "number" + (when (math::type value) + {.#Some "integer"} (|> value (as .Int) %.int) + {.#Some "float"} (|> value (as .Dec) %.dec) + _ - (JSON::stringify value))) - - .python - (`` (when (..str (..type value)) - (,, (template.with [ ] - [(^.or ) - (`` (|> value (,, (template.spliced ))))] - - ["" "" [(as .Bit) %.bit]] - ["" "" [(as .Int) %.int]] - ["" "" [(as .Dec) %.dec]] - ["" "" [(as .Text) %.text]] - ["" "" [(as .Text) %.text]])) - - (^.or "" "") - (tuple_inspection inspection value) - - (^.or "" "") - (let [variant (as (array.Array Any) value)] - (when (array.size variant) - 3 (let [variant_tag (.python_array_read# 0 variant) - variant_flag (.python_array_read# 1 variant) - variant_value (.python_array_read# 2 variant)] - (if (or (.python_object_none?# variant_tag) - (.python_object_none?# variant_value)) - (..str value) + (..tostring value)) + + "table" + (let [variant_tag (.lua_object_get# "_lux_tag" value) + variant_flag (.lua_object_get# "_lux_flag" value) + variant_value (.lua_object_get# "_lux_value" value)] + (if (or (.lua_object_nil?# variant_tag) + (.lua_object_nil?# variant_value)) + (tuple_inspection inspection value) + (|> (%.message (|> variant_tag (as .Nat) %.nat) + " " (%.bit (not (.lua_object_nil?# variant_flag))) + " " (inspection variant_value)) + (text.enclosed ["{" "}"])))) + + _ + (..tostring value))) + + .ruby + (template.let [(class_of ) + [(|> + (as ..Object) + (Object::class []))] + + (to_s ) + [(|> + (as ..Object) + (Object::to_s []))]] + (let [value_class (class_of value)] + (`` (cond (,, (template.with [ ] + [(same? (class_of ) value_class) + (|> value (as ) )] + + [#0 Bit %.bit] + [#1 Bit %.bit] + [+1 Int %.int] + [+1.0 Dec %.dec] + ["" Text %.text] + [(.ruby_object_nil#) Any (pipe.new "nil" [])] + )) + + (same? (class_of {.#None}) value_class) + (let [variant_tag (.ruby_object_get# "_lux_tag" value) + variant_flag (.ruby_object_get# "_lux_flag" value) + variant_value (.ruby_object_get# "_lux_value" value)] + (if (or (.ruby_object_nil?# variant_tag) + (.ruby_object_nil?# variant_value)) + (tuple_inspection inspection value) (|> (%.message (|> variant_tag (as .Nat) %.nat) - " " (|> variant_flag .python_object_none?# not %.bit) + " " (%.bit (not (.ruby_object_nil?# variant_flag))) " " (inspection variant_value)) (text.enclosed ["{" "}"])))) - _ (..str value))) - _ - (..str value))) - - .lua - (`` (when (..type value) - (,, (template.with [ ] - [ - (`` (|> value (,, (template.spliced ))))] - - ["boolean" [(as .Bit) %.bit]] - ["string" [(as .Text) %.text]] - ["nil" [(pipe.new "nil" [])]])) - - "number" - (when (math::type value) - {.#Some "integer"} (|> value (as .Int) %.int) - {.#Some "float"} (|> value (as .Dec) %.dec) - - _ - (..tostring value)) - - "table" - (let [variant_tag (.lua_object_get# "_lux_tag" value) - variant_flag (.lua_object_get# "_lux_flag" value) - variant_value (.lua_object_get# "_lux_value" value)] - (if (or (.lua_object_nil?# variant_tag) - (.lua_object_nil?# variant_value)) - (tuple_inspection inspection value) - (|> (%.message (|> variant_tag (as .Nat) %.nat) - " " (%.bit (not (.lua_object_nil?# variant_flag))) - " " (inspection variant_value)) - (text.enclosed ["{" "}"])))) + (same? (class_of [[] []]) value_class) + (tuple_inspection inspection value) - _ - (..tostring value))) - - .ruby - (template.let [(class_of ) - [(|> - (as ..Object) - (Object::class []))] - - (to_s ) - [(|> - (as ..Object) - (Object::to_s []))]] - (let [value_class (class_of value)] - (`` (cond (,, (template.with [ ] - [(same? (class_of ) value_class) - (|> value (as ) )] - - [#0 Bit %.bit] - [#1 Bit %.bit] - [+1 Int %.int] - [+1.0 Dec %.dec] - ["" Text %.text] - [(.ruby_object_nil#) Any (pipe.new "nil" [])] - )) - - (same? (class_of {.#None}) value_class) - (let [variant_tag (.ruby_object_get# "_lux_tag" value) - variant_flag (.ruby_object_get# "_lux_flag" value) - variant_value (.ruby_object_get# "_lux_value" value)] - (if (or (.ruby_object_nil?# variant_tag) - (.ruby_object_nil?# variant_value)) - (tuple_inspection inspection value) - (|> (%.message (|> variant_tag (as .Nat) %.nat) - " " (%.bit (not (.ruby_object_nil?# variant_flag))) - " " (inspection variant_value)) - (text.enclosed ["{" "}"])))) - - (same? (class_of [[] []]) value_class) - (tuple_inspection inspection value) - - ... else - (to_s value))))) - - .php - (`` (when (..gettype value) - (,, (template.with [ ] - [ - (`` (|> value (,, (template.spliced ))))] - - ["boolean" [(as .Bit) %.bit]] - ["integer" [(as .Int) %.int]] - ["double" [(as .Dec) %.dec]] - ["string" [(as .Text) %.text]] - ["NULL" [(pipe.new "null" [])]] - ["array" [(tuple_inspection inspection)]])) - - "object" - (let [variant_tag ("php object get" "_lux_tag" value) - variant_flag ("php object get" "_lux_flag" value) - variant_value ("php object get" "_lux_value" value)] - (if (or ("php object null?" variant_tag) - ("php object null?" variant_value)) - (..strval value) - (|> (%.message (|> variant_tag (as .Nat) %.nat) - " " (%.bit (not ("php object null?" variant_flag))) - " " (inspection variant_value)) - (text.enclosed ["{" "}"])))) + ... else + (to_s value))))) - _ - (..strval value))) - - .scheme - (`` (cond (,, (template.with [ ] - [( value) - (`` (|> value (,, (template.spliced ))))] - - [..boolean? [(as .Bit) %.bit]] - [..integer? [(as .Int) %.int]] - [..real? [(as .Dec) %.dec]] - [..string? [(as .Text) %.text]] - ["scheme object nil?" [(pipe.new "()" [])]] - [..vector? [(tuple_inspection inspection)]])) - - (..pair? value) - (let [variant_tag (..car value) - variant_rest (..cdr value)] - (if (and (..integer? variant_tag) - (i.> +0 (as Int variant_tag)) - (..pair? variant_rest)) - (let [variant_flag (..car variant_rest) - variant_value (..cdr variant_rest)] - (|> (%.message (|> variant_tag (as .Nat) %.nat) - " " (%.bit (not ("scheme object nil?" variant_flag))) - " " (inspection variant_value)) - (text.enclosed ["{" "}"]))) - (..format ["~s" value]))) + .php + (`` (when (..gettype value) + (,, (template.with [ ] + [ + (`` (|> value (,, (template.spliced ))))] + + ["boolean" [(as .Bit) %.bit]] + ["integer" [(as .Int) %.int]] + ["double" [(as .Dec) %.dec]] + ["string" [(as .Text) %.text]] + ["NULL" [(pipe.new "null" [])]] + ["array" [(tuple_inspection inspection)]])) + + "object" + (let [variant_tag ("php object get" "_lux_tag" value) + variant_flag ("php object get" "_lux_flag" value) + variant_value ("php object get" "_lux_value" value)] + (if (or ("php object null?" variant_tag) + ("php object null?" variant_value)) + (..strval value) + (|> (%.message (|> variant_tag (as .Nat) %.nat) + " " (%.bit (not ("php object null?" variant_flag))) + " " (inspection variant_value)) + (text.enclosed ["{" "}"])))) + + _ + (..strval value))) - ... else - (..format ["~s" value]) - )) - ))) + .scheme + (`` (cond (,, (template.with [ ] + [( value) + (`` (|> value (,, (template.spliced ))))] + + [..boolean? [(as .Bit) %.bit]] + [..integer? [(as .Int) %.int]] + [..real? [(as .Dec) %.dec]] + [..string? [(as .Text) %.text]] + ["scheme object nil?" [(pipe.new "()" [])]] + [..vector? [(tuple_inspection inspection)]])) + + (..pair? value) + (let [variant_tag (..car value) + variant_rest (..cdr value)] + (if (and (..integer? variant_tag) + (i.> +0 (as Int variant_tag)) + (..pair? variant_rest)) + (let [variant_flag (..car variant_rest) + variant_value (..cdr variant_rest)] + (|> (%.message (|> variant_tag (as .Nat) %.nat) + " " (%.bit (not ("scheme object nil?" variant_flag))) + " " (inspection variant_value)) + (text.enclosed ["{" "}"]))) + (..format ["~s" value]))) + + ... else + (..format ["~s" value]) + )) + )) (exception.the .public (cannot_represent_value type) (Exception Type) diff --git a/stdlib/source/library/lux/ffi.old.lux b/stdlib/source/library/lux/ffi.old.lux deleted file mode 100644 index da8a07cfe3..0000000000 --- a/stdlib/source/library/lux/ffi.old.lux +++ /dev/null @@ -1,1790 +0,0 @@ -... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(.require - [library - [lux (.except Double - is as type) - [abstract - ["[0]" monad (.only Monad do)] - ["[0]" enum]] - [control - ["<>" projection] - ["[0]" function] - ["[0]" io] - ["[0]" maybe] - ["[0]" try (.only Try)]] - [data - ["[0]" product] - ["[0]" bit (.use "[1]#[0]" format)] - ["[0]" text (.use "[1]#[0]" equivalence monoid) - ["%" \\injection]] - [collection - ["[0]" array (.only Array)] - ["[0]" list (.use "[1]#[0]" monad mix monoid)]]] - ["[0]" meta (.only) - ["[0]" module] - ["[0]" binding] - ["[0]" type (.use "[1]#[0]" equivalence)] - ["[0]" code (.only) - ["<[1]>" \\projection (.only Projection)]] - ["[0]" macro (.only with_symbols) - ["^" pattern] - ["[0]" syntax] - ["[0]" template]]]]]) - -(template.with [ ] - [(the .public ( value) - (-> (Nominal ) (Nominal )) - ( 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"] - ) - -(template.with [ ] - [(the .public - (template.macro ( it) - [(|> it (.is ) (.as (Nominal )))])) - - (the .public - (template.macro ( it) - [(|> it (.is (Nominal )) (.as ))]))] - - [as_boolean .Bit "java.lang.Boolean" of_boolean] - [as_long .Int "java.lang.Long" of_long] - [as_double .Dec "java.lang.Double" of_double] - [as_string .Text "java.lang.String" of_string] - ) - -(template.with [ <$> <$'> ] - [(the .public - (template.macro ( it) - [(|> it (.is ) (.as (Nominal )) <$> (.is (Nominal )))])) - - (the .public - (template.macro ( it) - [(|> it (.is (Nominal )) <$'> (.is (Nominal )) (.as ))]))] - - [as_byte .Int ..long_to_byte "java.lang.Long" ..byte_to_long "java.lang.Byte" of_byte] - [as_short .Int ..long_to_short "java.lang.Long" ..short_to_long "java.lang.Short" of_short] - [as_int .Int ..long_to_int "java.lang.Long" ..int_to_long "java.lang.Integer" of_int] - [as_float .Dec ..double_to_float "java.lang.Double" ..float_to_double "java.lang.Float" of_float] - ) - -... [Utils] -(the constructor_method_name "") -(the member_separator "::") - -... Types -(.every JVM_Code - Text) - -(.every BoundKind - (Variant - {#UpperBound} - {#LowerBound})) - -(.every GenericType - (Rec GenericType - (Variant - {#GenericTypeVar Text} - {#GenericClass [Text (List GenericType)]} - {#GenericArray GenericType} - {#GenericWildcard (Maybe [BoundKind GenericType])}))) - -(.every Type_Parameter - [Text (List GenericType)]) - -(.every Primitive_Mode - (Variant - {#ManualPrM} - {#AutoPrM})) - -(.every .public Privacy - (Variant - {#PublicP} - {#PrivateP} - {#ProtectedP} - {#DefaultP})) - -(.every .public State - (Variant - {#VolatileS} - {#FinalS} - {#DefaultS})) - -(.every .public Inheritance - (Variant - {#FinalI} - {#AbstractI} - {#DefaultI})) - -(.every Class_Kind - (Variant - {#Class} - {#Interface})) - -(.every Class_Declaration - (Record - [#class_name Text - #class_params (List Type_Parameter)])) - -(.every StackFrame - (Nominal "java/lang/StackTraceElement")) - -(.every StackTrace - (Array StackFrame)) - -(.every Super_Class_Decl - (Record - [#super_class_name Text - #super_class_params (List GenericType)])) - -(.every AnnotationParam - [Text Code]) - -(.every Annotation - (Record - [#ann_name Text - #ann_params (List AnnotationParam)])) - -(.every Member_Declaration - (Record - [#member_name Text - #member_privacy Privacy - #member_anns (List Annotation)])) - -(.every FieldDecl - (Variant - {#ConstantField GenericType Code} - {#VariableField State GenericType})) - -(.every MethodDecl - (Record - [#method_tvars (List Type_Parameter) - #method_inputs (List GenericType) - #method_output GenericType - #method_exs (List GenericType)])) - -(.every ArgDecl - (Record - [#arg_name Text - #arg_type GenericType])) - -(.every ConstructorArg - [GenericType Code]) - -(.every Method_Definition - (Variant - {#ConstructorMethod [Bit - (List Type_Parameter) - (List ArgDecl) - (List ConstructorArg) - Code - (List GenericType)]} - {#VirtualMethod [Bit - Bit - (List Type_Parameter) - Text - (List ArgDecl) - GenericType - Code - (List GenericType)]} - {#OverridenMethod [Bit - Class_Declaration - (List Type_Parameter) - Text - (List ArgDecl) - GenericType - Code - (List GenericType)]} - {#StaticMethod [Bit - (List Type_Parameter) - (List ArgDecl) - GenericType - Code - (List GenericType)]} - {#AbstractMethod [(List Type_Parameter) - (List ArgDecl) - GenericType - (List GenericType)]} - {#NativeMethod [(List Type_Parameter) - (List ArgDecl) - GenericType - (List GenericType)]})) - -(.every Partial_Call - (Record - [#pc_method Symbol - #pc_args (List Code)])) - -(.every ImportMethodKind - (Variant - {#StaticIMK} - {#VirtualIMK})) - -(.every ImportMethodCommons - (Record - [#import_member_mode Primitive_Mode - #import_member_alias Text - #import_member_kind ImportMethodKind - #import_member_tvars (List Type_Parameter) - #import_member_args (List [Bit GenericType]) - #import_member_maybe? Bit - #import_member_try? Bit - #import_member_io? Bit])) - -(.every ImportConstructorDecl - (Record - [])) - -(.every ImportMethodDecl - (Record - [#import_method_name Text - #import_method_return GenericType])) - -(.every ImportFieldDecl - (Record - [#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])) - -(.every Import_Member_Declaration - (Variant - {#EnumDecl (List Text)} - {#ConstructorDecl [ImportMethodCommons ImportConstructorDecl]} - {#MethodDecl [ImportMethodCommons ImportMethodDecl]} - {#FieldAccessDecl ImportFieldDecl})) - -... Utils -(the (manual_primitive_type class) - (-> Text (Maybe Code)) - (`` (when class - (,, (template.with [ ] - [ - {.#Some (' )}] - - ["boolean" (Nominal "java.lang.Boolean")] - ["byte" (Nominal "java.lang.Byte")] - ["short" (Nominal "java.lang.Short")] - ["int" (Nominal "java.lang.Integer")] - ["long" (Nominal "java.lang.Long")] - ["float" (Nominal "java.lang.Float")] - ["double" (Nominal "java.lang.Double")] - ["char" (Nominal "java.lang.Character")] - ["void" .Any])) - - _ - {.#None}))) - -(the (auto_primitive_type class) - (-> Text (Maybe Code)) - (`` (when class - (,, (template.with [ ] - [ - {.#Some (' )}] - - ["boolean" .Bit] - ["byte" .Int] - ["short" .Int] - ["int" .Int] - ["long" .Int] - ["float" .Dec] - ["double" .Dec] - ["void" .Any])) - - _ - {.#None}))) - -(the safe - (-> Text Text) - (text.replaced "/" ".")) - -(the (generic_class_type' mode type_params in_array? name+params - class_type') - (-> Primitive_Mode (List Type_Parameter) Bit [Text (List GenericType)] - (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) - Code) - (when [name+params mode in_array?] - (^.multi [[prim {.#End}] {#ManualPrM} .false] - [(manual_primitive_type prim) - {.#Some output}]) - output - - (^.multi [[prim {.#End}] {#AutoPrM} .false] - [(auto_primitive_type prim) - {.#Some output}]) - output - - [[name params] _ _] - (let [name (safe name) - =params (list#each (class_type' mode type_params in_array?) params)] - (` (Nominal (, (code.text name)) [(,* =params)]))))) - -(the (class_type' mode type_params in_array? class) - (-> Primitive_Mode (List Type_Parameter) Bit GenericType Code) - (when class - {#GenericTypeVar name} - (when (list.example (function (_ [pname pbounds]) - (and (text#= name pname) - (not (list.empty? pbounds)))) - type_params) - {try.#Failure _} - (code.symbol ["" name]) - - {try.#Success [pname pbounds]} - (class_type' mode type_params in_array? (maybe.trusted (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 true param)] - (` (array.Array (, =param)))) - - (^.or {#GenericWildcard {.#None}} - {#GenericWildcard {.#Some [{#LowerBound} _]}}) - (` .Any) - - {#GenericWildcard {.#Some [{#UpperBound} upper_bound]}} - (class_type' mode type_params in_array? upper_bound) - )) - -(the (class_type mode type_params class) - (-> Primitive_Mode (List Type_Parameter) GenericType Code) - (class_type' mode type_params false class)) - -(the (type_param_type$ [name bounds]) - (-> Type_Parameter Code) - (code.symbol ["" name])) - -(the (class_decl_type$ (open "[0]")) - (-> Class_Declaration Code) - (let [=params (list#each (.is (-> Type_Parameter Code) - (function (_ [pname pbounds]) - (when pbounds - {.#End} - (code.symbol ["" pname]) - - {.#Item bound1 _} - (class_type {#ManualPrM} #class_params bound1)))) - #class_params)] - (` (Nominal (, (code.text (safe #class_name))) - [(,* =params)])))) - -(the type_var_class Text "java.lang.Object") - -(the (simple_class$ env class) - (-> (List Type_Parameter) GenericType Text) - (when class - {#GenericTypeVar name} - (when (list.example (function (_ [pname pbounds]) - (and (text#= name pname) - (not (list.empty? pbounds)))) - env) - {try.#Failure _} - type_var_class - - {try.#Success [pname pbounds]} - (simple_class$ env (maybe.trusted (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} - (safe name) - - {#GenericArray param'} - (`` (when param' - {#GenericArray param} - (%.message "[" (simple_class$ env param)) - - (,, (template.with [ ] - [{#GenericClass {.#End}} - ] - - ["boolean" "[Z"] - ["byte" "[B"] - ["short" "[S"] - ["int" "[I"] - ["long" "[J"] - ["float" "[F"] - ["double" "[D"] - ["char" "[C"])) - - param - (%.message "[L" (simple_class$ env param) ";"))) - )) - -(the (get_const_projection class_name field_name) - (-> Text Text (Projection Code)) - (do <>.monad - [.let [dotted_name (%.message "::" field_name)] - _ (.this (code.symbol ["" dotted_name]))] - (in (`' ((, (code.text (%.message "jvm getstatic" ":" class_name ":" field_name)))))))) - -(the (get_var_projection class_name field_name) - (-> Text Text (Projection Code)) - (do <>.monad - [.let [dotted_name (%.message "::" field_name)] - _ (.this (code.symbol ["" dotted_name]))] - (in (`' ((, (code.text (%.message "jvm getfield" ":" class_name ":" field_name))) _jvm_this))))) - -(the (put_var_projection class_name field_name) - (-> Text Text (Projection Code)) - (do <>.monad - [.let [dotted_name (%.message "::" field_name)] - [_ _ value] (.is (Projection [Any Any Code]) - (.form (all <>.and (.this (' :=)) (.this (code.symbol ["" dotted_name])) .any)))] - (in (`' ((, (code.text (%.message "jvm putfield" ":" class_name ":" field_name))) _jvm_this (, value)))))) - -(the (pre_walk_replace f input) - (-> (-> Code Code) Code Code) - (`` (when (f input) - (,, (template.with [] - [[meta { parts}] - [meta { (list#each (pre_walk_replace f) parts)}]] - - [.#Form] - [.#Variant] - [.#Tuple])) - - ast' - ast'))) - -(the (projection_replacer p ast) - (-> (Projection Code) (-> Code Code)) - (when (<>.value p (list ast)) - {.#Right [{.#End} ast']} - ast' - - _ - ast - )) - -(the (field_projection class_name [[field_name _ _] field]) - (-> Text [Member_Declaration FieldDecl] (Projection Code)) - (when field - {#ConstantField _} - (get_const_projection class_name field_name) - - {#VariableField _} - (<>.either (get_var_projection class_name field_name) - (put_var_projection class_name field_name)))) - -(the (constructor_projection params class_name arg_decls) - (-> (List Type_Parameter) Text (List ArgDecl) (Projection Code)) - (do <>.monad - [args (.is (Projection (List Code)) - (.form (<>.after (.this (' ::new!)) - (.tuple (<>.exactly (list.size arg_decls) .any))))) - .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]] - (in (` ((, (code.text (%.message "jvm new" ":" class_name ":" (text.interposed "," arg_decls')))) - (,* args)))))) - -(the (static_method_projection params class_name method_name arg_decls) - (-> (List Type_Parameter) Text Text (List ArgDecl) (Projection Code)) - (do <>.monad - [.let [dotted_name (%.message "::" method_name "!")] - args (.is (Projection (List Code)) - (.form (<>.after (.this (code.symbol ["" dotted_name])) - (.tuple (<>.exactly (list.size arg_decls) .any))))) - .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]] - (in (`' ((, (code.text (%.message "jvm invokestatic" ":" class_name ":" method_name ":" (text.interposed "," arg_decls')))) - (,* args)))))) - -(template.with [ ] - [(the ( params class_name method_name arg_decls) - (-> (List Type_Parameter) Text Text (List ArgDecl) (Projection Code)) - (do <>.monad - [.let [dotted_name (%.message "::" method_name "!")] - args (.is (Projection (List Code)) - (.form (<>.after (.this (code.symbol ["" dotted_name])) - (.tuple (<>.exactly (list.size arg_decls) .any))))) - .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ params)) arg_decls))]] - (in (`' ((, (code.text (%.message ":" class_name ":" method_name ":" (text.interposed "," arg_decls')))) - (,' _jvm_this) (,* args))))))] - - [special_method_projection "jvm invokespecial"] - [virtual_method_projection "jvm invokevirtual"] - ) - -(the (method_projection params class_name [[method_name _ _] meth_def]) - (-> (List Type_Parameter) Text [Member_Declaration Method_Definition] (Projection Code)) - (when meth_def - {#ConstructorMethod strict? type_vars args constructor_args return_expr exs} - (constructor_projection params class_name args) - - {#StaticMethod strict? type_vars args return_type return_expr exs} - (static_method_projection params class_name method_name args) - - (^.or {#VirtualMethod final? strict? type_vars self_name args return_type return_expr exs} - {#OverridenMethod strict? owner_class type_vars self_name args return_type return_expr exs}) - (special_method_projection params class_name method_name args) - - {#AbstractMethod type_vars args return_type exs} - (virtual_method_projection params class_name method_name args) - - {#NativeMethod type_vars args return_type exs} - (virtual_method_projection params class_name method_name args))) - -... Projections -(the privacy_modifier^ - (Projection Privacy) - (let [(open "[0]") <>.monad] - (all <>.or - (.this (' "public")) - (.this (' "private")) - (.this (' "protected")) - (in [])))) - -(the inheritance_modifier^ - (Projection Inheritance) - (let [(open "[0]") <>.monad] - (all <>.or - (.this (' "final")) - (.this (' "abstract")) - (in [])))) - -(the bound_kind^ - (Projection BoundKind) - (<>.or (.this (' <)) - (.this (' >)))) - -(the (no_periods_assertion name) - (-> Text (Projection Any)) - (<>.assertion "Names in class declarations cannot contain periods." - (not (text.contains? "." name)))) - -(the (generic_type^ type_vars) - (-> (List Type_Parameter) (Projection GenericType)) - (<>.rec - (function (_ again^) - (all <>.either - (do <>.monad - [_ (.this (' ?))] - (in {#GenericWildcard {.#None}})) - (.tuple (do <>.monad - [_ (.this (' ?)) - bound_kind bound_kind^ - bound again^] - (in {#GenericWildcard {.#Some [bound_kind bound]}}))) - (do <>.monad - [name .local - _ (no_periods_assertion name)] - (if (list.member? text.equivalence (list#each product.left type_vars) name) - (in {#GenericTypeVar name}) - (in {#GenericClass name (list)}))) - (.tuple (do <>.monad - [component again^] - (`` (when component - (,, (template.with [ ] - [{#GenericClass {.#End}} - (in {#GenericClass (list)})] - - ["[Z" "boolean"] - ["[B" "byte"] - ["[S" "short"] - ["[I" "int"] - ["[J" "long"] - ["[F" "float"] - ["[D" "double"] - ["[C" "char"])) - - _ - (in {#GenericArray component}))))) - (.form (do <>.monad - [name .local - _ (no_periods_assertion name) - params (<>.some again^) - _ (<>.assertion (%.message name " cannot be a type-parameter!") - (not (list.member? text.equivalence (list#each product.left type_vars) name)))] - (in {#GenericClass name params}))) - )))) - -(the type_param^ - (Projection Type_Parameter) - (<>.either (do <>.monad - [param_name .local] - (in [param_name (list)])) - (.tuple (do <>.monad - [param_name .local - _ (.this (' <)) - bounds (<>.many (..generic_type^ (list)))] - (in [param_name bounds]))))) - -(the type_params^ - (Projection (List Type_Parameter)) - (|> ..type_param^ - <>.some - .tuple - (<>.else (list)))) - -(the class_decl^ - (Projection Class_Declaration) - (<>.either (do <>.monad - [name .local - _ (no_periods_assertion name)] - (in [name (list)])) - (.form (do <>.monad - [name .local - _ (no_periods_assertion name) - params (<>.some ..type_param^)] - (in [name params]))) - )) - -(the (super_class_decl^ type_vars) - (-> (List Type_Parameter) (Projection Super_Class_Decl)) - (<>.either (do <>.monad - [name .local - _ (no_periods_assertion name)] - (in [name (list)])) - (.form (do <>.monad - [name .local - _ (no_periods_assertion name) - params (<>.some (..generic_type^ type_vars))] - (in [name params]))))) - -(the annotation_params^ - (Projection (List AnnotationParam)) - (.tuple (<>.some (<>.and .text .any)))) - -(the annotation^ - (Projection Annotation) - (<>.either (do <>.monad - [ann_name .local] - (in [ann_name (list)])) - (.form (<>.and .local - annotation_params^)))) - -(the annotations^' - (Projection (List Annotation)) - (do <>.monad - [_ (.this (' "ann"))] - (.tuple (<>.some ..annotation^)))) - -(the annotations^ - (Projection (List Annotation)) - (do <>.monad - [anns?? (<>.maybe ..annotations^')] - (in (maybe.else (list) anns??)))) - -(the (throws_decl'^ type_vars) - (-> (List Type_Parameter) (Projection (List GenericType))) - (do <>.monad - [_ (.this (' "throws"))] - (.tuple (<>.some (..generic_type^ type_vars))))) - -(the (throws_decl^ type_vars) - (-> (List Type_Parameter) (Projection (List GenericType))) - (do <>.monad - [exs? (<>.maybe (throws_decl'^ type_vars))] - (in (maybe.else (list) exs?)))) - -(the (method_decl^ type_vars) - (-> (List Type_Parameter) (Projection [Member_Declaration MethodDecl])) - (.form (do <>.monad - [tvars ..type_params^ - name .local - anns ..annotations^ - inputs (.tuple (<>.some (..generic_type^ type_vars))) - output (..generic_type^ type_vars) - exs (..throws_decl^ type_vars)] - (in [[name {#PublicP} anns] [#method_tvars tvars - #method_inputs inputs - #method_output output - #method_exs exs]])))) - -(the state_modifier^ - (Projection State) - (all <>.or - (.this (' "volatile")) - (.this (' "final")) - (of <>.monad in []))) - -(the (field_decl^ type_vars) - (-> (List Type_Parameter) (Projection [Member_Declaration FieldDecl])) - (<>.either (.form (do <>.monad - [_ (.this (' "const")) - name .local - anns ..annotations^ - type (..generic_type^ type_vars) - body .any] - (in [[name {#PublicP} anns] {#ConstantField [type body]}]))) - (.form (do <>.monad - [pm privacy_modifier^ - sm state_modifier^ - name .local - anns ..annotations^ - type (..generic_type^ type_vars)] - (in [[name pm anns] {#VariableField [sm type]}]))))) - -(the (arg_decl^ type_vars) - (-> (List Type_Parameter) (Projection ArgDecl)) - (<>.and .local - (..generic_type^ type_vars))) - -(the (arg_decls^ type_vars) - (-> (List Type_Parameter) (Projection (List ArgDecl))) - (.tuple (<>.some (arg_decl^ type_vars)))) - -(the (constructor_arg^ type_vars) - (-> (List Type_Parameter) (Projection ConstructorArg)) - (<>.and (..generic_type^ type_vars) .any)) - -(the (constructor_args^ type_vars) - (-> (List Type_Parameter) (Projection (List ConstructorArg))) - (.tuple (<>.some (constructor_arg^ type_vars)))) - -(the (constructor_method^ class_vars) - (-> (List Type_Parameter) (Projection [Member_Declaration Method_Definition])) - (.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (.this (' "strict"))) - method_vars ..type_params^ - .let [total_vars (list#composite class_vars method_vars)] - [_ arg_decls] (.form (<>.and (.this (' new)) - (..arg_decls^ total_vars))) - constructor_args (..constructor_args^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body .any] - (in [[#member_name constructor_method_name - #member_privacy pm - #member_anns annotations] - {#ConstructorMethod strict_fp? method_vars arg_decls constructor_args body exs}])))) - -(the (virtual_method_def^ class_vars) - (-> (List Type_Parameter) (Projection [Member_Declaration Method_Definition])) - (.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (.this (' "strict"))) - final? (<>.parses? (.this (' "final"))) - method_vars ..type_params^ - .let [total_vars (list#composite class_vars method_vars)] - [name this_name arg_decls] (.form (all <>.and - .local - .local - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body .any] - (in [[#member_name name - #member_privacy pm - #member_anns annotations] - {#VirtualMethod final? strict_fp? - method_vars - this_name arg_decls return_type - body exs}])))) - -(the overriden_method_def^ - (Projection [Member_Declaration Method_Definition]) - (.form (do <>.monad - [strict_fp? (<>.parses? (.this (' "strict"))) - owner_class ..class_decl^ - method_vars ..type_params^ - .let [total_vars (list#composite (product.right owner_class) method_vars)] - [name this_name arg_decls] (.form (all <>.and - .local - .local - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body .any] - (in [[#member_name name - #member_privacy {#PublicP} - #member_anns annotations] - {#OverridenMethod strict_fp? - owner_class method_vars - this_name arg_decls return_type - body exs}])))) - -(the static_method_def^ - (Projection [Member_Declaration Method_Definition]) - (.form (do <>.monad - [pm privacy_modifier^ - strict_fp? (<>.parses? (.this (' "strict"))) - _ (.this (' "static")) - method_vars ..type_params^ - .let [total_vars method_vars] - [name arg_decls] (.form (<>.and .local - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^ - body .any] - (in [[#member_name name - #member_privacy pm - #member_anns annotations] - {#StaticMethod strict_fp? method_vars arg_decls return_type body exs}])))) - -(the abstract_method_def^ - (Projection [Member_Declaration Method_Definition]) - (.form (do <>.monad - [pm privacy_modifier^ - _ (.this (' "abstract")) - method_vars ..type_params^ - .let [total_vars method_vars] - [name arg_decls] (.form (<>.and .local - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^] - (in [[#member_name name - #member_privacy pm - #member_anns annotations] - {#AbstractMethod method_vars arg_decls return_type exs}])))) - -(the native_method_def^ - (Projection [Member_Declaration Method_Definition]) - (.form (do <>.monad - [pm privacy_modifier^ - _ (.this (' "native")) - method_vars ..type_params^ - .let [total_vars method_vars] - [name arg_decls] (.form (<>.and .local - (..arg_decls^ total_vars))) - return_type (..generic_type^ total_vars) - exs (..throws_decl^ total_vars) - annotations ..annotations^] - (in [[#member_name name - #member_privacy pm - #member_anns annotations] - {#NativeMethod method_vars arg_decls return_type exs}])))) - -(the (method_def^ class_vars) - (-> (List Type_Parameter) (Projection [Member_Declaration Method_Definition])) - (all <>.either - (..constructor_method^ class_vars) - (..virtual_method_def^ class_vars) - ..overriden_method_def^ - ..static_method_def^ - ..abstract_method_def^ - ..native_method_def^)) - -(the partial_call^ - (Projection Partial_Call) - (.form (<>.and .symbol (.tuple (<>.some .any))))) - -(the import_member_alias^ - (Projection (Maybe Text)) - (<>.maybe (do <>.monad - [_ (.this (' "as"))] - .local))) - -(the (import_member_args^ type_vars) - (-> (List Type_Parameter) (Projection (List [Bit GenericType]))) - (.tuple (<>.some (<>.and (<>.parses? (.this (' "?"))) (..generic_type^ type_vars))))) - -(the import_member_return_flags^ - (Projection [Bit Bit Bit]) - (all <>.and (<>.parses? (.this (' "io"))) (<>.parses? (.this (' "try"))) (<>.parses? (.this (' "?"))))) - -(the primitive_mode^ - (Projection Primitive_Mode) - (<>.or (.this (' "manual")) - (.this (' "auto")))) - -(the (import_member_decl^ owner_vars) - (-> (List Type_Parameter) (Projection Import_Member_Declaration)) - (all <>.either - (.form (do <>.monad - [_ (.this (' "enum")) - enum_members (<>.some .local)] - (in {#EnumDecl enum_members}))) - (.form (do <>.monad - [tvars ..type_params^ - _ (.this (' new)) - ?alias import_member_alias^ - .let [total_vars (list#composite owner_vars tvars)] - ?prim_mode (<>.maybe primitive_mode^) - args (..import_member_args^ total_vars) - [io? try? maybe?] import_member_return_flags^] - (in {#ConstructorDecl [[#import_member_mode (maybe.else {#AutoPrM} ?prim_mode) - #import_member_alias (maybe.else "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?] - []]}))) - (.form (do <>.monad - [kind (.is (Projection ImportMethodKind) - (<>.or (.this (' "static")) - (in []))) - tvars ..type_params^ - name .local - ?alias import_member_alias^ - .let [total_vars (list#composite owner_vars tvars)] - ?prim_mode (<>.maybe primitive_mode^) - args (..import_member_args^ total_vars) - [io? try? maybe?] import_member_return_flags^ - return (..generic_type^ total_vars)] - (in {#MethodDecl [[#import_member_mode (maybe.else {#AutoPrM} ?prim_mode) - #import_member_alias (maybe.else 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]]}))) - (.form (do <>.monad - [read_only? (<>.parses? (.this (' "read_only"))) - static? (<>.parses? (.this (' "static"))) - name .local - ?prim_mode (<>.maybe primitive_mode^) - gtype (..generic_type^ owner_vars) - maybe? (<>.parses? (.this (' "?")))] - (in {#FieldAccessDecl [#import_field_mode (maybe.else {#AutoPrM} ?prim_mode) - #import_field_name name - #import_field_static? static? - #import_field_maybe? maybe? - #import_field_setter? (not read_only?) - #import_field_type gtype]}))) - )) - -... Generators -(the with_parens - (-> JVM_Code JVM_Code) - (text.enclosed ["(" ")"])) - -(the with_brackets - (-> JVM_Code JVM_Code) - (text.enclosed ["[" "]"])) - -(the spaced - (-> (List JVM_Code) JVM_Code) - (text.interposed " ")) - -(the (privacy_modifier$ pm) - (-> Privacy JVM_Code) - (when pm - {#PublicP} "public" - {#PrivateP} "private" - {#ProtectedP} "protected" - {#DefaultP} "default")) - -(the (inheritance_modifier$ im) - (-> Inheritance JVM_Code) - (when im - {#FinalI} "final" - {#AbstractI} "abstract" - {#DefaultI} "default")) - -(the (annotation_param$ [name value]) - (-> AnnotationParam JVM_Code) - (%.message name "=" (code.absolute value))) - -(the (annotation$ [name params]) - (-> Annotation JVM_Code) - (%.message "(" name " " "{" (text.interposed text.tab (list#each annotation_param$ params)) "}" ")")) - -(the (bound_kind$ kind) - (-> BoundKind JVM_Code) - (when kind - {#UpperBound} "<" - {#LowerBound} ">")) - -(the (generic_type$ gtype) - (-> GenericType JVM_Code) - (when gtype - {#GenericTypeVar name} - name - - {#GenericClass name params} - (%.message "(" (safe name) " " (spaced (list#each generic_type$ params)) ")") - - {#GenericArray param} - (%.message "(" array.nominal " " (generic_type$ param) ")") - - {#GenericWildcard {.#None}} - "?" - - {#GenericWildcard {.#Some [bound_kind bound]}} - (%.message (bound_kind$ bound_kind) (generic_type$ bound)))) - -(the (type_param$ [name bounds]) - (-> Type_Parameter JVM_Code) - (%.message "(" name " " (spaced (list#each generic_type$ bounds)) ")")) - -(the (class_decl$ (open "[0]")) - (-> Class_Declaration JVM_Code) - (%.message "(" (safe #class_name) " " (spaced (list#each type_param$ #class_params)) ")")) - -(the (super_class_decl$ (open "[0]")) - (-> Super_Class_Decl JVM_Code) - (%.message "(" (safe #super_class_name) - " " (spaced (list#each generic_type$ #super_class_params)) - ")")) - -(the (method_decl$ [[name pm anns] method_decl]) - (-> [Member_Declaration MethodDecl] JVM_Code) - (let [(open "[0]") method_decl] - (with_parens - (spaced (list name - (with_brackets (spaced (list#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ #method_tvars))) - (with_brackets (spaced (list#each generic_type$ #method_exs))) - (with_brackets (spaced (list#each generic_type$ #method_inputs))) - (generic_type$ #method_output)) - )))) - -(the (state_modifier$ sm) - (-> State JVM_Code) - (when sm - {#VolatileS} "volatile" - {#FinalS} "final" - {#DefaultS} "default")) - -(the (field_decl$ [[name pm anns] field]) - (-> [Member_Declaration FieldDecl] JVM_Code) - (when field - {#ConstantField class value} - (with_parens - (spaced (list "constant" name - (with_brackets (spaced (list#each annotation$ anns))) - (generic_type$ class) - (code.absolute value)) - )) - - {#VariableField sm class} - (with_parens - (spaced (list "variable" name - (privacy_modifier$ pm) - (state_modifier$ sm) - (with_brackets (spaced (list#each annotation$ anns))) - (generic_type$ class)) - )) - )) - -(the (arg_decl$ [name type]) - (-> ArgDecl JVM_Code) - (with_parens - (spaced (list name (generic_type$ type))))) - -(the (constructor_arg$ [class term]) - (-> ConstructorArg JVM_Code) - (with_brackets - (spaced (list (generic_type$ class) (code.absolute term))))) - -(the (method_def$ replacer super_class [[name pm anns] method_def]) - (-> (-> Code Code) Super_Class_Decl [Member_Declaration Method_Definition] JVM_Code) - (when method_def - {#ConstructorMethod strict_fp? type_vars arg_decls constructor_args body exs} - (with_parens - (spaced (list "init" - (privacy_modifier$ pm) - (bit#injection strict_fp?) - (with_brackets (spaced (list#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ type_vars))) - (with_brackets (spaced (list#each generic_type$ exs))) - (with_brackets (spaced (list#each arg_decl$ arg_decls))) - (with_brackets (spaced (list#each constructor_arg$ constructor_args))) - (code.absolute (pre_walk_replace replacer body)) - ))) - - {#VirtualMethod final? strict_fp? type_vars this_name arg_decls return_type body exs} - (with_parens - (spaced (list "virtual" - name - (privacy_modifier$ pm) - (bit#injection final?) - (bit#injection strict_fp?) - (with_brackets (spaced (list#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ type_vars))) - (with_brackets (spaced (list#each generic_type$ exs))) - (with_brackets (spaced (list#each arg_decl$ arg_decls))) - (generic_type$ return_type) - (code.absolute (pre_walk_replace replacer (` (let [(, (code.local this_name)) (,' _jvm_this)] - (, body)))))))) - - {#OverridenMethod strict_fp? class_decl type_vars this_name arg_decls return_type body exs} - (let [super_replacer (projection_replacer (.form (do <>.monad - [_ (.this (' ::super!)) - args (.tuple (<>.exactly (list.size arg_decls) .any)) - .let [arg_decls' (.is (List Text) (list#each (|>> product.right (simple_class$ (list))) - arg_decls))]] - (in (`' ((, (code.text (%.message "jvm invokespecial" - ":" (its #super_class_name super_class) - ":" name - ":" (text.interposed "," arg_decls')))) - (,' _jvm_this) (,* args)))))))] - (with_parens - (spaced (list "override" - (class_decl$ class_decl) - name - (bit#injection strict_fp?) - (with_brackets (spaced (list#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ type_vars))) - (with_brackets (spaced (list#each generic_type$ exs))) - (with_brackets (spaced (list#each arg_decl$ arg_decls))) - (generic_type$ return_type) - (|> (` (let [(, (code.local this_name)) (,' _jvm_this)] - (, body))) - (pre_walk_replace replacer) - (pre_walk_replace super_replacer) - code.absolute) - )))) - - {#StaticMethod strict_fp? type_vars arg_decls return_type body exs} - (with_parens - (spaced (list "static" - name - (privacy_modifier$ pm) - (bit#injection strict_fp?) - (with_brackets (spaced (list#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ type_vars))) - (with_brackets (spaced (list#each generic_type$ exs))) - (with_brackets (spaced (list#each arg_decl$ arg_decls))) - (generic_type$ return_type) - (code.absolute (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#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ type_vars))) - (with_brackets (spaced (list#each generic_type$ exs))) - (with_brackets (spaced (list#each 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#each annotation$ anns))) - (with_brackets (spaced (list#each type_param$ type_vars))) - (with_brackets (spaced (list#each generic_type$ exs))) - (with_brackets (spaced (list#each arg_decl$ arg_decls))) - (generic_type$ return_type)))) - )) - -(the (complete_call$ g!obj [method args]) - (-> Code Partial_Call Code) - (` ((, (code.symbol method)) [(,* args)] (, g!obj)))) - -... [Syntax] -(the object_super_class - Super_Class_Decl - [#super_class_name "java/lang/Object" - #super_class_params (list)]) - -(the .public class - (syntax.macro (_ [im inheritance_modifier^ - class_decl ..class_decl^ - .let [full_class_name (product.left class_decl)] - .let [class_vars (product.right class_decl)] - super (<>.else object_super_class - (..super_class_decl^ class_vars)) - interfaces (<>.else (list) - (.tuple (<>.some (..super_class_decl^ class_vars)))) - annotations ..annotations^ - fields (<>.some (..field_decl^ class_vars)) - methods (<>.some (..method_def^ class_vars))]) - (do meta.monad - [[current_module _] module.current - .let [fully_qualified_class_name (%.message (safe current_module) "." full_class_name) - field_projections (list#each (field_projection fully_qualified_class_name) fields) - method_projections (list#each (method_projection (product.right class_decl) fully_qualified_class_name) methods) - replacer (projection_replacer (list#mix <>.either - (<>.failure "") - (list#composite field_projections method_projections))) - def_code (%.message "jvm class:" - (spaced (list (class_decl$ class_decl) - (super_class_decl$ super) - (with_brackets (spaced (list#each super_class_decl$ interfaces))) - (inheritance_modifier$ im) - (with_brackets (spaced (list#each annotation$ annotations))) - (with_brackets (spaced (list#each field_decl$ fields))) - (with_brackets (spaced (list#each (method_def$ replacer super) methods))))))]] - (in (list (` ((, (code.text def_code))))))))) - -(the .public interface - (syntax.macro (_ [class_decl ..class_decl^ - .let [class_vars (product.right class_decl)] - supers (<>.else (list) - (.tuple (<>.some (..super_class_decl^ class_vars)))) - annotations ..annotations^ - members (<>.some (..method_decl^ class_vars))]) - (let [def_code (%.message "jvm interface:" - (spaced (list (class_decl$ class_decl) - (with_brackets (spaced (list#each super_class_decl$ supers))) - (with_brackets (spaced (list#each annotation$ annotations))) - (spaced (list#each method_decl$ members)))))] - (in (list (` ((, (code.text def_code))))))))) - -(the .public object - (syntax.macro (_ [class_vars (.tuple (<>.some ..type_param^)) - super (<>.else object_super_class - (..super_class_decl^ class_vars)) - interfaces (<>.else (list) - (.tuple (<>.some (..super_class_decl^ class_vars)))) - constructor_args (..constructor_args^ class_vars) - methods (<>.some ..overriden_method_def^)]) - (let [def_code (%.message "jvm anon-class:" - (spaced (list (super_class_decl$ super) - (with_brackets (spaced (list#each super_class_decl$ interfaces))) - (with_brackets (spaced (list#each constructor_arg$ constructor_args))) - (with_brackets (spaced (list#each (method_def$ function.identity super) methods))))))] - (in (list (` ((, (code.text def_code))))))))) - -(the .public null - (syntax.macro (_ []) - (in (list (` ("jvm object null")))))) - -(the .public (null? obj) - (-> (Nominal "java.lang.Object") Bit) - ("jvm object null?" obj)) - -(the .public ??? - (syntax.macro (_ [expr .any]) - (with_symbols [g!temp] - (in (list (` (let [(, g!temp) (, expr)] - (if ("jvm object null?" (, g!temp)) - {.#None} - {.#Some (, g!temp)})))))))) - -(the .public !!! - (syntax.macro (_ [expr .any]) - (with_symbols [g!value] - (in (list (` (.when (, expr) - {.#Some (, g!value)} - (, g!value) - - {.#None} - ("jvm object null")))))))) - -(the .public as - (syntax.macro (_ [class (..generic_type^ (list)) - unchecked (<>.maybe .any)]) - (with_symbols [g!_ g!unchecked] - (let [class_name (simple_class$ (list) class) - class_type (` (.Nominal (, (code.text class_name)))) - check_type (` (.Maybe (, class_type))) - check_code (` (if ((, (code.text (%.message "jvm instanceof" ":" class_name))) (, g!unchecked)) - {.#Some (.as (, class_type) - (, g!unchecked))} - {.#None}))] - (when unchecked - {.#Some unchecked} - (in (list (` (.is (, check_type) - (let [(, g!unchecked) (, unchecked)] - (, check_code)))))) - - {.#None} - (in (list (` (.is (-> (Nominal "java.lang.Object") (, check_type)) - (function ((, g!_) (, g!unchecked)) - (, check_code)))))) - ))))) - -(the .public synchronized - (syntax.macro (_ [lock .any - body .any]) - (in (list (` ("jvm object synchronized" (, lock) (, body))))))) - -(the .public to - (syntax.macro (_ [obj .any - methods (<>.some partial_call^)]) - (with_symbols [g!obj] - (in (list (` (let [(, g!obj) (, obj)] - (exec - (,* (list#each (complete_call$ g!obj) methods)) - (, g!obj))))))))) - -(the (class_import$ [full_name params]) - (-> Class_Declaration Code) - (let [params' (list#each (|>> product.left code.local) params)] - (template.with_locals [g!_] - (` (the (, (code.symbol ["" full_name])) - Type - (for_any ((, (' g!_)) (,* params')) - (Nominal (, (code.text (safe full_name))) - [(,* params')]))))))) - -(the (member_type_vars class_tvars member) - (-> (List Type_Parameter) Import_Member_Declaration (List Type_Parameter)) - (when member - {#ConstructorDecl [commons _]} - (list#composite class_tvars (its #import_member_tvars commons)) - - {#MethodDecl [commons _]} - (when (its #import_member_kind commons) - {#StaticIMK} - (its #import_member_tvars commons) - - _ - (list#composite class_tvars (its #import_member_tvars commons))) - - _ - class_tvars)) - -(the (member_def_arg_bindings type_params class member) - (-> (List Type_Parameter) Class_Declaration Import_Member_Declaration (Meta [(List [Bit Code]) (List Text) (List Code)])) - (when member - (^.or {#ConstructorDecl [commons _]} - {#MethodDecl [commons _]}) - (let [(open "[0]") commons] - (do [! meta.monad] - [arg_inputs (monad.each ! - (.is (-> [Bit GenericType] (Meta [Bit Code])) - (function (_ [maybe? _]) - (with_symbols [arg_name] - (in [maybe? arg_name])))) - #import_member_args) - .let [arg_classes (.is (List Text) - (list#each (|>> product.right (simple_class$ (list#composite type_params #import_member_tvars))) - #import_member_args)) - arg_types (list#each (.is (-> [Bit GenericType] Code) - (function (_ [maybe? arg]) - (let [arg_type (class_type (its #import_member_mode commons) type_params arg)] - (if maybe? - (` (Maybe (, arg_type))) - arg_type)))) - #import_member_args)]] - (in [arg_inputs arg_classes arg_types]))) - - _ - (of meta.monad in [(list) (list) (list)]))) - -(the (decorate_return_maybe class member return_term) - (-> Class_Declaration Import_Member_Declaration Code Code) - (when member - (^.or {#ConstructorDecl [commons _]} - {#MethodDecl [commons _]}) - (if (its #import_member_maybe? commons) - (` (??? (, return_term))) - (let [g!temp (` ((,' ,') (, (code.symbol ["" " Ω "]))))] - (` (let [(, g!temp) (, return_term)] - (if (not (..null? (.as (Nominal "java.lang.Object") - (, g!temp)))) - (, g!temp) - (panic! (, (code.text (%.message "Cannot produce null references from method calls @ " - (its #class_name class) - "." (its #import_member_alias commons)))))))))) - - _ - return_term)) - -(template.with [ ] - [(the ( member return_term) - (-> Import_Member_Declaration Code Code) - (when member - (^.or {#ConstructorDecl [commons _]} - {#MethodDecl [commons _]}) - (if (its commons) - - return_term) - - _ - return_term))] - - [decorate_return_try #import_member_try? (` (.try (, return_term)))] - [decorate_return_io #import_member_io? (` (io.io (, return_term)))] - ) - -(the (free_type_param? [name bounds]) - (-> Type_Parameter Bit) - (when bounds - {.#End} - true - - _ - false)) - -(the (lux_type_parameter [name _]) - (-> Type_Parameter Code) - (code.symbol ["" name])) - -(template.with [ ] - [(the ( mode [class expression]) - (-> Primitive_Mode [Text Code] Code) - (when mode - {#ManualPrM} - expression - - {#AutoPrM} - 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] - ) - -(the (un_quote quoted) - (-> Code Code) - (` ((,' ,) (, quoted)))) - -(the (jvm_extension_inputs mode classes inputs) - (-> Primitive_Mode (List Text) (List [Bit Code]) (List Code)) - (|> inputs - (list#each (function (_ [maybe? input]) - (if maybe? - (` (!!! (, (un_quote input)))) - (un_quote input)))) - (list.zipped_2 classes) - (list#each (auto_convert_input mode)))) - -(the (import_name format class member) - (-> Text Text Text Text) - (|> format - (text.replaced "[1]" class) - (text.replaced "[0]" member))) - -(the (syntax_inputs it) - (-> (List Code) - (List Code)) - (list (` [(,* it)]) - (` (.tuple (, (when it - (list) - (` .end) - - _ - (` (all <>.and (,* (list.repeated (list.size it) (` .any))))))))))) - -(the (member_def_interop type_params kind class [arg_function_inputs arg_classes arg_types] member method_prefix import_format) - (-> (List Type_Parameter) Class_Kind Class_Declaration [(List [Bit Code]) (List Text) (List Code)] Import_Member_Declaration Text Text (Meta (List Code))) - (let [[full_name class_tvars] class - full_name (safe full_name) - all_params (|> (member_type_vars class_tvars member) - (list.only free_type_param?) - (list#each lux_type_parameter))] - (when member - {#EnumDecl enum_members} - (macro.with_symbols [g!_] - (do [! meta.monad] - [.let [enum_type (.is Code - (when class_tvars - {.#End} - (` (Nominal (, (code.text full_name)))) - - _ - (let [=class_tvars (|> class_tvars - (list.only free_type_param?) - (list#each lux_type_parameter))] - (` (for_any ((, g!_) (,* =class_tvars)) (Nominal (, (code.text full_name)) [(,* =class_tvars)])))))) - getter_interop (.is (-> Text Code) - (function (_ name) - (let [getter_name (code.symbol ["" (..import_name import_format method_prefix name)])] - (` (the (, getter_name) - (, enum_type) - ((, (code.text (%.message "jvm getstatic" ":" full_name ":" name)))))))))]] - (in (list#each getter_interop enum_members)))) - - {#ConstructorDecl [commons _]} - (do meta.monad - [.let [def_name (code.symbol ["" (..import_name import_format method_prefix (its #import_member_alias commons))]) - jvm_extension (code.text (%.message "jvm new" ":" full_name ":" (text.interposed "," arg_classes))) - jvm_interop (|> (` ((, jvm_extension) - (,* (jvm_extension_inputs (its #import_member_mode commons) arg_classes arg_function_inputs)))) - (decorate_return_maybe class member) - (decorate_return_try member) - (decorate_return_io member))]] - (in (list (` (the (, def_name) - (syntax.macro ((, def_name) [(,* (syntax_inputs (list#each product.right arg_function_inputs)))]) - ((,' in) (.list (.` (, jvm_interop)))))))))) - - {#MethodDecl [commons method]} - (with_symbols [g!obj] - (do meta.monad - [.let [def_name (code.symbol ["" (..import_name import_format method_prefix (its #import_member_alias commons))]) - (open "[0]") commons - (open "[0]") method - [jvm_op object_ast] (.is [Text (List Code)] - (when #import_member_kind - {#StaticIMK} - ["invokestatic" - (list)] - - {#VirtualIMK} - (when kind - {#Class} - ["invokevirtual" - (list g!obj)] - - {#Interface} - ["invokeinterface" - (list g!obj)] - ))) - jvm_extension (code.text (%.message "jvm " jvm_op ":" full_name ":" #import_method_name ":" (text.interposed "," arg_classes))) - jvm_interop (|> [(simple_class$ (list) (its #import_method_return method)) - (` ((, jvm_extension) (,* (list#each un_quote object_ast)) - (,* (jvm_extension_inputs (its #import_member_mode commons) arg_classes arg_function_inputs))))] - (auto_convert_output (its #import_member_mode commons)) - (decorate_return_maybe class member) - (decorate_return_try member) - (decorate_return_io member))]] - (in (list (` (the (, def_name) - (syntax.macro ((, def_name) [(,* (syntax_inputs (list#each product.right arg_function_inputs))) - (,* (when object_ast - (list) - (list) - - _ - (list#composite object_ast - (list (` .any)))))]) - ((,' in) (.list (.` (, jvm_interop))))))))))) - - {#FieldAccessDecl fad} - (do meta.monad - [.let [(open "[0]") 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 (.is (List Code) - (|> class_tvars - (list.only free_type_param?) - (list#each lux_type_parameter))) - getter_name (code.symbol ["" (..import_name import_format method_prefix #import_field_name)]) - setter_name (code.symbol ["" (..import_name import_format method_prefix (%.message #import_field_name "!"))])] - getter_interop (with_symbols [g!obj] - (let [getter_call (if #import_field_static? - (` ((, getter_name) [])) - (` ((, getter_name) [(, g!obj) .any]))) - getter_body (<| (auto_convert_output #import_field_mode) - [(simple_class$ (list) #import_field_type) - (if #import_field_static? - (let [jvm_extension (code.text (%.message "jvm getstatic" ":" full_name ":" #import_field_name))] - (` ((, jvm_extension)))) - (let [jvm_extension (code.text (%.message "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)] - (in (` (the (, getter_name) - (syntax.macro (, getter_call) - ((,' in) (.list (.` (, getter_body)))))))))) - setter_interop (.is (Meta (List Code)) - (if #import_field_setter? - (with_symbols [g!obj g!value] - (let [setter_call (if #import_field_static? - (` ((, setter_name) [(, g!value) .any])) - (` ((, setter_name) [(, g!value) .any - (, g!obj) .any]))) - 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 (%.message (if #import_field_static? "jvm putstatic" "jvm putfield") - ":" full_name ":" #import_field_name) - g!obj+ (.is (List Code) - (if #import_field_static? - (list) - (list (un_quote g!obj))))] - (in (list (` (the (, setter_name) - (syntax.macro (, setter_call) - ((,' in) (.list (.` (io.io ((, (code.text setter_command)) (,* g!obj+) (, setter_value))))))))))))) - (in (list))))] - (in (list.partial getter_interop setter_interop))) - ))) - -(the (member_import$ type_params kind class [import_format member]) - (-> (List Type_Parameter) Class_Kind Class_Declaration [Text Import_Member_Declaration] (Meta (List Code))) - (let [[method_prefix _] class] - (do meta.monad - [=args (member_def_arg_bindings type_params class member)] - (member_def_interop type_params kind class =args member method_prefix import_format)))) - -(.every (java/lang/Class a) - (Nominal "java.lang.Class" [a])) - -(the interface? - (for_any (_ a) - (-> (java/lang/Class a) - Bit)) - (|>> "jvm invokevirtual:java.lang.Class:isInterface:")) - -(the (load_class class_name) - (-> Text (Try (java/lang/Class Any))) - (try ("jvm invokestatic:java.lang.Class:forName:java.lang.String" class_name))) - -(the (class_kind [class_name _]) - (-> Class_Declaration (Meta Class_Kind)) - (let [class_name (..safe class_name)] - (when (..load_class class_name) - {try.#Success class} - (of meta.monad in (if (interface? class) - {#Interface} - {#Class})) - - {try.#Failure error} - (meta.failure (%.message "Cannot load class: " class_name text.new_line - error))))) - -(the .public import - (syntax.macro (_ [class_decl ..class_decl^ - import_format .text - members (<>.some (..import_member_decl^ (product.right class_decl)))]) - (do [! meta.monad] - [kind (class_kind class_decl) - =members (|> members - (list#each (|>> [import_format])) - (monad.each ! (member_import$ (product.right class_decl) kind class_decl)))] - (in (list.partial (class_import$ class_decl) (list#conjoint =members)))))) - -(the .public array - (syntax.macro (_ [type (..generic_type^ (list)) - size .any]) - (`` (when type - (,, (template.with [ ] - [{#GenericClass (list)} - (in (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"])) - - _ - (in (list (` ("jvm anewarray" (, (code.text (generic_type$ type))) (, size))))))))) - -(the .public length - (syntax.macro (_ [array .any]) - (in (list (` ("jvm arraylength" (, array))))))) - -(the (type_class_name type) - (-> Type (Meta Text)) - (if (type#= Any type) - (of meta.monad in "java.lang.Object") - (when type - {.#Nominal name params} - (of meta.monad in name) - - {.#Apply A F} - (when (type.applied (list A) F) - {.#None} - (meta.failure (%.message "Cannot apply type: " (%.type F) " to " (%.type A))) - - {.#Some type'} - (type_class_name type')) - - {.#Named _ type'} - (type_class_name type') - - _ - (meta.failure (%.message "Cannot convert to JvmType: " (%.type type)))))) - -(the .public read! - (syntax.macro (_ [idx .any - array .any]) - (when array - [_ {.#Symbol array_name}] - (do meta.monad - [array_type (binding.type array_name) - array_jvm_type (type_class_name array_type)] - (`` (when array_jvm_type - (,, (template.with [ ] - [ - (in (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"])) - - _ - (in (list (` ("jvm aaload" (, array) (, idx)))))))) - - _ - (with_symbols [g!array] - (in (list (` (let [(, g!array) (, array)] - (..read! (, idx) (, g!array)))))))))) - -(the .public write! - (syntax.macro (_ [idx .any - value .any - array .any]) - (when array - [_ {.#Symbol array_name}] - (do meta.monad - [array_type (binding.type array_name) - array_jvm_type (type_class_name array_type)] - (`` (when array_jvm_type - (,, (template.with [ ] - [ - (in (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"])) - - _ - (in (list (` ("jvm aastore" (, array) (, idx) (, value)))))))) - - _ - (with_symbols [g!array] - (in (list (` (let [(, g!array) (, array)] - (..write! (, idx) (, value) (, g!array)))))))))) - -(the .public class_for - (syntax.macro (_ [type (..generic_type^ (list))]) - (in (list (` ("jvm object class" (, (code.text (simple_class$ (list) type))))))))) - -(the .public type - (syntax.macro (_ [type (..generic_type^ (list))]) - (in (list (..class_type {#ManualPrM} (list) type))))) - -(the .public is - (template.macro (is type term) - [(.as type term)])) diff --git a/stdlib/source/library/lux/math.lux b/stdlib/source/library/lux/math.lux index 86a926dbd5..4f0b102691 100644 --- a/stdlib/source/library/lux/math.lux +++ b/stdlib/source/library/lux/math.lux @@ -66,160 +66,159 @@ last prevs))))) -(for .old (these) - (expansion.let [ [frac.#numerator 0 frac.#denominator 1] - [frac.#numerator 1 frac.#denominator 1] - [complex.#real +0.0 complex.#imaginary +0.0] - [complex.#real +1.0 complex.#imaginary +0.0]] - (these (template.with [ '] - [(expansion.let [ (template.spliced ')] - (these (the .public - .Analysis - (analysis (_ phase archive [operands (<>.some .any)]) - (<| type.with_var - (function (_ [$it :it:])) - (do [! phase.monad] - [operands (monad.each ! (|>> (phase archive) (type.expecting :it:)) - operands) - _ (type.inference :it:) - :it: (type.check (check.identity (list) $it))] - (when (list.reversed operands) - (list single) - (in single) - - (list) - (`` (cond (check.subsumed? .I64 :it:) - (phase.except ..no_arithmetic_for [:it:]) - - (,, (template.with [ <0> <+>] - [(check.subsumed? :it:) - <0>] - - )) - - ... else - (phase.except ..no_arithmetic_for [:it:]))) - - (list.partial last prevs) - (`` (cond (check.subsumed? .I64 :it:) - (phase.except ..no_arithmetic_for [:it:]) - - (,, (template.with [ <0> <+>] - [(check.subsumed? :it:) - (..composite phase archive (` <+>) last prevs)] - - )) - - ... else - (phase.except ..no_arithmetic_for [:it:]))))))))))] - - [+ [[.Nat (in (analysis.nat location.dummy 0)) .i64_+#|translation] - [.Int (in (analysis.int location.dummy +0)) .i64_+#|translation] - [.Rev (in (analysis.rev location.dummy .0)) .i64_+#|translation] - [.Dec (in (analysis.dec location.dummy +0.0)) .f64_+#|translation] - [Frac (type.expecting Frac (phase archive (` ))) frac.+] - [Complex (type.expecting Complex (phase archive (` ))) complex.+]]] - [- [[.Nat (in (analysis.nat location.dummy 0)) .i64_-#|translation] - [.Int (in (analysis.int location.dummy -0)) .i64_-#|translation] - [.Rev (in (analysis.rev location.dummy .0)) .i64_-#|translation] - [.Dec (in (analysis.dec location.dummy -0.0)) .f64_-#|translation] - [Frac (type.expecting Frac (phase archive (` ))) frac.-] - [Complex (type.expecting Complex (phase archive (` ))) complex.-]]] - [* [[.Nat (in (analysis.nat location.dummy 1)) nat.*] - [.Int (in (analysis.int location.dummy +1)) .int_*#|translation] - [.Rev (in (analysis.rev location.dummy rev./1)) rev.*] - [.Dec (in (analysis.dec location.dummy +1.0)) .f64_*#|translation] - [Frac (type.expecting Frac (phase archive (` ))) frac.*] - [Complex (type.expecting Complex (phase archive (` ))) complex.*]]] - [/ [[.Nat (in (analysis.nat location.dummy 1)) nat./] - [.Int (in (analysis.int location.dummy +1)) .int_/#|translation] - [.Rev (in (analysis.rev location.dummy rev./1)) rev./] - [.Dec (in (analysis.dec location.dummy +1.0)) .f64_/#|translation] - [Frac (type.expecting Frac (phase archive (` ))) frac./] - [Complex (type.expecting Complex (phase archive (` ))) complex./]]] - ) - (template.with [ '] - [(expansion.let [ (template.spliced ')] - (these (the .public - .Analysis - (analysis (_ phase archive [left .any - right .any]) - (<| type.with_var - (function (_ [$it :it:])) - (do [! phase.monad] - [left (type.expecting :it: (phase archive left)) - right (type.expecting :it: (phase archive right)) - _ (type.inference .Bit) - :it: (type.check (check.identity (list) $it))] - (`` (cond (check.subsumed? .I64 :it:) - (phase.except ..no_arithmetic_for [:it:]) - - (,, (template.with [ <+>] - [(check.subsumed? :it:) - (..composite phase archive (` <+>) right (list left))] - - )) - - ... else - (phase.except ..no_arithmetic_for [:it:])))))))))] - - [= [[.Nat .i64_=#|translation] - [.Int .i64_=#|translation] - [.Rev .i64_=#|translation] - [.Dec .f64_=#|translation] - [Frac frac.=] - [Complex complex.=]]] - [< [[.Nat nat.<] - [.Int .int_<#|translation] - [.Rev rev.<] - [.Dec .f64_<#|translation] - [Frac frac.<]]] - [> [[.Nat nat.>] - [.Int int.>] - [.Rev rev.>] - [.Dec dec.>] - [Frac frac.>]]] - [<= [[.Nat nat.<=] - [.Int int.<=] - [.Rev rev.<=] - [.Dec dec.<=] - [Frac frac.<=]]] - [>= [[.Nat nat.>=] - [.Int int.>=] - [.Rev rev.>=] - [.Dec dec.>=] - [Frac frac.>=]]] - ) - (template.with [ '] - [(expansion.let [ (template.spliced ')] - (these (the .public - .Analysis - (analysis (_ phase archive [left .any - right .any]) - (<| type.with_var - (function (_ [$it :it:])) - (do [! phase.monad] - [left (type.expecting :it: (phase archive left)) - right (type.expecting :it: (phase archive right)) - _ (type.inference :it:) - :it: (type.check (check.identity (list) $it))] - (`` (cond (check.subsumed? .I64 :it:) - (phase.except ..no_arithmetic_for [:it:]) - - (,, (template.with [ <+>] - [(check.subsumed? :it:) - (..composite phase archive (` <+>) right (list left))] - - )) - - ... else - (phase.except ..no_arithmetic_for [:it:])))))))))] - - [% [[.Nat nat.%] - [.Int .int_%#|translation] - [.Rev rev.%] - [.Dec .f64_%#|translation] - [Frac frac.%] - [Complex complex.%]]] - ) - ))) +(expansion.let [ [frac.#numerator 0 frac.#denominator 1] + [frac.#numerator 1 frac.#denominator 1] + [complex.#real +0.0 complex.#imaginary +0.0] + [complex.#real +1.0 complex.#imaginary +0.0]] + (these (template.with [ '] + [(expansion.let [ (template.spliced ')] + (these (the .public + .Analysis + (analysis (_ phase archive [operands (<>.some .any)]) + (<| type.with_var + (function (_ [$it :it:])) + (do [! phase.monad] + [operands (monad.each ! (|>> (phase archive) (type.expecting :it:)) + operands) + _ (type.inference :it:) + :it: (type.check (check.identity (list) $it))] + (when (list.reversed operands) + (list single) + (in single) + + (list) + (`` (cond (check.subsumed? .I64 :it:) + (phase.except ..no_arithmetic_for [:it:]) + + (,, (template.with [ <0> <+>] + [(check.subsumed? :it:) + <0>] + + )) + + ... else + (phase.except ..no_arithmetic_for [:it:]))) + + (list.partial last prevs) + (`` (cond (check.subsumed? .I64 :it:) + (phase.except ..no_arithmetic_for [:it:]) + + (,, (template.with [ <0> <+>] + [(check.subsumed? :it:) + (..composite phase archive (` <+>) last prevs)] + + )) + + ... else + (phase.except ..no_arithmetic_for [:it:]))))))))))] + + [+ [[.Nat (in (analysis.nat location.dummy 0)) .i64_+#|translation] + [.Int (in (analysis.int location.dummy +0)) .i64_+#|translation] + [.Rev (in (analysis.rev location.dummy .0)) .i64_+#|translation] + [.Dec (in (analysis.dec location.dummy +0.0)) .f64_+#|translation] + [Frac (type.expecting Frac (phase archive (` ))) frac.+] + [Complex (type.expecting Complex (phase archive (` ))) complex.+]]] + [- [[.Nat (in (analysis.nat location.dummy 0)) .i64_-#|translation] + [.Int (in (analysis.int location.dummy -0)) .i64_-#|translation] + [.Rev (in (analysis.rev location.dummy .0)) .i64_-#|translation] + [.Dec (in (analysis.dec location.dummy -0.0)) .f64_-#|translation] + [Frac (type.expecting Frac (phase archive (` ))) frac.-] + [Complex (type.expecting Complex (phase archive (` ))) complex.-]]] + [* [[.Nat (in (analysis.nat location.dummy 1)) nat.*] + [.Int (in (analysis.int location.dummy +1)) .int_*#|translation] + [.Rev (in (analysis.rev location.dummy rev./1)) rev.*] + [.Dec (in (analysis.dec location.dummy +1.0)) .f64_*#|translation] + [Frac (type.expecting Frac (phase archive (` ))) frac.*] + [Complex (type.expecting Complex (phase archive (` ))) complex.*]]] + [/ [[.Nat (in (analysis.nat location.dummy 1)) nat./] + [.Int (in (analysis.int location.dummy +1)) .int_/#|translation] + [.Rev (in (analysis.rev location.dummy rev./1)) rev./] + [.Dec (in (analysis.dec location.dummy +1.0)) .f64_/#|translation] + [Frac (type.expecting Frac (phase archive (` ))) frac./] + [Complex (type.expecting Complex (phase archive (` ))) complex./]]] + ) + (template.with [ '] + [(expansion.let [ (template.spliced ')] + (these (the .public + .Analysis + (analysis (_ phase archive [left .any + right .any]) + (<| type.with_var + (function (_ [$it :it:])) + (do [! phase.monad] + [left (type.expecting :it: (phase archive left)) + right (type.expecting :it: (phase archive right)) + _ (type.inference .Bit) + :it: (type.check (check.identity (list) $it))] + (`` (cond (check.subsumed? .I64 :it:) + (phase.except ..no_arithmetic_for [:it:]) + + (,, (template.with [ <+>] + [(check.subsumed? :it:) + (..composite phase archive (` <+>) right (list left))] + + )) + + ... else + (phase.except ..no_arithmetic_for [:it:])))))))))] + + [= [[.Nat .i64_=#|translation] + [.Int .i64_=#|translation] + [.Rev .i64_=#|translation] + [.Dec .f64_=#|translation] + [Frac frac.=] + [Complex complex.=]]] + [< [[.Nat nat.<] + [.Int .int_<#|translation] + [.Rev rev.<] + [.Dec .f64_<#|translation] + [Frac frac.<]]] + [> [[.Nat nat.>] + [.Int int.>] + [.Rev rev.>] + [.Dec dec.>] + [Frac frac.>]]] + [<= [[.Nat nat.<=] + [.Int int.<=] + [.Rev rev.<=] + [.Dec dec.<=] + [Frac frac.<=]]] + [>= [[.Nat nat.>=] + [.Int int.>=] + [.Rev rev.>=] + [.Dec dec.>=] + [Frac frac.>=]]] + ) + (template.with [ '] + [(expansion.let [ (template.spliced ')] + (these (the .public + .Analysis + (analysis (_ phase archive [left .any + right .any]) + (<| type.with_var + (function (_ [$it :it:])) + (do [! phase.monad] + [left (type.expecting :it: (phase archive left)) + right (type.expecting :it: (phase archive right)) + _ (type.inference :it:) + :it: (type.check (check.identity (list) $it))] + (`` (cond (check.subsumed? .I64 :it:) + (phase.except ..no_arithmetic_for [:it:]) + + (,, (template.with [ <+>] + [(check.subsumed? :it:) + (..composite phase archive (` <+>) right (list left))] + + )) + + ... else + (phase.except ..no_arithmetic_for [:it:])))))))))] + + [% [[.Nat nat.%] + [.Int .int_%#|translation] + [.Rev rev.%] + [.Dec .f64_%#|translation] + [Frac frac.%] + [Complex complex.%]]] + ) + )) diff --git a/stdlib/source/library/lux/math/geometry/circle.lux b/stdlib/source/library/lux/math/geometry/circle.lux index 919612fc17..5fda53eb25 100644 --- a/stdlib/source/library/lux/math/geometry/circle.lux +++ b/stdlib/source/library/lux/math/geometry/circle.lux @@ -47,23 +47,7 @@ ... https://en.wikipedia.org/wiki/Trigonometric_functions ... https://en.wikipedia.org/wiki/Inverse_trigonometric_functions -(for .old - (these (template.with [ ] - [(the .public ( it) - (-> - ) - ( it))] - - [Angle Dec cos "jvm invokestatic:java.lang.Math:cos:double"] - [Angle Dec sin "jvm invokestatic:java.lang.Math:sin:double"] - [Angle Dec tan "jvm invokestatic:java.lang.Math:tan:double"] - - [Dec Angle acos "jvm invokestatic:java.lang.Math:acos:double"] - [Dec Angle asin "jvm invokestatic:java.lang.Math:asin:double"] - [Dec Angle atan "jvm invokestatic:java.lang.Math:atan:double"] - )) - - .jvm +(for .jvm (these (the !double (template.macro (_ value) [(|> value diff --git a/stdlib/source/library/lux/math/number/dec.lux b/stdlib/source/library/lux/math/number/dec.lux index b292dcf015..e143db254c 100644 --- a/stdlib/source/library/lux/math/number/dec.lux +++ b/stdlib/source/library/lux/math/number/dec.lux @@ -40,29 +40,7 @@ [zero +0.0] ) -(for .old - (these (with_template' [ ] - [(the .public ( it) - (-> Dec - Dec) - ( it))] - - [exp "jvm invokestatic:java.lang.Math:exp:double"] - [log "jvm invokestatic:java.lang.Math:log:double"] - - [ceil "jvm invokestatic:java.lang.Math:ceil:double"] - [floor "jvm invokestatic:java.lang.Math:floor:double"] - - [root_2 "jvm invokestatic:java.lang.Math:sqrt:double"] - [root_3 "jvm invokestatic:java.lang.Math:cbrt:double"] - ) - - (the .public (pow param subject) - (-> Dec Dec - Dec) - ("jvm invokestatic:java.lang.Math:pow:double,double" subject param))) - - .jvm +(for .jvm (these (the !double (template#macro (_ value) @@ -513,10 +491,7 @@ (-> Dec Text) (<| (as Text) - (for .old - ("jvm invokestatic:java.lang.Double:toString:double" it) - - .jvm + (for .jvm (|> it ..!double ["D"] @@ -560,13 +535,7 @@ (.text_composite# "+" (decimal#injection it))))) (the (projection it) - (for .old - (|> it - (as (Nominal "java.lang.String")) - "jvm invokestatic:java.lang.Double:parseDouble:java.lang.String" - with_projection_error) - - .jvm + (for .jvm (|> it (as (Nominal "java.lang.String")) .jvm_object_cast# diff --git a/stdlib/source/library/lux/math/number/i32.lux b/stdlib/source/library/lux/math/number/i32.lux index 0aa8489309..0b643000ed 100644 --- a/stdlib/source/library/lux/math/number/i32.lux +++ b/stdlib/source/library/lux/math/number/i32.lux @@ -20,26 +20,15 @@ (the sub (maybe.trusted (i64.sub 32))) -(for .old - (the .public I32 - Type - (when (type_of ..sub) - {.#Apply {.#Named _ {.#Apply :size: :sub:}} _} - (type (I64 :size:)) - - _ - (undefined))) - - (`` (every .public I32 - (I64 (,, (|> (type_of ..sub) - (?type.value (<| ?type.applied - (?.after ?type.any) - ?type.applied - (?.after (?type.exactly i64.Sub)) - ?type.any)) - try.trusted - (static.literal type.code)))))) - ) +(`` (every .public I32 + (I64 (,, (|> (type_of ..sub) + (?type.value (<| ?type.applied + (?.after ?type.any) + ?type.applied + (?.after (?type.exactly i64.Sub)) + ?type.any)) + try.trusted + (static.literal type.code)))))) (the .public equivalence (Equivalence I32) (of ..sub sub_equivalence)) (the .public width Nat (of ..sub bits)) diff --git a/stdlib/source/library/lux/math/random.lux b/stdlib/source/library/lux/math/random.lux index cc6cf045a0..a740f33e0f 100644 --- a/stdlib/source/library/lux/math/random.lux +++ b/stdlib/source/library/lux/math/random.lux @@ -43,26 +43,17 @@ [macro ["[0]" template]]]]]) -(for .old - (every .public PRNG - (Rec PRNG - (-> Any - [PRNG I64]))) - - ... else - (object.every .public (PRNG [] state) - [#number (object.Method Any [(Object PRNG state) I64])])) +(object.every .public (PRNG [] state) + [#number (object.Method Any [(Object PRNG state) I64])]) (every .public (Random of) - (for .old (State PRNG of) - (for_any (_ seed) - (State (Object PRNG seed) of)))) + (for_any (_ seed) + (State (Object PRNG seed) of))) (the Implementation (template.macro (_ ,interface) - [(for .old (,interface Random) - (for_any (_ seed) - (,interface (for_any (_ of) (Random of seed)))))])) + [(for_any (_ seed) + (,interface (for_any (_ of) (Random of seed))))])) (the .public functor (Implementation Functor) @@ -115,8 +106,7 @@ (the .public bit (Random Bit) (function (_ prng) - (let [[prng output] (for .old (prng []) - (object.on ..#number [] prng))] + (let [[prng output] (object.on ..#number [] prng)] [prng (|> output (i64.and 1) (n.= 1))]))) @@ -124,10 +114,8 @@ (the .public i64 (Random I64) (function (_ prng) - (let [[prng left] (for .old (prng []) - (object.on ..#number [] prng)) - [prng right] (for .old (prng []) - (object.on ..#number [] prng))] + (let [[prng left] (object.on ..#number [] prng) + [prng right] (object.on ..#number [] prng)] [prng (|> left (i64.left_shifted 32) (.i64_+# right))]))) @@ -341,34 +329,22 @@ (again []))))) (of ..monad in (dictionary.empty hash)))) -(for .old - (the .public (value prng seed it) - (for_any (_ seed of) - (-> (-> seed PRNG) seed (Random of) - [PRNG of])) - (state.value (prng seed) it)) - - ... else - (the .public (value prng seed it) - (for_any (_ seed of) - (-> (PRNG seed) seed (Random of seed) - [(Object PRNG seed) of])) - (state.value (object prng seed) - it))) +(the .public (value prng seed it) + (for_any (_ seed of) + (-> (PRNG seed) seed (Random of seed) + [(Object PRNG seed) of])) + (state.value (object prng seed) + it)) (the .public (prng update return) (for_any (_ seed) (-> (-> seed seed) (-> seed I64) - (for .old (-> seed PRNG) - (PRNG seed)))) - (for .old (function (_ seed _) - [(prng update return (update seed)) - (return seed)]) - [#number (object.method - (function (_ next again [this _]) - (let [seed (object.state this)] - [(object (prng update return) (update seed)) - (return seed)])))])) + (PRNG seed))) + [#number (object.method + (function (_ next again [this _]) + (let [seed (object.state this)] + [(object (prng update return) (update seed)) + (return seed)])))]) (every .public PCG_32 (Record @@ -376,8 +352,7 @@ #seed (I64 Any)])) (the .public pcg_32 - (for .old (-> PCG_32 PRNG) - (PRNG PCG_32)) + (PRNG PCG_32) (let [magic 6364136223846793005] (..prng (function (_ [increase seed]) (|> seed .nat (n.* magic) (.i64_+# increase) [increase])) @@ -396,8 +371,7 @@ #seed_1 (I64 Any)])) (the .public xoroshiro_128+ - (for .old (-> Xoroshiro_128+ PRNG) - (PRNG Xoroshiro_128+)) + (PRNG Xoroshiro_128+) (..prng (function (_ [s0 s1]) (let [s01 (i64.xor s0 s1)] [(|> s0 @@ -415,8 +389,7 @@ Nat) (the .public split_mix_64 - (for .old (-> Split_Mix_64 PRNG) - (PRNG Split_Mix_64)) + (PRNG Split_Mix_64) (let [twist (is (-> Nat Nat Nat) (function (_ shift value) (i64.xor (i64.right_shifted shift value) diff --git a/stdlib/source/library/lux/meta/compiler/default/platform.lux b/stdlib/source/library/lux/meta/compiler/default/platform.lux index bff425828f..7499f93eb5 100644 --- a/stdlib/source/library/lux/meta/compiler/default/platform.lux +++ b/stdlib/source/library/lux/meta/compiler/default/platform.lux @@ -744,15 +744,6 @@ {try.#Failure error} ))))))) - (for .old (these (the Fake_State - Type - {.#Nominal (%.nat (static.random_nat)) (list)}) - - (the Fake_Document - Type - {.#Nominal (%.nat (static.random_nat)) (list)})) - (these)) - (the (serial_compiler import context platform compilation_sources configuration compiler) (for_any (_ ) (-> Import context.Context (List _io.Context) Configuration (///.Compiler .Module) @@ -765,9 +756,7 @@ compilation_sources (its context.#host_module_extension context) module)] - (loop (again [customs (for .old (as (List (///.Custom Fake_State Fake_Document)) - all_customs) - all_customs)]) + (loop (again [customs all_customs]) (when customs {.#End} ((..lux_compiler import context platform compilation_sources configuration compiler (compiler input)) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux b/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux index 3af887279f..94b36783a5 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/cache/module.lux @@ -115,5 +115,4 @@ (|> path (of fs read) (of ! each (|>> [name]))))))] - (in (dictionary.of_list text.hash (for .old (as (List [Text Binary]) pairs) - pairs))))) + (in (dictionary.of_list text.hash pairs)))) diff --git a/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux b/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux index 06a37462d6..ddd967063b 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/cli/compiler.lux @@ -3,7 +3,7 @@ (.require [library - [lux (.except parameter) + [lux (.except) [abstract [monad (.only do)] [equivalence (.only Equivalence)]] diff --git a/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux b/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux index 7b69c6bb1a..7301ea7517 100644 --- a/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux +++ b/stdlib/source/library/lux/meta/compiler/meta/io/archive.lux @@ -189,9 +189,7 @@ (the (cache_projection customs) (-> (List Custom) (Projection [(module.Module Any) Registry])) - (when (for .old (as (List (Custom Any Any)) - customs) - customs) + (when customs {.#End} (..projection $.key $.projection) @@ -252,14 +250,8 @@ (list.only (|>> product.left (dictionary.key? purge) not)) (monad.each ! (function (_ [module_name [@module entry]]) (do ! - [entry (expansion.let [ (..load_definitions fs context @module host_environment entry)] - (for .old (as (Async (Try (archive.Entry .Module))) - ) - ))] - (in (expansion.let [ [module_name entry]] - (for .old (as [descriptor.Module (archive.Entry .Module)] - ) - )))))))] + [entry (..load_definitions fs context @module host_environment entry)] + (in [module_name entry])))))] (in it))) (the (load_every_reserved_module customs configuration host_environment fs context import contexts archive) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux index 833cd531fe..549fea24d0 100644 --- a/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/constant.lux @@ -75,12 +75,8 @@ (Equivalence java/lang/Float) (implementation (the (= parameter subject) - (for .old - ("jvm feq" parameter subject) - - .jvm - (.jvm_float_=# (.jvm_object_cast# parameter) - (.jvm_object_cast# subject)))))) + (.jvm_float_=# (.jvm_object_cast# parameter) + (.jvm_object_cast# subject))))) (import java/lang/Double "[1]::[0]" diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux index 6a1b7806e5..fe21ae91d0 100644 --- a/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/loader.lux @@ -109,30 +109,25 @@ (the .public (memory library) (-> Library java/lang/ClassLoader) - (expansion.let [ (for .old - (<|) - - .jvm - .jvm_object_cast#)] - (<| - (object [] java/lang/ClassLoader [] - [] - (java/lang/ClassLoader (findClass self [class_name java/lang/String]) - (java/lang/Class [? < java/lang/Object]) - "throws" [java/lang/ClassNotFoundException] - (let [class_name (as Text class_name) - classes (|> library atom.read! io.value)] - (when (dictionary.value class_name classes) - {try.#Success bytecode} - (when (..define class_name bytecode (<| self)) - {try.#Success class} - (as_expected class) - - {try.#Failure error} - (panic! (exception.error ..cannot_define [class_name error]))) - - failure - (panic! (exception.error ..unknown [class_name]))))))))) + (<| .jvm_object_cast# + (object [] java/lang/ClassLoader [] + [] + (java/lang/ClassLoader (findClass self [class_name java/lang/String]) + (java/lang/Class [? < java/lang/Object]) + "throws" [java/lang/ClassNotFoundException] + (let [class_name (as Text class_name) + classes (|> library atom.read! io.value)] + (when (dictionary.value class_name classes) + {try.#Success bytecode} + (when (..define class_name bytecode (<| .jvm_object_cast# self)) + {try.#Success class} + (as_expected class) + + {try.#Failure error} + (panic! (exception.error ..cannot_define [class_name error]))) + + failure + (panic! (exception.error ..unknown [class_name])))))))) (the .public (store name bytecode library) (-> Text Binary Library (IO (Try Any))) diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux index ac053046ac..7f8c107c0d 100644 --- a/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/reflection.lux @@ -3,7 +3,7 @@ (.require [library - [lux (.except parameter type) + [lux (.except type) ["[0]" ffi (.only import)] [abstract ["[0]" monad (.only do)]] diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux index 6fd2d7775a..5ff9be1556 100644 --- a/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/lux.lux @@ -3,7 +3,7 @@ (.require [library - [lux (.except int char parameter type) + [lux (.except int char type) [abstract ["[0]" monad (.only do)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/target/jvm/type/projection.lux b/stdlib/source/library/lux/meta/compiler/target/jvm/type/projection.lux index 6c7c1ab4c6..4e1a4e9ad7 100644 --- a/stdlib/source/library/lux/meta/compiler/target/jvm/type/projection.lux +++ b/stdlib/source/library/lux/meta/compiler/target/jvm/type/projection.lux @@ -4,7 +4,7 @@ (.require [library [lux (.except Type Declaration - int char parameter) + int char) [abstract [monad (.only do)]] [control diff --git a/stdlib/source/library/lux/meta/compiler/target/php.lux b/stdlib/source/library/lux/meta/compiler/target/php.lux index 25b7a4317d..596a076b6a 100644 --- a/stdlib/source/library/lux/meta/compiler/target/php.lux +++ b/stdlib/source/library/lux/meta/compiler/target/php.lux @@ -4,7 +4,7 @@ (.require [library [lux (.except Location Code Global Label - static int if cond or and not comment for try global its parameter when) + static int if cond or and not comment for try global its when) [abstract [equivalence (.only Equivalence)] [hash (.only Hash)] diff --git a/stdlib/source/library/lux/meta/extension.lux b/stdlib/source/library/lux/meta/extension.lux index c96d0a624f..3d5de50050 100644 --- a/stdlib/source/library/lux/meta/extension.lux +++ b/stdlib/source/library/lux/meta/extension.lux @@ -37,11 +37,7 @@ ["[0]" declaration] [phase [translation - (.,, (.for .old - ["[0]" jvm - ["[1]" runtime]] - - .jvm + (.,, (.for .jvm ["[0]" jvm ["[1]" runtime]] diff --git a/stdlib/source/library/lux/meta/type/object.lux b/stdlib/source/library/lux/meta/type/object.lux index 5ff083a599..b5d6a5f24b 100644 --- a/stdlib/source/library/lux/meta/type/object.lux +++ b/stdlib/source/library/lux/meta/type/object.lux @@ -134,13 +134,10 @@ (template.macro (_ ) [((debug.private ..override') (.revised ) )])) -(for .old - (these) - - (the .public (as class object) - (for_any (_ interface state) - (-> (interface state) (Object interface Any) - (Maybe (Object interface state)))) - (if (same? class (..class object)) - {.#Some (as_expected object)} - {.#None}))) +(the .public (as class object) + (for_any (_ interface state) + (-> (interface state) (Object interface Any) + (Maybe (Object interface state)))) + (if (same? class (..class object)) + {.#Some (as_expected object)} + {.#None})) diff --git a/stdlib/source/library/lux/program.lux b/stdlib/source/library/lux/program.lux index f23a0f8df1..0888cab08a 100644 --- a/stdlib/source/library/lux/program.lux +++ b/stdlib/source/library/lux/program.lux @@ -35,8 +35,7 @@ (syntax.macro (_ [args ..arguments^ body .any]) (with_symbols [g!program g!args g!_ g!output g!message] - (let [initialization+event_loop (for .old body - .jvm body + (let [initialization+event_loop (for .jvm body .js body .python body ... else diff --git a/stdlib/source/library/lux/web/html.lux b/stdlib/source/library/lux/web/html.lux index 9249e54775..669e4fbf18 100644 --- a/stdlib/source/library/lux/web/html.lux +++ b/stdlib/source/library/lux/web/html.lux @@ -4,7 +4,7 @@ (.require [library [lux (.except Meta Source Target - comment and open parameter quote ruby) + comment and open quote ruby) [control ["[0]" function] ["[0]" maybe (.use "[1]#[0]" functor)]] diff --git a/stdlib/source/library/lux/web/html/tag.lux b/stdlib/source/library/lux/web/html/tag.lux index 1271781714..d2719a6b32 100644 --- a/stdlib/source/library/lux/web/html/tag.lux +++ b/stdlib/source/library/lux/web/html/tag.lux @@ -3,7 +3,7 @@ (.require [library - [lux (.except comment and open parameter quote ruby) + [lux (.except comment and open quote ruby) [meta [macro ["[0]" template]]]]]) diff --git a/stdlib/source/library/lux/world/console.lux b/stdlib/source/library/lux/world/console.lux index f9cb1d8950..bdf84ea897 100644 --- a/stdlib/source/library/lux/world/console.lux +++ b/stdlib/source/library/lux/world/console.lux @@ -50,128 +50,126 @@ (exception.the .public cannot_close) -(expansion.let [ (these (import java/lang/String - "[1]::[0]") - - (import java/io/Console - "[1]::[0]" - (readLine [] "io" "try" java/lang/String)) - - (import java/io/InputStream - "[1]::[0]" - (read [] "io" "try" int)) - - (import java/io/PrintStream - "[1]::[0]" - (print [java/lang/String] "io" "try" void)) - - (import java/lang/System - "[1]::[0]" - ("static" console [] "io" "?" java/io/Console) - ("read_only" "static" in java/io/InputStream) - ("read_only" "static" out java/io/PrintStream)) - - (exception.the .public cannot_open) - - (the .public default - (IO (Try (Console IO))) - (do io.monad - [?jvm_console (java/lang/System::console [])] - (when ?jvm_console - {.#None} - (in (exception.except ..cannot_open [])) - - {.#Some jvm_console} - (let [jvm_input (java/lang/System::in) - jvm_output (java/lang/System::out)] - (<| in - {try.#Success} - (is (Console IO)) ... TODO: Remove ASAP - (implementation - (the (read _) - (|> jvm_input - (java/io/InputStream::read []) - (of (try.with io.monad) each (|>> ffi.of_int .nat)))) - - (the (read_line _) - (io#each (try#each (|>> ffi.of_string)) - (java/io/Console::readLine [] jvm_console))) - - (the (write message) - (java/io/PrintStream::print [(ffi.as_string message)] jvm_output)) - - (the close - (|>> (exception.except ..cannot_close) in)))))))))] - (for .old (these ) - .jvm (these ) - .js (these (ffi.import Buffer - "[1]::[0]" - (toString [] ffi.String)) - - (ffi.import Readable_Stream - "[1]::[0]" - (read [] "?" Buffer) - (unshift "as" unshift|String [ffi.String] ffi.Boolean) - (unshift "as" unshift|Buffer [Buffer] ffi.Boolean)) - - (ffi.import Writable_Stream - "[1]::[0]" - (write [ffi.String ffi.Function] ffi.Boolean) - (once [ffi.String ffi.Function] Any)) - - (ffi.import process - "[1]::[0]" - ("static" stdout Writable_Stream) - ("static" stdin Readable_Stream)) - - (exception.the .public cannot_read) - - (the !read - (template.macro (_ ) - [(let [it (io.value (process::stdin))] - (when (Readable_Stream::read [] it) - {.#Some buffer} - (let [input (Buffer::toString [] buffer)] - (when (is (Maybe [ Text]) - ) - {.#Some [head tail]} - (exec - (Readable_Stream::unshift|String [tail] it) - (async#in {try.#Success head})) - - {.#None} - (exec - (Readable_Stream::unshift|Buffer [buffer] it) - (async#in (exception.except ..cannot_read []))))) - - {.#None} - (async#in (exception.except ..cannot_read []))))])) - - (the .public default - (Maybe (Console Async)) - (if ffi.on_node_js? - {.#Some (implementation - (the (read _) - (!read Char (do maybe.monad - [head (text.char 0 input) - [_ tail] (text.split_at 1 input)] - (in [head tail])))) - - (the (read_line _) - (!read Text (text.split_by text.\n input))) - - (the (write it) - (let [[read! write!] (is [(async.Async (Try [])) (async.Resolver (Try []))] - (async.async []))] - (exec - (Writable_Stream::write [it (ffi.function (_ []) Any (io.value (write! {try.#Success []})))] - (io.value (process::stdout))) - read!))) - - (the close - (|>> (exception.except ..cannot_close) async#in)))} - {.#None}))) - (these))) +(for .jvm (these (import java/lang/String + "[1]::[0]") + + (import java/io/Console + "[1]::[0]" + (readLine [] "io" "try" java/lang/String)) + + (import java/io/InputStream + "[1]::[0]" + (read [] "io" "try" int)) + + (import java/io/PrintStream + "[1]::[0]" + (print [java/lang/String] "io" "try" void)) + + (import java/lang/System + "[1]::[0]" + ("static" console [] "io" "?" java/io/Console) + ("read_only" "static" in java/io/InputStream) + ("read_only" "static" out java/io/PrintStream)) + + (exception.the .public cannot_open) + + (the .public default + (IO (Try (Console IO))) + (do io.monad + [?jvm_console (java/lang/System::console [])] + (when ?jvm_console + {.#None} + (in (exception.except ..cannot_open [])) + + {.#Some jvm_console} + (let [jvm_input (java/lang/System::in) + jvm_output (java/lang/System::out)] + (<| in + {try.#Success} + (is (Console IO)) ... TODO: Remove ASAP + (implementation + (the (read _) + (|> jvm_input + (java/io/InputStream::read []) + (of (try.with io.monad) each (|>> ffi.of_int .nat)))) + + (the (read_line _) + (io#each (try#each (|>> ffi.of_string)) + (java/io/Console::readLine [] jvm_console))) + + (the (write message) + (java/io/PrintStream::print [(ffi.as_string message)] jvm_output)) + + (the close + (|>> (exception.except ..cannot_close) in))))))))) + .js (these (ffi.import Buffer + "[1]::[0]" + (toString [] ffi.String)) + + (ffi.import Readable_Stream + "[1]::[0]" + (read [] "?" Buffer) + (unshift "as" unshift|String [ffi.String] ffi.Boolean) + (unshift "as" unshift|Buffer [Buffer] ffi.Boolean)) + + (ffi.import Writable_Stream + "[1]::[0]" + (write [ffi.String ffi.Function] ffi.Boolean) + (once [ffi.String ffi.Function] Any)) + + (ffi.import process + "[1]::[0]" + ("static" stdout Writable_Stream) + ("static" stdin Readable_Stream)) + + (exception.the .public cannot_read) + + (the !read + (template.macro (_ ) + [(let [it (io.value (process::stdin))] + (when (Readable_Stream::read [] it) + {.#Some buffer} + (let [input (Buffer::toString [] buffer)] + (when (is (Maybe [ Text]) + ) + {.#Some [head tail]} + (exec + (Readable_Stream::unshift|String [tail] it) + (async#in {try.#Success head})) + + {.#None} + (exec + (Readable_Stream::unshift|Buffer [buffer] it) + (async#in (exception.except ..cannot_read []))))) + + {.#None} + (async#in (exception.except ..cannot_read []))))])) + + (the .public default + (Maybe (Console Async)) + (if ffi.on_node_js? + {.#Some (implementation + (the (read _) + (!read Char (do maybe.monad + [head (text.char 0 input) + [_ tail] (text.split_at 1 input)] + (in [head tail])))) + + (the (read_line _) + (!read Text (text.split_by text.\n input))) + + (the (write it) + (let [[read! write!] (is [(async.Async (Try [])) (async.Resolver (Try []))] + (async.async []))] + (exec + (Writable_Stream::write [it (ffi.function (_ []) Any (io.value (write! {try.#Success []})))] + (io.value (process::stdout))) + read!))) + + (the close + (|>> (exception.except ..cannot_close) async#in)))} + {.#None}))) + (these)) (the .public (write_line message console) (for_any (_ !) (-> Text (Console !) (! (Try Any)))) diff --git a/stdlib/source/library/lux/world/environment.lux b/stdlib/source/library/lux/world/environment.lux index 261ac2a680..f23ef3b828 100644 --- a/stdlib/source/library/lux/world/environment.lux +++ b/stdlib/source/library/lux/world/environment.lux @@ -25,7 +25,6 @@ ["[0]" list (.use "[1]#[0]" functor)]]] ["[0]" ffi (.only import) (.,, (.for .js (.,, (.these ["[0]" node_js])) - .old (.,, (.these ["node_js" //math])) (.,, (.these))))] [math [number @@ -113,229 +112,225 @@ ... 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 -(expansion.let [ (these (import java/lang/String - "[1]::[0]") - - (import (java/util/Iterator a) - "[1]::[0]" - (hasNext [] boolean) - (next [] a)) - - (import (java/util/Set a) - "[1]::[0]" - (iterator [] (java/util/Iterator a))) - - (import (java/util/Map k v) - "[1]::[0]" - (keySet [] (java/util/Set k))) - - (import java/lang/System - "[1]::[0]" - ("static" getenv [] (java/util/Map java/lang/String java/lang/String)) - ("static" getenv "as" resolveEnv [java/lang/String] "io" "?" java/lang/String) - ("static" getProperty [java/lang/String] "?" java/lang/String) - ("static" exit [int] "io" void)) - - (the (jvm::consume iterator) - (for_any (_ a) - (-> (java/util/Iterator a) - (List a))) - (if (ffi.of_boolean (java/util/Iterator::hasNext [] iterator)) - {.#Item (java/util/Iterator::next [] iterator) - (jvm::consume iterator)} - {.#End})) - )] - (for .old (these ) - .jvm (these ) - .js (these (the default_exit! - (-> Exit (IO Nothing)) - (|>> %.int panic! io.io)) - - (import NodeJs_Process - "[1]::[0]" - (exit [ffi.Number] "io" Nothing) - (cwd [] "io" Path)) - - (the (exit_node_js! code) - (-> Exit (IO Nothing)) - (when (ffi.global ..NodeJs_Process [process]) - {.#Some process} - (NodeJs_Process::exit [(i.dec code)] process) - - {.#None} - (..default_exit! code))) - - (import Browser_Window - "[1]::[0]" - (close [] Nothing)) +(for .jvm (these (import java/lang/String + "[1]::[0]") + + (import (java/util/Iterator a) + "[1]::[0]" + (hasNext [] boolean) + (next [] a)) + + (import (java/util/Set a) + "[1]::[0]" + (iterator [] (java/util/Iterator a))) + + (import (java/util/Map k v) + "[1]::[0]" + (keySet [] (java/util/Set k))) + + (import java/lang/System + "[1]::[0]" + ("static" getenv [] (java/util/Map java/lang/String java/lang/String)) + ("static" getenv "as" resolveEnv [java/lang/String] "io" "?" java/lang/String) + ("static" getProperty [java/lang/String] "?" java/lang/String) + ("static" exit [int] "io" void)) + + (the (jvm::consume iterator) + (for_any (_ a) + (-> (java/util/Iterator a) + (List a))) + (if (ffi.of_boolean (java/util/Iterator::hasNext [] iterator)) + {.#Item (java/util/Iterator::next [] iterator) + (jvm::consume iterator)} + {.#End})) + ) + .js (these (the default_exit! + (-> Exit (IO Nothing)) + (|>> %.int panic! io.io)) + + (import NodeJs_Process + "[1]::[0]" + (exit [ffi.Number] "io" Nothing) + (cwd [] "io" Path)) + + (the (exit_node_js! code) + (-> Exit (IO Nothing)) + (when (ffi.global ..NodeJs_Process [process]) + {.#Some process} + (NodeJs_Process::exit [(i.dec code)] process) + + {.#None} + (..default_exit! code))) + + (import Browser_Window + "[1]::[0]" + (close [] Nothing)) + + (import Browser_Location + "[1]::[0]" + (reload [] Nothing)) + + (the (exit_browser! code) + (-> Exit (IO Nothing)) + (when [(ffi.global ..Browser_Window [window]) + (ffi.global ..Browser_Location [location])] + [{.#Some window} {.#Some location}] + (exec + (Browser_Window::close [] window) + (Browser_Location::reload [] location) + (..default_exit! code)) - (import Browser_Location - "[1]::[0]" - (reload [] Nothing)) - - (the (exit_browser! code) - (-> Exit (IO Nothing)) - (when [(ffi.global ..Browser_Window [window]) - (ffi.global ..Browser_Location [location])] - [{.#Some window} {.#Some location}] - (exec - (Browser_Window::close [] window) - (Browser_Location::reload [] location) - (..default_exit! code)) - - [{.#Some window} {.#None}] - (exec - (Browser_Window::close [] window) - (..default_exit! code)) - - [{.#None} {.#Some location}] - (exec - (Browser_Location::reload [] location) - (..default_exit! code)) - - [{.#None} {.#None}] - (..default_exit! code))) - - (import Object - "[1]::[0]" - ("static" entries [Object] (Array (Array ffi.String)))) + [{.#Some window} {.#None}] + (exec + (Browser_Window::close [] window) + (..default_exit! code)) - (import NodeJs_OS - "[1]::[0]" - (homedir [] "io" Path))) - .python (these (import os/path - "[1]::[0]" - (expanduser [ffi.String] "io" ffi.String)) - - (import os/environ - "[1]::[0]" - (keys [] "io" (Array ffi.String)) - (get [ffi.String] "io" "?" ffi.String)) - - (import os - "[1]::[0]" - ("static" getcwd [] "io" ffi.String) - ("static" _exit [ffi.Integer] "io" Nothing) - - ("static" path os/path) - ("static" environ os/environ))) - .lua (these (ffi.import LuaFile - "[1]::[0]" - (read [ffi.String] "io" "?" ffi.String) - (close [] "io" ffi.Boolean)) - - (ffi.import (io/popen [ffi.String] "io" "try" "?" LuaFile)) - (ffi.import (os/getenv [ffi.String] "io" "?" ffi.String)) - (ffi.import (os/exit [ffi.Integer] "io" Nothing)) - - (the (run_command default command) - (-> Text Text (IO Text)) - (do [! io.monad] - [outcome (io/popen [command])] - (when outcome - {try.#Success outcome} - (when outcome - {.#Some file} - (do ! - [?output (LuaFile::read ["*l"] file) - _ (LuaFile::close [] file)] - (in (maybe.else default ?output))) - - {.#None} - (in default)) - - {try.#Failure _} - (in default))))) - .ruby (these (ffi.import Env + [{.#None} {.#Some location}] + (exec + (Browser_Location::reload [] location) + (..default_exit! code)) + + [{.#None} {.#None}] + (..default_exit! code))) + + (import Object + "[1]::[0]" + ("static" entries [Object] (Array (Array ffi.String)))) + + (import NodeJs_OS + "[1]::[0]" + (homedir [] "io" Path))) + .python (these (import os/path "[1]::[0]" - ("static" keys [] (Array Text)) - ("static" fetch [Text] "io" "?" Text)) + (expanduser [ffi.String] "io" ffi.String)) - (ffi.import "fileutils" FileUtils - "[2]/[1]::[0]" - ("static" pwd Path)) - - (ffi.import Dir + (import os/environ "[1]::[0]" - ("static" home Path)) + (keys [] "io" (Array ffi.String)) + (get [ffi.String] "io" "?" ffi.String)) - (ffi.import Kernel + (import os "[1]::[0]" - ("static" exit [Int] "io" Nothing))) - - ... .php - ... (these (ffi.import (exit [Int] "io" Nothing)) - ... ... https://www.php.net/manual/en/function.exit.php - ... (ffi.import (getcwd [] "io" ffi.String)) - ... ... https://www.php.net/manual/en/function.getcwd.php - ... (ffi.import (getenv "as" getenv/1 [ffi.String] "io" ffi.String)) - ... (ffi.import (getenv "as" getenv/0 [] "io" (Array ffi.String))) - ... ... https://www.php.net/manual/en/function.getenv.php - ... ... https://www.php.net/manual/en/function.array-keys.php - ... (ffi.import (array_keys [(Array ffi.String)] (Array ffi.String))) - ... ) - - ... .scheme - ... (these (ffi.import (exit [Int] "io" Nothing)) - ... ... https://srfi.schemers.org/srfi-98/srfi-98.html - ... (nominal.every Pair Any) - ... (nominal.every PList Any) - ... (ffi.import (get-environment-variables [] "io" PList)) - ... (ffi.import (car [Pair] Text)) - ... (ffi.import (cdr [Pair] Text)) - ... (ffi.import (car "as" head [PList] Pair)) - ... (ffi.import (cdr "as" tail [PList] PList))) - - (these))) + ("static" getcwd [] "io" ffi.String) + ("static" _exit [ffi.Integer] "io" Nothing) + + ("static" path os/path) + ("static" environ os/environ))) + .lua (these (ffi.import LuaFile + "[1]::[0]" + (read [ffi.String] "io" "?" ffi.String) + (close [] "io" ffi.Boolean)) + + (ffi.import (io/popen [ffi.String] "io" "try" "?" LuaFile)) + (ffi.import (os/getenv [ffi.String] "io" "?" ffi.String)) + (ffi.import (os/exit [ffi.Integer] "io" Nothing)) + + (the (run_command default command) + (-> Text Text (IO Text)) + (do [! io.monad] + [outcome (io/popen [command])] + (when outcome + {try.#Success outcome} + (when outcome + {.#Some file} + (do ! + [?output (LuaFile::read ["*l"] file) + _ (LuaFile::close [] file)] + (in (maybe.else default ?output))) + + {.#None} + (in default)) + + {try.#Failure _} + (in default))))) + .ruby (these (ffi.import Env + "[1]::[0]" + ("static" keys [] (Array Text)) + ("static" fetch [Text] "io" "?" Text)) + + (ffi.import "fileutils" FileUtils + "[2]/[1]::[0]" + ("static" pwd Path)) + + (ffi.import Dir + "[1]::[0]" + ("static" home Path)) + + (ffi.import Kernel + "[1]::[0]" + ("static" exit [Int] "io" Nothing))) + + ... .php + ... (these (ffi.import (exit [Int] "io" Nothing)) + ... ... https://www.php.net/manual/en/function.exit.php + ... (ffi.import (getcwd [] "io" ffi.String)) + ... ... https://www.php.net/manual/en/function.getcwd.php + ... (ffi.import (getenv "as" getenv/1 [ffi.String] "io" ffi.String)) + ... (ffi.import (getenv "as" getenv/0 [] "io" (Array ffi.String))) + ... ... https://www.php.net/manual/en/function.getenv.php + ... ... https://www.php.net/manual/en/function.array-keys.php + ... (ffi.import (array_keys [(Array ffi.String)] (Array ffi.String))) + ... ) + + ... .scheme + ... (these (ffi.import (exit [Int] "io" Nothing)) + ... ... https://srfi.schemers.org/srfi-98/srfi-98.html + ... (nominal.every Pair Any) + ... (nominal.every PList Any) + ... (ffi.import (get-environment-variables [] "io" PList)) + ... (ffi.import (car [Pair] Text)) + ... (ffi.import (cdr [Pair] Text)) + ... (ffi.import (car "as" head [PList] Pair)) + ... (ffi.import (cdr "as" tail [PList] PList))) + + (these)) (the .public default (Environment IO) (implementation (the (available_variables _) - (expansion.let [ (|> (java/lang/System::getenv []) - (java/util/Map::keySet []) - (java/util/Set::iterator []) - ..jvm::consume - (list#each (|>> ffi.of_string)) - io.io)] - (for .old - .jvm - .js (io.io (if ffi.on_node_js? - (when (ffi.global Object [process env]) - {.#Some process/env} - (|> (Object::entries [process/env]) - (array.list {.#None}) - (list#each (|>> (array.item 0) maybe.trusted))) - - {.#None} - (list)) - (list))) - .python (do [! io.monad] - [it (os::environ)] - (of ! each - (array.list {.#None}) - (os/environ::keys [] it))) - ... Lua offers no way to get all the environment variables available. - .lua (io.io (list)) - .ruby (io.io (array.list {.#None} (Env::keys []))) - ... .php (do io.monad - ... [environment (..getenv/0 [])] - ... (in (|> environment - ... ..array_keys - ... (array.list {.#None}) - ... (list#each (function (_ variable) - ... [variable ("php array read" (as Nat variable) environment)])) - ... (dictionary.of_list text.hash)))) - ... .scheme (do io.monad - ... [input (..get-environment-variables [])] - ... (loop (again [input input - ... output \\projection.empty]) - ... (if ("scheme object nil?" input) - ... (in output) - ... (let [entry (..head input)] - ... (again (..tail input) - ... (dictionary.has (..car entry) (..cdr entry) output)))))) - ))) + (for .jvm (|> (java/lang/System::getenv []) + (java/util/Map::keySet []) + (java/util/Set::iterator []) + ..jvm::consume + (list#each (|>> ffi.of_string)) + io.io) + .js (io.io (if ffi.on_node_js? + (when (ffi.global Object [process env]) + {.#Some process/env} + (|> (Object::entries [process/env]) + (array.list {.#None}) + (list#each (|>> (array.item 0) maybe.trusted))) + + {.#None} + (list)) + (list))) + .python (do [! io.monad] + [it (os::environ)] + (of ! each + (array.list {.#None}) + (os/environ::keys [] it))) + ... Lua offers no way to get all the environment variables available. + .lua (io.io (list)) + .ruby (io.io (array.list {.#None} (Env::keys []))) + ... .php (do io.monad + ... [environment (..getenv/0 [])] + ... (in (|> environment + ... ..array_keys + ... (array.list {.#None}) + ... (list#each (function (_ variable) + ... [variable ("php array read" (as Nat variable) environment)])) + ... (dictionary.of_list text.hash)))) + ... .scheme (do io.monad + ... [input (..get-environment-variables [])] + ... (loop (again [input input + ... output \\projection.empty]) + ... (if ("scheme object nil?" input) + ... (in output) + ... (let [entry (..head input)] + ... (again (..tail input) + ... (dictionary.has (..car entry) (..cdr entry) output)))))) + )) (the (variable name) (template.let [(!fetch ) @@ -348,42 +343,38 @@ {.#None} (exception.except ..unknown_environment_variable [name]))))]] - (expansion.let [ (!fetch (<| java/lang/System::resolveEnv [] ffi.as_string) ffi.of_string)] - (for .old - .jvm - .js (io.io (if ffi.on_node_js? - (when (do maybe.monad - [process/env (ffi.global Object [process env])] - (array.item (as Nat name) - (as (Array Text) process/env))) - {.#Some value} - {try.#Success value} + (for .jvm (!fetch (<| java/lang/System::resolveEnv [] ffi.as_string) ffi.of_string) + .js (io.io (if ffi.on_node_js? + (when (do maybe.monad + [process/env (ffi.global Object [process env])] + (array.item (as Nat name) + (as (Array Text) process/env))) + {.#Some value} + {try.#Success value} - {.#None} - (exception.except ..unknown_environment_variable [name])) - (exception.except ..unknown_environment_variable [name]))) - .python (do io.monad - [it (os::environ) - value (os/environ::get [name] it)] - (in (when value - {.#Some value} - {try.#Success value} - - {.#None} - (exception.except ..unknown_environment_variable [name])))) - .lua (!fetch os/getenv |>) - .ruby (!fetch Env::fetch |>) - )))) + {.#None} + (exception.except ..unknown_environment_variable [name])) + (exception.except ..unknown_environment_variable [name]))) + .python (do io.monad + [it (os::environ) + value (os/environ::get [name] it)] + (in (when value + {.#Some value} + {try.#Success value} + + {.#None} + (exception.except ..unknown_environment_variable [name])))) + .lua (!fetch os/getenv |>) + .ruby (!fetch Env::fetch |>) + ))) (the home (io.value - (expansion.let [ (io.io "~") - (|> (java/lang/System::getProperty [(ffi.as_string "user.home")]) - (maybe#each (|>> ffi.of_string)) - (maybe.else "") - io.io)] - (for .old - .jvm + (expansion.let [ (io.io "~")] + (for .jvm (|> (java/lang/System::getProperty [(ffi.as_string "user.home")]) + (maybe#each (|>> ffi.of_string)) + (maybe.else "") + io.io) .js (if ffi.on_node_js? (|> (node_js.require "os") maybe.trusted @@ -406,13 +397,11 @@ (the directory (io.value - (expansion.let [ "." - (|> (java/lang/System::getProperty [(ffi.as_string "user.dir")]) - (maybe#each (|>> ffi.of_string)) - (maybe.else "") - io.io)] - (for .old - .jvm + (expansion.let [ "."] + (for .jvm (|> (java/lang/System::getProperty [(ffi.as_string "user.dir")]) + (maybe#each (|>> ffi.of_string)) + (maybe.else "") + io.io) .js (if ffi.on_node_js? (when (ffi.global ..NodeJs_Process [process]) {.#Some process} @@ -439,22 +428,20 @@ (io.io ))))) (the (exit code) - (expansion.let [ (do io.monad - [_ (java/lang/System::exit [(ffi.as_int code)])] - (in (undefined)))] - (for .old - .jvm - .js (cond ffi.on_node_js? - (..exit_node_js! code) - - ffi.on_browser? - (..exit_browser! code) - - ... else - (..default_exit! code)) - .python (os::_exit [code]) - .lua (os/exit [code]) - .ruby (Kernel::exit code) - ... .php (..exit [code]) - ... .scheme (..exit [code]) - ))))) + (for .jvm (do io.monad + [_ (java/lang/System::exit [(ffi.as_int code)])] + (in (undefined))) + .js (cond ffi.on_node_js? + (..exit_node_js! code) + + ffi.on_browser? + (..exit_browser! code) + + ... else + (..default_exit! code)) + .python (os::_exit [code]) + .lua (os/exit [code]) + .ruby (Kernel::exit code) + ... .php (..exit [code]) + ... .scheme (..exit [code]) + )))) diff --git a/stdlib/source/library/lux/world/file.lux b/stdlib/source/library/lux/world/file.lux index fe32c0f3e7..6f7a8805d9 100644 --- a/stdlib/source/library/lux/world/file.lux +++ b/stdlib/source/library/lux/world/file.lux @@ -29,7 +29,6 @@ ["[0]" dictionary (.only Dictionary)]]] ["[0]" ffi (.only) (.,, (.for .js (.,, (.these ["[0]" node_js])) - .old (.,, (.these ["node_js" //control/thread])) (.,, (.these))))] [math [number @@ -173,814 +172,813 @@ [cannot_find_directory] ) -(expansion.let [ (these (ffi.import java/lang/String - "[1]::[0]") - - (`` (ffi.import java/io/File - "[1]::[0]" - (new [java/lang/String]) - (,, (template.with [] - [( [] "io" "try" boolean)] - - [createNewFile] [mkdir] - [delete] - [isFile] [isDirectory] - [canRead] [canWrite] [canExecute])) - - (length [] "io" "try" long) - (listFiles [] "io" "try" "?" [java/io/File]) - (getAbsolutePath [] "io" "try" java/lang/String) - (renameTo [java/io/File] "io" "try" boolean) - (lastModified [] "io" "try" long) - (setLastModified [long] "io" "try" boolean) - ("read_only" "static" separator java/lang/String))) - - (ffi.import java/lang/AutoCloseable - "[1]::[0]" - (close [] "io" "try" void)) - - (ffi.import java/io/OutputStream - "[1]::[0]" - (write [[byte]] "io" "try" void) - (flush [] "io" "try" void)) - - (ffi.import java/io/FileOutputStream - "[1]::[0]" - (new [java/io/File boolean] "io" "try")) - - (ffi.import java/io/InputStream - "[1]::[0]" - (read [[byte]] "io" "try" int)) - - (ffi.import java/io/FileInputStream - "[1]::[0]" - (new [java/io/File] "io" "try")) - - (`` (the .public default - (System IO) - (implementation - (the separator - (ffi.of_string (java/io/File::separator))) - - (,, (template.with [ ] - [(the - (|>> ffi.as_string - [] java/io/File::new - ( []) - (io#each (|>> (try#each (|>> ffi.of_boolean)) (try.else false)))))] - - [file? java/io/File::isFile] - [directory? java/io/File::isDirectory] - )) - - (the make_directory - (|>> ffi.as_string - [] java/io/File::new - (java/io/File::mkdir []))) - - (,, (template.with [ ] - [(the ( path) - (do [! (try.with io.monad)] - [?children (java/io/File::listFiles [] (java/io/File::new [(ffi.as_string path)]))] - (when ?children - {.#Some children} - (|> children - (array.list {.#None}) - (monad.only ! (|>> ( []) - (of ! each (|>> ffi.of_boolean)))) - (of ! each (monad.each ! (|>> (java/io/File::getAbsolutePath []) - (of ! each (|>> ffi.of_string))))) - (of ! conjoint)) - - {.#None} - (of io.monad in (exception.except ..cannot_find_directory [path])))))] - - [directory_files java/io/File::isFile] - [sub_directories java/io/File::isDirectory] - )) - - (the file_size - (|>> ffi.as_string - [] java/io/File::new - (java/io/File::length []) - (of (try.with io.monad) each (|>> ffi.of_long .nat)))) - - (the last_modified - (|>> ffi.as_string - [] java/io/File::new - (java/io/File::lastModified []) - (of (try.with io.monad) each (|>> ffi.of_long duration.of_millis instant.absolute)))) - - (the can_execute? - (|>> ffi.as_string - [] java/io/File::new - (java/io/File::canExecute []) - (io#each (try#each (|>> ffi.of_boolean))))) - - (the (read path) - (do (try.with io.monad) - [.let [file (java/io/File::new [(ffi.as_string path)])] - size (java/io/File::length [] file) - stream (java/io/FileInputStream::new [file]) - .let [data (binary.empty (.nat (ffi.of_long size)))] - bytes_read (java/io/InputStream::read [data] stream) - _ (java/lang/AutoCloseable::close [] stream)] - (in data))) - - (the (delete path) - (|> path - ffi.as_string - [] java/io/File::new - (java/io/File::delete []))) - - (the (modify path time_stamp) - (|> path - ffi.as_string - [] java/io/File::new - (java/io/File::setLastModified [(|> time_stamp instant.relative duration.millis ffi.as_long)]))) - - (,, (template.with [ ] - [(the ( path data) - (do (try.with io.monad) - [stream (java/io/FileOutputStream::new [[(java/io/File::new [(ffi.as_string path)])] - (ffi.as_boolean )]) - _ (java/io/OutputStream::write [data] stream) - _ (java/io/OutputStream::flush [] stream)] - (java/lang/AutoCloseable::close [] stream)))] - - [#0 write] - [#1 append] - )) - - (the (move origin destination) - (|> origin - ffi.as_string - [] java/io/File::new - (java/io/File::renameTo [(java/io/File::new [(ffi.as_string destination)])]))) - ))))] - (for .old (these ) - .jvm (these ) - - .js - (these (ffi.import Buffer - "[1]::[0]" - ("static" from [Binary] ..Buffer)) - - (ffi.import Stats - "[1]::[0]" - (size ffi.Number) - (mtimeMs ffi.Number) - (isFile [] ffi.Boolean) - (isDirectory [] ffi.Boolean)) - - (ffi.import FsConstants - "[1]::[0]" - (F_OK ffi.Number) - (X_OK ffi.Number)) - - (ffi.import Error - "[1]::[0]" - (toString [] ffi.String)) - - (the with_async - (template.macro (_ ) - [(template.with_locals [] - (let [[ ] (is [(Async ) (async.Resolver )] - (async.async []))] - (exec - - )))])) - - (ffi.import Fs - "[1]::[0]" - (constants FsConstants) - (readFile [ffi.String ffi.Function] Any) - (appendFile [ffi.String Buffer ffi.Function] Any) - (writeFile [ffi.String Buffer ffi.Function] Any) - (stat [ffi.String ffi.Function] Any) - (access [ffi.String ffi.Number ffi.Function] Any) - (rename [ffi.String ffi.String ffi.Function] Any) - (utimes [ffi.String ffi.Number ffi.Number ffi.Function] Any) - (readdir [ffi.String ffi.Function] Any) - (mkdir [ffi.String ffi.Function] Any) - (unlink [ffi.String ffi.Function] Any) - (rmdir [ffi.String ffi.Function] Any)) - - (the (any_callback write!) - (-> (async.Resolver (Try Any)) ffi.Function) - (<| (ffi.function (_ [error Error]) Any) - io.value - write! - (if (ffi.null? error) - {try.#Success []} - {try.#Failure (Error::toString [] error)}))) - - (the (value_callback write!) - (for_any (_ a) (-> (async.Resolver (Try a)) ffi.Function)) - (<| (ffi.function (_ [error Error datum Any]) Any) - io.value - write! - (if (ffi.null? error) - {try.#Success (as_expected datum)} - {try.#Failure (Error::toString [] error)}))) - - (ffi.import JsPath - "[1]::[0]" - (sep ffi.String)) - - (the .public default - (Maybe (System Async)) - (do maybe.monad - [node_fs (node_js.require "fs") - node_path (node_js.require "path") - .let [node_fs (as ..Fs node_fs) - js_separator (if ffi.on_node_js? - (JsPath::sep (as ..JsPath node_path)) - "/")]] - (in (is (System Async) - (`` (implementation - (the separator - js_separator) - - (,, (template.with [ ] - [(the ( path) - (do async.monad - [?stats (with_async write! (Try Stats) - (Fs::stat [path (..value_callback write!)] - node_fs))] - (in (when ?stats - {try.#Success stats} - ( [] stats) - - {try.#Failure _} - false))))] - - [file? Stats::isFile] - [directory? Stats::isDirectory] - )) - - (the (make_directory path) - (do async.monad - [outcome (with_async write! (Try Any) - (Fs::access [path - (|> node_fs Fs::constants FsConstants::F_OK) - (..any_callback write!)] - node_fs))] - (when outcome - {try.#Success _} - (in (exception.except ..cannot_make_directory [path])) - - {try.#Failure _} - (with_async write! (Try Any) - (Fs::mkdir [path (..any_callback write!)] node_fs))))) - - (,, (template.with [ ] - [(the ( path) - (do [! (try.with async.monad)] - [subs (with_async write! (Try (Array ffi.String)) - (Fs::readdir [path (..value_callback write!)] - node_fs))] - (|> subs - (array.list {.#None}) - (list#each (|>> (%.message path js_separator))) - (monad.each ! (function (_ sub) - (of ! each (|>> ( []) [sub]) - (with_async write! (Try Stats) - (Fs::stat [sub (..value_callback write!)] - node_fs))))) - (of ! each (|>> (list.only product.right) - (list#each product.left))))))] - - [directory_files Stats::isFile] - [sub_directories Stats::isDirectory] - )) - - (the (file_size path) - (do (try.with async.monad) - [stats (with_async write! (Try Stats) - (Fs::stat [path (..value_callback write!)] - node_fs))] - (in (|> stats - Stats::size - d.nat)))) - - (the (last_modified path) - (do (try.with async.monad) - [stats (with_async write! (Try Stats) - (Fs::stat [path (..value_callback write!)] - node_fs))] - (in (|> stats - Stats::mtimeMs - d.int - duration.of_millis - instant.absolute)))) - - (the (can_execute? path) - (of async.monad each - (|>> (pipe.when - {try.#Success _} - true - - {try.#Failure _} - false) - {try.#Success}) - (with_async write! (Try Any) - (Fs::access [path - (|> node_fs Fs::constants FsConstants::X_OK) - (..any_callback write!)] - node_fs)))) - - (the (read path) - (with_async write! (Try Binary) - (Fs::readFile [path (..value_callback write!)] - node_fs))) - - (the (delete path) - (do (try.with async.monad) - [stats (with_async write! (Try Stats) - (Fs::stat [path (..value_callback write!)] - node_fs))] +(for .jvm + (these (ffi.import java/lang/String + "[1]::[0]") + + (`` (ffi.import java/io/File + "[1]::[0]" + (new [java/lang/String]) + (,, (template.with [] + [( [] "io" "try" boolean)] + + [createNewFile] [mkdir] + [delete] + [isFile] [isDirectory] + [canRead] [canWrite] [canExecute])) + + (length [] "io" "try" long) + (listFiles [] "io" "try" "?" [java/io/File]) + (getAbsolutePath [] "io" "try" java/lang/String) + (renameTo [java/io/File] "io" "try" boolean) + (lastModified [] "io" "try" long) + (setLastModified [long] "io" "try" boolean) + ("read_only" "static" separator java/lang/String))) + + (ffi.import java/lang/AutoCloseable + "[1]::[0]" + (close [] "io" "try" void)) + + (ffi.import java/io/OutputStream + "[1]::[0]" + (write [[byte]] "io" "try" void) + (flush [] "io" "try" void)) + + (ffi.import java/io/FileOutputStream + "[1]::[0]" + (new [java/io/File boolean] "io" "try")) + + (ffi.import java/io/InputStream + "[1]::[0]" + (read [[byte]] "io" "try" int)) + + (ffi.import java/io/FileInputStream + "[1]::[0]" + (new [java/io/File] "io" "try")) + + (`` (the .public default + (System IO) + (implementation + (the separator + (ffi.of_string (java/io/File::separator))) + + (,, (template.with [ ] + [(the + (|>> ffi.as_string + [] java/io/File::new + ( []) + (io#each (|>> (try#each (|>> ffi.of_boolean)) (try.else false)))))] + + [file? java/io/File::isFile] + [directory? java/io/File::isDirectory] + )) + + (the make_directory + (|>> ffi.as_string + [] java/io/File::new + (java/io/File::mkdir []))) + + (,, (template.with [ ] + [(the ( path) + (do [! (try.with io.monad)] + [?children (java/io/File::listFiles [] (java/io/File::new [(ffi.as_string path)]))] + (when ?children + {.#Some children} + (|> children + (array.list {.#None}) + (monad.only ! (|>> ( []) + (of ! each (|>> ffi.of_boolean)))) + (of ! each (monad.each ! (|>> (java/io/File::getAbsolutePath []) + (of ! each (|>> ffi.of_string))))) + (of ! conjoint)) + + {.#None} + (of io.monad in (exception.except ..cannot_find_directory [path])))))] + + [directory_files java/io/File::isFile] + [sub_directories java/io/File::isDirectory] + )) + + (the file_size + (|>> ffi.as_string + [] java/io/File::new + (java/io/File::length []) + (of (try.with io.monad) each (|>> ffi.of_long .nat)))) + + (the last_modified + (|>> ffi.as_string + [] java/io/File::new + (java/io/File::lastModified []) + (of (try.with io.monad) each (|>> ffi.of_long duration.of_millis instant.absolute)))) + + (the can_execute? + (|>> ffi.as_string + [] java/io/File::new + (java/io/File::canExecute []) + (io#each (try#each (|>> ffi.of_boolean))))) + + (the (read path) + (do (try.with io.monad) + [.let [file (java/io/File::new [(ffi.as_string path)])] + size (java/io/File::length [] file) + stream (java/io/FileInputStream::new [file]) + .let [data (binary.empty (.nat (ffi.of_long size)))] + bytes_read (java/io/InputStream::read [data] stream) + _ (java/lang/AutoCloseable::close [] stream)] + (in data))) + + (the (delete path) + (|> path + ffi.as_string + [] java/io/File::new + (java/io/File::delete []))) + + (the (modify path time_stamp) + (|> path + ffi.as_string + [] java/io/File::new + (java/io/File::setLastModified [(|> time_stamp instant.relative duration.millis ffi.as_long)]))) + + (,, (template.with [ ] + [(the ( path data) + (do (try.with io.monad) + [stream (java/io/FileOutputStream::new [[(java/io/File::new [(ffi.as_string path)])] + (ffi.as_boolean )]) + _ (java/io/OutputStream::write [data] stream) + _ (java/io/OutputStream::flush [] stream)] + (java/lang/AutoCloseable::close [] stream)))] + + [#0 write] + [#1 append] + )) + + (the (move origin destination) + (|> origin + ffi.as_string + [] java/io/File::new + (java/io/File::renameTo [(java/io/File::new [(ffi.as_string destination)])]))) + )))) + + .js + (these (ffi.import Buffer + "[1]::[0]" + ("static" from [Binary] ..Buffer)) + + (ffi.import Stats + "[1]::[0]" + (size ffi.Number) + (mtimeMs ffi.Number) + (isFile [] ffi.Boolean) + (isDirectory [] ffi.Boolean)) + + (ffi.import FsConstants + "[1]::[0]" + (F_OK ffi.Number) + (X_OK ffi.Number)) + + (ffi.import Error + "[1]::[0]" + (toString [] ffi.String)) + + (the with_async + (template.macro (_ ) + [(template.with_locals [] + (let [[ ] (is [(Async ) (async.Resolver )] + (async.async []))] + (exec + + )))])) + + (ffi.import Fs + "[1]::[0]" + (constants FsConstants) + (readFile [ffi.String ffi.Function] Any) + (appendFile [ffi.String Buffer ffi.Function] Any) + (writeFile [ffi.String Buffer ffi.Function] Any) + (stat [ffi.String ffi.Function] Any) + (access [ffi.String ffi.Number ffi.Function] Any) + (rename [ffi.String ffi.String ffi.Function] Any) + (utimes [ffi.String ffi.Number ffi.Number ffi.Function] Any) + (readdir [ffi.String ffi.Function] Any) + (mkdir [ffi.String ffi.Function] Any) + (unlink [ffi.String ffi.Function] Any) + (rmdir [ffi.String ffi.Function] Any)) + + (the (any_callback write!) + (-> (async.Resolver (Try Any)) ffi.Function) + (<| (ffi.function (_ [error Error]) Any) + io.value + write! + (if (ffi.null? error) + {try.#Success []} + {try.#Failure (Error::toString [] error)}))) + + (the (value_callback write!) + (for_any (_ a) (-> (async.Resolver (Try a)) ffi.Function)) + (<| (ffi.function (_ [error Error datum Any]) Any) + io.value + write! + (if (ffi.null? error) + {try.#Success (as_expected datum)} + {try.#Failure (Error::toString [] error)}))) + + (ffi.import JsPath + "[1]::[0]" + (sep ffi.String)) + + (the .public default + (Maybe (System Async)) + (do maybe.monad + [node_fs (node_js.require "fs") + node_path (node_js.require "path") + .let [node_fs (as ..Fs node_fs) + js_separator (if ffi.on_node_js? + (JsPath::sep (as ..JsPath node_path)) + "/")]] + (in (is (System Async) + (`` (implementation + (the separator + js_separator) + + (,, (template.with [ ] + [(the ( path) + (do async.monad + [?stats (with_async write! (Try Stats) + (Fs::stat [path (..value_callback write!)] + node_fs))] + (in (when ?stats + {try.#Success stats} + ( [] stats) + + {try.#Failure _} + false))))] + + [file? Stats::isFile] + [directory? Stats::isDirectory] + )) + + (the (make_directory path) + (do async.monad + [outcome (with_async write! (Try Any) + (Fs::access [path + (|> node_fs Fs::constants FsConstants::F_OK) + (..any_callback write!)] + node_fs))] + (when outcome + {try.#Success _} + (in (exception.except ..cannot_make_directory [path])) + + {try.#Failure _} (with_async write! (Try Any) - (if (Stats::isFile [] stats) - (Fs::unlink [path (..any_callback write!)] - node_fs) - (Fs::rmdir [path (..any_callback write!)] - node_fs))))) - - (the (modify path time_stamp) - (with_async write! (Try Any) - (let [when (|> time_stamp instant.relative duration.millis i.dec)] - (Fs::utimes [path when when (..any_callback write!)] + (Fs::mkdir [path (..any_callback write!)] node_fs))))) + + (,, (template.with [ ] + [(the ( path) + (do [! (try.with async.monad)] + [subs (with_async write! (Try (Array ffi.String)) + (Fs::readdir [path (..value_callback write!)] + node_fs))] + (|> subs + (array.list {.#None}) + (list#each (|>> (%.message path js_separator))) + (monad.each ! (function (_ sub) + (of ! each (|>> ( []) [sub]) + (with_async write! (Try Stats) + (Fs::stat [sub (..value_callback write!)] + node_fs))))) + (of ! each (|>> (list.only product.right) + (list#each product.left))))))] + + [directory_files Stats::isFile] + [sub_directories Stats::isDirectory] + )) + + (the (file_size path) + (do (try.with async.monad) + [stats (with_async write! (Try Stats) + (Fs::stat [path (..value_callback write!)] + node_fs))] + (in (|> stats + Stats::size + d.nat)))) + + (the (last_modified path) + (do (try.with async.monad) + [stats (with_async write! (Try Stats) + (Fs::stat [path (..value_callback write!)] + node_fs))] + (in (|> stats + Stats::mtimeMs + d.int + duration.of_millis + instant.absolute)))) + + (the (can_execute? path) + (of async.monad each + (|>> (pipe.when + {try.#Success _} + true + + {try.#Failure _} + false) + {try.#Success}) + (with_async write! (Try Any) + (Fs::access [path + (|> node_fs Fs::constants FsConstants::X_OK) + (..any_callback write!)] node_fs)))) - (,, (template.with [ ] - [(the ( path data) - (with_async write! (Try Any) - ( [path (Buffer::from [data]) (..any_callback write!)] - node_fs)))] - - [write Fs::writeFile] - [append Fs::appendFile] - )) + (the (read path) + (with_async write! (Try Binary) + (Fs::readFile [path (..value_callback write!)] + node_fs))) - (the (move origin destination) + (the (delete path) + (do (try.with async.monad) + [stats (with_async write! (Try Stats) + (Fs::stat [path (..value_callback write!)] + node_fs))] (with_async write! (Try Any) - (Fs::rename [origin destination (..any_callback write!)] - node_fs)))))))))) - - .python - (these (every (Tuple/2 left right) - (Nominal "python_tuple[2]" [left right])) - - (ffi.import PyFile - "[1]::[0]" - (read [] "io" "try" Binary) - (write [Binary] "io" "try" "?" Any) - (close [] "io" "try" "?" Any)) - - (ffi.import (open [ffi.String ffi.String] "io" "try" PyFile)) - (ffi.import (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer))) - - (ffi.import os - "[1]::[0]" - ("static" X_OK ffi.Integer) - - ("static" mkdir [ffi.String] "io" "try" "?" Any) - ("static" access [ffi.String ffi.Integer] "io" "try" ffi.Boolean) - ("static" remove [ffi.String] "io" "try" "?" Any) - ("static" rmdir [ffi.String] "io" "try" "?" Any) - ("static" rename [ffi.String ffi.String] "io" "try" "?" Any) - ("static" utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] "io" "try" "?" Any) - ("static" listdir [ffi.String] "io" "try" (Array ffi.String))) - - (ffi.import os/path - "[1]::[0]" - ("static" isfile [ffi.String] "io" "try" ffi.Boolean) - ("static" isdir [ffi.String] "io" "try" ffi.Boolean) - ("static" sep ffi.String) - ("static" getsize [ffi.String] "io" "try" ffi.Integer) - ("static" getmtime [ffi.String] "io" "try" ffi.Float)) - - (the python_separator - (io.value (os/path::sep))) - - (`` (the .public default - (System IO) - (implementation - (the separator - ..python_separator) - - (,, (template.with [ ] - [(the - (|>> [] - - (io#each (|>> (try.else false)))))] - - [file? os/path::isfile] - [directory? os/path::isdir] - )) - - (the make_directory - (|>> [] os::mkdir)) - - (,, (template.with [ ] - [(the ( path) - (let [! (try.with io.monad)] - (|> path - [] - os::listdir - (of ! each (|>> (array.list {.#None}) - (list#each (|>> (%.message path ..python_separator))) - (monad.each ! (function (_ sub) - (of ! each (|>> [sub]) ( [sub])))) - (of ! each (|>> (list.only product.right) - (list#each product.left))))) - (of ! conjoint))))] - - [directory_files os/path::isfile] - [sub_directories os/path::isdir] - )) - - (the file_size - (|>> [] - os/path::getsize - (of (try.with io.monad) each (|>> .nat)))) - - (the last_modified - (|>> [] - os/path::getmtime - (of (try.with io.monad) each (|>> d.int - (i.* +1,000) - duration.of_millis - instant.absolute)))) - - (the (can_execute? path) - (do io.monad - [permission (os::X_OK)] - (os::access [path permission]))) - - (the (read path) - (do (try.with io.monad) - [file (..open [path "rb"]) - data (PyFile::read [] file) - _ (PyFile::close [] file)] - (in data))) - - (the (delete path) - (do (try.with io.monad) - [? (os/path::isfile [path])] - (if ? - (os::remove [path]) - (os::rmdir [path])))) - - (the (modify path time_stamp) - (let [when (|> time_stamp instant.relative duration.millis (i./ +1,000))] - (os::utime [path (..tuple [when when])]))) - - (,, (template.with [ ] - [(the ( path data) - (do (try.with io.monad) - [file (..open [path ]) - _ (PyFile::write [data] file)] - (PyFile::close [] file)))] - - [write "w+b"] - [append "ab"] - )) - - (the (move origin destination) - (os::rename [origin destination])) - )))) - - .ruby - (these (ffi.import Time - "[1]::[0]" - ("static" at [Dec] Time) - (to_f [] Dec)) - - (ffi.import Stat - "[1]::[0]" - (executable? [] Bit) - (size Int) - (mtime [] Time)) - - (ffi.import File "as" RubyFile - "[1]::[0]" - ("static" SEPARATOR ffi.String) - ("static" open [Path ffi.String] "io" "try" RubyFile) - ("static" stat [Path] "io" "try" Stat) - ("static" delete [Path] "io" "try" Int) - ("static" file? [Path] "io" "try" Bit) - ("static" directory? [Path] "io" "try" Bit) - ("static" utime [Time Time Path] "io" "try" Int) - - (read [] "io" "try" Binary) - (write [Binary] "io" "try" Int) - (flush [] "io" "try" "?" Any) - (close [] "io" "try" "?" Any)) - - (ffi.import Dir - "[1]::[0]" - ("static" open [Path] "io" "try" Dir) - - (children [] "io" "try" (Array Path)) - (close [] "io" "try" "?" Any)) - - (ffi.import "fileutils" FileUtils - "[2]/[1]::[0]" - ("static" move [Path Path] "io" "try" "?" Any) - ("static" rmdir [Path] "io" "try" "?" Any) - ("static" mkdir [Path] "io" "try" "?" Any)) - - (the ruby_separator - Text - (io.value (..RubyFile::SEPARATOR))) - - (`` (the .public default - (System IO) - (implementation - (the separator - ..ruby_separator) - - (,, (template.with [ ] - [(the - (|>> [] - (io#each (|>> (try.else false)))))] - - [file? RubyFile::file?] - [directory? RubyFile::directory?] - )) - - (the make_directory - (|>> [] fileutils/FileUtils::mkdir)) - - (,, (template.with [ ] - [(the ( path) - (do [! (try.with io.monad)] - [self (Dir::open [path]) - children (Dir::children [] self) - output (loop (again [input (|> children - (array.list {.#None}) - (list#each (|>> (%.message path ..ruby_separator)))) - output (is (List ..Path) - (list))]) - (when input - {.#End} - (in output) - - {.#Item head tail} - (do ! - [verdict ( [head])] - (again tail (if verdict - {.#Item head output} - output))))) - _ (Dir::close [] self)] - (in output)))] - - [directory_files RubyFile::file?] - [sub_directories RubyFile::directory?] - )) - - (,, (template.with [ ] - [(the - (let [! (try.with io.monad)] - (|>> [] RubyFile::stat - (of ! each (`` (|>> (,, (template.spliced ))))))))] - - [file_size [Stat::size .nat]] - [last_modified [(Stat::mtime []) - (Time::to_f []) - (d.* +1,000.0) - d.int - duration.of_millis - instant.absolute]] - [can_execute? [(Stat::executable? [])]] - )) - - (the (read path) - (do (try.with io.monad) - [file (RubyFile::open [path "rb"]) - data (RubyFile::read [] file) - _ (RubyFile::close [] file)] - (in data))) - - (the (delete path) - (do (try.with io.monad) - [? (RubyFile::file? [path])] - (if ? - (RubyFile::delete [path]) - (fileutils/FileUtils::rmdir [path])))) - - (the (modify path moment) - (let [moment (|> moment - instant.relative - duration.millis - i.dec - (d./ +1,000.0) - [] Time::at)] - (RubyFile::utime [moment moment path]))) - - (,, (template.with [ ] - [(the ( path data) - (do [! (try.with io.monad)] - [file (RubyFile::open [path ]) - data (RubyFile::write [data] file) - _ (RubyFile::flush [] file) - _ (RubyFile::close [] file)] - (in [])))] - - ["wb" write] - ["ab" append] - )) - - (the (move origin destination) - (do (try.with io.monad) - [_ (fileutils/FileUtils::move [origin destination])] - (in []))) - )))) - - ... .php - ... (these (ffi.import (FILE_APPEND Int)) - ... ... https://www.php.net/manual/en/dir.constants.php - ... (ffi.import (DIRECTORY_SEPARATOR ffi.String)) - ... ... https://www.php.net/manual/en/function.pack.php - ... ... https://www.php.net/manual/en/function.unpack.php - ... (ffi.import (unpack [ffi.String ffi.String] Binary)) - ... ... https://www.php.net/manual/en/ref.filesystem.php - ... ... https://www.php.net/manual/en/function.file-get-contents.php - ... (ffi.import (file_get_contents [Path] "io" "try" ffi.String)) - ... ... https://www.php.net/manual/en/function.file-put-contents.php - ... (ffi.import (file_put_contents [Path ffi.String Int] "io" "try" ffi.Integer)) - ... (ffi.import (filemtime [Path] "io" "try" ffi.Integer)) - ... (ffi.import (filesize [Path] "io" "try" ffi.Integer)) - ... (ffi.import (is_executable [Path] "io" "try" ffi.Boolean)) - ... (ffi.import (touch [Path ffi.Integer] "io" "try" ffi.Boolean)) - ... (ffi.import (rename [Path Path] "io" "try" ffi.Boolean)) - ... (ffi.import (unlink [Path] "io" "try" ffi.Boolean)) - - ... ... https://www.php.net/manual/en/function.rmdir.php - ... (ffi.import (rmdir [Path] "io" "try" ffi.Boolean)) - ... ... https://www.php.net/manual/en/function.scandir.php - ... (ffi.import (scandir [Path] "io" "try" (Array Path))) - ... ... https://www.php.net/manual/en/function.is-file.php - ... (ffi.import (is_file [Path] "io" "try" ffi.Boolean)) - ... ... https://www.php.net/manual/en/function.is-dir.php - ... (ffi.import (is_dir [Path] "io" "try" ffi.Boolean)) - ... ... https://www.php.net/manual/en/function.mkdir.php - ... (ffi.import (mkdir [Path] "io" "try" ffi.Boolean)) - - ... (the byte_array_format "C*") - ... (the default_separator (..DIRECTORY_SEPARATOR)) - - ... (template.with [] - ... [(exception.the .public ( file) - ... (Exception Path) - ... (exception.report - ... (list ["Path" file])))] - - ... [cannot_write_to_file] - ... ) - - ... (`` (the (file path) - ... (-> Path (File IO)) - ... (implementation - ... (,, (template.with [ ] - ... [(the ( data) - ... (do [! (try.with io.monad)] - ... [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) ])] - ... (if (bit#= false (as Bit outcome)) - ... (of io.monad in (exception.except ..cannot_write_to_file [path])) - ... (in []))))] - - ... [over_write +0] - ... [append (..FILE_APPEND)] - ... )) - - ... (the (content _) - ... (do [! (try.with io.monad)] - ... [data (..file_get_contents [path])] - ... (if (bit#= false (as Bit data)) - ... (of io.monad in (exception.except ..cannot_find_file [path])) - ... (in (..unpack [..byte_array_format data]))))) - - ... (the path - ... path) - - ... (,, (template.with [ ] - ... [(the ( _) - ... (do [! (try.with io.monad)] - ... [value ( [path])] - ... (if (bit#= false (as Bit value)) - ... (of io.monad in (exception.except ..cannot_find_file [path])) - ... (in (`` (|> value (,, (template.spliced ))))))))] - - ... [size ..filesize [.nat]] - ... [last_modified ..filemtime [(i.* +1,000) duration.of_millis instant.absolute]] - ... )) - - ... (the (can_execute? _) - ... (..is_executable [path])) - - ... (the (modify moment) - ... (do [! (try.with io.monad)] - ... [verdict (..touch [path (|> moment instant.relative duration.millis (i./ +1,000))])] - ... (if (bit#= false (as Bit verdict)) - ... (of io.monad in (exception.except ..cannot_find_file [path])) - ... (in [])))) - - ... (the (move destination) - ... (do [! (try.with io.monad)] - ... [verdict (..rename [path destination])] - ... (if (bit#= false (as Bit verdict)) - ... (of io.monad in (exception.except ..cannot_find_file [path])) - ... (in (file destination))))) - - ... (the (delete _) - ... (do (try.with io.monad) - ... [verdict (..unlink [path])] - ... (if (bit#= false (as Bit verdict)) - ... (of io.monad in (exception.except ..cannot_find_file [path])) - ... (in [])))) - ... ))) - - ... (`` (the (directory path) - ... (-> Path (Directory IO)) - ... (implementation - ... (the scope - ... path) - - ... (,, (template.with [ ] - ... [(the ( _) - ... (do [! (try.with io.monad)] - ... [children (..scandir [path])] - ... (loop (again [input (|> children - ... (array.list {.#None}) - ... (list.only (function (_ child) - ... (not (or (text#= "." child) - ... (text#= ".." child)))))) - ... output (is (List ( IO)) - ... (list))]) - ... (when input - ... {.#End} - ... (in output) - - ... {.#Item head tail} - ... (do ! - ... [verdict ( head)] - ... (if verdict - ... (again tail {.#Item ( head) output}) - ... (again tail output)))))))] - - ... [files ..is_file ..file File] - ... [directories ..is_dir directory Directory] - ... )) - - ... (the (discard _) - ... (do (try.with io.monad) - ... [verdict (..rmdir [path])] - ... (if (bit#= false (as Bit verdict)) - ... (of io.monad in (exception.except ..cannot_find_directory [path])) - ... (in [])))) - ... ))) - - ... (`` (the .public default - ... (System IO) - ... (implementation - ... (,, (template.with [ ] - ... [(the ( path) - ... (do [! (try.with io.monad)] - ... [verdict ( path)] - ... (of io.monad in - ... (if verdict - ... {try.#Success ( path)} - ... (exception.except [path])))))] - - ... [file ..is_file ..file ..cannot_find_file] - ... [directory ..is_dir ..directory ..cannot_find_directory] - ... )) - - ... (the (make_file path) - ... (do [! (try.with io.monad)] - ... [verdict (..touch [path (|> instant.now io.value instant.relative duration.millis (i./ +1,000))])] - ... (of io.monad in - ... (if verdict - ... {try.#Success (..file path)} - ... (exception.except ..cannot_make_file [path]))))) - - ... (the (make_directory path) - ... (do [! (try.with io.monad)] - ... [verdict (..mkdir path)] - ... (of io.monad in - ... (if verdict - ... {try.#Success (..directory path)} - ... (exception.except ..cannot_make_directory [path]))))) - - ... (the separator - ... ..default_separator) - ... ))) - ... ) - - (these))) + (if (Stats::isFile [] stats) + (Fs::unlink [path (..any_callback write!)] + node_fs) + (Fs::rmdir [path (..any_callback write!)] + node_fs))))) + + (the (modify path time_stamp) + (with_async write! (Try Any) + (let [when (|> time_stamp instant.relative duration.millis i.dec)] + (Fs::utimes [path when when (..any_callback write!)] + node_fs)))) + + (,, (template.with [ ] + [(the ( path data) + (with_async write! (Try Any) + ( [path (Buffer::from [data]) (..any_callback write!)] + node_fs)))] + + [write Fs::writeFile] + [append Fs::appendFile] + )) + + (the (move origin destination) + (with_async write! (Try Any) + (Fs::rename [origin destination (..any_callback write!)] + node_fs)))))))))) + + .python + (these (every (Tuple/2 left right) + (Nominal "python_tuple[2]" [left right])) + + (ffi.import PyFile + "[1]::[0]" + (read [] "io" "try" Binary) + (write [Binary] "io" "try" "?" Any) + (close [] "io" "try" "?" Any)) + + (ffi.import (open [ffi.String ffi.String] "io" "try" PyFile)) + (ffi.import (tuple [[ffi.Integer ffi.Integer]] (Tuple/2 ffi.Integer ffi.Integer))) + + (ffi.import os + "[1]::[0]" + ("static" X_OK ffi.Integer) + + ("static" mkdir [ffi.String] "io" "try" "?" Any) + ("static" access [ffi.String ffi.Integer] "io" "try" ffi.Boolean) + ("static" remove [ffi.String] "io" "try" "?" Any) + ("static" rmdir [ffi.String] "io" "try" "?" Any) + ("static" rename [ffi.String ffi.String] "io" "try" "?" Any) + ("static" utime [ffi.String (Tuple/2 ffi.Integer ffi.Integer)] "io" "try" "?" Any) + ("static" listdir [ffi.String] "io" "try" (Array ffi.String))) + + (ffi.import os/path + "[1]::[0]" + ("static" isfile [ffi.String] "io" "try" ffi.Boolean) + ("static" isdir [ffi.String] "io" "try" ffi.Boolean) + ("static" sep ffi.String) + ("static" getsize [ffi.String] "io" "try" ffi.Integer) + ("static" getmtime [ffi.String] "io" "try" ffi.Float)) + + (the python_separator + (io.value (os/path::sep))) + + (`` (the .public default + (System IO) + (implementation + (the separator + ..python_separator) + + (,, (template.with [ ] + [(the + (|>> [] + + (io#each (|>> (try.else false)))))] + + [file? os/path::isfile] + [directory? os/path::isdir] + )) + + (the make_directory + (|>> [] os::mkdir)) + + (,, (template.with [ ] + [(the ( path) + (let [! (try.with io.monad)] + (|> path + [] + os::listdir + (of ! each (|>> (array.list {.#None}) + (list#each (|>> (%.message path ..python_separator))) + (monad.each ! (function (_ sub) + (of ! each (|>> [sub]) ( [sub])))) + (of ! each (|>> (list.only product.right) + (list#each product.left))))) + (of ! conjoint))))] + + [directory_files os/path::isfile] + [sub_directories os/path::isdir] + )) + + (the file_size + (|>> [] + os/path::getsize + (of (try.with io.monad) each (|>> .nat)))) + + (the last_modified + (|>> [] + os/path::getmtime + (of (try.with io.monad) each (|>> d.int + (i.* +1,000) + duration.of_millis + instant.absolute)))) + + (the (can_execute? path) + (do io.monad + [permission (os::X_OK)] + (os::access [path permission]))) + + (the (read path) + (do (try.with io.monad) + [file (..open [path "rb"]) + data (PyFile::read [] file) + _ (PyFile::close [] file)] + (in data))) + + (the (delete path) + (do (try.with io.monad) + [? (os/path::isfile [path])] + (if ? + (os::remove [path]) + (os::rmdir [path])))) + + (the (modify path time_stamp) + (let [when (|> time_stamp instant.relative duration.millis (i./ +1,000))] + (os::utime [path (..tuple [when when])]))) + + (,, (template.with [ ] + [(the ( path data) + (do (try.with io.monad) + [file (..open [path ]) + _ (PyFile::write [data] file)] + (PyFile::close [] file)))] + + [write "w+b"] + [append "ab"] + )) + + (the (move origin destination) + (os::rename [origin destination])) + )))) + + .ruby + (these (ffi.import Time + "[1]::[0]" + ("static" at [Dec] Time) + (to_f [] Dec)) + + (ffi.import Stat + "[1]::[0]" + (executable? [] Bit) + (size Int) + (mtime [] Time)) + + (ffi.import File "as" RubyFile + "[1]::[0]" + ("static" SEPARATOR ffi.String) + ("static" open [Path ffi.String] "io" "try" RubyFile) + ("static" stat [Path] "io" "try" Stat) + ("static" delete [Path] "io" "try" Int) + ("static" file? [Path] "io" "try" Bit) + ("static" directory? [Path] "io" "try" Bit) + ("static" utime [Time Time Path] "io" "try" Int) + + (read [] "io" "try" Binary) + (write [Binary] "io" "try" Int) + (flush [] "io" "try" "?" Any) + (close [] "io" "try" "?" Any)) + + (ffi.import Dir + "[1]::[0]" + ("static" open [Path] "io" "try" Dir) + + (children [] "io" "try" (Array Path)) + (close [] "io" "try" "?" Any)) + + (ffi.import "fileutils" FileUtils + "[2]/[1]::[0]" + ("static" move [Path Path] "io" "try" "?" Any) + ("static" rmdir [Path] "io" "try" "?" Any) + ("static" mkdir [Path] "io" "try" "?" Any)) + + (the ruby_separator + Text + (io.value (..RubyFile::SEPARATOR))) + + (`` (the .public default + (System IO) + (implementation + (the separator + ..ruby_separator) + + (,, (template.with [ ] + [(the + (|>> [] + (io#each (|>> (try.else false)))))] + + [file? RubyFile::file?] + [directory? RubyFile::directory?] + )) + + (the make_directory + (|>> [] fileutils/FileUtils::mkdir)) + + (,, (template.with [ ] + [(the ( path) + (do [! (try.with io.monad)] + [self (Dir::open [path]) + children (Dir::children [] self) + output (loop (again [input (|> children + (array.list {.#None}) + (list#each (|>> (%.message path ..ruby_separator)))) + output (is (List ..Path) + (list))]) + (when input + {.#End} + (in output) + + {.#Item head tail} + (do ! + [verdict ( [head])] + (again tail (if verdict + {.#Item head output} + output))))) + _ (Dir::close [] self)] + (in output)))] + + [directory_files RubyFile::file?] + [sub_directories RubyFile::directory?] + )) + + (,, (template.with [ ] + [(the + (let [! (try.with io.monad)] + (|>> [] RubyFile::stat + (of ! each (`` (|>> (,, (template.spliced ))))))))] + + [file_size [Stat::size .nat]] + [last_modified [(Stat::mtime []) + (Time::to_f []) + (d.* +1,000.0) + d.int + duration.of_millis + instant.absolute]] + [can_execute? [(Stat::executable? [])]] + )) + + (the (read path) + (do (try.with io.monad) + [file (RubyFile::open [path "rb"]) + data (RubyFile::read [] file) + _ (RubyFile::close [] file)] + (in data))) + + (the (delete path) + (do (try.with io.monad) + [? (RubyFile::file? [path])] + (if ? + (RubyFile::delete [path]) + (fileutils/FileUtils::rmdir [path])))) + + (the (modify path moment) + (let [moment (|> moment + instant.relative + duration.millis + i.dec + (d./ +1,000.0) + [] Time::at)] + (RubyFile::utime [moment moment path]))) + + (,, (template.with [ ] + [(the ( path data) + (do [! (try.with io.monad)] + [file (RubyFile::open [path ]) + data (RubyFile::write [data] file) + _ (RubyFile::flush [] file) + _ (RubyFile::close [] file)] + (in [])))] + + ["wb" write] + ["ab" append] + )) + + (the (move origin destination) + (do (try.with io.monad) + [_ (fileutils/FileUtils::move [origin destination])] + (in []))) + )))) + + ... .php + ... (these (ffi.import (FILE_APPEND Int)) + ... ... https://www.php.net/manual/en/dir.constants.php + ... (ffi.import (DIRECTORY_SEPARATOR ffi.String)) + ... ... https://www.php.net/manual/en/function.pack.php + ... ... https://www.php.net/manual/en/function.unpack.php + ... (ffi.import (unpack [ffi.String ffi.String] Binary)) + ... ... https://www.php.net/manual/en/ref.filesystem.php + ... ... https://www.php.net/manual/en/function.file-get-contents.php + ... (ffi.import (file_get_contents [Path] "io" "try" ffi.String)) + ... ... https://www.php.net/manual/en/function.file-put-contents.php + ... (ffi.import (file_put_contents [Path ffi.String Int] "io" "try" ffi.Integer)) + ... (ffi.import (filemtime [Path] "io" "try" ffi.Integer)) + ... (ffi.import (filesize [Path] "io" "try" ffi.Integer)) + ... (ffi.import (is_executable [Path] "io" "try" ffi.Boolean)) + ... (ffi.import (touch [Path ffi.Integer] "io" "try" ffi.Boolean)) + ... (ffi.import (rename [Path Path] "io" "try" ffi.Boolean)) + ... (ffi.import (unlink [Path] "io" "try" ffi.Boolean)) + + ... ... https://www.php.net/manual/en/function.rmdir.php + ... (ffi.import (rmdir [Path] "io" "try" ffi.Boolean)) + ... ... https://www.php.net/manual/en/function.scandir.php + ... (ffi.import (scandir [Path] "io" "try" (Array Path))) + ... ... https://www.php.net/manual/en/function.is-file.php + ... (ffi.import (is_file [Path] "io" "try" ffi.Boolean)) + ... ... https://www.php.net/manual/en/function.is-dir.php + ... (ffi.import (is_dir [Path] "io" "try" ffi.Boolean)) + ... ... https://www.php.net/manual/en/function.mkdir.php + ... (ffi.import (mkdir [Path] "io" "try" ffi.Boolean)) + + ... (the byte_array_format "C*") + ... (the default_separator (..DIRECTORY_SEPARATOR)) + + ... (template.with [] + ... [(exception.the .public ( file) + ... (Exception Path) + ... (exception.report + ... (list ["Path" file])))] + + ... [cannot_write_to_file] + ... ) + + ... (`` (the (file path) + ... (-> Path (File IO)) + ... (implementation + ... (,, (template.with [ ] + ... [(the ( data) + ... (do [! (try.with io.monad)] + ... [outcome (..file_put_contents [path ("php pack" ..byte_array_format data) ])] + ... (if (bit#= false (as Bit outcome)) + ... (of io.monad in (exception.except ..cannot_write_to_file [path])) + ... (in []))))] + + ... [over_write +0] + ... [append (..FILE_APPEND)] + ... )) + + ... (the (content _) + ... (do [! (try.with io.monad)] + ... [data (..file_get_contents [path])] + ... (if (bit#= false (as Bit data)) + ... (of io.monad in (exception.except ..cannot_find_file [path])) + ... (in (..unpack [..byte_array_format data]))))) + + ... (the path + ... path) + + ... (,, (template.with [ ] + ... [(the ( _) + ... (do [! (try.with io.monad)] + ... [value ( [path])] + ... (if (bit#= false (as Bit value)) + ... (of io.monad in (exception.except ..cannot_find_file [path])) + ... (in (`` (|> value (,, (template.spliced ))))))))] + + ... [size ..filesize [.nat]] + ... [last_modified ..filemtime [(i.* +1,000) duration.of_millis instant.absolute]] + ... )) + + ... (the (can_execute? _) + ... (..is_executable [path])) + + ... (the (modify moment) + ... (do [! (try.with io.monad)] + ... [verdict (..touch [path (|> moment instant.relative duration.millis (i./ +1,000))])] + ... (if (bit#= false (as Bit verdict)) + ... (of io.monad in (exception.except ..cannot_find_file [path])) + ... (in [])))) + + ... (the (move destination) + ... (do [! (try.with io.monad)] + ... [verdict (..rename [path destination])] + ... (if (bit#= false (as Bit verdict)) + ... (of io.monad in (exception.except ..cannot_find_file [path])) + ... (in (file destination))))) + + ... (the (delete _) + ... (do (try.with io.monad) + ... [verdict (..unlink [path])] + ... (if (bit#= false (as Bit verdict)) + ... (of io.monad in (exception.except ..cannot_find_file [path])) + ... (in [])))) + ... ))) + + ... (`` (the (directory path) + ... (-> Path (Directory IO)) + ... (implementation + ... (the scope + ... path) + + ... (,, (template.with [ ] + ... [(the ( _) + ... (do [! (try.with io.monad)] + ... [children (..scandir [path])] + ... (loop (again [input (|> children + ... (array.list {.#None}) + ... (list.only (function (_ child) + ... (not (or (text#= "." child) + ... (text#= ".." child)))))) + ... output (is (List ( IO)) + ... (list))]) + ... (when input + ... {.#End} + ... (in output) + + ... {.#Item head tail} + ... (do ! + ... [verdict ( head)] + ... (if verdict + ... (again tail {.#Item ( head) output}) + ... (again tail output)))))))] + + ... [files ..is_file ..file File] + ... [directories ..is_dir directory Directory] + ... )) + + ... (the (discard _) + ... (do (try.with io.monad) + ... [verdict (..rmdir [path])] + ... (if (bit#= false (as Bit verdict)) + ... (of io.monad in (exception.except ..cannot_find_directory [path])) + ... (in [])))) + ... ))) + + ... (`` (the .public default + ... (System IO) + ... (implementation + ... (,, (template.with [ ] + ... [(the ( path) + ... (do [! (try.with io.monad)] + ... [verdict ( path)] + ... (of io.monad in + ... (if verdict + ... {try.#Success ( path)} + ... (exception.except [path])))))] + + ... [file ..is_file ..file ..cannot_find_file] + ... [directory ..is_dir ..directory ..cannot_find_directory] + ... )) + + ... (the (make_file path) + ... (do [! (try.with io.monad)] + ... [verdict (..touch [path (|> instant.now io.value instant.relative duration.millis (i./ +1,000))])] + ... (of io.monad in + ... (if verdict + ... {try.#Success (..file path)} + ... (exception.except ..cannot_make_file [path]))))) + + ... (the (make_directory path) + ... (do [! (try.with io.monad)] + ... [verdict (..mkdir path)] + ... (of io.monad in + ... (if verdict + ... {try.#Success (..directory path)} + ... (exception.except ..cannot_make_directory [path]))))) + + ... (the separator + ... ..default_separator) + ... ))) + ... ) + + (these)) (the .public (exists? monad fs path) (for_any (_ !) diff --git a/stdlib/source/library/lux/world/file/watch.lux b/stdlib/source/library/lux/world/file/watch.lux index 09b886b5ee..0e72ac7a5c 100644 --- a/stdlib/source/library/lux/world/file/watch.lux +++ b/stdlib/source/library/lux/world/file/watch.lux @@ -282,212 +282,213 @@ [fs (..polling fs)])) -(expansion.let [ (these (import java/lang/Object - "[1]::[0]") - - (import java/lang/String - "[1]::[0]") - - (import (java/util/List a) - "[1]::[0]" - (size [] int) - (get [int] a)) - - (the (default_list list) - (for_any (_ of) - (-> (java/util/List of) - (List of))) - (let [size (.nat (ffi.of_int (java/util/List::size [] list)))] - (loop (again [idx 0 - output {.#End}]) - (if (n.< size idx) - (again (++ idx) - {.#Item (java/util/List::get [(ffi.as_int (.int idx))] list) - output}) - output)))) - - (import (java/nio/file/WatchEvent$Kind of) - "[1]::[0]") - - (import (java/nio/file/WatchEvent of) - "[1]::[0]" - (kind [] (java/nio/file/WatchEvent$Kind of))) - - (import java/nio/file/Watchable - "[1]::[0]") - - (import java/nio/file/Path - "[1]::[0]" - (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] "io" "try" java/nio/file/WatchKey) - (toString [] java/lang/String)) - - (import java/nio/file/StandardWatchEventKinds - "[1]::[0]" - ("read_only" "static" ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path)) - ("read_only" "static" ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path)) - ("read_only" "static" ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))) - - (the (default_event_concern event) - (for_any (_ of) - (-> (java/nio/file/WatchEvent of) - Concern)) - (let [kind (as (java/nio/file/WatchEvent$Kind java/nio/file/Path) - (java/nio/file/WatchEvent::kind [] event))] - (cond (same? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE) - kind) - ..creation - - (same? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY) - kind) - ..modification - - (same? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE) - kind) - ..deletion - - ... else - ..none - ))) - - (import java/nio/file/WatchKey - "[1]::[0]" - (reset [] "io" boolean) - (cancel [] "io" void) - (watchable [] java/nio/file/Watchable) - (pollEvents [] "io" (java/util/List (java/nio/file/WatchEvent ?)))) - - (the default_key_concern - (-> java/nio/file/WatchKey - (IO Concern)) - (|>> (java/nio/file/WatchKey::pollEvents []) - (of io.monad each (|>> ..default_list - (list#each default_event_concern) - (list#mix ..and ..none))))) - - (import java/nio/file/WatchService - "[1]::[0]" - (poll [] "io" "try" "?" java/nio/file/WatchKey)) - - (import java/nio/file/FileSystem - "[1]::[0]" - (newWatchService [] "io" "try" java/nio/file/WatchService)) - - (import java/nio/file/FileSystems - "[1]::[0]" - ("static" getDefault [] java/nio/file/FileSystem)) - - (import java/io/File - "[1]::[0]" - (new [java/lang/String]) - (toPath [] java/nio/file/Path)) - - (every Watch_Event - (java/nio/file/WatchEvent$Kind java/lang/Object)) - - (the (default_start watch_events watcher path) - (-> (List Watch_Event) java/nio/file/WatchService //.Path - (Async (Try java/nio/file/WatchKey))) - (let [watch_events' (list#mix (function (_ [index watch_event] watch_events') - (ffi.write! index watch_event watch_events')) - (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object) - (list.size watch_events)) - (list.enumeration watch_events))] - (async.future - (java/nio/file/Path::register [watcher - watch_events'] - (|> path ffi.as_string [] java/io/File::new (java/io/File::toPath [])))))) - - (the (default_poll watcher) - (-> java/nio/file/WatchService - (IO (Try (List [Concern //.Path])))) - (loop (again [output (is (List [Concern //.Path]) - (list))]) - (do (try.with io.monad) - [?key (java/nio/file/WatchService::poll [] watcher)] - (when ?key - {.#Some key} - (do [! io.monad] - [valid? (java/nio/file/WatchKey::reset [] key)] - (if (ffi.of_boolean valid?) - (do ! - [.let [path (|> key - (java/nio/file/WatchKey::watchable []) - (as java/nio/file/Path) - (java/nio/file/Path::toString []) - ffi.of_string - (as //.Path))] - the_concern (..default_key_concern key)] - (again {.#Item [the_concern path] - output})) - (again output))) - - {.#None} - (in output))))) - - (the (watch_events concern) - (-> Concern - (List Watch_Event)) - (.all list#composite - (if (..creation? concern) - (list (as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE))) - (list)) - (if (..modification? concern) - (list (as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY))) - (list)) - (if (..deletion? concern) - (list (as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE))) - (list)) - )) - - (the .public default - (IO (Try (Watcher Async))) - (do (try.with io.monad) - [watcher (|> (java/nio/file/FileSystems::getDefault []) - (java/nio/file/FileSystem::newWatchService [])) - .let [tracker (stm.var (is (Dictionary //.Path [Concern java/nio/file/WatchKey]) - (dictionary.empty text.hash))) - - stop (is (-> //.Path (Async (Try Concern))) - (function (_ path) - (do [! async.monad] - [@tracker (stm.commit! (stm.read tracker))] - (when (dictionary.value path @tracker) - {try.#Success [the_concern key]} - (do ! - [_ (async.future - (java/nio/file/WatchKey::cancel [] key)) - _ (stm.commit! (stm.update (dictionary.lacks path) tracker))] - (in {try.#Success the_concern})) - - failure - (in (exception.except ..not_being_watched [path]))))))]] - (in (is (Watcher Async) - (implementation - (the (start the_concern path) - (do async.monad - [?concern (stop path)] - (do (try.with async.monad) - [key (..default_start (..watch_events (..and (try.else ..none ?concern) - the_concern)) - watcher - path)] - (do async.monad - [_ (stm.commit! (stm.update (dictionary.has path [the_concern key]) tracker))] - (in {try.#Success []}))))) - (the (concern path) - (do async.monad - [@tracker (stm.commit! (stm.read tracker))] - (when (dictionary.value path @tracker) - {try.#Success [it key]} - (in {try.#Success it}) - - failure - (in (exception.except ..not_being_watched [path]))))) - (the stop stop) - (the (poll _) - (async.future (..default_poll watcher))) - ))))) - )] - (for .old (these ) - .jvm (these ) - (these))) +(for .jvm + (these (import java/lang/Object + "[1]::[0]") + + (import java/lang/String + "[1]::[0]") + + (import (java/util/List a) + "[1]::[0]" + (size [] int) + (get [int] a)) + + (the (default_list list) + (for_any (_ of) + (-> (java/util/List of) + (List of))) + (let [size (.nat (ffi.of_int (java/util/List::size [] list)))] + (loop (again [idx 0 + output {.#End}]) + (if (n.< size idx) + (again (++ idx) + {.#Item (java/util/List::get [(ffi.as_int (.int idx))] list) + output}) + output)))) + + (import (java/nio/file/WatchEvent$Kind of) + "[1]::[0]") + + (import (java/nio/file/WatchEvent of) + "[1]::[0]" + (kind [] (java/nio/file/WatchEvent$Kind of))) + + (import java/nio/file/Watchable + "[1]::[0]") + + (import java/nio/file/Path + "[1]::[0]" + (register [java/nio/file/WatchService [(java/nio/file/WatchEvent$Kind [? < java/lang/Object])]] "io" "try" java/nio/file/WatchKey) + (toString [] java/lang/String)) + + (import java/nio/file/StandardWatchEventKinds + "[1]::[0]" + ("read_only" "static" ENTRY_CREATE (java/nio/file/WatchEvent$Kind java/nio/file/Path)) + ("read_only" "static" ENTRY_MODIFY (java/nio/file/WatchEvent$Kind java/nio/file/Path)) + ("read_only" "static" ENTRY_DELETE (java/nio/file/WatchEvent$Kind java/nio/file/Path))) + + (the (default_event_concern event) + (for_any (_ of) + (-> (java/nio/file/WatchEvent of) + Concern)) + (let [kind (as (java/nio/file/WatchEvent$Kind java/nio/file/Path) + (java/nio/file/WatchEvent::kind [] event))] + (cond (same? (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE) + kind) + ..creation + + (same? (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY) + kind) + ..modification + + (same? (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE) + kind) + ..deletion + + ... else + ..none + ))) + + (import java/nio/file/WatchKey + "[1]::[0]" + (reset [] "io" boolean) + (cancel [] "io" void) + (watchable [] java/nio/file/Watchable) + (pollEvents [] "io" (java/util/List (java/nio/file/WatchEvent ?)))) + + (the default_key_concern + (-> java/nio/file/WatchKey + (IO Concern)) + (|>> (java/nio/file/WatchKey::pollEvents []) + (of io.monad each (|>> ..default_list + (list#each default_event_concern) + (list#mix ..and ..none))))) + + (import java/nio/file/WatchService + "[1]::[0]" + (poll [] "io" "try" "?" java/nio/file/WatchKey)) + + (import java/nio/file/FileSystem + "[1]::[0]" + (newWatchService [] "io" "try" java/nio/file/WatchService)) + + (import java/nio/file/FileSystems + "[1]::[0]" + ("static" getDefault [] java/nio/file/FileSystem)) + + (import java/io/File + "[1]::[0]" + (new [java/lang/String]) + (toPath [] java/nio/file/Path)) + + (every Watch_Event + (java/nio/file/WatchEvent$Kind java/lang/Object)) + + (the (default_start watch_events watcher path) + (-> (List Watch_Event) java/nio/file/WatchService //.Path + (Async (Try java/nio/file/WatchKey))) + (let [watch_events' (list#mix (function (_ [index watch_event] watch_events') + (ffi.write! index watch_event watch_events')) + (ffi.array (java/nio/file/WatchEvent$Kind java/lang/Object) + (list.size watch_events)) + (list.enumeration watch_events))] + (async.future + (java/nio/file/Path::register [watcher + watch_events'] + (|> path ffi.as_string [] java/io/File::new (java/io/File::toPath [])))))) + + (the (default_poll watcher) + (-> java/nio/file/WatchService + (IO (Try (List [Concern //.Path])))) + (loop (again [output (is (List [Concern //.Path]) + (list))]) + (do (try.with io.monad) + [?key (java/nio/file/WatchService::poll [] watcher)] + (when ?key + {.#Some key} + (do [! io.monad] + [valid? (java/nio/file/WatchKey::reset [] key)] + (if (ffi.of_boolean valid?) + (do ! + [.let [path (|> key + (java/nio/file/WatchKey::watchable []) + (as java/nio/file/Path) + (java/nio/file/Path::toString []) + ffi.of_string + (as //.Path))] + the_concern (..default_key_concern key)] + (again {.#Item [the_concern path] + output})) + (again output))) + + {.#None} + (in output))))) + + (the (watch_events concern) + (-> Concern + (List Watch_Event)) + (.all list#composite + (if (..creation? concern) + (list (as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_CREATE))) + (list)) + (if (..modification? concern) + (list (as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_MODIFY))) + (list)) + (if (..deletion? concern) + (list (as Watch_Event (java/nio/file/StandardWatchEventKinds::ENTRY_DELETE))) + (list)) + )) + + (the .public default + (IO (Try (Watcher Async))) + (do (try.with io.monad) + [watcher (|> (java/nio/file/FileSystems::getDefault []) + (java/nio/file/FileSystem::newWatchService [])) + .let [tracker (stm.var (is (Dictionary //.Path [Concern java/nio/file/WatchKey]) + (dictionary.empty text.hash))) + + stop (is (-> //.Path (Async (Try Concern))) + (function (_ path) + (do [! async.monad] + [@tracker (stm.commit! (stm.read tracker))] + (when (dictionary.value path @tracker) + {try.#Success [the_concern key]} + (do ! + [_ (async.future + (java/nio/file/WatchKey::cancel [] key)) + _ (stm.commit! (stm.update (dictionary.lacks path) tracker))] + (in {try.#Success the_concern})) + + failure + (in (exception.except ..not_being_watched [path]))))))]] + (in (is (Watcher Async) + (implementation + (the (start the_concern path) + (do async.monad + [?concern (stop path)] + (do (try.with async.monad) + [key (..default_start (..watch_events (..and (try.else ..none ?concern) + the_concern)) + watcher + path)] + (do async.monad + [_ (stm.commit! (stm.update (dictionary.has path [the_concern key]) tracker))] + (in {try.#Success []}))))) + (the (concern path) + (do async.monad + [@tracker (stm.commit! (stm.read tracker))] + (when (dictionary.value path @tracker) + {try.#Success [it key]} + (in {try.#Success it}) + + failure + (in (exception.except ..not_being_watched [path]))))) + (the stop stop) + (the (poll _) + (async.future (..default_poll watcher))) + ))))) + ) + + ... else + (these)) diff --git a/stdlib/source/library/lux/world/net/http/client.lux b/stdlib/source/library/lux/world/net/http/client.lux index b7e8b69e3a..7747653bb9 100644 --- a/stdlib/source/library/lux/world/net/http/client.lux +++ b/stdlib/source/library/lux/world/net/http/client.lux @@ -94,225 +94,223 @@ {//.#Options} "OPTIONS" {//.#Trace} "TRACE"))) -(expansion.let [ (these (ffi.import java/lang/String - "[1]::[0]") - - (ffi.import java/lang/AutoCloseable - "[1]::[0]" - (close [] "io" "try" void)) - - (ffi.import java/io/InputStream - "[1]::[0]") - - (ffi.import java/io/OutputStream - "[1]::[0]" - (flush [] "io" "try" void) - (write [[byte]] "io" "try" void)) - - (ffi.import java/net/URLConnection - "[1]::[0]" - (setDoOutput [boolean] "io" "try" void) - (setRequestProperty [java/lang/String java/lang/String] "io" "try" void) - (getInputStream [] "io" "try" java/io/InputStream) - (getOutputStream [] "io" "try" java/io/OutputStream) - (getHeaderFieldKey [int] "io" "try" "?" java/lang/String) - (getHeaderField [int] "io" "try" "?" java/lang/String)) - - (ffi.import java/net/HttpURLConnection - "[1]::[0]" - (setRequestMethod [java/lang/String] "io" "try" void) - (getResponseCode [] "io" "try" int)) - - (ffi.import java/net/URL - "[1]::[0]" - (new [java/lang/String]) - (openConnection [] "io" "try" java/net/URLConnection)) - - (ffi.import java/io/BufferedInputStream - "[1]::[0]" - (new [java/io/InputStream]) - (read [[byte] int int] "io" "try" int)) - - (the (default_body input) - (-> java/io/BufferedInputStream - (//.Body IO)) - (|>> (maybe#each (|>> [true])) - (maybe.else [false ..default_buffer_size]) - (pipe.when - [_ 0] - (do (try.with io.monad) - [_ (java/lang/AutoCloseable::close [] input)] - (in ..empty_body)) - - [partial? buffer_size] - (let [buffer (binary.empty buffer_size)] - (if partial? - (loop (again [so_far +0]) - (do [! (try.with io.monad)] - [.let [remaining (i.- so_far (.int buffer_size))] - bytes_read (of ! each (|>> ffi.of_int) - (java/io/BufferedInputStream::read [buffer (ffi.as_int so_far) (ffi.as_int remaining)] input))] - (when bytes_read - -1 (do ! - [_ (java/lang/AutoCloseable::close [] input)] - (in [(.nat so_far) buffer])) - +0 (again so_far) - _ (if (i.= remaining bytes_read) - (in [buffer_size buffer]) - (again (i.+ bytes_read so_far)))))) - (loop (again [so_far +0 - output (of binary.monoid identity)]) - (do [! (try.with io.monad)] - [.let [remaining (i.- so_far (.int buffer_size))] - bytes_read (of ! each (|>> ffi.of_int) - (java/io/BufferedInputStream::read [buffer (ffi.as_int so_far) (ffi.as_int remaining)] input))] - (when bytes_read - -1 (do ! - [_ (java/lang/AutoCloseable::close [] input)] - (when so_far - +0 (in (..body_of output)) - _ (|> buffer - (binary.slice 0 (.nat so_far)) - (of try.functor each - (|>> (of binary.monoid composite output) - ..body_of)) - (of io.monad in)))) - +0 (again so_far output) - _ (if (i.= remaining bytes_read) - (again +0 - (of binary.monoid composite output buffer)) - (again (i.+ bytes_read so_far) - output)))))))))) - - (the (default_headers connection) - (-> java/net/HttpURLConnection - (IO (Try Headers))) - (loop (again [index +0 - headers header.empty]) - (do [! (try.with io.monad)] - [?name (java/net/URLConnection::getHeaderFieldKey [(ffi.as_int index)] connection)] - (when ?name - {.#Some name} - (do ! - [?value (java/net/URLConnection::getHeaderField [(ffi.as_int index)] connection)] - (again (++ index) - (dictionary.has (ffi.of_string name) (maybe.else "" (maybe#each (|>> ffi.of_string) ?value)) headers))) - - {.#None} - (in headers))))) - - (the .public default - (Client IO) - (implementation - (the (request method url headers data) - (is (IO (Try (Response IO))) - (do [! (try.with io.monad)] - [connection (|> url ffi.as_string [] java/net/URL::new (java/net/URL::openConnection [])) - .let [connection (as java/net/HttpURLConnection connection)] - _ (java/net/HttpURLConnection::setRequestMethod [(ffi.as_string (..method_name method))] connection) - _ (monad.each ! (function (_ [name value]) - (java/net/URLConnection::setRequestProperty [(ffi.as_string name) (ffi.as_string value)] connection)) - (dictionary.entries headers)) - _ (when data - {.#Some data} - (do ! - [_ (java/net/URLConnection::setDoOutput [true] connection) - stream (java/net/URLConnection::getOutputStream [] connection) - _ (java/io/OutputStream::write [data] stream) - _ (java/io/OutputStream::flush [] stream) - _ (java/lang/AutoCloseable::close [] stream)] - (in [])) - - {.#None} - (in [])) - status (java/net/HttpURLConnection::getResponseCode [] connection) - headers (..default_headers connection) - input (|> connection - (java/net/URLConnection::getInputStream []) - (of ! each (|>> [] java/io/BufferedInputStream::new)))] - (in [(.nat (ffi.of_int status)) - [//.#headers headers - //.#body (..default_body input)]])))))))] - (for .old (these ) - .jvm (these ) - .python (these (ffi.import Dict - "[1]#[0]" - (setdefault [Text Text] Text)) - - (ffi.import (dict [] Dict)) - - (the headers_input - (-> Headers - Dict) - (|>> dictionary.entries - (list#mix (function (_ [header value] it) - (exec - (Dict#setdefault [header value] it) - it)) - (..dict [])))) - - (the headers_output - (-> (Array (Array Text)) - Headers) - (|>> (array.mix (function (_ _ header,value it) - (dictionary.has (array.item 0 header,value) - (array.item 1 header,value) - it)) - header.empty))) - - (ffi.import http/client/HTTPResponse - "[1]#[0]" - (status Nat) - (read ["?" Nat] "io" "try" Binary) - (getheaders [] "io" "try" (Array (Array Text)))) - - (ffi.import urllib/request/Request - "[1]#[0]") - - (ffi.import urllib/request - "[1]#[0]" - ("static" Request [URL "?" Binary Dict "?" Any Bit Text] urllib/request/Request) - ("static" urlopen [urllib/request/Request] "io" "try" http/client/HTTPResponse)) - - (the (default_body input) - (-> http/client/HTTPResponse - (//.Body IO)) - (let [! (try.with io.monad)] - (|>> (maybe#each (|>> [true])) - (maybe.else [false ..default_buffer_size]) - (pipe.when - [_ 0] - (of ! in ..empty_body) - - [partial? buffer_size] +(for .jvm (these (ffi.import java/lang/String + "[1]::[0]") + + (ffi.import java/lang/AutoCloseable + "[1]::[0]" + (close [] "io" "try" void)) + + (ffi.import java/io/InputStream + "[1]::[0]") + + (ffi.import java/io/OutputStream + "[1]::[0]" + (flush [] "io" "try" void) + (write [[byte]] "io" "try" void)) + + (ffi.import java/net/URLConnection + "[1]::[0]" + (setDoOutput [boolean] "io" "try" void) + (setRequestProperty [java/lang/String java/lang/String] "io" "try" void) + (getInputStream [] "io" "try" java/io/InputStream) + (getOutputStream [] "io" "try" java/io/OutputStream) + (getHeaderFieldKey [int] "io" "try" "?" java/lang/String) + (getHeaderField [int] "io" "try" "?" java/lang/String)) + + (ffi.import java/net/HttpURLConnection + "[1]::[0]" + (setRequestMethod [java/lang/String] "io" "try" void) + (getResponseCode [] "io" "try" int)) + + (ffi.import java/net/URL + "[1]::[0]" + (new [java/lang/String]) + (openConnection [] "io" "try" java/net/URLConnection)) + + (ffi.import java/io/BufferedInputStream + "[1]::[0]" + (new [java/io/InputStream]) + (read [[byte] int int] "io" "try" int)) + + (the (default_body input) + (-> java/io/BufferedInputStream + (//.Body IO)) + (|>> (maybe#each (|>> [true])) + (maybe.else [false ..default_buffer_size]) + (pipe.when + [_ 0] + (do (try.with io.monad) + [_ (java/lang/AutoCloseable::close [] input)] + (in ..empty_body)) + + [partial? buffer_size] + (let [buffer (binary.empty buffer_size)] + (if partial? + (loop (again [so_far +0]) + (do [! (try.with io.monad)] + [.let [remaining (i.- so_far (.int buffer_size))] + bytes_read (of ! each (|>> ffi.of_int) + (java/io/BufferedInputStream::read [buffer (ffi.as_int so_far) (ffi.as_int remaining)] input))] + (when bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close [] input)] + (in [(.nat so_far) buffer])) + +0 (again so_far) + _ (if (i.= remaining bytes_read) + (in [buffer_size buffer]) + (again (i.+ bytes_read so_far)))))) + (loop (again [so_far +0 + output (of binary.monoid identity)]) + (do [! (try.with io.monad)] + [.let [remaining (i.- so_far (.int buffer_size))] + bytes_read (of ! each (|>> ffi.of_int) + (java/io/BufferedInputStream::read [buffer (ffi.as_int so_far) (ffi.as_int remaining)] input))] + (when bytes_read + -1 (do ! + [_ (java/lang/AutoCloseable::close [] input)] + (when so_far + +0 (in (..body_of output)) + _ (|> buffer + (binary.slice 0 (.nat so_far)) + (of try.functor each + (|>> (of binary.monoid composite output) + ..body_of)) + (of io.monad in)))) + +0 (again so_far output) + _ (if (i.= remaining bytes_read) + (again +0 + (of binary.monoid composite output buffer)) + (again (i.+ bytes_read so_far) + output)))))))))) + + (the (default_headers connection) + (-> java/net/HttpURLConnection + (IO (Try Headers))) + (loop (again [index +0 + headers header.empty]) + (do [! (try.with io.monad)] + [?name (java/net/URLConnection::getHeaderFieldKey [(ffi.as_int index)] connection)] + (when ?name + {.#Some name} + (do ! + [?value (java/net/URLConnection::getHeaderField [(ffi.as_int index)] connection)] + (again (++ index) + (dictionary.has (ffi.of_string name) (maybe.else "" (maybe#each (|>> ffi.of_string) ?value)) headers))) + + {.#None} + (in headers))))) + + (the .public default + (Client IO) + (implementation + (the (request method url headers data) + (is (IO (Try (Response IO))) + (do [! (try.with io.monad)] + [connection (|> url ffi.as_string [] java/net/URL::new (java/net/URL::openConnection [])) + .let [connection (as java/net/HttpURLConnection connection)] + _ (java/net/HttpURLConnection::setRequestMethod [(ffi.as_string (..method_name method))] connection) + _ (monad.each ! (function (_ [name value]) + (java/net/URLConnection::setRequestProperty [(ffi.as_string name) (ffi.as_string value)] connection)) + (dictionary.entries headers)) + _ (when data + {.#Some data} (do ! - [it (http/client/HTTPResponse#read [(if partial? - {.#Some buffer_size} - {.#None})] - input)] - (in (body_of it))))))) - - (the .public default - (Client IO) - (implementation - (the (request method url headers data) - (is (IO (Try (Response IO))) - (do [! (try.with io.monad)] - [.let [request (urllib/request#Request [url - data - (..headers_input headers) - {.#None} - false - (..method_name method)])] - response (urllib/request#urlopen [request]) - .let [status (http/client/HTTPResponse#status response)] - headers (of ! each ..headers_output - (http/client/HTTPResponse#getheaders [] response))] - (in [status - [//.#headers headers - //.#body (..default_body response)]]))) - )))) - (these))) + [_ (java/net/URLConnection::setDoOutput [true] connection) + stream (java/net/URLConnection::getOutputStream [] connection) + _ (java/io/OutputStream::write [data] stream) + _ (java/io/OutputStream::flush [] stream) + _ (java/lang/AutoCloseable::close [] stream)] + (in [])) + + {.#None} + (in [])) + status (java/net/HttpURLConnection::getResponseCode [] connection) + headers (..default_headers connection) + input (|> connection + (java/net/URLConnection::getInputStream []) + (of ! each (|>> [] java/io/BufferedInputStream::new)))] + (in [(.nat (ffi.of_int status)) + [//.#headers headers + //.#body (..default_body input)]]))))))) + .python (these (ffi.import Dict + "[1]#[0]" + (setdefault [Text Text] Text)) + + (ffi.import (dict [] Dict)) + + (the headers_input + (-> Headers + Dict) + (|>> dictionary.entries + (list#mix (function (_ [header value] it) + (exec + (Dict#setdefault [header value] it) + it)) + (..dict [])))) + + (the headers_output + (-> (Array (Array Text)) + Headers) + (|>> (array.mix (function (_ _ header,value it) + (dictionary.has (array.item 0 header,value) + (array.item 1 header,value) + it)) + header.empty))) + + (ffi.import http/client/HTTPResponse + "[1]#[0]" + (status Nat) + (read ["?" Nat] "io" "try" Binary) + (getheaders [] "io" "try" (Array (Array Text)))) + + (ffi.import urllib/request/Request + "[1]#[0]") + + (ffi.import urllib/request + "[1]#[0]" + ("static" Request [URL "?" Binary Dict "?" Any Bit Text] urllib/request/Request) + ("static" urlopen [urllib/request/Request] "io" "try" http/client/HTTPResponse)) + + (the (default_body input) + (-> http/client/HTTPResponse + (//.Body IO)) + (let [! (try.with io.monad)] + (|>> (maybe#each (|>> [true])) + (maybe.else [false ..default_buffer_size]) + (pipe.when + [_ 0] + (of ! in ..empty_body) + + [partial? buffer_size] + (do ! + [it (http/client/HTTPResponse#read [(if partial? + {.#Some buffer_size} + {.#None})] + input)] + (in (body_of it))))))) + + (the .public default + (Client IO) + (implementation + (the (request method url headers data) + (is (IO (Try (Response IO))) + (do [! (try.with io.monad)] + [.let [request (urllib/request#Request [url + data + (..headers_input headers) + {.#None} + false + (..method_name method)])] + response (urllib/request#urlopen [request]) + .let [status (http/client/HTTPResponse#status response)] + headers (of ! each ..headers_output + (http/client/HTTPResponse#getheaders [] response))] + (in [status + [//.#headers headers + //.#body (..default_body response)]]))) + )))) + (these)) (the .public (async client) (-> (Client IO) diff --git a/stdlib/source/library/lux/world/shell.lux b/stdlib/source/library/lux/world/shell.lux index 6b048cc10f..3a9d11fab2 100644 --- a/stdlib/source/library/lux/world/shell.lux +++ b/stdlib/source/library/lux/world/shell.lux @@ -179,150 +179,151 @@ (text.enclosed' text.double_quote)))] (..policy safe_command safe_argument))) -(expansion.let [ (these (import java/lang/String - "[1]::[0]" - (toLowerCase [] java/lang/String)) - - (the (jvm::arguments_array arguments) - (-> (List Argument) (Array java/lang/String)) - (product.right - (list#mix (function (_ argument [idx output]) - [(++ idx) (ffi.write! idx - (ffi.as_string argument) - output)]) - [0 (ffi.array java/lang/String (list.size arguments))] - arguments))) - - (import (java/util/Map k v) - "[1]::[0]" - (put [k v] "?" v)) - - (the (jvm::load_environment input target) - (-> Environment - (java/util/Map java/lang/String java/lang/String) - (java/util/Map java/lang/String java/lang/String)) - (list#mix (function (_ [key value] target') - (exec - (java/util/Map::put [(as java/lang/String key) - (as java/lang/String value)] - target') - target')) - target - (dictionary.entries input))) - - (import java/io/Reader - "[1]::[0]") - - (import java/io/BufferedReader - "[1]::[0]" - (new [java/io/Reader]) - (readLine [] "io" "try" "?" java/lang/String)) - - (import java/io/InputStream - "[1]::[0]") - - (import java/io/InputStreamReader - "[1]::[0]" - (new [java/io/InputStream])) - - (import java/io/OutputStream - "[1]::[0]" - (write [[byte]] "io" "try" void)) - - (import java/lang/Process - "[1]::[0]" - (getInputStream [] "io" "try" java/io/InputStream) - (getErrorStream [] "io" "try" java/io/InputStream) - (getOutputStream [] "io" "try" java/io/OutputStream) - (destroy [] "io" "try" void) - (waitFor [] "io" "try" int)) - - (exception.the .public no_more_output) - - (the (default_process process) - (-> java/lang/Process (IO (Try (Process IO)))) - (do [! (try.with io.monad)] - [jvm_input (java/lang/Process::getInputStream [] process) - jvm_error (java/lang/Process::getErrorStream [] process) - jvm_output (java/lang/Process::getOutputStream [] process) - .let [jvm_input (|> jvm_input - [] java/io/InputStreamReader::new - [] java/io/BufferedReader::new) - jvm_error (|> jvm_error - [] java/io/InputStreamReader::new - [] java/io/BufferedReader::new)]] - (in (is (Process IO) - (`` (implementation - (,, (template.with [ ] - [(the ( _) - (do ! - [output (java/io/BufferedReader::readLine [] )] - (when output - {.#Some output} - (in (ffi.of_string output)) - - {.#None} - (of io.monad in (exception.except ..no_more_output [])))))] - - [read jvm_input] - [fail jvm_error] - )) - (the (write message) - (java/io/OutputStream::write [(of utf8.format injection message)] - jvm_output)) - (,, (template.with [ ] - [(the ( _) - (|> process - ))] - - [destroy (java/lang/Process::destroy [])] - [await (<| (of ! each (|>> ffi.of_int)) - (java/lang/Process::waitFor []))] - )))))))) - - (import java/io/File - "[1]::[0]" - (new [java/lang/String])) - - (import java/lang/ProcessBuilder - "[1]::[0]" - (new [[java/lang/String]]) - (environment [] "try" (java/util/Map java/lang/String java/lang/String)) - (directory [java/io/File] java/lang/ProcessBuilder) - (start [] "io" "try" java/lang/Process)) - - (import java/lang/System - "[1]::[0]" - ("static" getProperty [java/lang/String] "io" "try" java/lang/String)) - - ... https://en.wikipedia.org/wiki/Code_injection#Shell_injection - (the windows? - (IO (Try Bit)) - (of (try.with io.monad) each - (|>> (java/lang/String::toLowerCase []) - ffi.of_string - (text.starts_with? "windows")) - (java/lang/System::getProperty [(ffi.as_string "os.name")]))) - - (the .public default - (Shell IO) - (implementation - (the (execute [environment working_directory the_command arguments]) - (do [! (try.with io.monad)] - [.let [builder (|> (list.partial the_command arguments) - ..jvm::arguments_array - [] java/lang/ProcessBuilder::new - (java/lang/ProcessBuilder::directory [(java/io/File::new [(ffi.as_string working_directory)])]))] - _ (|> builder - (java/lang/ProcessBuilder::environment []) - (of try.functor each (..jvm::load_environment environment)) - (of io.monad in)) - process (java/lang/ProcessBuilder::start [] builder)] - (..default_process process))))) - )] - (for .old (these ) - .jvm (these ) - (these))) +(for .jvm + (these (import java/lang/String + "[1]::[0]" + (toLowerCase [] java/lang/String)) + + (the (jvm::arguments_array arguments) + (-> (List Argument) (Array java/lang/String)) + (product.right + (list#mix (function (_ argument [idx output]) + [(++ idx) (ffi.write! idx + (ffi.as_string argument) + output)]) + [0 (ffi.array java/lang/String (list.size arguments))] + arguments))) + + (import (java/util/Map k v) + "[1]::[0]" + (put [k v] "?" v)) + + (the (jvm::load_environment input target) + (-> Environment + (java/util/Map java/lang/String java/lang/String) + (java/util/Map java/lang/String java/lang/String)) + (list#mix (function (_ [key value] target') + (exec + (java/util/Map::put [(as java/lang/String key) + (as java/lang/String value)] + target') + target')) + target + (dictionary.entries input))) + + (import java/io/Reader + "[1]::[0]") + + (import java/io/BufferedReader + "[1]::[0]" + (new [java/io/Reader]) + (readLine [] "io" "try" "?" java/lang/String)) + + (import java/io/InputStream + "[1]::[0]") + + (import java/io/InputStreamReader + "[1]::[0]" + (new [java/io/InputStream])) + + (import java/io/OutputStream + "[1]::[0]" + (write [[byte]] "io" "try" void)) + + (import java/lang/Process + "[1]::[0]" + (getInputStream [] "io" "try" java/io/InputStream) + (getErrorStream [] "io" "try" java/io/InputStream) + (getOutputStream [] "io" "try" java/io/OutputStream) + (destroy [] "io" "try" void) + (waitFor [] "io" "try" int)) + + (exception.the .public no_more_output) + + (the (default_process process) + (-> java/lang/Process (IO (Try (Process IO)))) + (do [! (try.with io.monad)] + [jvm_input (java/lang/Process::getInputStream [] process) + jvm_error (java/lang/Process::getErrorStream [] process) + jvm_output (java/lang/Process::getOutputStream [] process) + .let [jvm_input (|> jvm_input + [] java/io/InputStreamReader::new + [] java/io/BufferedReader::new) + jvm_error (|> jvm_error + [] java/io/InputStreamReader::new + [] java/io/BufferedReader::new)]] + (in (is (Process IO) + (`` (implementation + (,, (template.with [ ] + [(the ( _) + (do ! + [output (java/io/BufferedReader::readLine [] )] + (when output + {.#Some output} + (in (ffi.of_string output)) + + {.#None} + (of io.monad in (exception.except ..no_more_output [])))))] + + [read jvm_input] + [fail jvm_error] + )) + (the (write message) + (java/io/OutputStream::write [(of utf8.format injection message)] + jvm_output)) + (,, (template.with [ ] + [(the ( _) + (|> process + ))] + + [destroy (java/lang/Process::destroy [])] + [await (<| (of ! each (|>> ffi.of_int)) + (java/lang/Process::waitFor []))] + )))))))) + + (import java/io/File + "[1]::[0]" + (new [java/lang/String])) + + (import java/lang/ProcessBuilder + "[1]::[0]" + (new [[java/lang/String]]) + (environment [] "try" (java/util/Map java/lang/String java/lang/String)) + (directory [java/io/File] java/lang/ProcessBuilder) + (start [] "io" "try" java/lang/Process)) + + (import java/lang/System + "[1]::[0]" + ("static" getProperty [java/lang/String] "io" "try" java/lang/String)) + + ... https://en.wikipedia.org/wiki/Code_injection#Shell_injection + (the windows? + (IO (Try Bit)) + (of (try.with io.monad) each + (|>> (java/lang/String::toLowerCase []) + ffi.of_string + (text.starts_with? "windows")) + (java/lang/System::getProperty [(ffi.as_string "os.name")]))) + + (the .public default + (Shell IO) + (implementation + (the (execute [environment working_directory the_command arguments]) + (do [! (try.with io.monad)] + [.let [builder (|> (list.partial the_command arguments) + ..jvm::arguments_array + [] java/lang/ProcessBuilder::new + (java/lang/ProcessBuilder::directory [(java/io/File::new [(ffi.as_string working_directory)])]))] + _ (|> builder + (java/lang/ProcessBuilder::environment []) + (of try.functor each (..jvm::load_environment environment)) + (of io.monad in)) + process (java/lang/ProcessBuilder::start [] builder)] + (..default_process process))))) + ) + + ... else + (these)) (every .public (Mock s) (Interface diff --git a/stdlib/source/library/lux/world/time/instant.lux b/stdlib/source/library/lux/world/time/instant.lux index f6a3e93314..574e012ec1 100644 --- a/stdlib/source/library/lux/world/time/instant.lux +++ b/stdlib/source/library/lux/world/time/instant.lux @@ -200,8 +200,7 @@ (the .public now (IO Instant) - (io (..of_millis (for .old ("jvm invokestatic:java.lang.System:currentTimeMillis:") - .jvm (|> (.jvm_member_invoke_static# [] "java.lang.System" "currentTimeMillis" []) + (io (..of_millis (for .jvm (|> (.jvm_member_invoke_static# [] "java.lang.System" "currentTimeMillis" []) .jvm_object_cast# (is (Nominal "java.lang.Long")) (as Int)) diff --git a/stdlib/source/projection/lux/meta/type.lux b/stdlib/source/projection/lux/meta/type.lux index ca7b5e7b9e..7d0f64fd11 100644 --- a/stdlib/source/projection/lux/meta/type.lux +++ b/stdlib/source/projection/lux/meta/type.lux @@ -3,7 +3,7 @@ (.require [library - [lux (.except function local parameter variant tuple) + [lux (.except function local variant tuple) [abstract ["[0]" monad (.only do)]] [control diff --git a/stdlib/source/projection/lux/program.lux b/stdlib/source/projection/lux/program.lux index e92d7c9a91..9867de8c65 100644 --- a/stdlib/source/projection/lux/program.lux +++ b/stdlib/source/projection/lux/program.lux @@ -3,7 +3,7 @@ (.require [library - [lux (.except parameter) + [lux (.except) [abstract [monad (.only do)]] [control diff --git a/stdlib/source/test/lux.lux b/stdlib/source/test/lux.lux index 66de885382..0898090c1a 100644 --- a/stdlib/source/test/lux.lux +++ b/stdlib/source/test/lux.lux @@ -459,9 +459,8 @@ (same? (is Any macro)))) (_.coverage [/.macro] (same? expected (..identity_macro expected))) - (,, (for .old (,, (these)) - (_.coverage [/.Source] - (..found_crosshair?)))) + (_.coverage [/.Source] + (..found_crosshair?)) ... (_.coverage [/.require] ... (`` (expansion.let [ (.in_module# "library/lux" library/lux.refer) ... (static.random code.text (random.lower_cased 1)) @@ -844,8 +843,7 @@ (/.for "fake host" dummy expected)) (n.= expected - (/.for .old expected - .jvm expected + (/.for .jvm expected .js expected .python expected .lua expected @@ -1055,8 +1053,7 @@ (the possible_targets (Set Target) (<| (set.of_list text.hash) - (list .old - .js + (list .js .jvm .lua .python @@ -1164,91 +1161,90 @@ true) )) -(for .old (these) - (these (the for_bindings|test - (syntax.macro (_ lux_state - [fn/0 .local - var/0 .local - let/0 .local - - fn/1 .local - var/1 .local - let/1 .local - - fn/2 .local - var/2 .local - let/2 .local - - let/3 .local]) - (in (list (code.bit (when (its .#scopes lux_state) - (list.partial scope/2 _) - (let [locals/2 (its .#locals scope/2) - expected_locals/2 (set.of_list text.hash (list fn/2 var/2 let/2 - let/3)) - actual_locals/2 (|> locals/2 - (its .#mappings) - (list#each product.left) - (set.of_list text.hash)) - - correct_locals! - (and (n.= 4 (its .#counter locals/2)) - (set#= expected_locals/2 - actual_locals/2)) - - captured/2 (its .#captured scope/2) - - local? (is (-> Ref Bit) - (function (_ ref) - (when ref - {.#Local _} true - {.#Captured _} false))) - captured? (is (-> Ref Bit) - (|>> local? not)) - binding? (is (-> (-> Ref Bit) Text Bit) - (function (_ is? name) - (|> captured/2 - (its .#mappings) - (property.value name) - (maybe#each (|>> product.right is?)) - (maybe.else false)))) - - correct_closure! - (and (n.= 6 (its .#counter captured/2)) - (binding? local? fn/1) - (binding? local? var/1) - (binding? local? let/1) - (binding? captured? fn/0) - (binding? captured? var/0) - (binding? captured? let/0))] - (and correct_locals! - correct_closure!)) - - _ - false)))))) - - (the for_bindings - Test - ((<| (template.with_locals [fn/0 var/0 let/0 - fn/1 var/1 let/1 - fn/2 var/2 let/2 - let/3]) - (function (fn/0 var/0)) (let [let/0 123]) - (function (fn/1 var/1)) (let [let/1 456]) - (function (fn/2 var/2)) (let [let/2 789]) - (let [let/3 [fn/0 var/0 let/0 - fn/1 var/1 let/1 - fn/2 var/2 let/2] - verdict (for_bindings|test fn/0 var/0 let/0 - fn/1 var/1 let/1 - fn/2 var/2 let/2 - let/3)] - (_.coverage [/.Ref - /.#Local /.#Captured - - /.Bindings - /.#counter /.#mappings] - verdict))) - 0 1 2)))) +(the for_bindings|test + (syntax.macro (_ lux_state + [fn/0 .local + var/0 .local + let/0 .local + + fn/1 .local + var/1 .local + let/1 .local + + fn/2 .local + var/2 .local + let/2 .local + + let/3 .local]) + (in (list (code.bit (when (its .#scopes lux_state) + (list.partial scope/2 _) + (let [locals/2 (its .#locals scope/2) + expected_locals/2 (set.of_list text.hash (list fn/2 var/2 let/2 + let/3)) + actual_locals/2 (|> locals/2 + (its .#mappings) + (list#each product.left) + (set.of_list text.hash)) + + correct_locals! + (and (n.= 4 (its .#counter locals/2)) + (set#= expected_locals/2 + actual_locals/2)) + + captured/2 (its .#captured scope/2) + + local? (is (-> Ref Bit) + (function (_ ref) + (when ref + {.#Local _} true + {.#Captured _} false))) + captured? (is (-> Ref Bit) + (|>> local? not)) + binding? (is (-> (-> Ref Bit) Text Bit) + (function (_ is? name) + (|> captured/2 + (its .#mappings) + (property.value name) + (maybe#each (|>> product.right is?)) + (maybe.else false)))) + + correct_closure! + (and (n.= 6 (its .#counter captured/2)) + (binding? local? fn/1) + (binding? local? var/1) + (binding? local? let/1) + (binding? captured? fn/0) + (binding? captured? var/0) + (binding? captured? let/0))] + (and correct_locals! + correct_closure!)) + + _ + false)))))) + +(the for_bindings + Test + ((<| (template.with_locals [fn/0 var/0 let/0 + fn/1 var/1 let/1 + fn/2 var/2 let/2 + let/3]) + (function (fn/0 var/0)) (let [let/0 123]) + (function (fn/1 var/1)) (let [let/1 456]) + (function (fn/2 var/2)) (let [let/2 789]) + (let [let/3 [fn/0 var/0 let/0 + fn/1 var/1 let/1 + fn/2 var/2 let/2] + verdict (for_bindings|test fn/0 var/0 let/0 + fn/1 var/1 let/1 + fn/2 var/2 let/2 + let/3)] + (_.coverage [/.Ref + /.#Local /.#Captured + + /.Bindings + /.#counter /.#mappings] + verdict))) + 0 1 2)) (the test|lux Test @@ -1276,8 +1272,7 @@ ..for_export ..for_complex ..for_extension - (,, (for .old (,, (these)) - (,, (these ..for_bindings)))) + ..for_bindings )))) (the test @@ -1326,8 +1321,7 @@ (the _ (program args - (let [times (for .old 100 - .jvm 100 + (let [times (for .jvm 100 .js 10 .python 1 .lua 1 diff --git a/stdlib/source/test/lux/abstract/equivalence.lux b/stdlib/source/test/lux/abstract/equivalence.lux index ca4fa7ba6c..2579b3bf67 100644 --- a/stdlib/source/test/lux/abstract/equivalence.lux +++ b/stdlib/source/test/lux/abstract/equivalence.lux @@ -102,17 +102,15 @@ random_recursive ))) -(for .old (these) - (these (the equivalence - (/.Equivalence ..Record) - (\\polytypic.equivalence ..Record)))) +(the equivalence + (/.Equivalence ..Record) + (\\polytypic.equivalence ..Record)) (the \\polytypic Test (<| (_.covering \\polytypic._) (_.for [\\polytypic.equivalence] - (for .old (_.test "PLACEHOLDER" true) - (..spec ..equivalence ..random))))) + (..spec ..equivalence ..random)))) (the .public test Test diff --git a/stdlib/source/test/lux/abstract/functor.lux b/stdlib/source/test/lux/abstract/functor.lux index a3a515144e..6f0d51408a 100644 --- a/stdlib/source/test/lux/abstract/functor.lux +++ b/stdlib/source/test/lux/abstract/functor.lux @@ -34,73 +34,71 @@ of)) right) -(for .old (these) - (these (the pure_functor - (<| (is (Functor pure.Pure)) - (is (Functor //.Variable)) - (all either - pure.functor - (\\polytypic.functor pure.Pure) - /.variable - ))) - - (the maybe_functor - (<| (is (Functor .Maybe)) - (is (Functor (//.Sum (//.Constant Any) //.Variable))) - (all either - maybe.functor - (\\polytypic.functor .Maybe) - (/.sum /.constant - /.variable) - ))) - - (the writer_functor - (<| (is (Functor (writer.Writer Text))) - (is (Functor (//.Product (//.Constant Text) //.Variable))) - (all either - writer.functor - (\\polytypic.functor writer.Writer) - (/.product /.constant - /.variable) - ))) - - (the scope_functor - (<| (is (for_any (_ scope) - (Functor (scope.Scope scope)))) - (is (for_any (_ scope) - (Functor (/.Function scope //.Variable)))) - (all either - scope.functor - (\\polytypic.functor scope.Scope) - (/.function /.variable) - ))) - - (the state_functor - (for_any (_ state) - (Functor (state.State state))) - (is (for_any (_ state) - (Functor (/.Function state (//.Product (//.Constant state) //.Variable)))) - (all either - state.functor - (\\polytypic.functor state.State) - (/.function (/.product /.constant - /.variable)) - ))) - - (the list_functor - (Functor .List) - (is (Functor (//.Recursive (for_any (_ self) - (//.Sum (//.Constant Any) - (//.Product //.Variable self))))) - (all either - list.functor - (\\polytypic.functor .List) - (/.recursive - (function (_ it) - (/.sum /.constant - (/.product /.variable it)))) - ))) - )) +(the pure_functor + (<| (is (Functor pure.Pure)) + (is (Functor //.Variable)) + (all either + pure.functor + (\\polytypic.functor pure.Pure) + /.variable + ))) + +(the maybe_functor + (<| (is (Functor .Maybe)) + (is (Functor (//.Sum (//.Constant Any) //.Variable))) + (all either + maybe.functor + (\\polytypic.functor .Maybe) + (/.sum /.constant + /.variable) + ))) + +(the writer_functor + (<| (is (Functor (writer.Writer Text))) + (is (Functor (//.Product (//.Constant Text) //.Variable))) + (all either + writer.functor + (\\polytypic.functor writer.Writer) + (/.product /.constant + /.variable) + ))) + +(the scope_functor + (<| (is (for_any (_ scope) + (Functor (scope.Scope scope)))) + (is (for_any (_ scope) + (Functor (/.Function scope //.Variable)))) + (all either + scope.functor + (\\polytypic.functor scope.Scope) + (/.function /.variable) + ))) + +(the state_functor + (for_any (_ state) + (Functor (state.State state))) + (is (for_any (_ state) + (Functor (/.Function state (//.Product (//.Constant state) //.Variable)))) + (all either + state.functor + (\\polytypic.functor state.State) + (/.function (/.product /.constant + /.variable)) + ))) + +(the list_functor + (Functor .List) + (is (Functor (//.Recursive (for_any (_ self) + (//.Sum (//.Constant Any) + (//.Product //.Variable self))))) + (all either + list.functor + (\\polytypic.functor .List) + (/.recursive + (function (_ it) + (/.sum /.constant + (/.product /.variable it)))) + ))) (the \\polytypic Test diff --git a/stdlib/source/test/lux/data/format/json.lux b/stdlib/source/test/lux/data/format/json.lux index ce552ed170..5558b2601f 100644 --- a/stdlib/source/test/lux/data/format/json.lux +++ b/stdlib/source/test/lux/data/format/json.lux @@ -234,21 +234,19 @@ (random.maybe random.safe_dec) ..gen_recursive))) -(for .old (these) - (these (the equivalence - (Equivalence Arbitrary) - (\\polytypic/equivalence.equivalence Arbitrary)) +(the equivalence + (Equivalence Arbitrary) + (\\polytypic/equivalence.equivalence Arbitrary)) - (the format - (Format JSON Arbitrary) - (\\polytypic.format Arbitrary)))) +(the format + (Format JSON Arbitrary) + (\\polytypic.format Arbitrary)) (the \\polytypic Test (<| (_.covering \\polytypic._) (_.for [\\polytypic.format] - (for .old (_.test "PLACEHOLDER" true) - (formatT.spec ..equivalence ..format ..gen_arbitrary))))) + (formatT.spec ..equivalence ..format ..gen_arbitrary)))) (the .public random (Random /.JSON) diff --git a/stdlib/source/test/lux/ffi.old.lux b/stdlib/source/test/lux/ffi.old.lux deleted file mode 100644 index ca4e787216..0000000000 --- a/stdlib/source/test/lux/ffi.old.lux +++ /dev/null @@ -1,254 +0,0 @@ -... This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. -... If a copy of the MPL was not distributed with this file, You can obtain one at https://mozilla.org/MPL/2.0/. - -(.require - [library - [lux (.except) - [abstract - [equivalence (.only Equivalence)] - [monad (.only do)]] - [control - ["[0]" pipe]] - [data - ["[0]" text (.use "[1]#[0]" equivalence)]] - [math - ["[0]" random] - [number - ["n" nat] - ["i" int] - ["d" dec]]] - [meta - ["[0]" type (.use "[1]#[0]" equivalence)] - [macro - ["[0]" template] - ["[0]" expansion]]] - [test - ["_" property (.only Test)]]]] - [\\library - ["[0]" /]]) - -(/.import java/lang/Object - "[1]::[0]") - -(/.import java/lang/String - "[1]::[0]") - -(/.import java/lang/Exception - "[1]::[0]" - (new [java/lang/String])) - -(/.import (java/lang/Class a) - "[1]::[0]" - (getName [] java/lang/String)) - -(/.class "final" (TestClass A) [] - ... Fields - ("private" increase java/lang/Long) - ("private" counter java/lang/Long) - ... Methods - ("public" [] (new [increase java/lang/Long counter java/lang/Long]) [] - (exec - (:= ::increase increase) - (:= ::counter counter) - [])) - ("public" (currentC self []) java/lang/Long - ::counter) - ("public" (upC self []) void - (:= ::counter (i.+ ::increase ::counter))) - ("public" (downC self []) void - (:= ::counter (i.- ::increase ::counter)))) - -(/.import (test/lux/ffi/TestClass a) - "[1]::[0]" - (new [java/lang/Long java/lang/Long]) - (currentC [] java/lang/Long) - (upC [] void) - (downC [] void)) - -(/.interface TestInterface - ([] current [] java/lang/Long "throws" [java/lang/Exception]) - ([] up [] test/lux/ffi/TestInterface "throws" [java/lang/Exception]) - ([] down [] test/lux/ffi/TestInterface "throws" [java/lang/Exception])) - -(/.import test/lux/ffi/TestInterface - "[1]::[0]" - (current [] java/lang/Long) - (up [] java/lang/Long) - (down [] java/lang/Long)) - -(the (test_object increase counter) - (-> Int Int test/lux/ffi/TestInterface) - (/.object [] [test/lux/ffi/TestInterface] - [] - (test/lux/ffi/TestInterface - [] (current self []) - java/lang/Long - counter) - (test/lux/ffi/TestInterface - [] (up self []) - test/lux/ffi/TestInterface - (test_object increase (i.+ increase counter))) - (test/lux/ffi/TestInterface - [] (down self []) - test/lux/ffi/TestInterface - (test_object increase (i.- increase counter))))) - -(the conversions - Test - (do [! random.monad] - [long random.int - int (of ! each (|>> /.long_to_int) random.int) - char (of ! each (|>> /.long_to_int /.int_to_char) random.int) - double (|> random.dec - (random.only (|>> d.not_a_number? not))) - float (|> random.dec - (random.only (|>> d.not_a_number? not)) - (of ! each (|>> /.double_to_float)))] - (`` (all _.and - (,, (template.with [<=> ] - [(_.coverage [ ] - (or (|> (<=> )) - (let [capped (|> )] - (|> capped (<=> capped)))))] - - [i.= long /.long_to_byte /.byte_to_long] - [i.= long /.long_to_short /.short_to_long] - [i.= long /.long_to_int /.int_to_long] - [i.= long /.long_to_float /.float_to_long] - [i.= long /.long_to_double /.double_to_long] - - [d.= double /.double_to_float /.float_to_double] - [d.= double /.double_to_int /.int_to_double] - )) - (,, (template.with [ ] - [(_.coverage [] - (or (|> int (i.= (/.int_to_long int))) - (let [capped (|> int )] - (|> capped /.long_to_int (i.= capped)))))] - - [/.int_to_byte /.byte_to_long] - [/.int_to_short /.short_to_long] - [/.int_to_char /.char_to_long] - )) - (,, (template.with [ ] - [(_.coverage [ ] - (or (|> /.float_to_double (d.= (/.float_to_double ))) - (let [capped (|> )] - (|> capped /.float_to_double (d.= (/.float_to_double capped))))))] - - [float /.float_to_int /.int_to_float] - )) - (,, (template.with [ ] - [(_.coverage [] - (or (|> char (i.= (|> char /.char_to_int /.int_to_long))) - (let [capped (|> char )] - (|> capped /.long_to_int /.int_to_char (i.= capped)))))] - - [/.char_to_byte /.byte_to_long] - [/.char_to_short /.short_to_long] - )) - (_.coverage [/.char_to_long] - (expansion.let [ /.int_to_char - /.char_to_long] - (`` (or (|> int (i.= (/.int_to_long int))) - (let [capped (|> int )] - (|> capped /.long_to_int (i.= capped))))))) - (_.coverage [/.char_to_int] - (expansion.let [ /.int_to_char - /.char_to_int] - (`` (or (|> int /.int_to_long (i.= (/.int_to_long int))) - (let [capped (|> int )] - (|> capped /.int_to_long (i.= (/.int_to_long capped)))))))) - )))) - -(the arrays - Test - (do [! random.monad] - [size (|> random.nat (of ! each (|>> (n.% 100) (n.max 1)))) - idx (|> random.nat (of ! each (n.% size))) - value random.int] - (all _.and - (_.coverage [/.array /.length] - (n.= size (/.length (/.array java/lang/Long size)))) - (_.coverage [/.write! /.read!] - (|> (/.array java/lang/Long size) - (/.write! idx value) - (/.read! idx) - (i.= value))) - ))) - -(the null - Test - (do random.monad - [sample (random.ascii 1)] - (all _.and - (_.coverage [/.null /.null?] - (and (/.null? (/.null)) - (not (/.null? sample)))) - (_.coverage [/.???] - (and (|> (is (Maybe java/lang/Object) (/.??? (/.null))) - (pipe.when - {.#None} - true - - _ - false)) - (|> (is (Maybe java/lang/Object) (/.??? sample)) - (pipe.when - {.#Some _} - true - - _ - false)))) - (_.coverage [/.!!!] - (and (/.null? (/.!!! (/.??? (/.null)))) - (not (/.null? (/.!!! (/.??? sample)))))) - ))) - -(the miscellaneous - Test - (do random.monad - [sample (random.ascii 1) - counter random.int - increase random.int] - (all _.and - (_.coverage [/.as] - (and (when (/.as java/lang/String sample) {.#Some _} true {.#None} false) - (when (/.as java/lang/Long sample) {.#Some _} false {.#None} true) - (when (/.as java/lang/Object sample) {.#Some _} true {.#None} false) - (when (/.as java/lang/Object (/.null)) {.#Some _} false {.#None} true))) - (_.coverage [/.synchronized] - (/.synchronized sample true)) - (_.coverage [/.class_for /.import] - (|> (/.class_for java/lang/Class) - java/lang/Class::getName - (text#= "java.lang.Class"))) - (_.coverage [/.class /.to] - (|> (/.to (test/lux/ffi/TestClass::new increase counter) - (test/lux/ffi/TestClass::upC) - (test/lux/ffi/TestClass::upC) - (test/lux/ffi/TestClass::downC)) - test/lux/ffi/TestClass::currentC - (i.= (i.+ increase counter)))) - (_.coverage [/.interface /.object] - (|> (..test_object increase counter) - test/lux/ffi/TestInterface::up - test/lux/ffi/TestInterface::up - test/lux/ffi/TestInterface::down - test/lux/ffi/TestInterface::current - (i.= (i.+ increase counter)))) - (_.coverage [/.type] - (and (type#= (Nominal "java.lang.Char") - (/.type java/lang/Char)) - (type#= (Nominal "java.util.List" [(Nominal "java.lang.Byte")]) - (/.type (java/util/List java/lang/Byte))))) - ))) - -(the .public test - (<| (_.covering /._) - (all _.and - ..conversions - ..arrays - ..null - ..miscellaneous - ))) diff --git a/stdlib/source/test/lux/math/number/dec.lux b/stdlib/source/test/lux/math/number/dec.lux index 41ad5a41d5..37d064840a 100644 --- a/stdlib/source/test/lux/math/number/dec.lux +++ b/stdlib/source/test/lux/math/number/dec.lux @@ -147,13 +147,14 @@ (arithmeticT.spec /.equivalence /.arithmetic random.safe_dec)) ))) -(expansion.let [ (these (ffi.import java/lang/Double - "[1]::[0]" - ("static" doubleToRawLongBits [double] long) - ("static" longBitsToDouble [long] double)))] - (for .old (these ) - .jvm (these ) - (these))) +(for .jvm + (ffi.import java/lang/Double + "[1]::[0]" + ("static" doubleToRawLongBits [double] long) + ("static" longBitsToDouble [long] double)) + + ... else + (these)) (the margin_of_error +0.0000001) @@ -274,46 +275,47 @@ (/.= (/.+ left (/.% left right)) (/.mod left right)))))) )) - (expansion.let [ (all _.and - (let [test (is (-> Dec Bit) - (function (_ value) - (n.= (.nat (ffi.of_long (java/lang/Double::doubleToRawLongBits [(ffi.as_double value)]))) - (/.bits value))))] - (do random.monad - [sample random.dec] - (_.coverage [/.bits] - (and (test sample) - (test /.biggest) - (test /.smallest) - (test /.not_a_number) - (test /.positive_infinity) - (test /.negative_infinity))))) - (do random.monad - [sample random.i64] - (_.coverage [/.of_bits] - (let [expected (ffi.of_double (java/lang/Double::longBitsToDouble [(ffi.as_long sample)])) - actual (/.of_bits sample)] - (or (/.= expected actual) - (and (/.not_a_number? expected) - (/.not_a_number? actual)))))) - )] - (for .old - .jvm - (let [test (is (-> Dec Bit) - (function (_ expected) - (let [actual (|> expected /.bits /.of_bits)] - (or (/.= expected actual) - (and (/.not_a_number? expected) - (/.not_a_number? actual))))))] - (do random.monad - [sample random.dec] - (_.coverage [/.bits /.of_bits] - (and (test sample) - (test /.biggest) - (test /.smallest) - (test /.not_a_number) - (test /.positive_infinity) - (test /.negative_infinity))))))) + (for .jvm + (all _.and + (let [test (is (-> Dec Bit) + (function (_ value) + (n.= (.nat (ffi.of_long (java/lang/Double::doubleToRawLongBits [(ffi.as_double value)]))) + (/.bits value))))] + (do random.monad + [sample random.dec] + (_.coverage [/.bits] + (and (test sample) + (test /.biggest) + (test /.smallest) + (test /.not_a_number) + (test /.positive_infinity) + (test /.negative_infinity))))) + (do random.monad + [sample random.i64] + (_.coverage [/.of_bits] + (let [expected (ffi.of_double (java/lang/Double::longBitsToDouble [(ffi.as_long sample)])) + actual (/.of_bits sample)] + (or (/.= expected actual) + (and (/.not_a_number? expected) + (/.not_a_number? actual)))))) + ) + + ... else + (let [test (is (-> Dec Bit) + (function (_ expected) + (let [actual (|> expected /.bits /.of_bits)] + (or (/.= expected actual) + (and (/.not_a_number? expected) + (/.not_a_number? actual))))))] + (do random.monad + [sample random.dec] + (_.coverage [/.bits /.of_bits] + (and (test sample) + (test /.biggest) + (test /.smallest) + (test /.not_a_number) + (test /.positive_infinity) + (test /.negative_infinity)))))) (do random.monad [expected random.safe_dec] (_.coverage [/.opposite] diff --git a/stdlib/source/test/lux/meta.lux b/stdlib/source/test/lux/meta.lux index 0d754e71fc..e205b6e1de 100644 --- a/stdlib/source/test/lux/meta.lux +++ b/stdlib/source/test/lux/meta.lux @@ -367,8 +367,7 @@ /type.test /macro.test /static.test - (,, (for .old (,, (these)) - (,, (these /extension.test)))) + /extension.test /global.test /compiler.test /label.test diff --git a/stdlib/source/test/lux/meta/compiler.lux b/stdlib/source/test/lux/meta/compiler.lux index f7af81bac4..7f381d2c2c 100644 --- a/stdlib/source/test/lux/meta/compiler.lux +++ b/stdlib/source/test/lux/meta/compiler.lux @@ -20,8 +20,7 @@ ["[1]/[0]" lux]] ["[1][0]" meta] ["[1][0]" target - (.,, (.for .old (.,, (.these ["[1]/[0]" jvm])) - .jvm (.,, (.these ["[1]/[0]" jvm])) + (.,, (.for .jvm (.,, (.these ["[1]/[0]" jvm])) .js (.,, (.these ["[1]/[0]" js])) .lua (.,, (.these ["[1]/[0]" lua])) .python (.,, (.these ["[1]/[0]" python])) diff --git a/stdlib/source/test/lux/meta/compiler/target/jvm.lux b/stdlib/source/test/lux/meta/compiler/target/jvm.lux index 9b45af0fd9..a2a7a1dd7d 100644 --- a/stdlib/source/test/lux/meta/compiler/target/jvm.lux +++ b/stdlib/source/test/lux/meta/compiler/target/jvm.lux @@ -329,11 +329,7 @@ (do [! random.monad] [expected (of ! each (i64.and (i64.mask )) random.nat)] (<| (_.lifted ) - (..bytecode (for .old - (|>> (as ) ("jvm leq" expected)) - - .jvm - (|>> (as ) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (as java/lang/Long expected)))))) + (..bytecode (|>> (as ) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (as java/lang/Long expected))))) (do /.monad [_ ( (|> expected .int try.trusted))] ))))] @@ -347,13 +343,9 @@ (template.macro (_ ) [(is (-> ) (function (_ parameter subject) - (for .old - ( subject parameter) - - .jvm - (.jvm_object_cast# - ( (.jvm_object_cast# parameter) - (.jvm_object_cast# subject))))))]))] + (.jvm_object_cast# + ( (.jvm_object_cast# parameter) + (.jvm_object_cast# subject)))))]))] [int/2 java/lang/Integer] [long/2 java/lang/Long] @@ -365,23 +357,15 @@ (template.macro (_ ) [(is (-> java/lang/Integer java/lang/Long java/lang/Long) (function (_ parameter subject) - (for .old - ( subject parameter) - - .jvm - (.jvm_object_cast# - ( (.jvm_object_cast# parameter) - (.jvm_object_cast# subject))))))])) + (.jvm_object_cast# + ( (.jvm_object_cast# parameter) + (.jvm_object_cast# subject)))))])) (the int Test (let [int (is (-> java/lang/Integer (Bytecode Any) (Random Bit)) (function (_ expected bytecode) - (<| (..bytecode (for .old - (|>> (as java/lang/Integer) ("jvm ieq" expected)) - - .jvm - (|>> (as java/lang/Integer) .jvm_object_cast# (.jvm_int_=# (.jvm_object_cast# expected))))) + (<| (..bytecode (|>> (as java/lang/Integer) .jvm_object_cast# (.jvm_int_=# (.jvm_object_cast# expected)))) (do /.monad [_ bytecode] ..$Integer::wrap)))) @@ -458,11 +442,7 @@ Test (let [long (is (-> java/lang/Long (Bytecode Any) (Random Bit)) (function (_ expected bytecode) - (<| (..bytecode (for .old - (|>> (as Int) (i.= expected)) - - .jvm - (|>> (as java/lang/Long) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# expected))))) + (<| (..bytecode (|>> (as java/lang/Long) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# expected)))) (do /.monad [_ bytecode] ..$Long::wrap)))) @@ -531,11 +511,7 @@ ... (i.< (as Int expected) (as Int actual)) (as java/lang/Long -1))]] - (<| (..bytecode (for .old - (|>> (as Int) (i.= expected)) - - .jvm - (|>> (as java/lang/Long) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# expected))))) + (<| (..bytecode (|>> (as java/lang/Long) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# expected)))) (do /.monad [_ (..$Long::literal actual) _ (..$Long::literal expected) @@ -557,17 +533,10 @@ Test (let [float (is (-> java/lang/Float (Bytecode Any) (Random Bit)) (function (_ expected bytecode) - (<| (..bytecode (for .old - (function (_ actual) - (or (|> actual (as java/lang/Float) ("jvm feq" expected)) - (and (d.not_a_number? (as Dec (ffi.float_to_double expected))) - (d.not_a_number? (as Dec (ffi.float_to_double (as java/lang/Float actual))))))) - - .jvm - (function (_ actual) - (or (|> actual (as java/lang/Float) .jvm_object_cast# (.jvm_float_=# (.jvm_object_cast# expected))) - (and (d.not_a_number? (as Dec (ffi.float_to_double expected))) - (d.not_a_number? (as Dec (ffi.float_to_double (as java/lang/Float actual))))))))) + (<| (..bytecode (function (_ actual) + (or (|> actual (as java/lang/Float) .jvm_object_cast# (.jvm_float_=# (.jvm_object_cast# expected))) + (and (d.not_a_number? (as Dec (ffi.float_to_double expected))) + (d.not_a_number? (as Dec (ffi.float_to_double (as java/lang/Float actual)))))))) (do /.monad [_ bytecode] ..$Float::wrap)))) @@ -619,11 +588,7 @@ ..$Float::random)] expected valid_float actual valid_float - .let [expected_result (if (for .old - ("jvm feq" expected actual) - - .jvm - (.jvm_float_=# (.jvm_object_cast# expected) (.jvm_object_cast# actual))) + .let [expected_result (if (.jvm_float_=# (.jvm_object_cast# expected) (.jvm_object_cast# actual)) +0 (if (standard expected actual) +1 @@ -637,11 +602,7 @@ ..$Long::wrap))))) comparison_standard (is (-> java/lang/Float java/lang/Float Bit) (function (_ expected actual) - (for .old - ("jvm fgt" actual expected) - - .jvm - (.jvm_float_<# (.jvm_object_cast# actual) (.jvm_object_cast# expected))))) + (.jvm_float_<# (.jvm_object_cast# actual) (.jvm_object_cast# expected)))) comparison (all _.and (_.lifted "FCMPL" (comparison /.fcmpl comparison_standard)) (_.lifted "FCMPG" (comparison /.fcmpg comparison_standard)))] @@ -658,17 +619,10 @@ Test (let [double (is (-> java/lang/Double (Bytecode Any) (Random Bit)) (function (_ expected bytecode) - (<| (..bytecode (for .old - (function (_ actual) - (or (|> actual (as java/lang/Double) ("jvm deq" expected)) - (and (d.not_a_number? (as Dec expected)) - (d.not_a_number? (as Dec actual))))) - - .jvm - (function (_ actual) - (or (|> actual (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# expected))) - (and (d.not_a_number? (as Dec expected)) - (d.not_a_number? (as Dec actual))))))) + (<| (..bytecode (function (_ actual) + (or (|> actual (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# expected))) + (and (d.not_a_number? (as Dec expected)) + (d.not_a_number? (as Dec actual)))))) (do /.monad [_ bytecode] ..$Double::wrap)))) @@ -713,11 +667,7 @@ (do random.monad [expected ..valid_double actual ..valid_double - .let [expected_result (if (for .old - ("jvm deq" expected actual) - - .jvm - (.jvm_double_=# (.jvm_object_cast# expected) (.jvm_object_cast# actual))) + .let [expected_result (if (.jvm_double_=# (.jvm_object_cast# expected) (.jvm_object_cast# actual)) +0 (if (standard expected actual) +1 @@ -732,11 +682,7 @@ ... https://docs.oracle.com/javase/specs/jvms/se7/html/jvms-6.html#jvms-6.5.dcmp_op comparison_standard (is (-> java/lang/Double java/lang/Double Bit) (function (_ expected actual) - (for .old - ("jvm dgt" actual expected) - - .jvm - (.jvm_double_<# (.jvm_object_cast# actual) (.jvm_object_cast# expected))))) + (.jvm_double_<# (.jvm_object_cast# actual) (.jvm_object_cast# expected)))) comparison (all _.and (_.lifted "DCMPL" (comparison /.dcmpl comparison_standard)) (_.lifted "DCMPG" (comparison /.dcmpg comparison_standard)))] @@ -814,11 +760,7 @@ (do random.monad [expected (random.only (|>> (as Dec) d.not_a_number? not) ..$Double::random)]) - (..bytecode (for .old - (|>> (as java/lang/Double) ("jvm deq" expected)) - - .jvm - (|>> (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# expected))))) + (..bytecode (|>> (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# expected)))) (do /.monad [_ (/.double (as Dec expected))] (/.invokestatic ..$Double "valueOf" (/type.method [(list) (list /type.double) ..$Double (list)])))) @@ -835,11 +777,7 @@ (do random.monad [expected (random.only (|>> (as Dec) d.not_a_number? not) ..$Double::random)]) - (..bytecode (for .old - (|>> (as java/lang/Double) ("jvm deq" expected)) - - .jvm - (|>> (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# expected))))) + (..bytecode (|>> (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# expected)))) (do /.monad [_ (/.new ..$Double) _ /.dup @@ -863,12 +801,8 @@ part0 ..$Long::random part1 ..$Long::random .let [expected (is java/lang/Long - (for .old - ("jvm ladd" part0 part1) - - .jvm - (.jvm_object_cast# - (.jvm_long_+# (.jvm_object_cast# part0) (.jvm_object_cast# part1))))) + (.jvm_object_cast# + (.jvm_long_+# (.jvm_object_cast# part0) (.jvm_object_cast# part1)))) $Self (/type.class class_name (list)) class_field "class_field" object_field "object_field" @@ -983,59 +917,31 @@ (_.context "byte" (array (/.newarray /instruction.t_byte) $Byte::random $Byte::literal [/.bastore /.baload $Byte::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Byte) ffi.byte_to_long ("jvm leq" (ffi.byte_to_long expected))) - - .jvm - (|>> (as java/lang/Byte) ffi.byte_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.byte_to_long (as java/lang/Byte expected))))))))) + (|>> (as java/lang/Byte) ffi.byte_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.byte_to_long (as java/lang/Byte expected)))))))) (_.context "short" (array (/.newarray /instruction.t_short) $Short::random $Short::literal [/.sastore /.saload $Short::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Short) ffi.short_to_long ("jvm leq" (ffi.short_to_long expected))) - - .jvm - (|>> (as java/lang/Short) ffi.short_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.short_to_long (as java/lang/Short expected))))))))) + (|>> (as java/lang/Short) ffi.short_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.short_to_long (as java/lang/Short expected)))))))) (_.context "int" (array (/.newarray /instruction.t_int) $Integer::random $Integer::literal [/.iastore /.iaload $Integer::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Integer) ("jvm ieq" (as java/lang/Integer expected))) - - .jvm - (|>> (as java/lang/Integer) .jvm_object_cast# (.jvm_int_=# (.jvm_object_cast# (as java/lang/Integer expected)))))))) + (|>> (as java/lang/Integer) .jvm_object_cast# (.jvm_int_=# (.jvm_object_cast# (as java/lang/Integer expected))))))) (_.context "long" (array (/.newarray /instruction.t_long) $Long::random $Long::literal [/.lastore /.laload $Long::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Long) ("jvm leq" expected)) - - .jvm - (|>> (as java/lang/Long) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (as java/lang/Long expected)))))))) + (|>> (as java/lang/Long) .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (as java/lang/Long expected))))))) (_.context "float" (array (/.newarray /instruction.t_float) ..valid_float $Float::literal [/.fastore /.faload $Float::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Float) ("jvm feq" expected)) - - .jvm - (|>> (as java/lang/Float) .jvm_object_cast# (.jvm_float_=# (.jvm_object_cast# (as java/lang/Float expected)))))))) + (|>> (as java/lang/Float) .jvm_object_cast# (.jvm_float_=# (.jvm_object_cast# (as java/lang/Float expected))))))) (_.context "double" (array (/.newarray /instruction.t_double) ..valid_double $Double::literal [/.dastore /.daload $Double::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Double) ("jvm deq" expected)) - - .jvm - (|>> (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# (as java/lang/Double expected)))))))) + (|>> (as java/lang/Double) .jvm_object_cast# (.jvm_double_=# (.jvm_object_cast# (as java/lang/Double expected))))))) (_.context "char" (array (/.newarray /instruction.t_char) $Character::random $Character::literal [/.castore /.caload $Character::wrap] (function (_ expected) - (for .old - (|>> (as java/lang/Character) ("jvm ceq" expected)) - - .jvm - (|>> (as java/lang/Character) .jvm_object_cast# (.jvm_char_=# (.jvm_object_cast# (as java/lang/Character expected)))))))) + (|>> (as java/lang/Character) .jvm_object_cast# (.jvm_char_=# (.jvm_object_cast# (as java/lang/Character expected))))))) (_.context "object" (array (/.anewarray ..$String) $String::random $String::literal [/.aastore /.aaload /.nop] (function (_ expected) (|>> (as Text) (text#= (as Text expected)))))) @@ -1067,11 +973,7 @@ (template.macro (_ ) [(is (-> Any Bit) (function (_ expected) - (for .old - (|>> (as ) ( expected)) - - .jvm - (|>> (as ) .jvm_object_cast# ( (.jvm_object_cast# (as expected)))))))])) + (|>> (as ) .jvm_object_cast# ( (.jvm_object_cast# (as expected))))))])) (the conversion Test @@ -1098,20 +1000,12 @@ (_.lifted "I2D" (conversion ..$Integer::primitive ..$Double::primitive /.i2d (|>> ffi.int_to_double) double::=)) (_.lifted "I2B" (conversion ..$Integer::primitive ..$Byte::primitive /.i2b (|>> ffi.int_to_byte) (function (_ expected) - (for .old - (|>> (as java/lang/Byte) ffi.byte_to_long ("jvm leq" (ffi.byte_to_long expected))) - - .jvm - (|>> (as java/lang/Byte) ffi.byte_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.byte_to_long (as java/lang/Byte expected))))))))) + (|>> (as java/lang/Byte) ffi.byte_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.byte_to_long (as java/lang/Byte expected)))))))) (_.lifted "I2C" (conversion ..$Integer::primitive ..$Character::primitive /.i2c (|>> ffi.int_to_char) (!::= java/lang/Character "jvm ceq" .jvm_char_=#))) (_.lifted "I2S" (conversion ..$Integer::primitive ..$Short::primitive /.i2s (|>> ffi.int_to_short) (function (_ expected) - (for .old - (|>> (as java/lang/Short) ffi.short_to_long ("jvm leq" (ffi.short_to_long expected))) - - .jvm - (|>> (as java/lang/Short) ffi.short_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.short_to_long (as java/lang/Short expected))))))))))) + (|>> (as java/lang/Short) ffi.short_to_long .jvm_object_cast# (.jvm_long_=# (.jvm_object_cast# (ffi.short_to_long (as java/lang/Short expected)))))))))) (<| (_.context "long") (all _.and (_.lifted "L2I" (conversion ..$Long::primitive ..$Integer::primitive /.l2i (|>> ffi.long_to_int) int::=)) @@ -1183,15 +1077,9 @@ increment (of ! each (|>> (n.% 100) /unsigned.u1 try.trusted) random.nat) .let [expected (is java/lang/Long - (for .old - ("jvm ladd" - (ffi.byte_to_long base) - (.int (/unsigned.value increment))) - - .jvm - (.jvm_object_cast# - (.jvm_long_+# (.jvm_object_cast# (ffi.byte_to_long base)) - (.jvm_object_cast# (as java/lang/Long (/unsigned.value increment)))))))]] + (.jvm_object_cast# + (.jvm_long_+# (.jvm_object_cast# (ffi.byte_to_long base)) + (.jvm_object_cast# (as java/lang/Long (/unsigned.value increment))))))]] (..bytecode (|>> (as Int) (i.= (as Int expected))) (do /.monad [_ (..$Byte::literal base) @@ -1445,11 +1333,7 @@ expected ..$Integer::random actual (|> ..$Integer::random (random.only (|>> ((!::= java/lang/Integer "jvm ieq" .jvm_int_=#) expected) not))) - .let [[lesser greater] (if (for .old - ("jvm ilt" expected actual) - - .jvm - (.jvm_int_<# (.jvm_object_cast# actual) (.jvm_object_cast# expected))) + .let [[lesser greater] (if (.jvm_int_<# (.jvm_object_cast# actual) (.jvm_object_cast# expected)) [expected actual] [actual expected]) int_comparison (all _.and diff --git a/stdlib/source/test/lux/meta/extension.lux b/stdlib/source/test/lux/meta/extension.lux index 815784633e..763c7d1f96 100644 --- a/stdlib/source/test/lux/meta/extension.lux +++ b/stdlib/source/test/lux/meta/extension.lux @@ -67,138 +67,133 @@ [\\library ["[0]" / (.only analysis synthesis translation declaration)]]))) +... Analysis +(the my_analysis + Analysis + (analysis (_ phase archive [pass_through .any]) + (phase archive pass_through))) + +... Synthesis +(the my_synthesis|synthesis + Synthesis + (synthesis (_ phase archive [pass_through .any]) + (phase archive pass_through))) + +(the my_synthesis + Analysis + (analysis (_ phase archive [parameters (<>.some .any)]) + (let [! phase.monad] + (|> parameters + (monad.each ! (phase archive)) + (of ! each (|>> (is (List analysis.Term)) + {analysis.#Extension (symbol ..my_synthesis|synthesis)} + [location.dummy] + (is analysis.Term))))))) + ... Translation -(for .old - (these) - - (these - ... Analysis - (the my_analysis - Analysis - (analysis (_ phase archive [pass_through .any]) - (phase archive pass_through))) - - ... Synthesis - (the my_synthesis|synthesis - Synthesis - (synthesis (_ phase archive [pass_through .any]) - (phase archive pass_through))) - - (the my_synthesis - Analysis - (analysis (_ phase archive [parameters (<>.some .any)]) - (let [! phase.monad] - (|> parameters - (monad.each ! (phase archive)) - (of ! each (|>> (is (List analysis.Term)) - {analysis.#Extension (symbol ..my_synthesis|synthesis)} - [location.dummy] - (is analysis.Term))))))) - - ... Translation - (the my_translation|translation - Translation - (translation (_ phase archive [pass_through .any]) - (phase archive pass_through))) - - (the my_translation|synthesis - Synthesis - (synthesis (_ phase archive [parameters (<>.some .any)]) - (let [! phase.monad] - (|> parameters - (monad.each ! (phase archive)) - (of ! each (|>> {synthesis.#Extension (symbol ..my_translation|translation)} - [location.dummy] - (is synthesis.Term))))))) - - (the my_translation - Analysis - (analysis (_ phase archive [parameters (<>.some .any)]) - (let [! phase.monad] - (|> parameters - (monad.each ! (phase archive)) - (of ! each (|>> (is (List analysis.Term)) - {analysis.#Extension (symbol ..my_translation|synthesis)} - [location.dummy] - (is analysis.Term))))))) - - (the dummy_translation|translation - Translation - (translation (_ phase archive []) - (let [[_ self] (symbol ..dummy_translation)] - (of phase.monad in - (for .jvm (jvm.string self) - .js (js.string self) - .python (python.unicode self) - .lua (lua.string self) - .ruby (ruby.string self) - .php (php.string self) - .scheme (scheme.string self)))))) - - (the dummy_translation|synthesis - Synthesis - (synthesis (_ phase archive []) - (of phase.monad in (is synthesis.Term - [location.dummy {synthesis.#Extension (symbol ..dummy_translation|translation) (list)}])))) - - (the dummy_translation - Analysis - (analysis (_ phase archive []) - (of phase.monad in (is analysis.Term - [location.dummy {analysis.#Extension (symbol ..dummy_translation|synthesis) (list)}])))) - - ... Declaration - (the my_declaration - Declaration - (declaration (_ phase archive [expression .any]) - (do [! phase.monad] - [.let [[_ self] (symbol ..my_declaration)] - analysis_phase declaration.analysis - expressionA (<| declaration.of_analysis - (type.expecting .Any) - (analysis_phase archive expression)) - - lux (declaration.of_analysis meta.compiler_state) - - synthesis_phase declaration.synthesis - expressionS (declaration.of_synthesis - (synthesis_phase lux archive expressionA)) - - translation_phase declaration.translation - expressionG (declaration.of_translation - (translation_phase lux archive expressionS)) - - _ (declaration.of_translation - (translation.with_new_context archive unit.none - (do ! - [[module_id artifact_id] (translation.context archive) - .let [commentary (%.message "Successfully installed declaration " (%.text self) "!")] - _ (translation.save! artifact_id {.#None} - (for .jvm (let [$class (jvm/runtime.class_name [module_id artifact_id])] - (<| [$class] - (try.else (binary.empty 0)) - (try#each (binaryF.value class.injection)) - (class.class version.v6_0 class.public - (name.internal $class) - {.#None} - (name.internal "java.lang.Object") - (list) - (list) - (list) - (list)))) - .js (js.comment commentary - (js.statement (js.string commentary))) - .python (python.comment commentary - (python.statement (python.string commentary))) - .lua (lua.comment commentary - (lua.statement expressionG)) - .ruby (ruby.comment commentary - (ruby.statement (ruby.string commentary)))))] - (translation.log! commentary))))] - (in declaration.no_requirements)))) - - (..my_declaration (n.* 2 3)) - )) +(the my_translation|translation + Translation + (translation (_ phase archive [pass_through .any]) + (phase archive pass_through))) + +(the my_translation|synthesis + Synthesis + (synthesis (_ phase archive [parameters (<>.some .any)]) + (let [! phase.monad] + (|> parameters + (monad.each ! (phase archive)) + (of ! each (|>> {synthesis.#Extension (symbol ..my_translation|translation)} + [location.dummy] + (is synthesis.Term))))))) + +(the my_translation + Analysis + (analysis (_ phase archive [parameters (<>.some .any)]) + (let [! phase.monad] + (|> parameters + (monad.each ! (phase archive)) + (of ! each (|>> (is (List analysis.Term)) + {analysis.#Extension (symbol ..my_translation|synthesis)} + [location.dummy] + (is analysis.Term))))))) + +(the dummy_translation|translation + Translation + (translation (_ phase archive []) + (let [[_ self] (symbol ..dummy_translation)] + (of phase.monad in + (for .jvm (jvm.string self) + .js (js.string self) + .python (python.unicode self) + .lua (lua.string self) + .ruby (ruby.string self) + .php (php.string self) + .scheme (scheme.string self)))))) + +(the dummy_translation|synthesis + Synthesis + (synthesis (_ phase archive []) + (of phase.monad in (is synthesis.Term + [location.dummy {synthesis.#Extension (symbol ..dummy_translation|translation) (list)}])))) + +(the dummy_translation + Analysis + (analysis (_ phase archive []) + (of phase.monad in (is analysis.Term + [location.dummy {analysis.#Extension (symbol ..dummy_translation|synthesis) (list)}])))) + +... Declaration +(the my_declaration + Declaration + (declaration (_ phase archive [expression .any]) + (do [! phase.monad] + [.let [[_ self] (symbol ..my_declaration)] + analysis_phase declaration.analysis + expressionA (<| declaration.of_analysis + (type.expecting .Any) + (analysis_phase archive expression)) + + lux (declaration.of_analysis meta.compiler_state) + + synthesis_phase declaration.synthesis + expressionS (declaration.of_synthesis + (synthesis_phase lux archive expressionA)) + + translation_phase declaration.translation + expressionG (declaration.of_translation + (translation_phase lux archive expressionS)) + + _ (declaration.of_translation + (translation.with_new_context archive unit.none + (do ! + [[module_id artifact_id] (translation.context archive) + .let [commentary (%.message "Successfully installed declaration " (%.text self) "!")] + _ (translation.save! artifact_id {.#None} + (for .jvm (let [$class (jvm/runtime.class_name [module_id artifact_id])] + (<| [$class] + (try.else (binary.empty 0)) + (try#each (binaryF.value class.injection)) + (class.class version.v6_0 class.public + (name.internal $class) + {.#None} + (name.internal "java.lang.Object") + (list) + (list) + (list) + (list)))) + .js (js.comment commentary + (js.statement (js.string commentary))) + .python (python.comment commentary + (python.statement (python.string commentary))) + .lua (lua.comment commentary + (lua.statement expressionG)) + .ruby (ruby.comment commentary + (ruby.statement (ruby.string commentary)))))] + (translation.log! commentary))))] + (in declaration.no_requirements)))) + +(..my_declaration (n.* 2 3)) + (the .public test Test @@ -208,19 +203,17 @@ (`` (all _.and (,, (template.with [ ] [(_.coverage [] - (for .old false - (n.= expected - ( expected))))] + (n.= expected + ( expected)))] [/.analysis ..my_analysis] [/.synthesis ..my_synthesis])) (_.coverage [/.translation] - (for .old false - (and (n.= expected - (..my_translation expected)) - (let [[_ expected] (symbol ..dummy_translation)] - (text#= expected - (..dummy_translation)))))) + (and (n.= expected + (..my_translation expected)) + (let [[_ expected] (symbol ..dummy_translation)] + (text#= expected + (..dummy_translation))))) (_.coverage [/.declaration] true) ))))) diff --git a/stdlib/source/test/lux/meta/static.lux b/stdlib/source/test/lux/meta/static.lux index b09b984728..57b3894452 100644 --- a/stdlib/source/test/lux/meta/static.lux +++ b/stdlib/source/test/lux/meta/static.lux @@ -30,7 +30,6 @@ (the .public test Test (<| (_.covering /._) - (for .old (_.test "PLACEHOLDER" true)) (_.for [meta.eval]) (`` (all _.and (,, (template.with [ <=> <+> ] diff --git a/stdlib/source/unsafe/lux/data/binary.lux b/stdlib/source/unsafe/lux/data/binary.lux index 1dd16fe6da..c62a9572cf 100644 --- a/stdlib/source/unsafe/lux/data/binary.lux +++ b/stdlib/source/unsafe/lux/data/binary.lux @@ -20,59 +20,56 @@ ["[0]" expansion] ["[0]" template]]]]]) -(expansion.let [ (these (every .public Binary - (ffi.type [byte])) - - (ffi.import java/lang/Object - "[1]::[0]") - - (ffi.import java/lang/System - "[1]::[0]" - ("static" arraycopy [java/lang/Object int java/lang/Object int int] void)) - - (ffi.import java/util/Arrays - "[1]::[0]" - ("static" copyOfRange [[byte] int int] [byte]) - ("static" equals [[byte] [byte]] boolean)))] - (for .old (these ) - .jvm (these ) - - .js - (these (ffi.import ArrayBuffer - "[1]::[0]") - (ffi.import Uint8Array - "[1]::[0]") - - (every .public Binary - Uint8Array)) - - .python - (every .public Binary - (Nominal "bytearray")) - - .scheme - (these (every .public Binary - (Nominal "bytevector")) - - (ffi.import (make-bytevector [Nat] Binary)) - (ffi.import (bytevector-u8-ref [Binary Nat] I64)) - (ffi.import (bytevector-u8-set! [Binary Nat (I64 Any)] Any)) - (ffi.import (bytevector-length [Binary] Nat))) - - ... Default - (every .public Binary - (array.Array (I64 Any))))) - -(`` (expansion.let [ (.is .Nat size) - (ffi.array byte ) - (.is ..Binary )] +(for .jvm + (these (every .public Binary + (ffi.type [byte])) + + (ffi.import java/lang/Object + "[1]::[0]") + + (ffi.import java/lang/System + "[1]::[0]" + ("static" arraycopy [java/lang/Object int java/lang/Object int int] void)) + + (ffi.import java/util/Arrays + "[1]::[0]" + ("static" copyOfRange [[byte] int int] [byte]) + ("static" equals [[byte] [byte]] boolean))) + + .js + (these (ffi.import ArrayBuffer + "[1]::[0]") + (ffi.import Uint8Array + "[1]::[0]") + + (every .public Binary + Uint8Array)) + + .python + (every .public Binary + (Nominal "bytearray")) + + .scheme + (these (every .public Binary + (Nominal "bytevector")) + + (ffi.import (make-bytevector [Nat] Binary)) + (ffi.import (bytevector-u8-ref [Binary Nat] I64)) + (ffi.import (bytevector-u8-set! [Binary Nat (I64 Any)] Any)) + (ffi.import (bytevector-length [Binary] Nat))) + + ... Default + (every .public Binary + (array.Array (I64 Any)))) + +(`` (expansion.let [ (.is .Nat size)] (the .public empty (template.macro (empty size) [(is ..Binary - (for (,, (.static .old)) - (,, (.static .jvm)) + (for .jvm + (.is ..Binary (ffi.array byte )) - (,, (.static .js)) + .js (.|> .int .int_f64# @@ -82,39 +79,38 @@ (.js_object_new# (.js_constant# "Uint8Array")) (.as ..Binary)) - (,, (.static .python)) + .python (.|> [] (.python_apply# (.as ffi.Function (.python_constant# "bytearray"))) (.as ..Binary)) - (,, (.static .scheme)) + .scheme (..make-bytevector ) ... Default (array.empty )))])))) -(`` (expansion.let [ (.is ..Binary it) - (ffi.length )] +(`` (expansion.let [ (.is ..Binary it)] (the .public size (template.macro (size it) [(.is .Nat - (.for (,, (.static .old)) - (,, (.static .jvm)) + (.for .jvm + (ffi.length ) - (,, (.static .js)) + .js (.|> (.js_object_get# "length") (.as .Dec) .f64_int# .nat) - (,, (.static .python)) + .python (.|> (.as (array.Array (.I64 .Any))) .python_array_length#) - (,, (.static .scheme)) + .scheme (..bytevector-length []) ... Default @@ -126,20 +122,19 @@ (expansion.let [ (.static ..byte_mask) (.is ..Binary it) - (.is .Nat index) - (ffi.read! ) - (ffi.byte_to_long ) - (.|> - (.as .I64) - (.i64_and# ))] + (.is .Nat index)] (the .public bits_8 (template.macro (bits_8 index it) [(.<| (.as .I64) (.is (.I64 .Any)) - (`` (.for (,, (.static .old)) (,, ) - (,, (.static .jvm)) (,, ) + (`` (.for .jvm + (.|> + (ffi.read! ) + ffi.byte_to_long + (.as .I64) + (.i64_and# )) - (,, (.static .js)) + .js (.|> (.as (array.Array .Dec)) (.js_array_read# ) @@ -147,12 +142,12 @@ .f64_int# .i64) - (,, (.static .python)) + .python (.|> (.as (array.Array .I64)) (.python_array_read# )) - (,, (.static .scheme)) + .scheme (..bytevector-u8-ref [ ]) ... Default @@ -201,23 +196,18 @@ (expansion.let [ (hex "FF") (.is ..Binary it) (.is .Nat index) - (.is (.I64 .Any) value) - (`` (.for (,, (.static .old)) - (.as .Int ) - - (,, (.static .jvm)) - (.as (.Nominal "java.lang.Long") ) - )) - - (ffi.long_to_byte ) - (ffi.write! )] + (.is (.I64 .Any) value)] (`` (the .public has_8! (template.macro (has_8! index value it) [(.is ..Binary - (.for (,, (.static .old)) - (,, (.static .jvm)) - - (,, (.static .js)) + (.for .jvm + (ffi.write! + (|> + (.as (.Nominal "java.lang.Long")) + ffi.long_to_byte) + ) + + .js (.|> (.is ..Binary) (.as (array.Array .Dec)) @@ -229,14 +219,14 @@ .as_expected)) (.as ..Binary)) - (,, (.static .python)) + .python (.|> (.is ..Binary) (.as (array.Array (.I64 .Any))) (.python_array_write# (.|> (.i64_and# ) (.is (.I64 .Any)))) (.as ..Binary)) - (,, (.static .scheme)) + .scheme (.let [it' ] (.exec (..bytevector-u8-set! [it' ]) @@ -291,13 +281,13 @@ (..has_8! (.i64_+# 7 index) value))))]))) (expansion.let [ (.is ..Binary reference') - (.is ..Binary sample') - (java/util/Arrays::equals [ ]) - (ffi.of_boolean )] + (.is ..Binary sample')] (`` (the .public = (template.macro (= reference' sample') - [(.for (,, (.static .old)) - (,, (.static .jvm)) + [(.for .jvm + (ffi.of_boolean (,, (java/util/Arrays::equals [ ]))) + + ... else (.let [reference sample limit (..size reference)] @@ -313,36 +303,32 @@ (`` (the .public copy! (inlined (_ bytes source_offset source target_offset target) (-> .Nat .Nat ..Binary Nat ..Binary ..Binary) - (expansion.let [ (java/lang/System::arraycopy [source (ffi.as_int (.int source_offset)) - target (ffi.as_int (.int target_offset)) - (ffi.as_int (.int bytes))]) - (.exec - - target)] - (.for (,, (.static .old)) - (,, (.static .jvm)) - - ... Default - (.loop (again [index 0]) - (.if (.int_<# (.int bytes) (.int index)) - (.exec - (..has_8! (.i64_+# target_offset index) - (..bits_8 (.i64_+# source_offset index) source) - target) - (again (.i64_+# 1 index))) - target))))))) + (.for .jvm + (.exec + (java/lang/System::arraycopy [source (ffi.as_int (.int source_offset)) + target (ffi.as_int (.int target_offset)) + (ffi.as_int (.int bytes))]) + target) + + ... Default + (.loop (again [index 0]) + (.if (.int_<# (.int bytes) (.int index)) + (.exec + (..has_8! (.i64_+# target_offset index) + (..bits_8 (.i64_+# source_offset index) source) + target) + (again (.i64_+# 1 index))) + target)))))) ... TODO: Turn into a template ASAP. -(`` (expansion.let [ (java/util/Arrays::copyOfRange [binary - (ffi.as_int (.int offset)) - (ffi.as_int (.int limit))]) - (.let [limit (.i64_+# size offset)] - )] - (the .public slice - (inlined (_ offset size binary) - (-> .Nat .Nat ..Binary ..Binary) - (.for (,, (.static .old)) - (,, (.static .jvm)) - - ... Default - (..copy! size offset binary 0 (..empty size))))))) +(the .public slice + (inlined (_ offset size binary) + (-> .Nat .Nat ..Binary ..Binary) + (.for .jvm + (.let [limit (.i64_+# size offset)] + (java/util/Arrays::copyOfRange [binary + (ffi.as_int (.int offset)) + (ffi.as_int (.int limit))])) + + ... Default + (..copy! size offset binary 0 (..empty size))))) diff --git a/stdlib/source/unsafe/lux/data/collection/array.lux b/stdlib/source/unsafe/lux/data/collection/array.lux index 34e0640670..1117bbf3a5 100644 --- a/stdlib/source/unsafe/lux/data/collection/array.lux +++ b/stdlib/source/unsafe/lux/data/collection/array.lux @@ -53,20 +53,28 @@ (..Array of))) (.function (empty size) (.as_expected - (.for (,, (.static .old)) - ("jvm anewarray" "(java.lang.Object )" size) - - (,, (.static .jvm)) + (.for .jvm (|> (,, (..jvm_int size)) .jvm_array_new_object# (.is (..Array ))) - (,, (.static .js)) (.js_array_new# size) - (,, (.static .python)) (.python_array_new# size) - (,, (.static .lua)) (.lua_array_new# size) - (,, (.static .ruby)) (.ruby_array_new# size) - (,, (.static .php)) ("php array new" size) - (,, (.static .scheme)) ("scheme array new" size))))) + .js + (.js_array_new# size) + + .python + (.python_array_new# size) + + .lua + (.lua_array_new# size) + + .ruby + (.ruby_array_new# size) + + .php + ("php array new" size) + + .scheme + ("scheme array new" size))))) )]))) (`` (the .public size @@ -76,10 +84,7 @@ (.-> (..Array' read write) .Nat)) (.function (size array) - (.for (,, (.static .old)) - ("jvm arraylength" array) - - (,, (.static .jvm)) + (.for .jvm (.|> array .jvm_array_length_object# .jvm_conversion_int_to_long# @@ -87,12 +92,23 @@ (.is ) (.as .Nat)) - (,, (.static .js)) (.js_array_length# array) - (,, (.static .python)) (.python_array_length# array) - (,, (.static .lua)) (.lua_array_length# array) - (,, (.static .ruby)) (.ruby_array_length# array) - (,, (.static .php)) ("php array length" array) - (,, (.static .scheme)) ("scheme array length" array)))) + .js + (.js_array_length# array) + + .python + (.python_array_length# array) + + .lua + (.lua_array_length# array) + + .ruby + (.ruby_array_length# array) + + .php + ("php array length" array) + + .scheme + ("scheme array length" array)))) )]))) (the lacks?' @@ -109,20 +125,28 @@ (.function (lacks? index array) (.let [size (..size array)] (.if (.int_<# (.int size) (.int index)) - (.for (,, (.static .old)) - ("jvm object null?" ("jvm aaload" array index)) - - (,, (.static .jvm)) + (.for .jvm (.|> array (.jvm_array_read_object# (,, (jvm_int index))) .jvm_object_null?#) - (,, (.static .js)) (,, (lacks?' .js_array_read# .js_object_undefined?# index array)) - (,, (.static .python)) (,, (lacks?' .python_array_read# .python_object_none?# index array)) - (,, (.static .lua)) (,, (lacks?' .lua_array_read# .lua_object_nil?# index array)) - (,, (.static .ruby)) (,, (lacks?' .ruby_array_read# .ruby_object_nil?# index array)) - (,, (.static .php)) (,, (lacks?' "php array read" "php object null?" index array)) - (,, (.static .scheme)) (,, (lacks?' "scheme array read" "scheme object nil?" index array))) + .js + (,, (lacks?' .js_array_read# .js_object_undefined?# index array)) + + .python + (,, (lacks?' .python_array_read# .python_object_none?# index array)) + + .lua + (,, (lacks?' .lua_array_read# .lua_object_nil?# index array)) + + .ruby + (,, (lacks?' .ruby_array_read# .ruby_object_nil?# index array)) + + .php + (,, (lacks?' "php array read" "php object null?" index array)) + + .scheme + (,, (lacks?' "scheme array read" "scheme object nil?" index array))) .true)))) )]))) @@ -139,18 +163,26 @@ read)) (.function (item index array) (.as_expected - (.for (,, (.static .old)) - ("jvm aaload" array index) - - (,, (.static .jvm)) + (.for .jvm (.jvm_array_read_object# (,, (jvm_int index)) array) - (,, (.static .js)) (.js_array_read# index array) - (,, (.static .python)) (.python_array_read# index array) - (,, (.static .lua)) (.lua_array_read# index array) - (,, (.static .ruby)) (.ruby_array_read# index array) - (,, (.static .php)) ("php array read" index array) - (,, (.static .scheme)) ("scheme array read" index array))))) + .js + (.js_array_read# index array) + + .python + (.python_array_read# index array) + + .lua + (.lua_array_read# index array) + + .ruby + (.ruby_array_read# index array) + + .php + ("php array read" index array) + + .scheme + ("scheme array read" index array))))) )]))) (`` (the .public has! @@ -160,20 +192,28 @@ (.-> .Nat write (..Array' read write) (..Array' read write))) (.function (has! index value array) - (.for (,, (.static .old)) - ("jvm aastore" array index value) - - (,, (.static .jvm)) + (.for .jvm (.|> array (.jvm_array_write_object# (,, (jvm_int index)) value) .as_expected) - (,, (.static .js)) (.js_array_write# index (.as_expected value) array) - (,, (.static .python)) (.python_array_write# index (.as_expected value) array) - (,, (.static .lua)) (.lua_array_write# index (.as_expected value) array) - (,, (.static .ruby)) (.ruby_array_write# index (.as_expected value) array) - (,, (.static .php)) ("php array write" index (.as_expected value) array) - (,, (.static .scheme)) ("scheme array write" index (.as_expected value) array)))) + .js + (.js_array_write# index (.as_expected value) array) + + .python + (.python_array_write# index (.as_expected value) array) + + .lua + (.lua_array_write# index (.as_expected value) array) + + .ruby + (.ruby_array_write# index (.as_expected value) array) + + .php + ("php array write" index (.as_expected value) array) + + .scheme + ("scheme array write" index (.as_expected value) array)))) )]))) (`` (the .public lacks! @@ -185,18 +225,26 @@ (.function (lacks! index array) (.let [size (..size array)] (.if (.int_<# (.int size) (.int index)) - (.for (,, (.static .old)) - (..has! index (.as_expected ("jvm object null")) array) - - (,, (.static .jvm)) + (.for .jvm (..has! index (.as_expected (is (.jvm_object_null#))) array) - (,, (.static .js)) (.js_array_delete# index array) - (,, (.static .python)) (.python_array_delete# index array) - (,, (.static .lua)) (.lua_array_delete# index array) - (,, (.static .ruby)) (.ruby_array_delete# index array) - (,, (.static .php)) ("php array delete" index array) - (,, (.static .scheme)) ("scheme array delete" index array)) + .js + (.js_array_delete# index array) + + .python + (.python_array_delete# index array) + + .lua + (.lua_array_delete# index array) + + .ruby + (.ruby_array_delete# index array) + + .php + ("php array delete" index array) + + .scheme + ("scheme array delete" index array)) array)))) )])))) ) diff --git a/to_do.md b/to_do.md index e5b8318e72..ba2c4f5233 100644 --- a/to_do.md +++ b/to_do.md @@ -43,7 +43,7 @@ ## Done -0. Better syntax for the `.when#` extension. +0. [(Commit)](https://github.com/LuxLang/lux/commit/90bdd8c16e6864f36dfe44b716c48266a44549c4) Better syntax for the `.when#` extension. 0. [(Commit)](https://github.com/LuxLang/lux/commit/3b9cad357e2dcc44a42d5fa01cc380908b08970a) Re-name the `left` and `right` macros in the prelude. Also, get rid of their highlighting in `lux-mode`. 0. [(Commit)](https://github.com/LuxLang/lux/commit/6de33f8b2c7b3804be4bd5ec04fb3c4b0a3efe79) Make type-normalization no longer confuse local type parameters with globally-defined types/macros. * Remove instances of `(.except left right)`.