From 845ccb5460583df6cbf37824c2eed82729a24804 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Tue, 12 Feb 2019 18:56:18 -0400 Subject: Re-named "lux/platform" to "lux/tool". --- stdlib/project.clj | 6 +- stdlib/source/lux/cli.lux | 9 +- stdlib/source/lux/control/concurrency/atom.lux | 2 +- stdlib/source/lux/control/concurrency/process.lux | 2 +- stdlib/source/lux/control/thread.lux | 2 +- stdlib/source/lux/data/collection/array.lux | 2 +- stdlib/source/lux/data/text.lux | 2 +- stdlib/source/lux/data/text/encoding.lux | 2 +- stdlib/source/lux/platform/compiler.lux | 46 - stdlib/source/lux/platform/compiler/cli.lux | 41 - stdlib/source/lux/platform/compiler/default.lux | 6 - .../source/lux/platform/compiler/default/cache.lux | 35 - .../lux/platform/compiler/default/evaluation.lux | 36 - .../source/lux/platform/compiler/default/init.lux | 198 --- .../lux/platform/compiler/default/platform.lux | 109 -- .../lux/platform/compiler/default/syntax.lux | 561 --------- stdlib/source/lux/platform/compiler/host.lux | 18 - .../source/lux/platform/compiler/meta/archive.lux | 77 -- .../platform/compiler/meta/archive/descriptor.lux | 16 - .../platform/compiler/meta/archive/document.lux | 49 - .../lux/platform/compiler/meta/archive/key.lux | 20 - .../platform/compiler/meta/archive/signature.lux | 23 - stdlib/source/lux/platform/compiler/meta/cache.lux | 178 --- .../platform/compiler/meta/cache/dependency.lux | 53 - stdlib/source/lux/platform/compiler/meta/io.lux | 16 - .../lux/platform/compiler/meta/io/archive.lux | 74 -- .../lux/platform/compiler/meta/io/context.lux | 107 -- stdlib/source/lux/platform/compiler/name.lux | 47 - stdlib/source/lux/platform/compiler/phase.lux | 115 -- .../lux/platform/compiler/phase/analysis.lux | 349 ------ .../lux/platform/compiler/phase/analysis/case.lux | 300 ----- .../compiler/phase/analysis/case/coverage.lux | 366 ------ .../compiler/phase/analysis/expression.lux | 109 -- .../platform/compiler/phase/analysis/function.lux | 102 -- .../platform/compiler/phase/analysis/inference.lux | 259 ---- .../lux/platform/compiler/phase/analysis/macro.lux | 79 -- .../platform/compiler/phase/analysis/module.lux | 255 ---- .../platform/compiler/phase/analysis/primitive.lux | 29 - .../platform/compiler/phase/analysis/reference.lux | 79 -- .../lux/platform/compiler/phase/analysis/scope.lux | 206 ---- .../platform/compiler/phase/analysis/structure.lux | 358 ------ .../lux/platform/compiler/phase/analysis/type.lux | 52 - .../lux/platform/compiler/phase/extension.lux | 140 --- .../platform/compiler/phase/extension/analysis.lux | 18 - .../compiler/phase/extension/analysis/common.lux | 219 ---- .../compiler/phase/extension/analysis/host.jvm.lux | 1271 -------------------- .../platform/compiler/phase/extension/bundle.lux | 28 - .../compiler/phase/extension/statement.lux | 199 --- .../compiler/phase/extension/synthesis.lux | 10 - .../compiler/phase/extension/translation.lux | 10 - .../lux/platform/compiler/phase/statement.lux | 45 - .../platform/compiler/phase/statement/total.lux | 56 - .../lux/platform/compiler/phase/synthesis.lux | 468 ------- .../lux/platform/compiler/phase/synthesis/case.lux | 170 --- .../compiler/phase/synthesis/expression.lux | 86 -- .../platform/compiler/phase/synthesis/function.lux | 211 ---- .../lux/platform/compiler/phase/synthesis/loop.lux | 291 ----- .../lux/platform/compiler/phase/translation.lux | 250 ---- .../compiler/phase/translation/scheme/case.jvm.lux | 177 --- .../phase/translation/scheme/expression.jvm.lux | 59 - .../phase/translation/scheme/extension.jvm.lux | 15 - .../translation/scheme/extension/common.jvm.lux | 245 ---- .../translation/scheme/extension/host.jvm.lux | 11 - .../phase/translation/scheme/function.jvm.lux | 92 -- .../compiler/phase/translation/scheme/loop.jvm.lux | 41 - .../phase/translation/scheme/primitive.jvm.lux | 25 - .../phase/translation/scheme/reference.jvm.lux | 48 - .../phase/translation/scheme/runtime.jvm.lux | 322 ----- .../phase/translation/scheme/structure.jvm.lux | 33 - stdlib/source/lux/platform/compiler/reference.lux | 88 -- stdlib/source/lux/platform/interpreter.lux | 221 ---- stdlib/source/lux/platform/interpreter/type.lux | 203 ---- stdlib/source/lux/platform/mediator.lux | 20 - .../source/lux/platform/mediator/parallelism.lux | 169 --- stdlib/source/lux/tool/compiler.lux | 46 + stdlib/source/lux/tool/compiler/cli.lux | 41 + stdlib/source/lux/tool/compiler/default.lux | 6 + stdlib/source/lux/tool/compiler/default/cache.lux | 35 + .../lux/tool/compiler/default/evaluation.lux | 36 + stdlib/source/lux/tool/compiler/default/init.lux | 198 +++ .../source/lux/tool/compiler/default/platform.lux | 109 ++ stdlib/source/lux/tool/compiler/default/syntax.lux | 561 +++++++++ stdlib/source/lux/tool/compiler/host.lux | 18 + stdlib/source/lux/tool/compiler/meta/archive.lux | 77 ++ .../lux/tool/compiler/meta/archive/descriptor.lux | 16 + .../lux/tool/compiler/meta/archive/document.lux | 49 + .../source/lux/tool/compiler/meta/archive/key.lux | 20 + .../lux/tool/compiler/meta/archive/signature.lux | 23 + stdlib/source/lux/tool/compiler/meta/cache.lux | 178 +++ .../lux/tool/compiler/meta/cache/dependency.lux | 53 + stdlib/source/lux/tool/compiler/meta/io.lux | 16 + .../source/lux/tool/compiler/meta/io/archive.lux | 74 ++ .../source/lux/tool/compiler/meta/io/context.lux | 107 ++ stdlib/source/lux/tool/compiler/name.lux | 47 + stdlib/source/lux/tool/compiler/phase.lux | 115 ++ stdlib/source/lux/tool/compiler/phase/analysis.lux | 349 ++++++ .../lux/tool/compiler/phase/analysis/case.lux | 300 +++++ .../tool/compiler/phase/analysis/case/coverage.lux | 366 ++++++ .../tool/compiler/phase/analysis/expression.lux | 109 ++ .../lux/tool/compiler/phase/analysis/function.lux | 102 ++ .../lux/tool/compiler/phase/analysis/inference.lux | 259 ++++ .../lux/tool/compiler/phase/analysis/macro.lux | 79 ++ .../lux/tool/compiler/phase/analysis/module.lux | 255 ++++ .../lux/tool/compiler/phase/analysis/primitive.lux | 29 + .../lux/tool/compiler/phase/analysis/reference.lux | 79 ++ .../lux/tool/compiler/phase/analysis/scope.lux | 206 ++++ .../lux/tool/compiler/phase/analysis/structure.lux | 358 ++++++ .../lux/tool/compiler/phase/analysis/type.lux | 52 + .../source/lux/tool/compiler/phase/extension.lux | 140 +++ .../lux/tool/compiler/phase/extension/analysis.lux | 18 + .../compiler/phase/extension/analysis/common.lux | 219 ++++ .../compiler/phase/extension/analysis/host.jvm.lux | 1271 ++++++++++++++++++++ .../lux/tool/compiler/phase/extension/bundle.lux | 28 + .../tool/compiler/phase/extension/statement.lux | 199 +++ .../tool/compiler/phase/extension/synthesis.lux | 10 + .../tool/compiler/phase/extension/translation.lux | 10 + .../source/lux/tool/compiler/phase/statement.lux | 45 + .../lux/tool/compiler/phase/statement/total.lux | 56 + .../source/lux/tool/compiler/phase/synthesis.lux | 468 +++++++ .../lux/tool/compiler/phase/synthesis/case.lux | 170 +++ .../tool/compiler/phase/synthesis/expression.lux | 86 ++ .../lux/tool/compiler/phase/synthesis/function.lux | 211 ++++ .../lux/tool/compiler/phase/synthesis/loop.lux | 291 +++++ .../source/lux/tool/compiler/phase/translation.lux | 250 ++++ .../compiler/phase/translation/scheme/case.jvm.lux | 177 +++ .../phase/translation/scheme/expression.jvm.lux | 59 + .../phase/translation/scheme/extension.jvm.lux | 15 + .../translation/scheme/extension/common.jvm.lux | 245 ++++ .../translation/scheme/extension/host.jvm.lux | 11 + .../phase/translation/scheme/function.jvm.lux | 92 ++ .../compiler/phase/translation/scheme/loop.jvm.lux | 41 + .../phase/translation/scheme/primitive.jvm.lux | 25 + .../phase/translation/scheme/reference.jvm.lux | 48 + .../phase/translation/scheme/runtime.jvm.lux | 322 +++++ .../phase/translation/scheme/structure.jvm.lux | 33 + stdlib/source/lux/tool/compiler/reference.lux | 88 ++ stdlib/source/lux/tool/interpreter.lux | 221 ++++ stdlib/source/lux/tool/interpreter/type.lux | 203 ++++ stdlib/source/lux/tool/mediator.lux | 20 + stdlib/source/lux/tool/mediator/parallelism.lux | 169 +++ stdlib/source/lux/world/console.lux | 2 +- stdlib/source/lux/world/file.lux | 2 +- stdlib/source/lux/world/net/http/client.lux | 2 +- stdlib/source/lux/world/net/tcp.jvm.lux | 2 +- stdlib/source/lux/world/net/udp.jvm.lux | 2 +- 145 files changed, 9626 insertions(+), 9629 deletions(-) delete mode 100644 stdlib/source/lux/platform/compiler.lux delete mode 100644 stdlib/source/lux/platform/compiler/cli.lux delete mode 100644 stdlib/source/lux/platform/compiler/default.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/cache.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/evaluation.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/init.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/platform.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/syntax.lux delete mode 100644 stdlib/source/lux/platform/compiler/host.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/archive.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/archive/document.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/archive/key.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/archive/signature.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/cache.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/cache/dependency.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/io.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/io/archive.lux delete mode 100644 stdlib/source/lux/platform/compiler/meta/io/context.lux delete mode 100644 stdlib/source/lux/platform/compiler/name.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/case.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/expression.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/function.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/inference.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/macro.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/module.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/reference.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/scope.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/structure.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/type.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/analysis.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/bundle.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/statement.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/extension/translation.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/statement.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/statement/total.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/case.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/function.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/reference.lux delete mode 100644 stdlib/source/lux/platform/interpreter.lux delete mode 100644 stdlib/source/lux/platform/interpreter/type.lux delete mode 100644 stdlib/source/lux/platform/mediator.lux delete mode 100644 stdlib/source/lux/platform/mediator/parallelism.lux create mode 100644 stdlib/source/lux/tool/compiler.lux create mode 100644 stdlib/source/lux/tool/compiler/cli.lux create mode 100644 stdlib/source/lux/tool/compiler/default.lux create mode 100644 stdlib/source/lux/tool/compiler/default/cache.lux create mode 100644 stdlib/source/lux/tool/compiler/default/evaluation.lux create mode 100644 stdlib/source/lux/tool/compiler/default/init.lux create mode 100644 stdlib/source/lux/tool/compiler/default/platform.lux create mode 100644 stdlib/source/lux/tool/compiler/default/syntax.lux create mode 100644 stdlib/source/lux/tool/compiler/host.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/archive.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/archive/document.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/archive/key.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/archive/signature.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/cache.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/cache/dependency.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/io.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/io/archive.lux create mode 100644 stdlib/source/lux/tool/compiler/meta/io/context.lux create mode 100644 stdlib/source/lux/tool/compiler/name.lux create mode 100644 stdlib/source/lux/tool/compiler/phase.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/case.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/expression.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/function.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/inference.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/macro.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/module.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/scope.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/analysis/type.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/bundle.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/statement.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/translation.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/statement.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/statement/total.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/case.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/function.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/reference.lux create mode 100644 stdlib/source/lux/tool/interpreter.lux create mode 100644 stdlib/source/lux/tool/interpreter/type.lux create mode 100644 stdlib/source/lux/tool/mediator.lux create mode 100644 stdlib/source/lux/tool/mediator/parallelism.lux (limited to 'stdlib') diff --git a/stdlib/project.clj b/stdlib/project.clj index c4fa14f41..9497165ab 100644 --- a/stdlib/project.clj +++ b/stdlib/project.clj @@ -19,9 +19,9 @@ :url ~(str repo ".git")} :source-paths ["source"] - :profiles {:library {:description "Standard library for the Lux programming language." - :dependencies [] - :lux {:tests {:jvm "test/lux"}}} + :profiles {:bibliotheca {:description "Standard library for the Lux programming language." + :dependencies [] + :lux {:tests {:jvm "test/lux"}}} :scriptum {:description "A documentation generator for Lux code." :dependencies [] :lux {:program {:jvm "program/scriptum"}}} diff --git a/stdlib/source/lux/cli.lux b/stdlib/source/lux/cli.lux index e590700bc..69a7cae7f 100644 --- a/stdlib/source/lux/cli.lux +++ b/stdlib/source/lux/cli.lux @@ -2,7 +2,7 @@ [lux #* [control monad - ["p" parser] + ["p" parser (#+ Parser)] [concurrency ["." process]]] [data @@ -14,17 +14,15 @@ [macro (#+ with-gensyms) ["." code] ["s" syntax (#+ syntax: Syntax)]] - [platform + [tool [compiler ["." host]]] ["." io]]) -## [Types] (type: #export (CLI a) {#.doc "A command-line interface parser."} - (p.Parser (List Text) a)) + (Parser (List Text) a)) -## [Combinators] (def: #export (run inputs parser) (All [a] (-> (List Text) (CLI a) (Error a))) (case (p.run inputs parser) @@ -109,7 +107,6 @@ (p.after (p.either (..this short) (..this long))) ..somewhere)) -## [Syntax] (type: Program-Args (#Raw Text) (#Parsed (List [Code Code]))) diff --git a/stdlib/source/lux/control/concurrency/atom.lux b/stdlib/source/lux/control/concurrency/atom.lux index 61152d7b6..a8fd975b2 100644 --- a/stdlib/source/lux/control/concurrency/atom.lux +++ b/stdlib/source/lux/control/concurrency/atom.lux @@ -6,7 +6,7 @@ ["." io (#- run)] [type abstract] - [platform + [tool [compiler ["." host]]] [host (#+ import:)]]) diff --git a/stdlib/source/lux/control/concurrency/process.lux b/stdlib/source/lux/control/concurrency/process.lux index d1d2ac245..018659ba1 100644 --- a/stdlib/source/lux/control/concurrency/process.lux +++ b/stdlib/source/lux/control/concurrency/process.lux @@ -6,7 +6,7 @@ [data [collection ["." list]]] - [platform + [tool [compiler ["." host]]] ["." io (#+ IO io)] diff --git a/stdlib/source/lux/control/thread.lux b/stdlib/source/lux/control/thread.lux index 978d6a683..b83acabc9 100644 --- a/stdlib/source/lux/control/thread.lux +++ b/stdlib/source/lux/control/thread.lux @@ -9,7 +9,7 @@ ["." array (#+ Array)]]] [type (#+ :share) abstract] - [platform + [tool [compiler ["." host]]] ["." io (#+ IO)]]) diff --git a/stdlib/source/lux/data/collection/array.lux b/stdlib/source/lux/data/collection/array.lux index 4b8695bb0..0871e1a86 100644 --- a/stdlib/source/lux/data/collection/array.lux +++ b/stdlib/source/lux/data/collection/array.lux @@ -11,7 +11,7 @@ ["." maybe] [collection ["." list ("#/." fold)]]] - [platform + [tool [compiler ["." host]]]]) diff --git a/stdlib/source/lux/data/text.lux b/stdlib/source/lux/data/text.lux index 1b414f2f2..9be782e65 100644 --- a/stdlib/source/lux/data/text.lux +++ b/stdlib/source/lux/data/text.lux @@ -13,7 +13,7 @@ ["." i64]] [collection ["." list ("#/." fold)]]] - [platform + [tool [compiler ["." host]]]]) diff --git a/stdlib/source/lux/data/text/encoding.lux b/stdlib/source/lux/data/text/encoding.lux index 00b5b719b..55cb06ef3 100644 --- a/stdlib/source/lux/data/text/encoding.lux +++ b/stdlib/source/lux/data/text/encoding.lux @@ -8,7 +8,7 @@ abstract] [world [binary (#+ Binary)]] - [platform + [tool [compiler ["_" host]]] [host (#+ import:)]]) diff --git a/stdlib/source/lux/platform/compiler.lux b/stdlib/source/lux/platform/compiler.lux deleted file mode 100644 index b4fdd541e..000000000 --- a/stdlib/source/lux/platform/compiler.lux +++ /dev/null @@ -1,46 +0,0 @@ -(.module: - [lux (#- Module Source Code) - [control - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - [collection - ["." dictionary (#+ Dictionary)]]] - [world - ["." file (#+ File)]]] - [/ - [meta - ["." archive (#+ Archive) - [key (#+ Key)] - [descriptor (#+ Module)] - [document (#+ Document)]]]]) - -(type: #export Code - Text) - -(type: #export Parameter - Text) - -(type: #export Input - {#module Module - #file File - #hash Nat - #code Code}) - -(type: #export (Output o) - (Dictionary Text o)) - -(type: #export (Compilation d o) - {#dependencies (List Module) - #process (-> Archive - (Error (Either (Compilation d o) - [(Document d) (Output o)])))}) - -(type: #export (Compiler d o) - (-> Input (Compilation d o))) - -(type: #export (Instancer d o) - (-> (Key d) (List Parameter) (Compiler d o))) - -(exception: #export (cannot-compile {module Module}) - (ex.report ["Module" module])) diff --git a/stdlib/source/lux/platform/compiler/cli.lux b/stdlib/source/lux/platform/compiler/cli.lux deleted file mode 100644 index 7e92b2c34..000000000 --- a/stdlib/source/lux/platform/compiler/cli.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux #* - [control - ["p" parser]] - ["." cli (#+ CLI)] - [world - [file (#+ File)]]] - [/// - [importer (#+ Source)]]) - -(type: #export Configuration - {#sources (List Source) - #target File - #module Text}) - -(type: #export Service - (#Compilation Configuration) - (#Interpretation Configuration)) - -(do-template [ ] - [(def: #export - (CLI Text) - (cli.parameter [ ]))] - - [source "-s" "--source"] - [target "-t" "--target"] - [module "-m" "--module"] - ) - -(def: #export configuration - (CLI Configuration) - ($_ p.and - (p.some ..source) - ..target - ..module)) - -(def: #export service - (CLI Service) - ($_ p.or - (p.after (cli.this "build") ..configuration) - (p.after (cli.this "repl") ..configuration))) diff --git a/stdlib/source/lux/platform/compiler/default.lux b/stdlib/source/lux/platform/compiler/default.lux deleted file mode 100644 index 726562cc8..000000000 --- a/stdlib/source/lux/platform/compiler/default.lux +++ /dev/null @@ -1,6 +0,0 @@ -(.module: - [lux #*]) - -(type: #export Version Text) - -(def: #export version Version "0.6.0") diff --git a/stdlib/source/lux/platform/compiler/default/cache.lux b/stdlib/source/lux/platform/compiler/default/cache.lux deleted file mode 100644 index 1770b4a82..000000000 --- a/stdlib/source/lux/platform/compiler/default/cache.lux +++ /dev/null @@ -1,35 +0,0 @@ -(.module: - [lux #* - [data - [format - ["_" binary (#+ Format)]]]]) - -(def: definition - (Format Definition) - ($_ _.and _.type _.code _.any)) - -(def: alias - (Format [Text Text]) - (_.and _.text _.text)) - -## TODO: Remove #module-hash, #imports & #module-state ASAP. -## TODO: Not just from this parser, but from the lux.Module type. -(def: #export module - (Format Module) - ($_ _.and - ## #module-hash - (_.ignore 0) - ## #module-aliases - (_.list ..alias) - ## #definitions - (_.list (_.and _.text ..definition)) - ## #imports - (_.list _.text) - ## #tags - (_.ignore (list)) - ## #types - (_.ignore (list)) - ## #module-annotations - (_.maybe _.code) - ## #module-state - (_.ignore #.Cached))) diff --git a/stdlib/source/lux/platform/compiler/default/evaluation.lux b/stdlib/source/lux/platform/compiler/default/evaluation.lux deleted file mode 100644 index 1f21304ca..000000000 --- a/stdlib/source/lux/platform/compiler/default/evaluation.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." error] - [text - format]]] - [/// - ["." phase - [analysis (#+ Operation) - [".A" expression] - ["." type]] - ["." synthesis - [".S" expression]] - ["." translation]]]) - -(type: #export Eval - (-> Nat Type Code (Operation Any))) - -(def: #export (evaluator synthesis-state translation-state translate) - (All [anchor expression statement] - (-> synthesis.State+ - (translation.State+ anchor expression statement) - (translation.Phase anchor expression statement) - Eval)) - (function (eval count type exprC) - (do phase.monad - [exprA (type.with-type type - (expressionA.compile exprC))] - (phase.lift (do error.monad - [exprS (|> exprA expressionS.phase (phase.run synthesis-state))] - (phase.run translation-state - (do phase.monad - [exprO (translate exprS)] - (translation.evaluate! (format "eval" (%n count)) exprO)))))))) diff --git a/stdlib/source/lux/platform/compiler/default/init.lux b/stdlib/source/lux/platform/compiler/default/init.lux deleted file mode 100644 index a416c0a3b..000000000 --- a/stdlib/source/lux/platform/compiler/default/init.lux +++ /dev/null @@ -1,198 +0,0 @@ -(.module: - [lux (#- Module loop) - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." product] - ["." error (#+ Error)] - ["." text ("#/." hash)] - [collection - ["." dictionary]]] - ["." macro] - [world - ["." file]]] - ["." // - ["." syntax (#+ Aliases)] - ["." evaluation] - ["/." // (#+ Compiler) - ["." host] - ["." phase - ["." analysis - ["." module] - [".A" expression]] - ["." synthesis - [".S" expression]] - ["." translation] - ["." statement - [".S" total]] - ["." extension - [".E" analysis] - [".E" synthesis] - [".E" statement]]] - [meta - [archive - ["." signature] - ["." key (#+ Key)] - ["." descriptor (#+ Module)] - ["." document]]]]]) - -(def: #export info - Info - {#.target (`` (for {(~~ (static host.common-lisp)) host.common-lisp - (~~ (static host.js)) host.js - (~~ (static host.jvm)) host.jvm - (~~ (static host.lua)) host.lua - (~~ (static host.php)) host.php - (~~ (static host.python)) host.python - (~~ (static host.r)) host.r - (~~ (static host.ruby)) host.ruby - (~~ (static host.scheme)) host.scheme})) - #.version //.version - #.mode #.Build}) - -(def: refresh - (All [anchor expression statement] - (statement.Operation anchor expression statement Any)) - (do phase.monad - [[bundle state] phase.get-state - #let [eval (evaluation.evaluator (get@ [#statement.synthesis #statement.state] state) - (get@ [#statement.translation #statement.state] state) - (get@ [#statement.translation #statement.phase] state))]] - (phase.set-state [statementE.bundle - (update@ [#statement.analysis #statement.state] - (: (-> analysis.State+ analysis.State+) - (|>> product.right - [(analysisE.bundle eval)])) - state)]))) - -(def: #export (state host translate translation-bundle) - (All [anchor expression statement] - (-> (translation.Host expression statement) - (translation.Phase anchor expression statement) - (translation.Bundle anchor expression statement) - (statement.State+ anchor expression statement))) - (let [synthesis-state [synthesisE.bundle synthesis.init] - translation-state [translation-bundle (translation.state host)] - eval (evaluation.evaluator synthesis-state translation-state translate) - analysis-state [(analysisE.bundle eval) (analysis.state ..info host)]] - [statementE.bundle - {#statement.analysis {#statement.state analysis-state - #statement.phase expressionA.compile} - #statement.synthesis {#statement.state synthesis-state - #statement.phase expressionS.phase} - #statement.translation {#statement.state translation-state - #statement.phase translate}}])) - -(type: Reader - (-> Source (Error [Source Code]))) - -(def: (reader current-module aliases) - (-> Module Aliases (analysis.Operation Reader)) - (function (_ [bundle state]) - (let [[cursor offset source-code] (get@ #.source state)] - (#error.Success [[bundle state] - (syntax.parse current-module aliases ("lux text size" source-code))])))) - -(def: (read reader) - (-> Reader (analysis.Operation Code)) - (function (_ [bundle compiler]) - (case (reader (get@ #.source compiler)) - (#error.Failure error) - (#error.Failure error) - - (#error.Success [source' output]) - (let [[cursor _] output] - (#error.Success [[bundle (|> compiler - (set@ #.source source') - (set@ #.cursor cursor))] - output]))))) - -(with-expansions [ (as-is (All [anchor expression statement] - (statement.Operation anchor expression statement Any)))] - - (def: (begin hash input) - (-> Nat ///.Input ) - (statement.lift-analysis - (do phase.monad - [#let [module (get@ #///.module input)] - _ (module.create hash module) - _ (analysis.set-current-module module)] - (analysis.set-source-code (analysis.source (get@ #///.module input) (get@ #///.code input)))))) - - (def: end - (-> Module ) - (|>> module.set-compiled - statement.lift-analysis)) - - (def: (iteration reader) - (-> Reader ) - (do phase.monad - [code (statement.lift-analysis - (..read reader)) - _ (totalS.phase code)] - ..refresh)) - - (def: (loop module) - (-> Module ) - (do phase.monad - [reader (statement.lift-analysis - (..reader module syntax.no-aliases))] - (function (_ state) - (.loop [state state] - (case (..iteration reader state) - (#error.Success [state' output]) - (recur state') - - (#error.Failure error) - (if (ex.match? syntax.end-of-file error) - (#error.Success [state []]) - (ex.with-stack ///.cannot-compile module (#error.Failure error)))))))) - - (def: (compile hash input) - (-> Nat ///.Input ) - (do phase.monad - [#let [module (get@ #///.module input)] - _ (..begin hash input) - _ (..loop module)] - (..end module))) - - (def: (default-dependencies prelude input) - (-> Module ///.Input (List Module)) - (if (text/= prelude (get@ #///.module input)) - (list) - (list prelude))) - ) - -(def: #export (compiler prelude state) - (All [anchor expression statement] - (-> Module - (statement.State+ anchor expression statement) - (Compiler .Module))) - (function (_ key parameters input) - (let [hash (text/hash (get@ #///.code input)) - dependencies (default-dependencies prelude input)] - {#///.dependencies dependencies - #///.process (function (_ archive) - (do error.monad - [[state' analysis-module] (phase.run' state - (: (All [anchor expression statement] - (statement.Operation anchor expression statement .Module)) - (do phase.monad - [_ (compile hash input)] - (statement.lift-analysis - (extension.lift - macro.current-module))))) - #let [descriptor {#descriptor.hash hash - #descriptor.name (get@ #///.module input) - #descriptor.file (get@ #///.file input) - #descriptor.references dependencies - #descriptor.state #.Compiled}]] - (wrap (#.Right [(document.write key descriptor analysis-module) - (dictionary.new text.hash)]))))}))) - -(def: #export key - (Key .Module) - (key.key {#signature.name (name-of ..compiler) - #signature.version //.version} - (module.new 0))) diff --git a/stdlib/source/lux/platform/compiler/default/platform.lux b/stdlib/source/lux/platform/compiler/default/platform.lux deleted file mode 100644 index 7e3846c09..000000000 --- a/stdlib/source/lux/platform/compiler/default/platform.lux +++ /dev/null @@ -1,109 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." product] - ["." error]] - [world - ["." file (#+ File)]]] - [// - ["." init] - ["." syntax] - ["/." // - ["." phase - ["." translation] - ["." statement]] - ["." cli (#+ Configuration)] - [meta - ["." archive] - [io - ["." context]]]]]) - -(type: #export (Platform ! anchor expression statement) - {#host (translation.Host expression statement) - #phase (translation.Phase anchor expression statement) - #runtime (translation.Operation anchor expression statement Any) - #file-system (file.System !)}) - -## (def: (write-module target-dir file-name module-name module outputs) -## (-> File Text Text Module Outputs (Process Any)) -## (do (error.with-error io.monad) -## [_ (monad.map @ (product.uncurry (&io.write target-dir)) -## (dictionary.entries outputs))] -## (&io.write target-dir -## (format module-name "/" cache.descriptor-name) -## (encoding.to-utf8 (%code (cache/description.write file-name module)))))) - -(with-expansions [ (as-is (Platform ! anchor expression statement)) - (as-is (statement.State+ anchor expression statement)) - (as-is (translation.Bundle anchor expression statement))] - - (def: #export (initialize platform translation-bundle) - (All [! anchor expression statement] - (-> (! ))) - (|> platform - (get@ #runtime) - statement.lift-translation - (phase.run' (init.state (get@ #host platform) - (get@ #phase platform) - translation-bundle)) - (:: error.functor map product.left) - (:: (get@ #file-system platform) lift)) - - ## (case (runtimeT.translate ## (initL.compiler (io.run js.init)) - ## (initL.compiler (io.run hostL.init-host)) - ## ) - ## ## (#error.Success [state disk-write]) - ## ## (do @ - ## ## [_ (&io.prepare-target target) - ## ## _ disk-write - ## ## ## _ (cache/io.pre-load sources target (commonT.load-definition state)) - ## ## ] - ## ## (wrap (|> state - ## ## (set@ [#.info #.mode] #.Build)))) - - ## (#error.Success [state [runtime-bc function-bc]]) - ## (do @ - ## [_ (&io.prepare-target target) - ## ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc) - ## ## _ (&io.write target (format hostL.function-class ".class") function-bc) - ## ## _ (cache/io.pre-load sources target (commonT.load-definition state)) - ## ] - ## (wrap (|> state - ## (set@ [#.info #.mode] #.Build)))) - - ## (#error.Failure error) - ## (io.fail error)) - ) - - (def: #export (compile platform configuration state) - (All [! anchor expression statement] - (-> Configuration (! Any))) - (do (:: (get@ #file-system platform) &monad) - [input (context.read (get@ #file-system platform) - (get@ #cli.sources configuration) - (get@ #cli.module configuration)) - ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) - ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) - ] - ## (case (compiler input) - ## (#error.Failure error) - ## (:: (get@ #file-system platform) lift (#error.Failure error)) - - ## (#error.Success)) - (let [compiler (init.compiler syntax.prelude state) - compilation (compiler init.key (list) input)] - (case ((get@ #///.process compilation) - archive.empty) - (#error.Success more|done) - (case more|done - (#.Left more) - (:: (get@ #file-system platform) lift (#error.Failure "NOT DONE!")) - - (#.Right done) - (wrap [])) - - (#error.Failure error) - (:: (get@ #file-system platform) lift (#error.Failure error)))))) - ) diff --git a/stdlib/source/lux/platform/compiler/default/syntax.lux b/stdlib/source/lux/platform/compiler/default/syntax.lux deleted file mode 100644 index c76857aab..000000000 --- a/stdlib/source/lux/platform/compiler/default/syntax.lux +++ /dev/null @@ -1,561 +0,0 @@ -## This is LuxC's parser. -## It takes the source code of a Lux file in raw text form and -## extracts the syntactic structure of the code from it. -## It only produces Lux Code nodes, and thus removes any white-space -## and comments while processing its inputs. - -## Another important aspect of the parser is that it keeps track of -## its position within the input data. -## That is, the parser takes into account the line and column -## information in the input text (it doesn't really touch the -## file-name aspect of the cursor, leaving it intact in whatever -## base-line cursor it is given). - -## This particular piece of functionality is not located in one -## function, but it is instead scattered throughout several parsers, -## since the logic for how to update the cursor varies, depending on -## what is being parsed, and the rules involved. - -## You will notice that several parsers have a "where" parameter, that -## tells them the cursor position prior to the parser being run. -## They are supposed to produce some parsed output, alongside an -## updated cursor pointing to the end position, after the parser was run. - -## Lux Code nodes/tokens are annotated with cursor meta-data -## [file-name, line, column] to keep track of their provenance and -## location, which is helpful for documentation and debugging. -(.module: - [lux #* - [control - monad - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - [number - ["." nat] - ["." int] - ["." rev] - ["." frac]] - ["." text - [lexer (#+ Offset)] - format] - [collection - ["." list] - ["." dictionary (#+ Dictionary)]]]]) - -## TODO: Optimize how forms, tuples & records are parsed in the end. -## There is repeated-work going on when parsing the white-space before the -## closing parenthesis/bracket/brace. -## That repeated-work should be avoided. - -## TODO: Implement "lux syntax char case!" as a custom extension. -## That way, it should be possible to obtain the char without wrapping -## it into a java.lang.Long, thereby improving performance. - -## TODO: Make an extension to take advantage of java/lang/String::indexOf -## to get better performance than the current "lux text index" extension. - -(type: Char Nat) - -(do-template [ ] - [(template: ( value) - ( value ))] - - [!inc "lux i64 +" 1] - [!inc/2 "lux i64 +" 2] - [!dec "lux i64 -" 1] - ) - -(template: (!clip from to text) - ("lux text clip" text from to)) - -(do-template [ ] - [(template: ( reference subject) - ( subject reference))] - - [!n/= "lux i64 ="] - [!i/< "lux int <"] - ) - -(do-template [ ] - [(template: ( param subject) - ( subject param))] - - [!n/+ "lux i64 +"] - [!n/- "lux i64 -"] - ) - -(type: #export Aliases (Dictionary Text Text)) -(def: #export no-aliases Aliases (dictionary.new text.hash)) - -(def: #export prelude "lux") - -(def: #export space " ") - -(def: #export text-delimiter text.double-quote) - -(def: #export open-form "(") -(def: #export close-form ")") - -(def: #export open-tuple "[") -(def: #export close-tuple "]") - -(def: #export open-record "{") -(def: #export close-record "}") - -(def: #export sigil "#") - -(def: #export digit-separator "_") - -(def: #export positive-sign "+") -(def: #export negative-sign "-") - -(def: #export frac-separator ".") - -## The parts of an name are separated by a single mark. -## E.g. module.short. -## Only one such mark may be used in an name, since there -## can only be 2 parts to an name (the module [before the -## mark], and the short [after the mark]). -## There are also some extra rules regarding name syntax, -## encoded on the parser. -(def: #export name-separator ".") - -(exception: #export (end-of-file {module Text}) - (ex.report ["Module" (%t module)])) - -(def: amount-of-input-shown 64) - -(def: (input-at start input) - (-> Offset Text Text) - (let [end (|> start (n/+ amount-of-input-shown) (n/min ("lux text size" input)))] - (!clip start end input))) - -(exception: #export (unrecognized-input {[file line column] Cursor} {context Text} {input Text} {offset Offset}) - (ex.report ["File" file] - ["Line" (%n line)] - ["Column" (%n column)] - ["Context" (%t context)] - ["Input" (input-at offset input)])) - -(exception: #export (text-cannot-contain-new-lines {text Text}) - (ex.report ["Text" (%t text)])) - -(exception: #export (invalid-escape-syntax) - "") - -(exception: #export (cannot-close-composite-expression {closing-char Char} {source-code Text} {offset Offset}) - (ex.report ["Closing Character" (text.from-code closing-char)] - ["Input" (format text.new-line - (input-at offset source-code))])) - -(type: Parser - (-> Source (Error [Source Code]))) - -(template: (!with-char+ @source-code-size @source-code @offset @char @else @body) - (if (!i/< (:coerce Int @source-code-size) - (:coerce Int @offset)) - (let [@char ("lux text char" @source-code @offset)] - @body) - @else)) - -(template: (!with-char @source-code @offset @char @else @body) - (!with-char+ ("lux text size" @source-code) @source-code @offset @char @else @body)) - -(def: close-signal "CLOSE") - -(with-expansions [ (as-is (ex.throw cannot-close-composite-expression [closing-char source-code end]))] - (def: (read-close closing-char source-code//size source-code offset) - (-> Char Nat Text Offset (Error Offset)) - (loop [end offset] - (<| (!with-char+ source-code//size source-code end char - (if (!n/= closing-char char) - (#error.Success (!inc end)) - (`` ("lux syntax char case!" char - [[(~~ (static ..space)) - (~~ (static text.carriage-return)) - (~~ (static text.new-line))] - (recur (!inc end))] - - ## else - )))))))) - -(`` (do-template [ ] - [(def: ( parse source) - (-> Parser Parser) - (let [[_ _ source-code] source - source-code//size ("lux text size" source-code)] - (loop [source source - stack (: (List Code) #.Nil)] - (case (parse source) - (#error.Success [source' top]) - (recur source' (#.Cons top stack)) - - (#error.Failure error) - (let [[where offset _] source] - (case (read-close (char ) source-code//size source-code offset) - (#error.Success offset') - (#error.Success [[(update@ #.column inc where) offset' source-code] - [where ( (list.reverse stack))]]) - - (#error.Failure error) - (#error.Failure error)))))))] - - ## Form and tuple syntax is mostly the same, differing only in the - ## delimiters involved. - ## They may have an arbitrary number of arbitrary Code nodes as elements. - [parse-form (~~ (static ..close-form)) #.Form "Form"] - [parse-tuple (~~ (static ..close-tuple)) #.Tuple "Tuple"] - )) - -(def: (parse-record parse source) - (-> Parser Parser) - (let [[_ _ source-code] source - source-code//size ("lux text size" source-code)] - (loop [source source - stack (: (List [Code Code]) #.Nil)] - (case (parse source) - (#error.Success [sourceF field]) - (case (parse sourceF) - (#error.Success [sourceFV value]) - (recur sourceFV (#.Cons [field value] stack)) - - (#error.Failure error) - (#error.Failure error)) - - (#error.Failure error) - (let [[where offset _] source] - (<| (!with-char+ source-code//size source-code offset closing-char (#error.Failure error)) - (case (read-close (`` (char (~~ (static ..close-record)))) source-code//size source-code offset) - (#error.Success offset') - (#error.Success [[(update@ #.column inc where) offset' source-code] - [where (#.Record (list.reverse stack))]]) - - (#error.Failure error) - (#error.Failure error)))))))) - -(template: (!guarantee-no-new-lines content body) - (case ("lux text index" content (static text.new-line) 0) - #.None - body - - g!_ - (ex.throw ..text-cannot-contain-new-lines content))) - -(template: (!read-text where offset source-code) - (case ("lux text index" source-code (static ..text-delimiter) offset) - (#.Some g!end) - (let [g!content (!clip offset g!end source-code)] - (<| (!guarantee-no-new-lines g!content) - (#error.Success [[(update@ #.column (n/+ (!n/- offset g!end)) where) - (!inc g!end) - source-code] - [where - (#.Text g!content)]]))) - - _ - (ex.throw unrecognized-input [where "Text" source-code offset]))) - -(def: digit-bottom Nat (!dec (char "0"))) -(def: digit-top Nat (!inc (char "9"))) - -(template: (!digit? char) - (and (!i/< (:coerce Int char) (:coerce Int (static ..digit-bottom))) - (!i/< (:coerce Int (static ..digit-top)) (:coerce Int char)))) - -(`` (template: (!digit?+ char) - (or (!digit? char) - ("lux i64 =" (.char (~~ (static ..digit-separator))) char)))) - -(`` (template: (!strict-name-char? char) - (not (or ("lux i64 =" (.char (~~ (static ..space))) char) - ("lux i64 =" (.char (~~ (static text.new-line))) char) - - ("lux i64 =" (.char (~~ (static ..name-separator))) char) - - ("lux i64 =" (.char (~~ (static ..open-form))) char) - ("lux i64 =" (.char (~~ (static ..close-form))) char) - - ("lux i64 =" (.char (~~ (static ..open-tuple))) char) - ("lux i64 =" (.char (~~ (static ..close-tuple))) char) - - ("lux i64 =" (.char (~~ (static ..open-record))) char) - ("lux i64 =" (.char (~~ (static ..close-record))) char) - - ("lux i64 =" (.char (~~ (static ..text-delimiter))) char) - ("lux i64 =" (.char (~~ (static ..sigil))) char))))) - -(template: (!name-char?|head char) - (and (!strict-name-char? char) - (not (!digit? char)))) - -(template: (!name-char? char) - (or (!strict-name-char? char) - (!digit? char))) - -(template: (!number-output ) - (case (:: decode (!clip source-code)) - (#error.Success output) - (#error.Success [[(update@ #.column (n/+ (!n/- )) where) - - source-code] - [where ( output)]]) - - (#error.Failure error) - (#error.Failure error))) - -(def: no-exponent Offset 0) - -(with-expansions [ (as-is (!number-output start end int.decimal #.Int)) - (as-is (!number-output start end frac.decimal #.Frac)) - (ex.throw unrecognized-input [where "Frac" source-code offset])] - (def: (parse-frac source-code//size start [where offset source-code]) - (-> Nat Offset Parser) - (loop [end offset - exponent ..no-exponent] - (<| (!with-char+ source-code//size source-code end char/0 ) - (cond (!digit?+ char/0) - (recur (!inc end) exponent) - - (and (or (!n/= (char "e") char/0) - (!n/= (char "E") char/0)) - (not (is? ..no-exponent exponent))) - (<| (!with-char+ source-code//size source-code (!inc end) char/1 ) - (if (or (!n/= (`` (char (~~ (static ..positive-sign)))) char/1) - (!n/= (`` (char (~~ (static ..negative-sign)))) char/1)) - (<| (!with-char+ source-code//size source-code (!n/+ 2 end) char/2 ) - (if (!digit?+ char/2) - (recur (!n/+ 3 end) char/0) - )) - )) - - ## else - )))) - - (def: (parse-signed start [where offset source-code]) - (-> Offset Parser) - (let [source-code//size ("lux text size" source-code)] - (loop [end offset] - (<| (!with-char+ source-code//size source-code end char ) - (cond (!digit?+ char) - (recur (!inc end)) - - (!n/= (`` (.char (~~ (static ..frac-separator)))) - char) - (parse-frac source-code//size start [where (!inc end) source-code]) - - ## else - )))))) - -(do-template [ ] - [(template: ( source-code//size start where offset source-code) - (loop [g!end offset] - (<| (!with-char+ source-code//size source-code g!end g!char (!number-output start g!end )) - (if (!digit?+ g!char) - (recur (!inc g!end)) - (!number-output start g!end )))))] - - [!parse-nat nat.decimal #.Nat] - [!parse-rev rec.decimal #.Rev] - ) - -(template: (!parse-signed source-code//size offset where source-code @end) - (let [g!offset/1 (!inc offset)] - (<| (!with-char+ source-code//size source-code g!offset/1 g!char/1 @end) - (if (!digit? g!char/1) - (parse-signed offset [where (!inc/2 offset) source-code]) - (!parse-full-name offset [where (!inc offset) source-code] where #.Identifier))))) - -(with-expansions [ (#error.Success [[(update@ #.column (n/+ (!n/- start end)) where) - end - source-code] - (!clip start end source-code)])] - (def: (parse-name-part start [where offset source-code]) - (-> Offset Source (Error [Source Text])) - (let [source-code//size ("lux text size" source-code)] - (loop [end offset] - (<| (!with-char+ source-code//size source-code end char ) - (if (!name-char? char) - (recur (!inc end)) - )))))) - -(template: (!new-line where) - ## (-> Cursor Cursor) - (let [[where::file where::line where::column] where] - [where::file (!inc where::line) 0])) - -(with-expansions [ (ex.throw end-of-file current-module) - (ex.throw unrecognized-input [where "General" source-code offset/0]) - (#error.Failure close-signal) - (as-is [where (!inc offset/0) source-code]) - (as-is [where (!inc/2 offset/0) source-code])] - - (template: (!parse-half-name @offset @char @module) - (cond (!name-char?|head @char) - (case (..parse-name-part @offset [where (!inc @offset) source-code]) - (#error.Success [source' name]) - (#error.Success [source' [@module name]]) - - (#error.Failure error) - (#error.Failure error)) - - ## else - )) - - (`` (def: (parse-short-name current-module [where offset/0 source-code]) - (-> Text Source (Error [Source Name])) - (<| (!with-char source-code offset/0 char/0 ) - (if (!n/= (char (~~ (static ..name-separator))) char/0) - (let [offset/1 (!inc offset/0)] - (<| (!with-char source-code offset/1 char/1 ) - (!parse-half-name offset/1 char/1 current-module))) - (!parse-half-name offset/0 char/0 ..prelude))))) - - (template: (!parse-short-name @current-module @source @where @tag) - (case (..parse-short-name @current-module @source) - (#error.Success [source' name]) - (#error.Success [source' [@where (@tag name)]]) - - (#error.Failure error) - (#error.Failure error))) - - (with-expansions [ (as-is (#error.Success [source' ["" simple]]))] - (`` (def: (parse-full-name start source) - (-> Offset Source (Error [Source Name])) - (case (..parse-name-part start source) - (#error.Success [source' simple]) - (let [[where' offset' source-code'] source'] - (<| (!with-char source-code' offset' char/separator ) - (if (!n/= (char (~~ (static ..name-separator))) char/separator) - (let [offset'' (!inc offset')] - (case (..parse-name-part offset'' [where' offset'' source-code']) - (#error.Success [source'' complex]) - (#error.Success [source'' [simple complex]]) - - (#error.Failure error) - (#error.Failure error))) - ))) - - (#error.Failure error) - (#error.Failure error))))) - - (template: (!parse-full-name @offset @source @where @tag) - (case (..parse-full-name @offset @source) - (#error.Success [source' full-name]) - (#error.Success [source' [@where (@tag full-name)]]) - - (#error.Failure error) - (#error.Failure error))) - - (`` (template: (<>) - [(~~ (static ..close-form)) - (~~ (static ..close-tuple)) - (~~ (static ..close-record))])) - - ## TODO: Grammar macro for specifying syntax. - ## (grammar: lux-grammar - ## [expression ...] - ## [form "(" [#* expression] ")"]) - - (with-expansions [ (as-is (parse current-module aliases source-code//size)) - (as-is (recur [(update@ #.column inc where) - (!inc offset/0) - source-code]))] - (def: #export (parse current-module aliases source-code//size) - (-> Text Aliases Nat (-> Source (Error [Source Code]))) - ## The "exec []" is only there to avoid function fusion. - ## This is to preserve the loop as much as possible and keep it tight. - (exec [] - (function (recur [where offset/0 source-code]) - (<| (!with-char+ source-code//size source-code offset/0 char/0 ) - ## The space was singled-out for special treatment - ## because of how common it is. - (`` (if (!n/= (char (~~ (static ..space))) char/0) - - ("lux syntax char case!" char/0 - [## New line - [(~~ (static text.carriage-return))] - - - [(~~ (static text.new-line))] - (recur [(!new-line where) (!inc offset/0) source-code]) - - ## Form - [(~~ (static ..open-form))] - (parse-form ) - - ## Tuple - [(~~ (static ..open-tuple))] - (parse-tuple ) - - ## Record - [(~~ (static ..open-record))] - (parse-record ) - - ## Text - [(~~ (static ..text-delimiter))] - (let [offset/1 (!inc offset/0)] - (!read-text where offset/1 source-code)) - - ## Special code - [(~~ (static ..sigil))] - (let [offset/1 (!inc offset/0)] - (<| (!with-char+ source-code//size source-code offset/1 char/1 ) - ("lux syntax char case!" char/1 - [(~~ (do-template [ ] - [[] - (#error.Success [[(update@ #.column (|>> !inc/2) where) - (!inc offset/1) - source-code] - [where (#.Bit )]])] - - ["0" #0] - ["1" #1])) - - ## Single-line comment - [(~~ (static ..sigil))] - (case ("lux text index" source-code (static text.new-line) offset/1) - (#.Some end) - (recur [(!new-line where) (!inc end) source-code]) - - _ - ) - - [(~~ (static ..name-separator))] - (!parse-short-name current-module where #.Tag)] - - ## else - (cond (!name-char?|head char/1) ## Tag - (!parse-full-name offset/1 where #.Tag) - - ## else - )))) - - ## Coincidentally (= name-separator frac-separator) - [(~~ (static ..name-separator))] - (let [offset/1 (!inc offset/0)] - (<| (!with-char+ source-code//size source-code offset/1 char/1 ) - (if (!digit? char/1) - (let [offset/2 (!inc offset/1)] - (!parse-rev source-code//size offset/0 where offset/2 source-code)) - (!parse-short-name current-module [where offset/1 source-code] where #.Identifier)))) - - [(~~ (static ..positive-sign)) - (~~ (static ..negative-sign))] - (!parse-signed source-code//size offset/0 where source-code ) - - ## Invalid characters at this point... - (~~ (<>)) - ] - - ## else - (if (!digit? char/0) - ## Natural number - (let [offset/1 (!inc offset/0)] - (!parse-nat source-code//size offset/0 where offset/1 source-code)) - ## Identifier - (!parse-full-name offset/0 where #.Identifier)) - ))) - ))) - )) - ) diff --git a/stdlib/source/lux/platform/compiler/host.lux b/stdlib/source/lux/platform/compiler/host.lux deleted file mode 100644 index 218de67a4..000000000 --- a/stdlib/source/lux/platform/compiler/host.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - lux) - -(type: #export Host Text) - -(do-template [ ] - [(def: #export Host )] - - [common-lisp "Common Lisp"] - [js "JavaScript"] - [jvm "JVM"] - [lua "Lua"] - [php "PHP"] - [python "Python"] - [r "R"] - [ruby "Ruby"] - [scheme "Scheme"] - ) diff --git a/stdlib/source/lux/platform/compiler/meta/archive.lux b/stdlib/source/lux/platform/compiler/meta/archive.lux deleted file mode 100644 index c318bfaf7..000000000 --- a/stdlib/source/lux/platform/compiler/meta/archive.lux +++ /dev/null @@ -1,77 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["ex" exception (#+ exception:)] - ["." equivalence (#+ Equivalence)] - ["." monad (#+ do)]] - [data - ["." error (#+ Error)] - ["." name] - ["." text - format] - [collection - ["." dictionary (#+ Dictionary)]]] - [type (#+ :share) - abstract] - [world - [file (#+ File)]]] - [/// - [default (#+ Version)]] - [/ - ["." signature (#+ Signature)] - ["." key (#+ Key)] - ["." descriptor (#+ Module Descriptor)] - ["." document (#+ Document)]]) - -## Archive -(exception: #export (unknown-document {name Module}) - (ex.report ["Module" name])) - -(exception: #export (cannot-replace-document {name Module} - {old (Document Any)} - {new (Document Any)}) - (ex.report ["Module" name] - ["Old key" (signature.description (document.signature old))] - ["New key" (signature.description (document.signature new))])) - -(with-expansions [ (as-is (type (Ex [d] (Document d))))] - (abstract: #export Archive - {} - - (Dictionary Text [Descriptor ]) - - (def: #export empty - Archive - (:abstraction (dictionary.new text.hash))) - - (def: #export (add name descriptor document archive) - (-> Module Descriptor Archive (Error Archive)) - (case (dictionary.get name (:representation archive)) - (#.Some existing) - (if (is? document existing) - (#error.Success archive) - (ex.throw cannot-replace-document [name existing document])) - - #.None - (#error.Success (|> archive - :representation - (dictionary.put name [descriptor document]) - :abstraction)))) - - (def: #export (find name archive) - (-> Module Archive (Error [Descriptor ])) - (case (dictionary.get name (:representation archive)) - (#.Some document) - (#error.Success document) - - #.None - (ex.throw unknown-document [name]))) - - (def: #export (merge additions archive) - (-> Archive Archive (Error Archive)) - (monad.fold error.monad - (function (_ [name' descriptor+document'] archive') - (..add name' descriptor+document' archive')) - archive - (dictionary.entries (:representation additions)))) - )) diff --git a/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux deleted file mode 100644 index 328240e6c..000000000 --- a/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux +++ /dev/null @@ -1,16 +0,0 @@ -(.module: - [lux (#- Module) - [data - [collection - [set (#+ Set)]]] - [world - [file (#+ File)]]]) - -(type: #export Module Text) - -(type: #export Descriptor - {#hash Nat - #name Module - #file File - #references (Set Module) - #state Module-State}) diff --git a/stdlib/source/lux/platform/compiler/meta/archive/document.lux b/stdlib/source/lux/platform/compiler/meta/archive/document.lux deleted file mode 100644 index 5c077080f..000000000 --- a/stdlib/source/lux/platform/compiler/meta/archive/document.lux +++ /dev/null @@ -1,49 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - [collection - ["." dictionary (#+ Dictionary)]]] - [type (#+ :share) - abstract]] - [// - ["." signature (#+ Signature)] - ["." key (#+ Key)] - [descriptor (#+ Module)]]) - -## Document -(exception: #export (invalid-signature {expected Signature} {actual Signature}) - (ex.report ["Expected" (signature.description expected)] - ["Actual" (signature.description actual)])) - -(abstract: #export (Document d) - {} - - {#signature Signature - #content d} - - (def: #export (read key document) - (All [d] (-> (Key d) (Document Any) (Error d))) - (let [[document//signature document//content] (:representation document)] - (if (:: signature.equivalence = - (key.signature key) - document//signature) - (#error.Success (:share [e] - {(Key e) - key} - {e - document//content})) - (ex.throw invalid-signature [(key.signature key) - document//signature])))) - - (def: #export (write key content) - (All [d] (-> (Key d) d (Document d))) - (:abstraction {#signature (key.signature key) - #content content})) - - (def: #export signature - (-> (Document Any) Signature) - (|>> :representation (get@ #signature))) - ) diff --git a/stdlib/source/lux/platform/compiler/meta/archive/key.lux b/stdlib/source/lux/platform/compiler/meta/archive/key.lux deleted file mode 100644 index 50c10ac01..000000000 --- a/stdlib/source/lux/platform/compiler/meta/archive/key.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux #* - [type - abstract]] - [// - [signature (#+ Signature)]]) - -(abstract: #export (Key k) - {} - - Signature - - (def: #export signature - (-> (Key Any) Signature) - (|>> :representation)) - - (def: #export (key signature sample) - (All [d] (-> Signature d (Key d))) - (:abstraction signature)) - ) diff --git a/stdlib/source/lux/platform/compiler/meta/archive/signature.lux b/stdlib/source/lux/platform/compiler/meta/archive/signature.lux deleted file mode 100644 index fb96aec58..000000000 --- a/stdlib/source/lux/platform/compiler/meta/archive/signature.lux +++ /dev/null @@ -1,23 +0,0 @@ -(.module: - [lux #* - [control - ["." equivalence (#+ Equivalence)]] - [data - ["." name] - ["." text - format]]] - [//// - [default (#+ Version)]]) - -## Key -(type: #export Signature - {#name Name - #version Version}) - -(def: #export equivalence - (Equivalence Signature) - (equivalence.product name.equivalence text.equivalence)) - -(def: #export (description signature) - (-> Signature Text) - (format (%name (get@ #name signature)) " " (get@ #version signature))) diff --git a/stdlib/source/lux/platform/compiler/meta/cache.lux b/stdlib/source/lux/platform/compiler/meta/cache.lux deleted file mode 100644 index 7ba16878a..000000000 --- a/stdlib/source/lux/platform/compiler/meta/cache.lux +++ /dev/null @@ -1,178 +0,0 @@ -(.module: - [lux (#- Module) - [control - ["." monad (#+ Monad do)] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." bit ("#/." equivalence)] - ["." maybe] - ["." error] - ["." product] - [format - ["." binary (#+ Format)]] - ["." text - [format (#- Format)]] - [collection - ["." list ("#/." functor fold)] - ["dict" dictionary (#+ Dictionary)] - ["." set (#+ Set)]]] - [world - [file (#+ File System)]]] - [// - [io (#+ Context Module) - ["io/." context] - ["io/." archive]] - ["." archive (#+ Signature Key Descriptor Document Archive)] - ["/." //]] - ["." /dependency (#+ Dependency Graph)]) - -(exception: #export (cannot-delete-file {file File}) - (ex.report ["File" file])) - -(exception: #export (stale-document {module ///.Module} {current-hash Nat} {stale-hash Nat}) - (ex.report ["Module" module] - ["Current hash" (%n current-hash)] - ["Stale hash" (%n stale-hash)])) - -(exception: #export (mismatched-signature {module ///.Module} {expected Signature} {actual Signature}) - (ex.report ["Module" module] - ["Expected" (archive.describe expected)] - ["Actual" (archive.describe actual)])) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [cannot-load-definition] - ) - -## General -(def: #export (cached System root) - (All [m] (-> (System m) File (m (List File)))) - (|> root - (io/archive.archive System) - (do> (:: System &monad) - [(:: System files)] - [(monad.map @ (function (recur file) - (do @ - [is-dir? (:: System directory? file)] - (if is-dir? - (|> file - (do> @ - [(:: System files)] - [(monad.map @ recur)] - [list.concat - (list& (maybe.assume (io/archive.module System root file))) - wrap])) - (wrap (list))))))] - [list.concat wrap]))) - -## Clean -(def: (delete System document) - (All [m] (-> (System m) File (m Any))) - (do (:: System &monad) - [deleted? (:: System delete document)] - (if deleted? - (wrap []) - (:: System throw cannot-delete-file document)))) - -(def: (un-install System root module) - (All [m] (-> (System m) File Module (m Any))) - (let [document (io/archive.document System root module)] - (|> document - (do> (:: System &monad) - [(:: System files)] - [(monad.map @ (function (_ file) - (do @ - [? (:: System directory? file)] - (if ? - (wrap #0) - (do @ - [_ (..delete System file)] - (wrap #1))))))] - [(list.every? (bit/= #1)) - (if> [(..delete System document)] - [(wrap [])])])))) - -(def: #export (clean System root wanted-modules) - (All [m] (-> (System m) File (Set Module) (m Any))) - (|> root - (do> (:: System &monad) - [(..cached System)] - [(list.filter (bit.complement (set.member? wanted-modules))) - (monad.map @ (un-install System root))]))) - -## Load -(def: signature - (Format Signature) - ($_ binary.and binary.name binary.text)) - -(def: descriptor - (Format Descriptor) - ($_ binary.and binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached))) - -(def: document - (All [a] (-> (Format a) (Format [Signature Descriptor a]))) - (|>> ($_ binary.and ..signature ..descriptor))) - -(def: (load-document System contexts root key binary module) - (All [m d] (-> (System m) (List File) File (Key d) (Format d) Module - (m (Maybe [Dependency (Document d)])))) - (do (:: System &monad) - [document' (:: System read (io/archive.document System root module)) - [module' source-code] (io/context.read System contexts module) - #let [current-hash (:: text.hash hash source-code)]] - (case (do error.monad - [[signature descriptor content] (binary.read (..document binary) document') - #let [[document-hash _file references _state] descriptor] - _ (ex.assert mismatched-signature [module (get@ #archive.signature key) signature] - (:: archive.equivalence = - (get@ #archive.signature key) - signature)) - _ (ex.assert stale-document [module current-hash document-hash] - (n/= current-hash document-hash)) - document (archive.write key signature descriptor content)] - (wrap [[module references] document])) - (#error.Success [dependency document]) - (wrap (#.Some [dependency document])) - - (#error.Failure error) - (do @ - [_ (un-install System root module)] - (wrap #.None))))) - -(def: #export (load-archive System contexts root key binary) - (All [m d] (-> (System m) (List Context) File (Key d) (Format d) (m Archive))) - (do (:: System &monad) - [candidate (|> root - (do> @ - [(..cached System)] - [(monad.map @ (load-document System contexts root key binary)) - (:: @ map (list/fold (function (_ full-document archive) - (case full-document - (#.Some [[module references] document]) - (dict.put module [references document] archive) - - #.None - archive)) - (: (Dictionary Text [(List Module) (Ex [d] (Document d))]) - (dict.new text.hash))))])) - #let [candidate-entries (dict.entries candidate) - candidate-dependencies (list/map (product.both id product.left) - candidate-entries) - candidate-archive (|> candidate-entries - (list/map (product.both id product.right)) - (dict.from-list text.hash)) - graph (|> candidate - dict.entries - (list/map (product.both id product.left)) - /dependency.graph - (/dependency.prune candidate-archive)) - archive (list/fold (function (_ module archive) - (if (dict.contains? module graph) - archive - (dict.remove module archive))) - candidate-archive - (dict.keys candidate))]] - (wrap archive))) diff --git a/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux b/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux deleted file mode 100644 index 4664ade1d..000000000 --- a/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux +++ /dev/null @@ -1,53 +0,0 @@ -(.module: - [lux (#- Module) - [data - ["." text] - [collection - ["." list ("#/." functor fold)] - ["dict" dictionary (#+ Dictionary)]]]] - [///io (#+ Module)] - [///archive (#+ Archive)]) - -(type: #export Graph (Dictionary Module (List Module))) - -(def: #export empty Graph (dict.new text.hash)) - -(def: #export (add to from) - (-> Module Module Graph Graph) - (|>> (dict.update~ from (list) (|>> (#.Cons to))) - (dict.update~ to (list) id))) - -(def: dependents - (-> Module Graph (Maybe (List Text))) - dict.get) - -(def: #export (remove module dependency) - (-> Module Graph Graph) - (case (dependents module dependency) - (#.Some dependents) - (list/fold remove (dict.remove module dependency) dependents) - - #.None - dependency)) - -(type: #export Dependency - {#module Module - #imports (List Module)}) - -(def: #export (dependency [module imports]) - (-> Dependency Graph) - (list/fold (..add module) ..empty imports)) - -(def: #export graph - (-> (List Dependency) Graph) - (|>> (list/map ..dependency) - (list/fold dict.merge empty))) - -(def: #export (prune archive graph) - (-> Archive Graph Graph) - (list/fold (function (_ module graph) - (if (dict.contains? module archive) - graph - (..remove module graph))) - graph - (dict.keys graph))) diff --git a/stdlib/source/lux/platform/compiler/meta/io.lux b/stdlib/source/lux/platform/compiler/meta/io.lux deleted file mode 100644 index dd261a539..000000000 --- a/stdlib/source/lux/platform/compiler/meta/io.lux +++ /dev/null @@ -1,16 +0,0 @@ -(.module: - [lux (#- Module Code) - [data - ["." text]] - [world - [file (#+ File System)]]]) - -(type: #export Context File) - -(type: #export Module Text) - -(type: #export Code Text) - -(def: #export (sanitize system) - (All [m] (-> (System m) Text Text)) - (text.replace-all "/" (:: system separator))) diff --git a/stdlib/source/lux/platform/compiler/meta/io/archive.lux b/stdlib/source/lux/platform/compiler/meta/io/archive.lux deleted file mode 100644 index 354f84460..000000000 --- a/stdlib/source/lux/platform/compiler/meta/io/archive.lux +++ /dev/null @@ -1,74 +0,0 @@ -(.module: - [lux (#- Module) - [control - monad - ["ex" exception (#+ exception:)]] - [data - ["." error] - ["." text - format]] - [world - ["." file (#+ File System)] - [binary (#+ Binary)]]] - ["." // (#+ Module) - [/// - ["." host]]]) - -(type: #export Document File) - -(exception: #export (cannot-prepare {archive File} {module Module}) - (ex.report ["Archive" archive] - ["Module" module])) - -(def: #export (archive System root) - (All [m] (-> (System m) File File)) - (<| (format root (:: System separator)) - (`` (for {(~~ (static host.common-lisp)) host.common-lisp - (~~ (static host.js)) host.js - (~~ (static host.jvm)) host.jvm - (~~ (static host.lua)) host.lua - (~~ (static host.php)) host.php - (~~ (static host.python)) host.python - (~~ (static host.r)) host.r - (~~ (static host.ruby)) host.ruby - (~~ (static host.scheme)) host.scheme})))) - -(def: #export (document System root module) - (All [m] (-> (System m) File Module Document)) - (let [archive (..archive System root)] - (|> module - (//.sanitize System) - (format archive (:: System separator))))) - -(def: #export (prepare System root module) - (All [m] (-> (System m) File Module (m Any))) - (do (:: System &monad) - [#let [archive (..archive System root) - document (..document System root module)] - document-exists? (file.exists? System document)] - (if document-exists? - (wrap []) - (do @ - [outcome (:: System try (:: System make-directory document))] - (case outcome - (#error.Success output) - (wrap output) - - (#error.Failure _) - (:: System throw cannot-prepare [archive module])))))) - -(def: #export (write System root content name) - (All [m] (-> (System m) File Binary Text (m Any))) - (:: System write content (..document System root name))) - -(def: #export (module System root document) - (All [m] (-> (System m) File Document (Maybe Module))) - (case (text.split-with (..archive System root) document) - (#.Some ["" post]) - (let [raw (text.replace-all (:: System separator) "/" post)] - (if (text.starts-with? "/" raw) - (text.clip' 1 raw) - (#.Some raw))) - - _ - #.None)) diff --git a/stdlib/source/lux/platform/compiler/meta/io/context.lux b/stdlib/source/lux/platform/compiler/meta/io/context.lux deleted file mode 100644 index be72e4ccc..000000000 --- a/stdlib/source/lux/platform/compiler/meta/io/context.lux +++ /dev/null @@ -1,107 +0,0 @@ -(.module: - [lux (#- Module Code) - [control - monad - ["ex" exception (#+ Exception exception:)]] - [data - ["." error] - [text - format - ["." encoding]]] - [world - ["." file (#+ File)] - [binary (#+ Binary)]]] - ["." // (#+ Context Code) - [// - [archive - [descriptor (#+ Module)]] - ["//." // (#+ Input) - ["." host]]]]) - -(do-template [] - [(exception: #export ( {module Module}) - (ex.report ["Module" module]))] - - [cannot-find-module] - [cannot-read-module] - ) - -(type: #export Extension Text) - -(def: lux-extension - Extension - ".lux") - -(def: partial-host-extension - Extension - (`` (for {(~~ (static host.common-lisp)) ".cl" - (~~ (static host.js)) ".js" - (~~ (static host.jvm)) ".jvm" - (~~ (static host.lua)) ".lua" - (~~ (static host.php)) ".php" - (~~ (static host.python)) ".py" - (~~ (static host.r)) ".r" - (~~ (static host.ruby)) ".rb" - (~~ (static host.scheme)) ".scm"}))) - -(def: full-host-extension - Extension - (format partial-host-extension lux-extension)) - -(def: #export (file System context module) - (All [m] (-> (file.System m) Context Module File)) - (|> module - (//.sanitize System) - (format context (:: System separator)))) - -(def: (find-source-file System contexts module extension) - (All [!] - (-> (file.System !) (List Context) Module Extension - (! (Maybe File)))) - (case contexts - #.Nil - (:: (:: System &monad) wrap #.None) - - (#.Cons context contexts') - (do (:: System &monad) - [#let [file (format (..file System context module) extension)] - ? (file.exists? System file)] - (if ? - (wrap (#.Some file)) - (find-source-file System contexts' module extension))))) - -(def: (try System computations exception message) - (All [m a e] (-> (file.System m) (List (m (Maybe a))) (Exception e) e (m a))) - (case computations - #.Nil - (:: System throw exception message) - - (#.Cons computation computations') - (do (:: System &monad) - [outcome computation] - (case outcome - (#.Some output) - (wrap output) - - #.None - (try System computations' exception message))))) - -(def: #export (read System contexts module) - (All [!] - (-> (file.System !) (List Context) Module - (! Input))) - (let [find-source-file' (find-source-file System contexts module)] - (do (:: System &monad) - [file (try System - (list (find-source-file' ..full-host-extension) - (find-source-file' ..lux-extension)) - ..cannot-find-module [module]) - binary (:: System read file)] - (case (encoding.from-utf8 binary) - (#error.Success code) - (wrap {#////.module module - #////.file file - #////.code code}) - - (#error.Failure _) - (:: System throw ..cannot-read-module [module]))))) diff --git a/stdlib/source/lux/platform/compiler/name.lux b/stdlib/source/lux/platform/compiler/name.lux deleted file mode 100644 index 394bdb2db..000000000 --- a/stdlib/source/lux/platform/compiler/name.lux +++ /dev/null @@ -1,47 +0,0 @@ -(.module: - [lux #* - [data - ["." maybe] - ["." text - format]]]) - -(`` (template: (!sanitize char) - ("lux syntax char case!" char - [["*"] "_AS" - ["+"] "_PL" - ["-"] "_DS" - ["/"] "_SL" - ["\"] "_BS" - ["_"] "_US" - ["%"] "_PC" - ["$"] "_DL" - ["'"] "_QU" - ["`"] "_BQ" - ["@"] "_AT" - ["^"] "_CR" - ["&"] "_AA" - ["="] "_EQ" - ["!"] "_BG" - ["?"] "_QM" - [":"] "_CO" - ["."] "_PD" - [","] "_CM" - ["<"] "_LT" - [">"] "_GT" - ["~"] "_TI" - ["|"] "_PI"] - (text.from-code char)))) - -(def: #export (normalize name) - (-> Text Text) - (let [name/size (text.size name)] - (loop [idx 0 - output ""] - (if (n/< name/size idx) - (recur (inc idx) - (|> ("lux text char" name idx) !sanitize (format output))) - output)))) - -(def: #export (definition [module short]) - (-> Name Text) - (format (normalize module) "___" (normalize short))) diff --git a/stdlib/source/lux/platform/compiler/phase.lux b/stdlib/source/lux/platform/compiler/phase.lux deleted file mode 100644 index 66abcc6cd..000000000 --- a/stdlib/source/lux/platform/compiler/phase.lux +++ /dev/null @@ -1,115 +0,0 @@ -(.module: - [lux #* - [control - ["." state] - ["ex" exception (#+ Exception exception:)] - [monad (#+ do)]] - [data - ["." product] - ["." error (#+ Error) ("#/." functor)] - ["." text - format]] - [time - ["." instant] - ["." duration]] - ["." io] - [macro - ["s" syntax (#+ syntax:)]]]) - -(type: #export (Operation s o) - (state.State' Error s o)) - -(def: #export monad - (state.monad error.monad)) - -(type: #export (Phase s i o) - (-> i (Operation s o))) - -(def: #export (run' state operation) - (All [s o] - (-> s (Operation s o) (Error [s o]))) - (operation state)) - -(def: #export (run state operation) - (All [s o] - (-> s (Operation s o) (Error o))) - (|> state - operation - (:: error.monad map product.right))) - -(def: #export get-state - (All [s o] - (Operation s s)) - (function (_ state) - (#error.Success [state state]))) - -(def: #export (set-state state) - (All [s o] - (-> s (Operation s Any))) - (function (_ _) - (#error.Success [state []]))) - -(def: #export (sub [get set] operation) - (All [s s' o] - (-> [(-> s s') (-> s' s s)] - (Operation s' o) - (Operation s o))) - (function (_ state) - (do error.monad - [[state' output] (operation (get state))] - (wrap [(set state' state) output])))) - -(def: #export fail - (-> Text Operation) - (|>> error.fail (state.lift error.monad))) - -(def: #export (throw exception parameters) - (All [e] (-> (Exception e) e Operation)) - (state.lift error.monad - (ex.throw exception parameters))) - -(def: #export (lift error) - (All [s a] (-> (Error a) (Operation s a))) - (function (_ state) - (error/map (|>> [state]) error))) - -(syntax: #export (assert exception message test) - (wrap (list (` (if (~ test) - (:: ..monad (~' wrap) []) - (..throw (~ exception) (~ message))))))) - -(def: #export (with-stack exception message action) - (All [e s o] (-> (Exception e) e (Operation s o) (Operation s o))) - (<<| (ex.with-stack exception message) - action)) - -(def: #export identity - (All [s a] (Phase s a a)) - (function (_ input state) - (#error.Success [state input]))) - -(def: #export (compose pre post) - (All [s0 s1 i t o] - (-> (Phase s0 i t) - (Phase s1 t o) - (Phase [s0 s1] i o))) - (function (_ input [pre/state post/state]) - (do error.monad - [[pre/state' temp] (pre input pre/state) - [post/state' output] (post temp post/state)] - (wrap [[pre/state' post/state'] output])))) - -(def: #export (timed definition description operation) - (All [s a] - (-> Name Text (Operation s a) (Operation s a))) - (do ..monad - [_ (wrap []) - #let [pre (io.run instant.now)] - output operation - #let [_ (log! (|> instant.now - io.run - instant.relative - (duration.difference (instant.relative pre)) - %duration - (format (%name definition) " [" description "]: ")))]] - (wrap output))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis.lux b/stdlib/source/lux/platform/compiler/phase/analysis.lux deleted file mode 100644 index 845346482..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis.lux +++ /dev/null @@ -1,349 +0,0 @@ -(.module: - [lux (#- nat int rev) - [control - [monad (#+ do)]] - [data - ["." product] - ["." error] - ["." maybe] - ["." text ("#/." equivalence) - format] - [collection - ["." list ("#/." functor fold)]]] - ["." function]] - [// - ["." extension (#+ Extension)] - [// - ["." reference (#+ Register Variable Reference)]]]) - -(type: #export #rec Primitive - #Unit - (#Bit Bit) - (#Nat Nat) - (#Int Int) - (#Rev Rev) - (#Frac Frac) - (#Text Text)) - -(type: #export Tag Nat) - -(type: #export (Variant a) - {#lefts Nat - #right? Bit - #value a}) - -(type: #export (Tuple a) (List a)) - -(type: #export (Composite a) - (#Variant (Variant a)) - (#Tuple (Tuple a))) - -(type: #export #rec Pattern - (#Simple Primitive) - (#Complex (Composite Pattern)) - (#Bind Register)) - -(type: #export (Branch' e) - {#when Pattern - #then e}) - -(type: #export (Match' e) - [(Branch' e) (List (Branch' e))]) - -(type: #export Environment - (List Variable)) - -(type: #export #rec Analysis - (#Primitive Primitive) - (#Structure (Composite Analysis)) - (#Reference Reference) - (#Case Analysis (Match' Analysis)) - (#Function Environment Analysis) - (#Apply Analysis Analysis) - (#Extension (Extension Analysis))) - -(type: #export Branch - (Branch' Analysis)) - -(type: #export Match - (Match' Analysis)) - -(do-template [ ] - [(template: #export ( content) - ( content))] - - [control/case #..Case] - ) - -(do-template [ ] - [(def: #export - (-> Analysis) - (|>> #..Primitive))] - - [bit Bit #..Bit] - [nat Nat #..Nat] - [int Int #..Int] - [rev Rev #..Rev] - [frac Frac #..Frac] - [text Text #..Text] - ) - -(type: #export Arity Nat) - -(type: #export (Abstraction c) [Environment Arity c]) - -(type: #export (Application c) [c (List c)]) - -(def: (last? size tag) - (-> Nat Tag Bit) - (n/= (dec size) tag)) - -(template: #export (no-op value) - (|> 1 #reference.Local #reference.Variable #..Reference - (#..Function (list)) - (#..Apply value))) - -(def: #export (apply [abstraction inputs]) - (-> (Application Analysis) Analysis) - (list/fold (function (_ input abstraction') - (#Apply input abstraction')) - abstraction - inputs)) - -(def: #export (application analysis) - (-> Analysis (Application Analysis)) - (loop [abstraction analysis - inputs (list)] - (case abstraction - (#Apply input next) - (recur next (#.Cons input inputs)) - - _ - [abstraction inputs]))) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Reference - - content))] - - [variable #reference.Variable] - [constant #reference.Constant] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Complex - - content))] - - [pattern/variant #..Variant] - [pattern/tuple #..Tuple] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Structure - - content))] - - [variant #..Variant] - [tuple #..Tuple] - ) - -(template: #export (pattern/unit) - (#..Simple #..Unit)) - -(do-template [ ] - [(template: #export ( content) - (#..Simple ( content)))] - - [pattern/bit #..Bit] - [pattern/nat #..Nat] - [pattern/int #..Int] - [pattern/rev #..Rev] - [pattern/frac #..Frac] - [pattern/text #..Text] - ) - -(template: #export (pattern/bind register) - (#..Bind register)) - -(def: #export (%analysis analysis) - (Format Analysis) - (case analysis - (#Primitive primitive) - (case primitive - #Unit - "[]" - - (^template [ ] - ( value) - ( value)) - ([#Bit %b] - [#Nat %n] - [#Int %i] - [#Rev %r] - [#Frac %f] - [#Text %t])) - - (#Structure structure) - (case structure - (#Variant [lefts right? value]) - (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")") - - (#Tuple members) - (|> members - (list/map %analysis) - (text.join-with " ") - (text.enclose ["[" "]"]))) - - (#Reference reference) - (case reference - (#reference.Variable variable) - (reference.%variable variable) - - (#reference.Constant constant) - (%name constant)) - - (#Case analysis match) - "{?}" - - (#Function environment body) - (|> (%analysis body) - (format " ") - (format (|> environment - (list/map reference.%variable) - (text.join-with " ") - (text.enclose ["[" "]"]))) - (text.enclose ["(" ")"])) - - (#Apply _) - (|> analysis - ..application - #.Cons - (list/map %analysis) - (text.join-with " ") - (text.enclose ["(" ")"])) - - (#Extension name parameters) - (|> parameters - (list/map %analysis) - (text.join-with " ") - (format (%t name) " ") - (text.enclose ["(" ")"])))) - -(do-template [ ] - [(type: #export - ( .Lux Code Analysis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (with-source-code source action) - (All [a] (-> Source (Operation a) (Operation a))) - (function (_ [bundle state]) - (let [old-source (get@ #.source state)] - (case (action [bundle (set@ #.source source state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set@ #.source old-source state')] - output]) - - (#error.Failure error) - (#error.Failure error))))) - -(def: fresh-bindings - (All [k v] (Bindings k v)) - {#.counter 0 - #.mappings (list)}) - -(def: fresh-scope - Scope - {#.name (list) - #.inner 0 - #.locals fresh-bindings - #.captured fresh-bindings}) - -(def: #export (with-scope action) - (All [a] (-> (Operation a) (Operation [Scope a]))) - (function (_ [bundle state]) - (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh-scope)) state)]) - (#error.Success [[bundle' state'] output]) - (case (get@ #.scopes state') - (#.Cons head tail) - (#error.Success [[bundle' (set@ #.scopes tail state')] - [head output]]) - - #.Nil - (#error.Failure "Impossible error: Drained scopes!")) - - (#error.Failure error) - (#error.Failure error)))) - -(def: #export (with-current-module name) - (All [a] (-> Text (Operation a) (Operation a))) - (extension.localized (get@ #.current-module) - (set@ #.current-module) - (function.constant (#.Some name)))) - -(def: #export (with-cursor cursor action) - (All [a] (-> Cursor (Operation a) (Operation a))) - (if (text/= "" (product.left cursor)) - action - (function (_ [bundle state]) - (let [old-cursor (get@ #.cursor state)] - (case (action [bundle (set@ #.cursor cursor state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set@ #.cursor old-cursor state')] - output]) - - (#error.Failure error) - (#error.Failure (format "@ " (%cursor cursor) text.new-line - error))))))) - -(do-template [ ] - [(def: #export ( value) - (-> (Operation Any)) - (extension.update (set@ )))] - - [set-source-code Source #.source value] - [set-current-module Text #.current-module (#.Some value)] - [set-cursor Cursor #.cursor value] - ) - -(def: #export (cursor file) - (-> Text Cursor) - [file 1 0]) - -(def: #export (source file code) - (-> Text Text Source) - [(cursor file) 0 code]) - -(def: dummy-source - Source - [.dummy-cursor 0 ""]) - -(def: type-context - Type-Context - {#.ex-counter 0 - #.var-counter 0 - #.var-bindings (list)}) - -(def: #export (state info host) - (-> Info Any Lux) - {#.info info - #.source ..dummy-source - #.cursor .dummy-cursor - #.current-module #.None - #.modules (list) - #.scopes (list) - #.type-context ..type-context - #.expected #.None - #.seed 0 - #.scope-type-vars (list) - #.extensions [] - #.host host}) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/case.lux b/stdlib/source/lux/platform/compiler/phase/analysis/case.lux deleted file mode 100644 index 37bcfef6e..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/case.lux +++ /dev/null @@ -1,300 +0,0 @@ -(.module: - [lux (#- case) - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." product] - ["." error] - ["." maybe] - [text - format] - [collection - ["." list ("#/." fold monoid functor)]]] - ["." type - ["." check]] - ["." macro - ["." code]]] - ["." // (#+ Pattern Analysis Operation Phase) - ["." scope] - ["//." type] - ["." structure] - ["/." // - ["." extension]]] - [/ - ["." coverage (#+ Coverage)]]) - -(exception: #export (cannot-match-with-pattern {type Type} {pattern Code}) - (ex.report ["Type" (%type type)] - ["Pattern" (%code pattern)])) - -(exception: #export (sum-has-no-case {case Nat} {type Type}) - (ex.report ["Case" (%n case)] - ["Type" (%type type)])) - -(exception: #export (not-a-pattern {code Code}) - (ex.report ["Code" (%code code)])) - -(exception: #export (cannot-simplify-for-pattern-matching {type Type}) - (ex.report ["Type" (%type type)])) - -(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage}) - (ex.report ["Input" (%code input)] - ["Branches" (%code (code.record branches))] - ["Coverage" (coverage.%coverage coverage)])) - -(exception: #export (cannot-have-empty-branches {message Text}) - message) - -(def: (re-quantify envs baseT) - (-> (List (List Type)) Type Type) - (.case envs - #.Nil - baseT - - (#.Cons head tail) - (re-quantify tail (#.UnivQ head baseT)))) - -## Type-checking on the input value is done during the analysis of a -## "case" expression, to ensure that the patterns being used make -## sense for the type of the input value. -## Sometimes, that input value is complex, by depending on -## type-variables or quantifications. -## This function makes it easier for "case" analysis to properly -## type-check the input with respect to the patterns. -(def: (simplify-case caseT) - (-> Type (Operation Type)) - (loop [envs (: (List (List Type)) - (list)) - caseT caseT] - (.case caseT - (#.Var id) - (do ///.monad - [?caseT' (//type.with-env - (check.read id))] - (.case ?caseT' - (#.Some caseT') - (recur envs caseT') - - _ - (///.throw cannot-simplify-for-pattern-matching caseT))) - - (#.Named name unnamedT) - (recur envs unnamedT) - - (#.UnivQ env unquantifiedT) - (recur (#.Cons env envs) unquantifiedT) - - (#.ExQ _) - (do ///.monad - [[ex-id exT] (//type.with-env - check.existential)] - (recur envs (maybe.assume (type.apply (list exT) caseT)))) - - (#.Apply inputT funcT) - (.case funcT - (#.Var funcT-id) - (do ///.monad - [funcT' (//type.with-env - (do check.monad - [?funct' (check.read funcT-id)] - (.case ?funct' - (#.Some funct') - (wrap funct') - - _ - (check.throw cannot-simplify-for-pattern-matching caseT))))] - (recur envs (#.Apply inputT funcT'))) - - _ - (.case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur envs outputT) - - #.None - (///.throw cannot-simplify-for-pattern-matching caseT))) - - (#.Product _) - (|> caseT - type.flatten-tuple - (list/map (re-quantify envs)) - type.tuple - (:: ///.monad wrap)) - - _ - (:: ///.monad wrap (re-quantify envs caseT))))) - -(def: (analyse-primitive type inputT cursor output next) - (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) - (//.with-cursor cursor - (do ///.monad - [_ (//type.with-env - (check.check inputT type)) - outputA next] - (wrap [output outputA])))) - -## This function handles several concerns at once, but it must be that -## way because those concerns are interleaved when doing -## pattern-matching and they cannot be separated. -## The pattern is analysed in order to get a general feel for what is -## expected of the input value. This, in turn, informs the -## type-checking of the input. -## A kind of "continuation" value is passed around which signifies -## what needs to be done _after_ analysing a pattern. -## In general, this is done to analyse the "body" expression -## associated to a particular pattern _in the context of_ said -## pattern. -## The reason why *context* is important is because patterns may bind -## values to local variables, which may in turn be referenced in the -## body expressions. -## That is why the body must be analysed in the context of the -## pattern, and not separately. -(def: (analyse-pattern num-tags inputT pattern next) - (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - (.case pattern - [cursor (#.Identifier ["" name])] - (//.with-cursor cursor - (do ///.monad - [outputA (scope.with-local [name inputT] - next) - idx scope.next-local] - (wrap [(#//.Bind idx) outputA]))) - - (^template [ ] - [cursor ] - (analyse-primitive inputT cursor (#//.Simple ) next)) - ([Bit (#.Bit pattern-value) (#//.Bit pattern-value)] - [Nat (#.Nat pattern-value) (#//.Nat pattern-value)] - [Int (#.Int pattern-value) (#//.Int pattern-value)] - [Rev (#.Rev pattern-value) (#//.Rev pattern-value)] - [Frac (#.Frac pattern-value) (#//.Frac pattern-value)] - [Text (#.Text pattern-value) (#//.Text pattern-value)] - [Any (#.Tuple #.Nil) #//.Unit]) - - (^ [cursor (#.Tuple (list singleton))]) - (analyse-pattern #.None inputT singleton next) - - [cursor (#.Tuple sub-patterns)] - (//.with-cursor cursor - (do ///.monad - [inputT' (simplify-case inputT)] - (.case inputT' - (#.Product _) - (let [subs (type.flatten-tuple inputT') - num-subs (maybe.default (list.size subs) - num-tags) - num-sub-patterns (list.size sub-patterns) - matches (cond (n/< num-subs num-sub-patterns) - (let [[prefix suffix] (list.split (dec num-sub-patterns) subs)] - (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) - - (n/> num-subs num-sub-patterns) - (let [[prefix suffix] (list.split (dec num-subs) sub-patterns)] - (list.zip2 subs (list/compose prefix (list (code.tuple suffix))))) - - ## (n/= num-subs num-sub-patterns) - (list.zip2 subs sub-patterns))] - (do @ - [[memberP+ thenA] (list/fold (: (All [a] - (-> [Type Code] (Operation [(List Pattern) a]) - (Operation [(List Pattern) a]))) - (function (_ [memberT memberC] then) - (do @ - [[memberP [memberP+ thenA]] ((:coerce (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) - analyse-pattern) - #.None memberT memberC then)] - (wrap [(list& memberP memberP+) thenA])))) - (do @ - [nextA next] - (wrap [(list) nextA])) - (list.reverse matches))] - (wrap [(//.pattern/tuple memberP+) - thenA]))) - - _ - (///.throw cannot-match-with-pattern [inputT pattern]) - ))) - - [cursor (#.Record record)] - (do ///.monad - [record (structure.normalize record) - [members recordT] (structure.order record) - _ (//type.with-env - (check.check inputT recordT))] - (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next)) - - [cursor (#.Tag tag)] - (//.with-cursor cursor - (analyse-pattern #.None inputT (` ((~ pattern))) next)) - - (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) - (//.with-cursor cursor - (do ///.monad - [inputT' (simplify-case inputT)] - (.case inputT' - (#.Sum _) - (let [flat-sum (type.flatten-variant inputT') - size-sum (list.size flat-sum) - num-cases (maybe.default size-sum num-tags)] - (.case (list.nth idx flat-sum) - (^multi (#.Some caseT) - (n/< num-cases idx)) - (do ///.monad - [[testP nextA] (if (and (n/> num-cases size-sum) - (n/= (dec num-cases) idx)) - (analyse-pattern #.None - (type.variant (list.drop (dec num-cases) flat-sum)) - (` [(~+ values)]) - next) - (analyse-pattern #.None caseT (` [(~+ values)]) next)) - #let [right? (n/= (dec num-cases) idx) - lefts (if right? - (dec idx) - idx)]] - (wrap [(//.pattern/variant [lefts right? testP]) - nextA])) - - _ - (///.throw sum-has-no-case [idx inputT]))) - - _ - (///.throw cannot-match-with-pattern [inputT pattern])))) - - (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) - (//.with-cursor cursor - (do ///.monad - [tag (extension.lift (macro.normalize tag)) - [idx group variantT] (extension.lift (macro.resolve-tag tag)) - _ (//type.with-env - (check.check inputT variantT))] - (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) - - _ - (///.throw not-a-pattern pattern) - )) - -(def: #export (case analyse inputC branches) - (-> Phase Code (List [Code Code]) (Operation Analysis)) - (.case branches - (#.Cons [patternH bodyH] branchesT) - (do ///.monad - [[inputT inputA] (//type.with-inference - (analyse inputC)) - outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) - outputT (monad.map @ - (function (_ [patternT bodyT]) - (analyse-pattern #.None inputT patternT (analyse bodyT))) - branchesT) - outputHC (|> outputH product.left coverage.determine) - outputTC (monad.map @ (|>> product.left coverage.determine) outputT) - _ (.case (monad.fold error.monad coverage.merge outputHC outputTC) - (#error.Success coverage) - (///.assert non-exhaustive-pattern-matching [inputC branches coverage] - (coverage.exhaustive? coverage)) - - (#error.Failure error) - (///.fail error))] - (wrap (#//.Case inputA [outputH outputT]))) - - #.Nil - (///.throw cannot-have-empty-branches ""))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux deleted file mode 100644 index cd6ccd83d..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux +++ /dev/null @@ -1,366 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)] - equivalence] - [data - ["." bit ("#/." equivalence)] - ["." number] - ["." error (#+ Error) ("#/." monad)] - ["." maybe] - ["." text - format] - [collection - ["." list ("#/." functor fold)] - ["." dictionary (#+ Dictionary)]]]] - ["." //// ("#/." monad)] - ["." /// (#+ Pattern Variant Operation)]) - -(exception: #export (invalid-tuple-pattern) - "Tuple size must be >= 2") - -(def: cases - (-> (Maybe Nat) Nat) - (|>> (maybe.default 0))) - -(def: known-cases? - (-> Nat Bit) - (n/> 0)) - -## The coverage of a pattern-matching expression summarizes how well -## all the possible values of an input are being covered by the -## different patterns involved. -## Ideally, the pattern-matching has "exhaustive" coverage, which just -## means that every possible value can be matched by at least 1 -## pattern. -## Every other coverage is considered partial, and it would be valued -## as insuficient (since it could lead to runtime errors due to values -## not being handled by any pattern). -## The #Partial tag covers arbitrary partial coverages in a general -## way, while the other tags cover more specific cases for bits -## and variants. -(type: #export #rec Coverage - #Partial - (#Bit Bit) - (#Variant (Maybe Nat) (Dictionary Nat Coverage)) - (#Seq Coverage Coverage) - (#Alt Coverage Coverage) - #Exhaustive) - -(def: #export (exhaustive? coverage) - (-> Coverage Bit) - (case coverage - (#Exhaustive _) - #1 - - _ - #0)) - -(def: #export (%coverage value) - (Format Coverage) - (case value - #Partial - "#Partial" - - (#Bit value') - (|> value' - %b - (text.enclose ["(#Bit " ")"])) - - (#Variant ?max-cases cases) - (|> cases - dictionary.entries - (list/map (function (_ [idx coverage]) - (format (%n idx) " " (%coverage coverage)))) - (text.join-with " ") - (text.enclose ["{" "}"]) - (format (%n (..cases ?max-cases)) " ") - (text.enclose ["(#Variant " ")"])) - - (#Seq left right) - (format "(#Seq " (%coverage left) " " (%coverage right) ")") - - (#Alt left right) - (format "(#Alt " (%coverage left) " " (%coverage right) ")") - - #Exhaustive - "#Exhaustive")) - -(def: #export (determine pattern) - (-> Pattern (Operation Coverage)) - (case pattern - (^or (#///.Simple #///.Unit) - (#///.Bind _)) - (/////wrap #Exhaustive) - - ## Primitive patterns always have partial coverage because there - ## are too many possibilities as far as values go. - (^template [] - (#///.Simple ( _)) - (/////wrap #Partial)) - ([#///.Nat] - [#///.Int] - [#///.Rev] - [#///.Frac] - [#///.Text]) - - ## Bits are the exception, since there is only "#1" and - ## "#0", which means it is possible for bit - ## pattern-matching to become exhaustive if complementary parts meet. - (#///.Simple (#///.Bit value)) - (/////wrap (#Bit value)) - - ## Tuple patterns can be exhaustive if there is exhaustiveness for all of - ## their sub-patterns. - (#///.Complex (#///.Tuple membersP+)) - (case (list.reverse membersP+) - (^or #.Nil (#.Cons _ #.Nil)) - (////.throw invalid-tuple-pattern []) - - (#.Cons lastP prevsP+) - (do ////.monad - [lastC (determine lastP)] - (monad.fold ////.monad - (function (_ leftP rightC) - (do ////.monad - [leftC (determine leftP)] - (case rightC - #Exhaustive - (wrap leftC) - - _ - (wrap (#Seq leftC rightC))))) - lastC prevsP+))) - - ## Variant patterns can be shown to be exhaustive if all the possible - ## cases are handled exhaustively. - (#///.Complex (#///.Variant [lefts right? value])) - (do ////.monad - [value-coverage (determine value) - #let [idx (if right? - (inc lefts) - lefts)]] - (wrap (#Variant (if right? - (#.Some idx) - #.None) - (|> (dictionary.new number.hash) - (dictionary.put idx value-coverage))))))) - -(def: (xor left right) - (-> Bit Bit Bit) - (or (and left (not right)) - (and (not left) right))) - -## The coverage checker not only verifies that pattern-matching is -## exhaustive, but also that there are no redundant patterns. -## Redundant patterns will never be executed, since there will -## always be a pattern prior to them that would match the input. -## Because of that, the presence of redundant patterns is assumed to -## be a bug, likely due to programmer carelessness. -(exception: #export (redundant-pattern {so-far Coverage} {addition Coverage}) - (ex.report ["Coverage so-far" (%coverage so-far)] - ["Coverage addition" (%coverage addition)])) - -(def: (flatten-alt coverage) - (-> Coverage (List Coverage)) - (case coverage - (#Alt left right) - (list& left (flatten-alt right)) - - _ - (list coverage))) - -(structure: _ (Equivalence Coverage) - (def: (= reference sample) - (case [reference sample] - [#Exhaustive #Exhaustive] - #1 - - [(#Bit sideR) (#Bit sideS)] - (bit/= sideR sideS) - - [(#Variant allR casesR) (#Variant allS casesS)] - (and (n/= (cases allR) - (cases allS)) - (:: (dictionary.equivalence =) = casesR casesS)) - - [(#Seq leftR rightR) (#Seq leftS rightS)] - (and (= leftR leftS) - (= rightR rightS)) - - [(#Alt _) (#Alt _)] - (let [flatR (flatten-alt reference) - flatS (flatten-alt sample)] - (and (n/= (list.size flatR) (list.size flatS)) - (list.every? (function (_ [coverageR coverageS]) - (= coverageR coverageS)) - (list.zip2 flatR flatS)))) - - _ - #0))) - -(open: "coverage/." ..equivalence) - -(exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat}) - (ex.report ["So-far Cases" (%n so-far-cases)] - ["Addition Cases" (%n addition-cases)])) - -## After determining the coverage of each individual pattern, it is -## necessary to merge them all to figure out if the entire -## pattern-matching expression is exhaustive and whether it contains -## redundant patterns. -(def: #export (merge addition so-far) - (-> Coverage Coverage (Error Coverage)) - (case [addition so-far] - [#Partial #Partial] - (error/wrap #Partial) - - ## 2 bit coverages are exhaustive if they complement one another. - (^multi [(#Bit sideA) (#Bit sideSF)] - (xor sideA sideSF)) - (error/wrap #Exhaustive) - - [(#Variant allA casesA) (#Variant allSF casesSF)] - (let [addition-cases (cases allSF) - so-far-cases (cases allA)] - (cond (and (known-cases? addition-cases) - (known-cases? so-far-cases) - (not (n/= addition-cases so-far-cases))) - (ex.throw variants-do-not-match [addition-cases so-far-cases]) - - (:: (dictionary.equivalence ..equivalence) = casesSF casesA) - (ex.throw redundant-pattern [so-far addition]) - - ## else - (do error.monad - [casesM (monad.fold @ - (function (_ [tagA coverageA] casesSF') - (case (dictionary.get tagA casesSF') - (#.Some coverageSF) - (do @ - [coverageM (merge coverageA coverageSF)] - (wrap (dictionary.put tagA coverageM casesSF'))) - - #.None - (wrap (dictionary.put tagA coverageA casesSF')))) - casesSF (dictionary.entries casesA))] - (wrap (if (and (or (known-cases? addition-cases) - (known-cases? so-far-cases)) - (n/= (inc (n/max addition-cases so-far-cases)) - (dictionary.size casesM)) - (list.every? exhaustive? (dictionary.values casesM))) - #Exhaustive - (#Variant (case allSF - (#.Some _) - allSF - - _ - allA) - casesM)))))) - - [(#Seq leftA rightA) (#Seq leftSF rightSF)] - (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] - ## Same prefix - [#1 #0] - (do error.monad - [rightM (merge rightA rightSF)] - (if (exhaustive? rightM) - ## If all that follows is exhaustive, then it can be safely dropped - ## (since only the "left" part would influence whether the - ## merged coverage is exhaustive or not). - (wrap leftSF) - (wrap (#Seq leftSF rightM)))) - - ## Same suffix - [#0 #1] - (do error.monad - [leftM (merge leftA leftSF)] - (wrap (#Seq leftM rightA))) - - ## The 2 sequences cannot possibly be merged. - [#0 #0] - (error/wrap (#Alt so-far addition)) - - ## There is nothing the addition adds to the coverage. - [#1 #1] - (ex.throw redundant-pattern [so-far addition])) - - ## The addition cannot possibly improve the coverage. - [_ #Exhaustive] - (ex.throw redundant-pattern [so-far addition]) - - ## The addition completes the coverage. - [#Exhaustive _] - (error/wrap #Exhaustive) - - ## The left part will always match, so the addition is redundant. - (^multi [(#Seq left right) single] - (coverage/= left single)) - (ex.throw redundant-pattern [so-far addition]) - - ## The right part is not necessary, since it can always match the left. - (^multi [single (#Seq left right)] - (coverage/= left single)) - (error/wrap single) - - ## When merging a new coverage against one based on Alt, it may be - ## that one of the many coverages in the Alt is complementary to - ## the new one, so effort must be made to fuse carefully, to match - ## the right coverages together. - ## If one of the Alt sub-coverages matches the new one, the cycle - ## must be repeated, in case the resulting coverage can now match - ## other ones in the original Alt. - ## This process must be repeated until no further productive - ## merges can be done. - [_ (#Alt leftS rightS)] - (do error.monad - [#let [fuse-once (: (-> Coverage (List Coverage) - (Error [(Maybe Coverage) - (List Coverage)])) - (function (_ coverageA possibilitiesSF) - (loop [altsSF possibilitiesSF] - (case altsSF - #.Nil - (wrap [#.None (list coverageA)]) - - (#.Cons altSF altsSF') - (case (merge coverageA altSF) - (#error.Success altMSF) - (case altMSF - (#Alt _) - (do @ - [[success altsSF+] (recur altsSF')] - (wrap [success (#.Cons altSF altsSF+)])) - - _ - (wrap [(#.Some altMSF) altsSF'])) - - (#error.Failure error) - (error.fail error)) - ))))] - [successA possibilitiesSF] (fuse-once addition (flatten-alt so-far))] - (loop [successA successA - possibilitiesSF possibilitiesSF] - (case successA - (#.Some coverageA') - (do @ - [[successA' possibilitiesSF'] (fuse-once coverageA' possibilitiesSF)] - (recur successA' possibilitiesSF')) - - #.None - (case (list.reverse possibilitiesSF) - (#.Cons last prevs) - (wrap (list/fold (function (_ left right) (#Alt left right)) - last - prevs)) - - #.Nil - (undefined))))) - - _ - (if (coverage/= so-far addition) - ## The addition cannot possibly improve the coverage. - (ex.throw redundant-pattern [so-far addition]) - ## There are now 2 alternative paths. - (error/wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux b/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux deleted file mode 100644 index 3ce70fe9b..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux +++ /dev/null @@ -1,109 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." error] - [text - format]] - ["." macro]] - ["." // (#+ Analysis Operation Phase) - ["." type] - ["." primitive] - ["." structure] - ["//." reference] - ["." case] - ["." function] - ["//." macro] - ["/." // - ["." extension] - [// - ["." reference]]]]) - -(exception: #export (unrecognized-syntax {code Code}) - (ex.report ["Code" (%code code)])) - -(def: #export (compile code) - Phase - (do ///.monad - [expectedT (extension.lift macro.expected-type)] - (let [[cursor code'] code] - ## The cursor must be set in the state for the sake - ## of having useful error messages. - (//.with-cursor cursor - (case code' - (^template [ ] - ( value) - ( value)) - ([#.Bit primitive.bit] - [#.Nat primitive.nat] - [#.Int primitive.int] - [#.Rev primitive.rev] - [#.Frac primitive.frac] - [#.Text primitive.text]) - - (^template [ ] - (^ (#.Form (list& [_ ( tag)] - values))) - (case values - (#.Cons value #.Nil) - ( compile tag value) - - _ - ( compile tag (` [(~+ values)])))) - ([#.Nat structure.sum] - [#.Tag structure.tagged-sum]) - - (#.Tag tag) - (structure.tagged-sum compile tag (' [])) - - (^ (#.Tuple (list))) - primitive.unit - - (^ (#.Tuple (list singleton))) - (compile singleton) - - (^ (#.Tuple elems)) - (structure.product compile elems) - - (^ (#.Record pairs)) - (structure.record compile pairs) - - (#.Identifier reference) - (//reference.reference reference) - - (^ (#.Form (list [_ (#.Record branches)] input))) - (case.case compile input branches) - - (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) - (extension.apply "Analysis" compile [extension-name extension-args]) - - (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] - [_ (#.Identifier ["" arg-name])]))] - body))) - (function.function compile function-name arg-name body) - - (^ (#.Form (list& functionC argsC+))) - (do @ - [[functionT functionA] (type.with-inference - (compile functionC))] - (case functionA - (#//.Reference (#reference.Constant def-name)) - (do @ - [?macro (extension.lift (macro.find-macro def-name))] - (case ?macro - (#.Some macro) - (do @ - [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] - (compile expansion)) - - _ - (function.apply compile functionT functionA argsC+))) - - _ - (function.apply compile functionT functionA argsC+))) - - _ - (///.throw unrecognized-syntax code) - ))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/function.lux b/stdlib/source/lux/platform/compiler/phase/analysis/function.lux deleted file mode 100644 index cbea165f8..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/function.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux (#- function) - [control - monad - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - format] - [collection - ["." list ("#/." fold monoid monad)]]] - ["." type - ["." check]] - ["." macro]] - ["." // (#+ Analysis Operation Phase) - ["." scope] - ["//." type] - ["." inference] - ["/." // - ["." extension]]]) - -(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) - (ex.report ["Type" (%type expected)] - ["Function" function] - ["Argument" argument] - ["Body" (%code body)])) - -(exception: #export (cannot-apply {function Type} {arguments (List Code)}) - (ex.report ["Function" (%type function)] - ["Arguments" (|> arguments - list.enumerate - (list/map (.function (_ [idx argC]) - (format text.new-line " " (%n idx) " " (%code argC)))) - (text.join-with ""))])) - -(def: #export (function analyse function-name arg-name body) - (-> Phase Text Text Code (Operation Analysis)) - (do ///.monad - [functionT (extension.lift macro.expected-type)] - (loop [expectedT functionT] - (///.with-stack cannot-analyse [expectedT function-name arg-name body] - (case expectedT - (#.Named name unnamedT) - (recur unnamedT) - - (#.Apply argT funT) - (case (type.apply (list argT) funT) - (#.Some value) - (recur value) - - #.None - (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) - - (^template [ ] - ( _) - (do @ - [[_ instanceT] (//type.with-env )] - (recur (maybe.assume (type.apply (list instanceT) expectedT))))) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Var id) - (do @ - [?expectedT' (//type.with-env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (recur expectedT') - - ## Inference - _ - (do @ - [[input-id inputT] (//type.with-env check.var) - [output-id outputT] (//type.with-env check.var) - #let [functionT (#.Function inputT outputT)] - functionA (recur functionT) - _ (//type.with-env - (check.check expectedT functionT))] - (wrap functionA)) - )) - - (#.Function inputT outputT) - (<| (:: @ map (.function (_ [scope bodyA]) - (#//.Function (scope.environment scope) bodyA))) - //.with-scope - ## Functions have access not only to their argument, but - ## also to themselves, through a local variable. - (scope.with-local [function-name expectedT]) - (scope.with-local [arg-name inputT]) - (//type.with-type outputT) - (analyse body)) - - _ - (///.fail "") - ))))) - -(def: #export (apply analyse functionT functionA argsC+) - (-> Phase Type Analysis (List Code) (Operation Analysis)) - (<| (///.with-stack cannot-apply [functionT argsC+]) - (do ///.monad - [[applyT argsA+] (inference.general analyse functionT argsC+)]) - (wrap (//.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux b/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux deleted file mode 100644 index 4ce9c6985..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux +++ /dev/null @@ -1,259 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - format] - [collection - ["." list ("#/." functor)]]] - ["." type - ["." check]] - ["." macro]] - ["." /// ("#/." monad) - ["." extension]] - [// (#+ Tag Analysis Operation Phase)] - ["." //type]) - -(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) - (ex.report ["Tag" (%n tag)] - ["Variant size" (%i (.int size))] - ["Variant type" (%type type)])) - -(exception: #export (cannot-infer {type Type} {args (List Code)}) - (ex.report ["Type" (%type type)] - ["Arguments" (|> args - list.enumerate - (list/map (function (_ [idx argC]) - (format text.new-line " " (%n idx) " " (%code argC)))) - (text.join-with ""))])) - -(exception: #export (cannot-infer-argument {inferred Type} {argument Code}) - (ex.report ["Inferred Type" (%type inferred)] - ["Argument" (%code argument)])) - -(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) - (ex.report ["Expected" (%i (.int expected))] - ["Actual" (%i (.int actual))])) - -(do-template [] - [(exception: #export ( {type Type}) - (%type type))] - - [not-a-variant-type] - [not-a-record-type] - [invalid-type-application] - ) - -(def: (replace parameter-idx replacement type) - (-> Nat Type Type Type) - (case type - (#.Primitive name params) - (#.Primitive name (list/map (replace parameter-idx replacement) params)) - - (^template [] - ( left right) - ( (replace parameter-idx replacement left) - (replace parameter-idx replacement right))) - ([#.Sum] - [#.Product] - [#.Function] - [#.Apply]) - - (#.Parameter idx) - (if (n/= parameter-idx idx) - replacement - type) - - (^template [] - ( env quantified) - ( (list/map (replace parameter-idx replacement) env) - (replace (n/+ 2 parameter-idx) replacement quantified))) - ([#.UnivQ] - [#.ExQ]) - - _ - type)) - -(def: (named-type cursor id) - (-> Cursor Nat Type) - (let [name (format "{New Type @ " (.cursor-description cursor) " " (%n id) "}")] - (#.Primitive name (list)))) - -(def: new-named-type - (Operation Type) - (do ///.monad - [cursor (extension.lift macro.cursor) - [ex-id _] (//type.with-env check.existential)] - (wrap (named-type cursor ex-id)))) - -## Type-inference works by applying some (potentially quantified) type -## to a sequence of values. -## Function types are used for this, although inference is not always -## done for function application (alternative uses may be records and -## tagged variants). -## But, so long as the type being used for the inference can be treated -## as a function type, this method of inference should work. -(def: #export (general analyse inferT args) - (-> Phase Type (List Code) (Operation [Type (List Analysis)])) - (case args - #.Nil - (do ///.monad - [_ (//type.infer inferT)] - (wrap [inferT (list)])) - - (#.Cons argC args') - (case inferT - (#.Named name unnamedT) - (general analyse unnamedT args) - - (#.UnivQ _) - (do ///.monad - [[var-id varT] (//type.with-env check.var)] - (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) - - (#.ExQ _) - (do ///.monad - [[var-id varT] (//type.with-env check.var) - output (general analyse - (maybe.assume (type.apply (list varT) inferT)) - args) - bound? (//type.with-env - (check.bound? var-id)) - _ (if bound? - (wrap []) - (do @ - [newT new-named-type] - (//type.with-env - (check.check varT newT))))] - (wrap output)) - - (#.Apply inputT transT) - (case (type.apply (list inputT) transT) - (#.Some outputT) - (general analyse outputT args) - - #.None - (///.throw invalid-type-application inferT)) - - ## Arguments are inferred back-to-front because, by convention, - ## Lux functions take the most important arguments *last*, which - ## means that the most information for doing proper inference is - ## located in the last arguments to a function call. - ## By inferring back-to-front, a lot of type-annotations can be - ## avoided in Lux code, since the inference algorithm can piece - ## things together more easily. - (#.Function inputT outputT) - (do ///.monad - [[outputT' args'A] (general analyse outputT args') - argA (<| (///.with-stack cannot-infer-argument [inputT argC]) - (//type.with-type inputT) - (analyse argC))] - (wrap [outputT' (list& argA args'A)])) - - (#.Var infer-id) - (do ///.monad - [?inferT' (//type.with-env (check.read infer-id))] - (case ?inferT' - (#.Some inferT') - (general analyse inferT' args) - - _ - (///.throw cannot-infer [inferT args]))) - - _ - (///.throw cannot-infer [inferT args])) - )) - -## Turns a record type into the kind of function type suitable for inference. -(def: #export (record inferT) - (-> Type (Operation Type)) - (case inferT - (#.Named name unnamedT) - (record unnamedT) - - (^template [] - ( env bodyT) - (do ///.monad - [bodyT+ (record bodyT)] - (wrap ( env bodyT+)))) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (record outputT) - - #.None - (///.throw invalid-type-application inferT)) - - (#.Product _) - (////wrap (type.function (type.flatten-tuple inferT) inferT)) - - _ - (///.throw not-a-record-type inferT))) - -## Turns a variant type into the kind of function type suitable for inference. -(def: #export (variant tag expected-size inferT) - (-> Nat Nat Type (Operation Type)) - (loop [depth 0 - currentT inferT] - (case currentT - (#.Named name unnamedT) - (do ///.monad - [unnamedT+ (recur depth unnamedT)] - (wrap unnamedT+)) - - (^template [] - ( env bodyT) - (do ///.monad - [bodyT+ (recur (inc depth) bodyT)] - (wrap ( env bodyT+)))) - ([#.UnivQ] - [#.ExQ]) - - (#.Sum _) - (let [cases (type.flatten-variant currentT) - actual-size (list.size cases) - boundary (dec expected-size)] - (cond (or (n/= expected-size actual-size) - (and (n/> expected-size actual-size) - (n/< boundary tag))) - (case (list.nth tag cases) - (#.Some caseT) - (////wrap (if (n/= 0 depth) - (type.function (list caseT) currentT) - (let [replace' (replace (|> depth dec (n/* 2)) inferT)] - (type.function (list (replace' caseT)) - (replace' currentT))))) - - #.None - (///.throw variant-tag-out-of-bounds [expected-size tag inferT])) - - (n/< expected-size actual-size) - (///.throw smaller-variant-than-expected [expected-size actual-size]) - - (n/= boundary tag) - (let [caseT (type.variant (list.drop boundary cases))] - (////wrap (if (n/= 0 depth) - (type.function (list caseT) currentT) - (let [replace' (replace (|> depth dec (n/* 2)) inferT)] - (type.function (list (replace' caseT)) - (replace' currentT)))))) - - ## else - (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (variant tag expected-size outputT) - - #.None - (///.throw invalid-type-application inferT)) - - _ - (///.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux b/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux deleted file mode 100644 index 18455b837..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - ["." text - format] - [collection - [array (#+ Array)] - ["." list ("#/." functor)]]] - ["." macro] - ["." host (#+ import:)]] - ["." ///]) - -(exception: #export (expansion-failed {macro Name} {inputs (List Code)} {error Text}) - (ex.report ["Macro" (%name macro)] - ["Inputs" (|> inputs - (list/map (|>> %code (format text.new-line text.tab))) - (text.join-with ""))] - ["Error" error])) - -(exception: #export (must-have-single-expansion {macro Name} {inputs (List Code)}) - (ex.report ["Macro" (%name macro)] - ["Inputs" (|> inputs - (list/map (|>> %code (format text.new-line text.tab))) - (text.join-with ""))])) - -(import: java/lang/reflect/Method - (invoke [Object (Array Object)] #try Object)) - -(import: (java/lang/Class c) - (getMethod [String (Array (Class Object))] #try Method)) - -(import: java/lang/Object - (getClass [] (Class Object))) - -(def: _object-class - (Class Object) - (host.class-for Object)) - -(def: _apply-args - (Array (Class Object)) - (|> (host.array (Class Object) 2) - (host.array-write 0 _object-class) - (host.array-write 1 _object-class))) - -(def: #export (expand name macro inputs) - (-> Name Macro (List Code) (Meta (List Code))) - (function (_ state) - (do error.monad - [apply-method (|> macro - (:coerce Object) - (Object::getClass) - (Class::getMethod "apply" _apply-args)) - output (Method::invoke (:coerce Object macro) - (|> (host.array Object 2) - (host.array-write 0 (:coerce Object inputs)) - (host.array-write 1 (:coerce Object state))) - apply-method)] - (case (:coerce (Error [Lux (List Code)]) - output) - (#error.Success output) - (#error.Success output) - - (#error.Failure error) - ((///.throw expansion-failed [name inputs error]) state))))) - -(def: #export (expand-one name macro inputs) - (-> Name Macro (List Code) (Meta Code)) - (do macro.monad - [expansion (expand name macro inputs)] - (case expansion - (^ (list single)) - (wrap single) - - _ - (///.throw must-have-single-expansion [name inputs])))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/module.lux b/stdlib/source/lux/platform/compiler/phase/analysis/module.lux deleted file mode 100644 index 29865f352..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/module.lux +++ /dev/null @@ -1,255 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." text ("#/." equivalence) - format] - ["." error] - [collection - ["." list ("#/." fold functor)] - [dictionary - ["." plist]]]] - ["." macro]] - ["." // (#+ Operation) - ["/." // - ["." extension]]]) - -(type: #export Tag Text) - -(exception: #export (unknown-module {module Text}) - (ex.report ["Module" module])) - -(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) - (ex.report ["Module" module] - ["Tag" tag])) - -(do-template [] - [(exception: #export ( {tags (List Text)} {owner Type}) - (ex.report ["Tags" (text.join-with " " tags)] - ["Type" (%type owner)]))] - - [cannot-declare-tags-for-unnamed-type] - [cannot-declare-tags-for-foreign-type] - ) - -(exception: #export (cannot-define-more-than-once {name Name}) - (ex.report ["Definition" (%name name)])) - -(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) - (ex.report ["Module" module] - ["Desired state" (case state - #.Active "Active" - #.Compiled "Compiled" - #.Cached "Cached")])) - -(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) - (ex.report ["Module" module] - ["Old annotations" (%code old)] - ["New annotations" (%code new)])) - -(def: #export (new hash) - (-> Nat Module) - {#.module-hash hash - #.module-aliases (list) - #.definitions (list) - #.imports (list) - #.tags (list) - #.types (list) - #.module-annotations #.None - #.module-state #.Active}) - -(def: #export (set-annotations annotations) - (-> Code (Operation Any)) - (do ///.monad - [self-name (extension.lift macro.current-module-name) - self (extension.lift macro.current-module)] - (case (get@ #.module-annotations self) - #.None - (extension.lift - (function (_ state) - (#error.Success [(update@ #.modules - (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) - state) - []]))) - - (#.Some old) - (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) - -(def: #export (import module) - (-> Text (Operation Any)) - (do ///.monad - [self-name (extension.lift macro.current-module-name)] - (extension.lift - (function (_ state) - (#error.Success [(update@ #.modules - (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) - state) - []]))))) - -(def: #export (alias alias module) - (-> Text Text (Operation Any)) - (do ///.monad - [self-name (extension.lift macro.current-module-name)] - (extension.lift - (function (_ state) - (#error.Success [(update@ #.modules - (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) - (|>> (#.Cons [alias module]))))) - state) - []]))))) - -(def: #export (exists? module) - (-> Text (Operation Bit)) - (extension.lift - (function (_ state) - (|> state - (get@ #.modules) - (plist.get module) - (case> (#.Some _) #1 #.None #0) - [state] #error.Success)))) - -(def: #export (define name definition) - (-> Text Definition (Operation Any)) - (do ///.monad - [self-name (extension.lift macro.current-module-name) - self (extension.lift macro.current-module)] - (extension.lift - (function (_ state) - (case (plist.get name (get@ #.definitions self)) - #.None - (#error.Success [(update@ #.modules - (plist.put self-name - (update@ #.definitions - (: (-> (List [Text Definition]) (List [Text Definition])) - (|>> (#.Cons [name definition]))) - self)) - state) - []]) - - (#.Some already-existing) - ((///.throw cannot-define-more-than-once [self-name name]) state)))))) - -(def: #export (create hash name) - (-> Nat Text (Operation Any)) - (extension.lift - (function (_ state) - (let [module (new hash)] - (#error.Success [(update@ #.modules - (plist.put name module) - state) - []]))))) - -(def: #export (with-module hash name action) - (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) - (do ///.monad - [_ (create hash name) - output (//.with-current-module name - action) - module (extension.lift (macro.find-module name))] - (wrap [module output]))) - -(do-template [ ] - [(def: #export ( module-name) - (-> Text (Operation Any)) - (extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module-name)) - (#.Some module) - (let [active? (case (get@ #.module-state module) - #.Active #1 - _ #0)] - (if active? - (#error.Success [(update@ #.modules - (plist.put module-name (set@ #.module-state module)) - state) - []]) - ((///.throw can-only-change-state-of-active-module [module-name ]) - state))) - - #.None - ((///.throw unknown-module module-name) state))))) - - (def: #export ( module-name) - (-> Text (Operation Bit)) - (extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module-name)) - (#.Some module) - (#error.Success [state - (case (get@ #.module-state module) - #1 - _ #0)]) - - #.None - ((///.throw unknown-module module-name) state)))))] - - [set-active active? #.Active] - [set-compiled compiled? #.Compiled] - [set-cached cached? #.Cached] - ) - -(do-template [ ] - [(def: ( module-name) - (-> Text (Operation )) - (extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get module-name)) - (#.Some module) - (#error.Success [state (get@ module)]) - - #.None - ((///.throw unknown-module module-name) state)))))] - - [tags #.tags (List [Text [Nat (List Name) Bit Type]])] - [types #.types (List [Text [(List Name) Bit Type]])] - [hash #.module-hash Nat] - ) - -(def: (ensure-undeclared-tags module-name tags) - (-> Text (List Tag) (Operation Any)) - (do ///.monad - [bindings (..tags module-name) - _ (monad.map @ - (function (_ tag) - (case (plist.get tag bindings) - #.None - (wrap []) - - (#.Some _) - (///.throw cannot-declare-tag-twice [module-name tag]))) - tags)] - (wrap []))) - -(def: #export (declare-tags tags exported? type) - (-> (List Tag) Bit Type (Operation Any)) - (do ///.monad - [self-name (extension.lift macro.current-module-name) - [type-module type-name] (case type - (#.Named type-name _) - (wrap type-name) - - _ - (///.throw cannot-declare-tags-for-unnamed-type [tags type])) - _ (ensure-undeclared-tags self-name tags) - _ (///.assert cannot-declare-tags-for-foreign-type [tags type] - (text/= self-name type-module))] - (extension.lift - (function (_ state) - (case (|> state (get@ #.modules) (plist.get self-name)) - (#.Some module) - (let [namespaced-tags (list/map (|>> [self-name]) tags)] - (#error.Success [(update@ #.modules - (plist.update self-name - (|>> (update@ #.tags (function (_ tag-bindings) - (list/fold (function (_ [idx tag] table) - (plist.put tag [idx namespaced-tags exported? type] table)) - tag-bindings - (list.enumerate tags)))) - (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) - state) - []])) - #.None - ((///.throw unknown-module self-name) state)))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux b/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux deleted file mode 100644 index b46983293..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux +++ /dev/null @@ -1,29 +0,0 @@ -(.module: - [lux (#- nat int rev) - [control - monad]] - ["." // (#+ Analysis Operation) - [".A" type] - ["/." //]]) - -## [Analysers] -(do-template [ ] - [(def: #export ( value) - (-> (Operation Analysis)) - (do ///.monad - [_ (typeA.infer )] - (wrap (#//.Primitive ( value)))))] - - [bit Bit #//.Bit] - [nat Nat #//.Nat] - [int Int #//.Int] - [rev Rev #//.Rev] - [frac Frac #//.Frac] - [text Text #//.Text] - ) - -(def: #export unit - (Operation Analysis) - (do ///.monad - [_ (typeA.infer Any)] - (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux b/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux deleted file mode 100644 index 5969b9f5c..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - [lux #* - [control - monad - ["ex" exception (#+ exception:)]] - ["." macro] - [data - ["." text ("#/." equivalence) - format]]] - ["." // (#+ Analysis Operation) - ["." scope] - ["." type] - ["/." // - ["." extension] - [// - ["." reference]]]]) - -(exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text}) - (ex.report ["Current" current] - ["Foreign" foreign])) - -(exception: #export (definition-has-not-been-expored {definition Name}) - (ex.report ["Definition" (%name definition)])) - -## [Analysers] -(def: (definition def-name) - (-> Name (Operation Analysis)) - (with-expansions [ (wrap (|> def-name reference.constant #//.Reference))] - (do ///.monad - [[actualT def-anns _] (extension.lift (macro.find-def def-name))] - (case (macro.get-identifier-ann (name-of #.alias) def-anns) - (#.Some real-def-name) - (definition real-def-name) - - _ - (do @ - [_ (type.infer actualT) - (^@ def-name [::module ::name]) (extension.lift (macro.normalize def-name)) - current (extension.lift macro.current-module-name)] - (if (text/= current ::module) - - (if (macro.export? def-anns) - (do @ - [imported! (extension.lift (macro.imported-by? ::module current))] - (if imported! - - (///.throw foreign-module-has-not-been-imported [current ::module]))) - (///.throw definition-has-not-been-expored def-name)))))))) - -(def: (variable var-name) - (-> Text (Operation (Maybe Analysis))) - (do ///.monad - [?var (scope.find var-name)] - (case ?var - (#.Some [actualT ref]) - (do @ - [_ (type.infer actualT)] - (wrap (#.Some (|> ref reference.variable #//.Reference)))) - - #.None - (wrap #.None)))) - -(def: #export (reference reference) - (-> Name (Operation Analysis)) - (case reference - ["" simple-name] - (do ///.monad - [?var (variable simple-name)] - (case ?var - (#.Some varA) - (wrap varA) - - #.None - (do @ - [this-module (extension.lift macro.current-module-name)] - (definition [this-module simple-name])))) - - _ - (definition reference))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux b/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux deleted file mode 100644 index 69d7c80a9..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux +++ /dev/null @@ -1,206 +0,0 @@ -(.module: - [lux #* - [control - monad - ["ex" exception (#+ exception:)]] - [data - ["." text ("#/." equivalence) - format] - ["." maybe ("#/." monad)] - ["." product] - ["e" error] - [collection - ["." list ("#/." functor fold monoid)] - [dictionary - ["." plist]]]]] - [// (#+ Operation Phase) - ["/." // - ["." extension] - [// - ["." reference (#+ Register Variable)]]]]) - -(type: Local (Bindings Text [Type Register])) -(type: Foreign (Bindings Text [Type Variable])) - -(def: (local? name scope) - (-> Text Scope Bit) - (|> scope - (get@ [#.locals #.mappings]) - (plist.contains? name))) - -(def: (local name scope) - (-> Text Scope (Maybe [Type Variable])) - (|> scope - (get@ [#.locals #.mappings]) - (plist.get name) - (maybe/map (function (_ [type value]) - [type (#reference.Local value)])))) - -(def: (captured? name scope) - (-> Text Scope Bit) - (|> scope - (get@ [#.captured #.mappings]) - (plist.contains? name))) - -(def: (captured name scope) - (-> Text Scope (Maybe [Type Variable])) - (loop [idx 0 - mappings (get@ [#.captured #.mappings] scope)] - (case mappings - (#.Cons [_name [_source-type _source-ref]] mappings') - (if (text/= name _name) - (#.Some [_source-type (#reference.Foreign idx)]) - (recur (inc idx) mappings')) - - #.Nil - #.None))) - -(def: (reference? name scope) - (-> Text Scope Bit) - (or (local? name scope) - (captured? name scope))) - -(def: (reference name scope) - (-> Text Scope (Maybe [Type Variable])) - (case (..local name scope) - (#.Some type) - (#.Some type) - - _ - (..captured name scope))) - -(def: #export (find name) - (-> Text (Operation (Maybe [Type Variable]))) - (extension.lift - (function (_ state) - (let [[inner outer] (|> state - (get@ #.scopes) - (list.split-with (|>> (reference? name) not)))] - (case outer - #.Nil - (#.Right [state #.None]) - - (#.Cons top-outer _) - (let [[ref-type init-ref] (maybe.default (undefined) - (..reference name top-outer)) - [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) - (function (_ scope ref+inner) - [(#reference.Foreign (get@ [#.captured #.counter] scope)) - (#.Cons (update@ #.captured - (: (-> Foreign Foreign) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)])))) - scope) - (product.right ref+inner))])) - [init-ref #.Nil] - (list.reverse inner)) - scopes (list/compose inner' outer)] - (#.Right [(set@ #.scopes scopes state) - (#.Some [ref-type ref])])) - ))))) - -(exception: #export (cannot-create-local-binding-without-a-scope) - "") - -(exception: #export (invalid-scope-alteration) - "") - -(def: #export (with-local [name type] action) - (All [a] (-> [Text Type] (Operation a) (Operation a))) - (function (_ [bundle state]) - (case (get@ #.scopes state) - (#.Cons head tail) - (let [old-mappings (get@ [#.locals #.mappings] head) - new-var-id (get@ [#.locals #.counter] head) - new-head (update@ #.locals - (: (-> Local Local) - (|>> (update@ #.counter inc) - (update@ #.mappings (plist.put name [type new-var-id])))) - head)] - (case (///.run' [bundle (set@ #.scopes (#.Cons new-head tail) state)] - action) - (#e.Success [[bundle' state'] output]) - (case (get@ #.scopes state') - (#.Cons head' tail') - (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') - tail')] - (#e.Success [[bundle' (set@ #.scopes scopes' state')] - output])) - - _ - (ex.throw invalid-scope-alteration [])) - - (#e.Failure error) - (#e.Failure error))) - - _ - (ex.throw cannot-create-local-binding-without-a-scope [])) - )) - -(do-template [ ] - [(def: - (Bindings Text [Type ]) - {#.counter 0 - #.mappings (list)})] - - [init-locals Nat] - [init-captured Variable] - ) - -(def: (scope parent-name child-name) - (-> (List Text) Text Scope) - {#.name (list& child-name parent-name) - #.inner 0 - #.locals init-locals - #.captured init-captured}) - -(def: #export (with-scope name action) - (All [a] (-> Text (Operation a) (Operation a))) - (function (_ [bundle state]) - (let [parent-name (case (get@ #.scopes state) - #.Nil - (list) - - (#.Cons top _) - (get@ #.name top))] - (case (action [bundle (update@ #.scopes - (|>> (#.Cons (scope parent-name name))) - state)]) - (#e.Success [[bundle' state'] output]) - (#e.Success [[bundle' (update@ #.scopes - (|>> list.tail (maybe.default (list))) - state')] - output]) - - (#e.Failure error) - (#e.Failure error))) - )) - -(exception: #export (cannot-get-next-reference-when-there-is-no-scope) - "") - -(def: #export next-local - (Operation Register) - (extension.lift - (function (_ state) - (case (get@ #.scopes state) - (#.Cons top _) - (#e.Success [state (get@ [#.locals #.counter] top)]) - - #.Nil - (ex.throw cannot-get-next-reference-when-there-is-no-scope []))))) - -(def: (ref-to-variable ref) - (-> Ref Variable) - (case ref - (#.Local register) - (#reference.Local register) - - (#.Captured register) - (#reference.Foreign register))) - -(def: #export (environment scope) - (-> Scope (List Variable)) - (|> scope - (get@ [#.captured #.mappings]) - (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux b/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux deleted file mode 100644 index 6991c67f7..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux +++ /dev/null @@ -1,358 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)] - ["." state]] - [data - ["." name] - ["." number] - ["." product] - ["." maybe] - ["." error] - [text - format] - [collection - ["." list ("#/." functor)] - ["dict" dictionary (#+ Dictionary)]]] - ["." type - ["." check]] - ["." macro - ["." code]]] - ["." // (#+ Tag Analysis Operation Phase) - ["//." type] - ["." primitive] - ["." inference] - ["/." // - ["." extension]]]) - -(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) - (ex.report ["Type" (%type type)] - ["Tag" (%n tag)] - ["Expression" (%code code)])) - -(do-template [] - [(exception: #export ( {type Type} {members (List Code)}) - (ex.report ["Type" (%type type)] - ["Expression" (%code (` [(~+ members)]))]))] - - [invalid-tuple-type] - [cannot-analyse-tuple] - ) - -(exception: #export (not-a-quantified-type {type Type}) - (%type type)) - -(do-template [] - [(exception: #export ( {type Type} {tag Tag} {code Code}) - (ex.report ["Type" (%type type)] - ["Tag" (%n tag)] - ["Expression" (%code code)]))] - - [cannot-analyse-variant] - [cannot-infer-numeric-tag] - ) - -(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])}) - (ex.report ["Key" (%code key)] - ["Record" (%code (code.record record))])) - -(do-template [] - [(exception: #export ( {key Name} {record (List [Name Code])}) - (ex.report ["Tag" (%code (code.tag key))] - ["Record" (%code (code.record (list/map (function (_ [keyI valC]) - [(code.tag keyI) valC]) - record)))]))] - - [cannot-repeat-tag] - ) - -(exception: #export (tag-does-not-belong-to-record {key Name} {type Type}) - (ex.report ["Tag" (%code (code.tag key))] - ["Type" (%type type)])) - -(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) - (ex.report ["Expected" (|> expected .int %i)] - ["Actual" (|> actual .int %i)] - ["Type" (%type type)] - ["Expression" (%code (|> record - (list/map (function (_ [keyI valueC]) - [(code.tag keyI) valueC])) - code.record))])) - -(def: #export (sum analyse tag valueC) - (-> Phase Nat Code (Operation Analysis)) - (do ///.monad - [expectedT (extension.lift macro.expected-type)] - (///.with-stack cannot-analyse-variant [expectedT tag valueC] - (case expectedT - (#.Sum _) - (let [flat (type.flatten-variant expectedT) - type-size (list.size flat) - right? (n/= (dec type-size) - tag) - lefts (if right? - (dec tag) - tag)] - (case (list.nth tag flat) - (#.Some variant-type) - (do @ - [valueA (//type.with-type variant-type - (analyse valueC))] - (wrap (//.variant [lefts right? valueA]))) - - #.None - (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) - - (#.Named name unnamedT) - (//type.with-type unnamedT - (sum analyse tag valueC)) - - (#.Var id) - (do @ - [?expectedT' (//type.with-env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (//type.with-type expectedT' - (sum analyse tag valueC)) - - _ - ## Cannot do inference when the tag is numeric. - ## This is because there is no way of knowing how many - ## cases the inferred sum type would have. - (///.throw cannot-infer-numeric-tag [expectedT tag valueC]) - )) - - (^template [ ] - ( _) - (do @ - [[instance-id instanceT] (//type.with-env )] - (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) - (sum analyse tag valueC)))) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT-id) - (do @ - [?funT' (//type.with-env (check.read funT-id))] - (case ?funT' - (#.Some funT') - (//type.with-type (#.Apply inputT funT') - (sum analyse tag valueC)) - - _ - (///.throw invalid-variant-type [expectedT tag valueC]))) - - _ - (case (type.apply (list inputT) funT) - (#.Some outputT) - (//type.with-type outputT - (sum analyse tag valueC)) - - #.None - (///.throw not-a-quantified-type funT))) - - _ - (///.throw invalid-variant-type [expectedT tag valueC]))))) - -(def: (typed-product analyse members) - (-> Phase (List Code) (Operation Analysis)) - (do ///.monad - [expectedT (extension.lift macro.expected-type) - membersA+ (: (Operation (List Analysis)) - (loop [membersT+ (type.flatten-tuple expectedT) - membersC+ members] - (case [membersT+ membersC+] - [(#.Cons memberT #.Nil) _] - (//type.with-type memberT - (:: @ map (|>> list) (analyse (code.tuple membersC+)))) - - [_ (#.Cons memberC #.Nil)] - (//type.with-type (type.tuple membersT+) - (:: @ map (|>> list) (analyse memberC))) - - [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] - (do @ - [memberA (//type.with-type memberT - (analyse memberC)) - memberA+ (recur membersT+' membersC+')] - (wrap (#.Cons memberA memberA+))) - - _ - (///.throw cannot-analyse-tuple [expectedT members]))))] - (wrap (//.tuple membersA+)))) - -(def: #export (product analyse membersC) - (-> Phase (List Code) (Operation Analysis)) - (do ///.monad - [expectedT (extension.lift macro.expected-type)] - (///.with-stack cannot-analyse-tuple [expectedT membersC] - (case expectedT - (#.Product _) - (..typed-product analyse membersC) - - (#.Named name unnamedT) - (//type.with-type unnamedT - (product analyse membersC)) - - (#.Var id) - (do @ - [?expectedT' (//type.with-env - (check.read id))] - (case ?expectedT' - (#.Some expectedT') - (//type.with-type expectedT' - (product analyse membersC)) - - _ - ## Must do inference... - (do @ - [membersTA (monad.map @ (|>> analyse //type.with-inference) - membersC) - _ (//type.with-env - (check.check expectedT - (type.tuple (list/map product.left membersTA))))] - (wrap (//.tuple (list/map product.right membersTA)))))) - - (^template [ ] - ( _) - (do @ - [[instance-id instanceT] (//type.with-env )] - (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) - (product analyse membersC)))) - ([#.UnivQ check.existential] - [#.ExQ check.var]) - - (#.Apply inputT funT) - (case funT - (#.Var funT-id) - (do @ - [?funT' (//type.with-env (check.read funT-id))] - (case ?funT' - (#.Some funT') - (//type.with-type (#.Apply inputT funT') - (product analyse membersC)) - - _ - (///.throw invalid-tuple-type [expectedT membersC]))) - - _ - (case (type.apply (list inputT) funT) - (#.Some outputT) - (//type.with-type outputT - (product analyse membersC)) - - #.None - (///.throw not-a-quantified-type funT))) - - _ - (///.throw invalid-tuple-type [expectedT membersC]) - )))) - -(def: #export (tagged-sum analyse tag valueC) - (-> Phase Name Code (Operation Analysis)) - (do ///.monad - [tag (extension.lift (macro.normalize tag)) - [idx group variantT] (extension.lift (macro.resolve-tag tag)) - expectedT (extension.lift macro.expected-type)] - (case expectedT - (#.Var _) - (do @ - [#let [case-size (list.size group)] - inferenceT (inference.variant idx case-size variantT) - [inferredT valueA+] (inference.general analyse inferenceT (list valueC)) - #let [right? (n/= (dec case-size) idx) - lefts (if right? - (dec idx) - idx)]] - (wrap (//.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) - - _ - (..sum analyse idx valueC)))) - -## There cannot be any ambiguity or improper syntax when analysing -## records, so they must be normalized for further analysis. -## Normalization just means that all the tags get resolved to their -## canonical form (with their corresponding module identified). -(def: #export (normalize record) - (-> (List [Code Code]) (Operation (List [Name Code]))) - (monad.map ///.monad - (function (_ [key val]) - (case key - [_ (#.Tag key)] - (do ///.monad - [key (extension.lift (macro.normalize key))] - (wrap [key val])) - - _ - (///.throw record-keys-must-be-tags [key record]))) - record)) - -## Lux already possesses the means to analyse tuples, so -## re-implementing the same functionality for records makes no sense. -## Records, thus, get transformed into tuples by ordering the elements. -(def: #export (order record) - (-> (List [Name Code]) (Operation [(List Code) Type])) - (case record - ## empty-record = empty-tuple = unit = [] - #.Nil - (:: ///.monad wrap [(list) Any]) - - (#.Cons [head-k head-v] _) - (do ///.monad - [head-k (extension.lift (macro.normalize head-k)) - [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) - #let [size-record (list.size record) - size-ts (list.size tag-set)] - _ (if (n/= size-ts size-record) - (wrap []) - (///.throw record-size-mismatch [size-ts size-record recordT record])) - #let [tuple-range (list.indices size-ts) - tag->idx (dict.from-list name.hash (list.zip2 tag-set tuple-range))] - idx->val (monad.fold @ - (function (_ [key val] idx->val) - (do @ - [key (extension.lift (macro.normalize key))] - (case (dict.get key tag->idx) - (#.Some idx) - (if (dict.contains? idx idx->val) - (///.throw cannot-repeat-tag [key record]) - (wrap (dict.put idx val idx->val))) - - #.None - (///.throw tag-does-not-belong-to-record [key recordT])))) - (: (Dictionary Nat Code) - (dict.new number.hash)) - record) - #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) - tuple-range)]] - (wrap [ordered-tuple recordT])) - )) - -(def: #export (record analyse members) - (-> Phase (List [Code Code]) (Operation Analysis)) - (do ///.monad - [members (normalize members) - [membersC recordT] (order members)] - (case membersC - (^ (list)) - primitive.unit - - (^ (list singletonC)) - (analyse singletonC) - - _ - (do @ - [expectedT (extension.lift macro.expected-type)] - (case expectedT - (#.Var _) - (do @ - [inferenceT (inference.record recordT) - [inferredT membersA] (inference.general analyse inferenceT membersC)] - (wrap (//.tuple membersA))) - - _ - (..product analyse membersC)))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/type.lux b/stdlib/source/lux/platform/compiler/phase/analysis/type.lux deleted file mode 100644 index 75d691628..000000000 --- a/stdlib/source/lux/platform/compiler/phase/analysis/type.lux +++ /dev/null @@ -1,52 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." error]] - ["." function] - [type - ["tc" check]] - ["." macro]] - [// (#+ Operation) - ["/." // - ["." extension]]]) - -(def: #export (with-type expected) - (All [a] (-> Type (Operation a) (Operation a))) - (extension.localized (get@ #.expected) (set@ #.expected) - (function.constant (#.Some expected)))) - -(def: #export (with-env action) - (All [a] (-> (tc.Check a) (Operation a))) - (function (_ (^@ stateE [bundle state])) - (case (action (get@ #.type-context state)) - (#error.Success [context' output]) - (#error.Success [[bundle (set@ #.type-context context' state)] - output]) - - (#error.Failure error) - ((///.fail error) stateE)))) - -(def: #export with-fresh-env - (All [a] (-> (Operation a) (Operation a))) - (extension.localized (get@ #.type-context) (set@ #.type-context) - (function.constant tc.fresh-context))) - -(def: #export (infer actualT) - (-> Type (Operation Any)) - (do ///.monad - [expectedT (extension.lift macro.expected-type)] - (with-env - (tc.check expectedT actualT)))) - -(def: #export (with-inference action) - (All [a] (-> (Operation a) (Operation [Type a]))) - (do ///.monad - [[_ varT] (..with-env - tc.var) - output (with-type varT - action) - knownT (..with-env - (tc.clean varT))] - (wrap [knownT output]))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension.lux b/stdlib/source/lux/platform/compiler/phase/extension.lux deleted file mode 100644 index 0d58cf37a..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension.lux +++ /dev/null @@ -1,140 +0,0 @@ -(.module: - [lux (#- Name) - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - ["." text ("#/." order) - format] - [collection - ["." list ("#/." functor)] - ["." dictionary (#+ Dictionary)]]] - ["." function]] - ["." //]) - -(type: #export Name Text) - -(type: #export (Extension i) - [Name (List i)]) - -(with-expansions [ (as-is (Dictionary Name (Handler s i o)))] - (type: #export (Handler s i o) - (-> Name - (//.Phase [ s] i o) - (//.Phase [ s] (List i) o))) - - (type: #export (Bundle s i o) - )) - -(type: #export (State s i o) - {#bundle (Bundle s i o) - #state s}) - -(type: #export (Operation s i o v) - (//.Operation (State s i o) v)) - -(type: #export (Phase s i o) - (//.Phase (State s i o) i o)) - -(do-template [] - [(exception: #export ( {name Name}) - (ex.report ["Extension" (%t name)]))] - - [cannot-overwrite] - [invalid-syntax] - ) - -(exception: #export [s i o] (unknown {where Text} {name Name} {bundle (Bundle s i o)}) - (ex.report ["Where" (%t where)] - ["Extension" (%t name)] - ["Available" (|> bundle - dictionary.keys - (list.sort text/<) - (list/map (|>> %t (format text.new-line text.tab))) - (text.join-with ""))])) - -(exception: #export (incorrect-arity {name Name} {arity Nat} {args Nat}) - (ex.report ["Extension" (%t name)] - ["Expected" (%n arity)] - ["Actual" (%n args)])) - -(def: #export (install name handler) - (All [s i o] - (-> Text (Handler s i o) (Operation s i o Any))) - (function (_ [bundle state]) - (case (dictionary.get name bundle) - #.None - (#error.Success [[(dictionary.put name handler bundle) state] - []]) - - _ - (ex.throw cannot-overwrite name)))) - -(def: #export (apply where phase [name parameters]) - (All [s i o] - (-> Text (Phase s i o) (Extension i) (Operation s i o o))) - (function (_ (^@ stateE [bundle state])) - (case (dictionary.get name bundle) - (#.Some handler) - (((handler name phase) parameters) - stateE) - - #.None - (ex.throw unknown [where name bundle])))) - -(def: #export (localized get set transform) - (All [s s' i o v] - (-> (-> s s') (-> s' s s) (-> s' s') - (-> (Operation s i o v) (Operation s i o v)))) - (function (_ operation) - (function (_ [bundle state]) - (let [old (get state)] - (case (operation [bundle (set (transform old) state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set old state')] output]) - - (#error.Failure error) - (#error.Failure error)))))) - -(def: #export (temporary transform) - (All [s i o v] - (-> (-> s s) - (-> (Operation s i o v) (Operation s i o v)))) - (function (_ operation) - (function (_ [bundle state]) - (case (operation [bundle (transform state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' state] output]) - - (#error.Failure error) - (#error.Failure error))))) - -(def: #export (with-state state) - (All [s i o v] - (-> s (-> (Operation s i o v) (Operation s i o v)))) - (..temporary (function.constant state))) - -(def: #export (read get) - (All [s i o v] - (-> (-> s v) (Operation s i o v))) - (function (_ [bundle state]) - (#error.Success [[bundle state] (get state)]))) - -(def: #export (update transform) - (All [s i o] - (-> (-> s s) (Operation s i o Any))) - (function (_ [bundle state]) - (#error.Success [[bundle (transform state)] []]))) - -(def: #export (lift action) - (All [s i o v] - (-> (//.Operation s v) - (//.Operation [(Bundle s i o) s] v))) - (function (_ [bundle state]) - (case (action state) - (#error.Success [state' output]) - (#error.Success [[bundle state'] output]) - - (#error.Failure error) - (#error.Failure error)))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis.lux deleted file mode 100644 index 3b31f3d46..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/analysis.lux +++ /dev/null @@ -1,18 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [/// - [analysis (#+ Bundle)] - [// - [default - [evaluation (#+ Eval)]]]] - [/ - ["." common] - ["." host]]) - -(def: #export (bundle eval) - (-> Eval Bundle) - (dictionary.merge host.bundle - (common.bundle eval))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux deleted file mode 100644 index fa9b36270..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux +++ /dev/null @@ -1,219 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)]] - [data - ["." text - format] - [collection - ["." list ("#/." functor)] - ["." dictionary (#+ Dictionary)]]] - [type - ["." check]] - ["." macro] - [io (#+ IO)]] - ["." /// - ["." bundle] - ["//." // - ["." analysis (#+ Analysis Handler Bundle) - [".A" type] - [".A" case] - [".A" function]] - [// - [default - [evaluation (#+ Eval)]]]]]) - -## [Utils] -(def: (simple inputsT+ outputT) - (-> (List Type) Type Handler) - (let [num-expected (list.size inputsT+)] - (function (_ extension-name analyse args) - (let [num-actual (list.size args)] - (if (n/= num-expected num-actual) - (do ////.monad - [_ (typeA.infer outputT) - argsA (monad.map @ - (function (_ [argT argC]) - (typeA.with-type argT - (analyse argC))) - (list.zip2 inputsT+ args))] - (wrap (#analysis.Extension extension-name argsA))) - (////.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) - -(def: #export (nullary valueT) - (-> Type Handler) - (simple (list) valueT)) - -(def: #export (unary inputT outputT) - (-> Type Type Handler) - (simple (list inputT) outputT)) - -(def: #export (binary subjectT paramT outputT) - (-> Type Type Type Handler) - (simple (list subjectT paramT) outputT)) - -(def: #export (trinary subjectT param0T param1T outputT) - (-> Type Type Type Type Handler) - (simple (list subjectT param0T param1T) outputT)) - -## [Analysers] -## "lux is" represents reference/pointer equality. -(def: lux::is - Handler - (function (_ extension-name analyse args) - (do ////.monad - [[var-id varT] (typeA.with-env check.var)] - ((binary varT varT Bit extension-name) - analyse args)))) - -## "lux try" provides a simple way to interact with the host platform's -## error-handling facilities. -(def: lux::try - Handler - (function (_ extension-name analyse args) - (case args - (^ (list opC)) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer (type (Either Text varT))) - opA (typeA.with-type (type (IO varT)) - (analyse opC))] - (wrap (#analysis.Extension extension-name (list opA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: lux::in-module - Handler - (function (_ extension-name analyse argsC+) - (case argsC+ - (^ (list [_ (#.Text module-name)] exprC)) - (analysis.with-current-module module-name - (analyse exprC)) - - _ - (////.throw ///.invalid-syntax [extension-name])))) - -(do-template [ ] - [(def: ( eval) - (-> Eval Handler) - (function (_ extension-name analyse args) - (case args - (^ (list typeC valueC)) - (do ////.monad - [count (///.lift macro.count) - actualT (:: @ map (|>> (:coerce Type)) - (eval count Type typeC)) - _ (typeA.infer actualT)] - (typeA.with-type - (analyse valueC))) - - _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] - - [lux::check actualT] - [lux::coerce Any] - ) - -(def: lux::check::type - Handler - (function (_ extension-name analyse args) - (case args - (^ (list valueC)) - (do ////.monad - [_ (typeA.infer Type) - valueA (typeA.with-type Type - (analyse valueC))] - (wrap valueA)) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: (bundle::lux eval) - (-> Eval Bundle) - (|> bundle.empty - (bundle.install "is" lux::is) - (bundle.install "try" lux::try) - (bundle.install "check" (lux::check eval)) - (bundle.install "coerce" (lux::coerce eval)) - (bundle.install "check type" lux::check::type) - (bundle.install "in-module" lux::in-module))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary Text Any)) - (bundle.install "error" (unary Text Nothing)) - (bundle.install "exit" (unary Int Nothing)) - (bundle.install "current-time" (nullary Int))))) - -(def: I64* (type (I64 Any))) - -(def: bundle::i64 - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary I64* I64* I64)) - (bundle.install "or" (binary I64* I64* I64)) - (bundle.install "xor" (binary I64* I64* I64)) - (bundle.install "left-shift" (binary Nat I64* I64)) - (bundle.install "logical-right-shift" (binary Nat I64* I64)) - (bundle.install "arithmetic-right-shift" (binary Nat I64* I64)) - (bundle.install "+" (binary I64* I64* I64)) - (bundle.install "-" (binary I64* I64* I64)) - (bundle.install "=" (binary I64* I64* Bit))))) - -(def: bundle::int - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "*" (binary Int Int Int)) - (bundle.install "/" (binary Int Int Int)) - (bundle.install "%" (binary Int Int Int)) - (bundle.install "<" (binary Int Int Bit)) - (bundle.install "frac" (unary Int Frac)) - (bundle.install "char" (unary Int Text))))) - -(def: bundle::frac - Bundle - (<| (bundle.prefix "frac") - (|> bundle.empty - (bundle.install "+" (binary Frac Frac Frac)) - (bundle.install "-" (binary Frac Frac Frac)) - (bundle.install "*" (binary Frac Frac Frac)) - (bundle.install "/" (binary Frac Frac Frac)) - (bundle.install "%" (binary Frac Frac Frac)) - (bundle.install "=" (binary Frac Frac Bit)) - (bundle.install "<" (binary Frac Frac Bit)) - (bundle.install "smallest" (nullary Frac)) - (bundle.install "min" (nullary Frac)) - (bundle.install "max" (nullary Frac)) - (bundle.install "int" (unary Frac Int)) - (bundle.install "encode" (unary Frac Text)) - (bundle.install "decode" (unary Text (type (Maybe Frac))))))) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary Text Text Bit)) - (bundle.install "<" (binary Text Text Bit)) - (bundle.install "concat" (binary Text Text Text)) - (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) - (bundle.install "size" (unary Text Nat)) - (bundle.install "char" (binary Text Nat Nat)) - (bundle.install "clip" (trinary Text Nat Nat Text)) - ))) - -(def: #export (bundle eval) - (-> Eval Bundle) - (<| (bundle.prefix "lux") - (|> bundle.empty - (dictionary.merge (bundle::lux eval)) - (dictionary.merge bundle::i64) - (dictionary.merge bundle::int) - (dictionary.merge bundle::frac) - (dictionary.merge bundle::text) - (dictionary.merge bundle::io) - ))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux deleted file mode 100644 index 0654e79c4..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux +++ /dev/null @@ -1,1271 +0,0 @@ -(.module: - [lux (#- char int) - [control - ["." monad (#+ do)] - ["p" parser] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." error (#+ Error)] - ["." maybe] - ["." product] - ["." text ("#/." equivalence) - format] - [collection - ["." list ("#/." fold functor monoid)] - ["." array (#+ Array)] - ["." dictionary (#+ Dictionary)]]] - ["." type - ["." check]] - ["." macro - ["s" syntax]] - ["." host (#+ import:)]] - [// - ["." common] - ["/." // - ["." bundle] - ["//." // ("#/." monad) - ["." analysis (#+ Analysis Operation Handler Bundle) - [".A" type] - [".A" inference]]]]] - ) - -(type: Method-Signature - {#method Type - #exceptions (List Type)}) - -(import: #long java/lang/reflect/Type - (getTypeName [] String)) - -(do-template [] - [(exception: #export ( {jvm-type java/lang/reflect/Type}) - (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] - - [jvm-type-is-not-a-class] - [cannot-convert-to-a-class] - [cannot-convert-to-a-parameter] - [cannot-convert-to-a-lux-type] - ) - -(do-template [] - [(exception: #export ( {type Type}) - (%type type))] - - [non-object] - [non-array] - [non-jvm-type] - ) - -(do-template [] - [(exception: #export ( {name Text}) - name)] - - [non-interface] - [non-throwable] - ) - -(do-template [] - [(exception: #export ( {message Text}) - message)] - - [unknown-class] - [primitives-cannot-have-type-parameters] - [primitives-are-not-objects] - [invalid-type-for-array-element] - - [unknown-field] - [mistaken-field-owner] - [not-a-virtual-field] - [not-a-static-field] - [cannot-set-a-final-field] - - [cannot-cast] - - [cannot-possibly-be-an-instance] - - [unknown-type-var] - [type-parameter-mismatch] - [cannot-correspond-type-with-a-class] - ) - -(do-template [] - [(exception: #export ( {class Text} - {method Text} - {hints (List Method-Signature)}) - (ex.report ["Class" class] - ["Method" method] - ["Hints" (|> hints - (list/map (|>> product.left %type (format text.new-line text.tab))) - (text.join-with ""))]))] - - [no-candidates] - [too-many-candidates] - ) - -(do-template [ ] - [(def: #export Type (#.Primitive (list)))] - - ## Boxes - [Boolean "java.lang.Boolean"] - [Byte "java.lang.Byte"] - [Short "java.lang.Short"] - [Integer "java.lang.Integer"] - [Long "java.lang.Long"] - [Float "java.lang.Float"] - [Double "java.lang.Double"] - [Character "java.lang.Character"] - [String "java.lang.String"] - - ## Primitives - [boolean "boolean"] - [byte "byte"] - [short "short"] - [int "int"] - [long "long"] - [float "float"] - [double "double"] - [char "char"] - ) - -(def: bundle::conversion - Bundle - (<| (bundle.prefix "convert") - (|> bundle.empty - (bundle.install "double-to-float" (common.unary Double Float)) - (bundle.install "double-to-int" (common.unary Double Integer)) - (bundle.install "double-to-long" (common.unary Double Long)) - (bundle.install "float-to-double" (common.unary Float Double)) - (bundle.install "float-to-int" (common.unary Float Integer)) - (bundle.install "float-to-long" (common.unary Float Long)) - (bundle.install "int-to-byte" (common.unary Integer Byte)) - (bundle.install "int-to-char" (common.unary Integer Character)) - (bundle.install "int-to-double" (common.unary Integer Double)) - (bundle.install "int-to-float" (common.unary Integer Float)) - (bundle.install "int-to-long" (common.unary Integer Long)) - (bundle.install "int-to-short" (common.unary Integer Short)) - (bundle.install "long-to-double" (common.unary Long Double)) - (bundle.install "long-to-float" (common.unary Long Float)) - (bundle.install "long-to-int" (common.unary Long Integer)) - (bundle.install "long-to-short" (common.unary Long Short)) - (bundle.install "long-to-byte" (common.unary Long Byte)) - (bundle.install "char-to-byte" (common.unary Character Byte)) - (bundle.install "char-to-short" (common.unary Character Short)) - (bundle.install "char-to-int" (common.unary Character Integer)) - (bundle.install "char-to-long" (common.unary Character Long)) - (bundle.install "byte-to-long" (common.unary Byte Long)) - (bundle.install "short-to-long" (common.unary Short Long)) - ))) - -(do-template [ ] - [(def: - Bundle - (<| (bundle.prefix ) - (|> bundle.empty - (bundle.install "+" (common.binary )) - (bundle.install "-" (common.binary )) - (bundle.install "*" (common.binary )) - (bundle.install "/" (common.binary )) - (bundle.install "%" (common.binary )) - (bundle.install "=" (common.binary Bit)) - (bundle.install "<" (common.binary Bit)) - (bundle.install "and" (common.binary )) - (bundle.install "or" (common.binary )) - (bundle.install "xor" (common.binary )) - (bundle.install "shl" (common.binary Integer )) - (bundle.install "shr" (common.binary Integer )) - (bundle.install "ushr" (common.binary Integer )) - )))] - - [bundle::int "int" Integer] - [bundle::long "long" Long] - ) - -(do-template [ ] - [(def: - Bundle - (<| (bundle.prefix ) - (|> bundle.empty - (bundle.install "+" (common.binary )) - (bundle.install "-" (common.binary )) - (bundle.install "*" (common.binary )) - (bundle.install "/" (common.binary )) - (bundle.install "%" (common.binary )) - (bundle.install "=" (common.binary Bit)) - (bundle.install "<" (common.binary Bit)) - )))] - - [bundle::float "float" Float] - [bundle::double "double" Double] - ) - -(def: bundle::char - Bundle - (<| (bundle.prefix "char") - (|> bundle.empty - (bundle.install "=" (common.binary Character Character Bit)) - (bundle.install "<" (common.binary Character Character Bit)) - ))) - -(def: #export boxes - (Dictionary Text Text) - (|> (list ["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - (dictionary.from-list text.hash))) - -(def: array::length - Handler - (function (_ extension-name analyse args) - (case args - (^ (list arrayC)) - (do ////.monad - [_ (typeA.infer Nat) - [var-id varT] (typeA.with-env check.var) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC))] - (wrap (#analysis.Extension extension-name (list arrayA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: array::new - Handler - (function (_ extension-name analyse args) - (case args - (^ (list lengthC)) - (do ////.monad - [lengthA (typeA.with-type Nat - (analyse lengthC)) - expectedT (///.lift macro.expected-type) - [level elem-class] (: (Operation [Nat Text]) - (loop [analysisT expectedT - level 0] - (case analysisT - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (recur outputT level) - - #.None - (////.throw non-array expectedT)) - - (^ (#.Primitive "#Array" (list elemT))) - (recur elemT (inc level)) - - (#.Primitive class _) - (wrap [level class]) - - _ - (////.throw non-array expectedT)))) - _ (if (n/> 0 level) - (wrap []) - (////.throw non-array expectedT))] - (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level)) - (analysis.text elem-class) - lengthA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: (check-jvm objectT) - (-> Type (Operation Text)) - (case objectT - (#.Primitive name _) - (/////wrap name) - - (#.Named name unnamed) - (check-jvm unnamed) - - (#.Var id) - (/////wrap "java.lang.Object") - - (^template [] - ( env unquantified) - (check-jvm unquantified)) - ([#.UnivQ] - [#.ExQ]) - - (#.Apply inputT funcT) - (case (type.apply (list inputT) funcT) - (#.Some outputT) - (check-jvm outputT) - - #.None - (////.throw non-object objectT)) - - _ - (////.throw non-object objectT))) - -(def: (check-object objectT) - (-> Type (Operation Text)) - (do ////.monad - [name (check-jvm objectT)] - (if (dictionary.contains? name boxes) - (////.throw primitives-are-not-objects name) - (/////wrap name)))) - -(def: (box-array-element-type elemT) - (-> Type (Operation [Type Text])) - (case elemT - (#.Primitive name #.Nil) - (let [boxed-name (|> (dictionary.get name boxes) - (maybe.default name))] - (/////wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) - - (#.Primitive name _) - (if (dictionary.contains? name boxes) - (////.throw primitives-cannot-have-type-parameters name) - (/////wrap [elemT name])) - - _ - (////.throw invalid-type-for-array-element (%type elemT)))) - -(def: array::read - Handler - (function (_ extension-name analyse args) - (case args - (^ (list arrayC idxC)) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer varT) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC)) - ?elemT (typeA.with-env - (check.read var-id)) - [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (typeA.with-type Nat - (analyse idxC))] - (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: array::write - Handler - (function (_ extension-name analyse args) - (case args - (^ (list arrayC idxC valueC)) - (do ////.monad - [[var-id varT] (typeA.with-env check.var) - _ (typeA.infer (type (Array varT))) - arrayA (typeA.with-type (type (Array varT)) - (analyse arrayC)) - ?elemT (typeA.with-env - (check.read var-id)) - [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) - idxA (typeA.with-type Nat - (analyse idxC)) - valueA (typeA.with-type valueT - (analyse valueC))] - (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) - -(def: bundle::array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "length" array::length) - (bundle.install "new" array::new) - (bundle.install "read" array::read) - (bundle.install "write" array::write) - ))) - -(def: object::null - Handler - (function (_ extension-name analyse args) - (case args - (^ (list)) - (do ////.monad - [expectedT (///.lift macro.expected-type) - _ (check-object expectedT)] - (wrap (#analysis.Extension extension-name (list)))) - - _ - (////.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) - -(def: object::null? - Handler - (function (_ extension-name analyse args) - (case args - (^ (list objectC)) - (do ////.monad - [_ (typeA.infer Bit) - [objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (check-object objectT)] - (wrap (#analysis.Extension extension-name (list objectA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: object::synchronized - Handler - (function (_ extension-name analyse args) - (case args - (^ (list monitorC exprC)) - (do ////.monad - [[monitorT monitorA] (typeA.with-inference - (analyse monitorC)) - _ (check-object monitorT) - exprA (analyse exprC)] - (wrap (#analysis.Extension extension-name (list monitorA exprA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(import: java/lang/Object - (equals [Object] boolean)) - -(import: java/lang/ClassLoader) - -(import: java/lang/reflect/GenericArrayType - (getGenericComponentType [] java/lang/reflect/Type)) - -(import: java/lang/reflect/ParameterizedType - (getRawType [] java/lang/reflect/Type) - (getActualTypeArguments [] (Array java/lang/reflect/Type))) - -(import: (java/lang/reflect/TypeVariable d) - (getName [] String) - (getBounds [] (Array java/lang/reflect/Type))) - -(import: (java/lang/reflect/WildcardType d) - (getLowerBounds [] (Array java/lang/reflect/Type)) - (getUpperBounds [] (Array java/lang/reflect/Type))) - -(import: java/lang/reflect/Modifier - (#static isStatic [int] boolean) - (#static isFinal [int] boolean) - (#static isInterface [int] boolean) - (#static isAbstract [int] boolean)) - -(import: java/lang/reflect/Field - (getDeclaringClass [] (java/lang/Class Object)) - (getModifiers [] int) - (getGenericType [] java/lang/reflect/Type)) - -(import: java/lang/reflect/Method - (getName [] String) - (getModifiers [] int) - (getDeclaringClass [] (Class Object)) - (getTypeParameters [] (Array (TypeVariable Method))) - (getGenericParameterTypes [] (Array java/lang/reflect/Type)) - (getGenericReturnType [] java/lang/reflect/Type) - (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) - -(import: (java/lang/reflect/Constructor c) - (getModifiers [] int) - (getDeclaringClass [] (Class c)) - (getTypeParameters [] (Array (TypeVariable (Constructor c)))) - (getGenericParameterTypes [] (Array java/lang/reflect/Type)) - (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) - -(import: (java/lang/Class c) - (getName [] String) - (getModifiers [] int) - (#static forName [String] #try (Class Object)) - (isAssignableFrom [(Class Object)] boolean) - (getTypeParameters [] (Array (TypeVariable (Class c)))) - (getGenericInterfaces [] (Array java/lang/reflect/Type)) - (getGenericSuperclass [] java/lang/reflect/Type) - (getDeclaredField [String] #try Field) - (getConstructors [] (Array (Constructor Object))) - (getDeclaredMethods [] (Array Method))) - -(def: (load-class name) - (-> Text (Operation (Class Object))) - (do ////.monad - [] - (case (Class::forName name) - (#error.Success [class]) - (wrap class) - - (#error.Failure error) - (////.throw unknown-class name)))) - -(def: (sub-class? super sub) - (-> Text Text (Operation Bit)) - (do ////.monad - [super (load-class super) - sub (load-class sub)] - (wrap (Class::isAssignableFrom sub super)))) - -(def: object::throw - Handler - (function (_ extension-name analyse args) - (case args - (^ (list exceptionC)) - (do ////.monad - [_ (typeA.infer Nothing) - [exceptionT exceptionA] (typeA.with-inference - (analyse exceptionC)) - exception-class (check-object exceptionT) - ? (sub-class? "java.lang.Throwable" exception-class) - _ (: (Operation Any) - (if ? - (wrap []) - (////.throw non-throwable exception-class)))] - (wrap (#analysis.Extension extension-name (list exceptionA)))) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: object::class - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC)) - (case classC - [_ (#.Text class)] - (do ////.monad - [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) - _ (load-class class)] - (wrap (#analysis.Extension extension-name (list (analysis.text class))))) - - _ - (////.throw ///.invalid-syntax extension-name)) - - _ - (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) - -(def: object::instance? - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC objectC)) - (case classC - [_ (#.Text class)] - (do ////.monad - [_ (typeA.infer Bit) - [objectT objectA] (typeA.with-inference - (analyse objectC)) - object-class (check-object objectT) - ? (sub-class? class object-class)] - (if ? - (wrap (#analysis.Extension extension-name (list (analysis.text class)))) - (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) - - _ - (////.throw ///.invalid-syntax extension-name)) - - _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: (java-type-to-class jvm-type) - (-> java/lang/reflect/Type (Operation Text)) - (cond (host.instance? Class jvm-type) - (/////wrap (Class::getName (:coerce Class jvm-type))) - - (host.instance? ParameterizedType jvm-type) - (java-type-to-class (ParameterizedType::getRawType (:coerce ParameterizedType jvm-type))) - - ## else - (////.throw cannot-convert-to-a-class jvm-type))) - -(type: Mappings - (Dictionary Text Type)) - -(def: fresh-mappings Mappings (dictionary.new text.hash)) - -(def: (java-type-to-lux-type mappings java-type) - (-> Mappings java/lang/reflect/Type (Operation Type)) - (cond (host.instance? TypeVariable java-type) - (let [var-name (TypeVariable::getName (:coerce TypeVariable java-type))] - (case (dictionary.get var-name mappings) - (#.Some var-type) - (/////wrap var-type) - - #.None - (////.throw unknown-type-var var-name))) - - (host.instance? WildcardType java-type) - (let [java-type (:coerce WildcardType java-type)] - (case [(array.read 0 (WildcardType::getUpperBounds java-type)) - (array.read 0 (WildcardType::getLowerBounds java-type))] - (^or [(#.Some bound) _] [_ (#.Some bound)]) - (java-type-to-lux-type mappings bound) - - _ - (/////wrap Any))) - - (host.instance? Class java-type) - (let [java-type (:coerce (Class Object) java-type) - class-name (Class::getName java-type)] - (/////wrap (case (array.size (Class::getTypeParameters java-type)) - 0 - (#.Primitive class-name (list)) - - arity - (|> (list.indices arity) - list.reverse - (list/map (|>> (n/* 2) inc #.Parameter)) - (#.Primitive class-name) - (type.univ-q arity))))) - - (host.instance? ParameterizedType java-type) - (let [java-type (:coerce ParameterizedType java-type) - raw (ParameterizedType::getRawType java-type)] - (if (host.instance? Class raw) - (do ////.monad - [paramsT (|> java-type - ParameterizedType::getActualTypeArguments - array.to-list - (monad.map @ (java-type-to-lux-type mappings)))] - (/////wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) - paramsT))) - (////.throw jvm-type-is-not-a-class raw))) - - (host.instance? GenericArrayType java-type) - (do ////.monad - [innerT (|> (:coerce GenericArrayType java-type) - GenericArrayType::getGenericComponentType - (java-type-to-lux-type mappings))] - (wrap (#.Primitive "#Array" (list innerT)))) - - ## else - (////.throw cannot-convert-to-a-lux-type java-type))) - -(def: (correspond-type-params class type) - (-> (Class Object) Type (Operation Mappings)) - (case type - (#.Primitive name params) - (let [class-name (Class::getName class) - class-params (array.to-list (Class::getTypeParameters class)) - num-class-params (list.size class-params) - num-type-params (list.size params)] - (cond (not (text/= class-name name)) - (////.throw cannot-correspond-type-with-a-class - (format "Class = " class-name text.new-line - "Type = " (%type type))) - - (not (n/= num-class-params num-type-params)) - (////.throw type-parameter-mismatch - (format "Expected: " (%i (.int num-class-params)) text.new-line - " Actual: " (%i (.int num-type-params)) text.new-line - " Class: " class-name text.new-line - " Type: " (%type type))) - - ## else - (/////wrap (|> params - (list.zip2 (list/map (|>> TypeVariable::getName) class-params)) - (dictionary.from-list text.hash))) - )) - - _ - (////.throw non-jvm-type type))) - -(def: object::cast - Handler - (function (_ extension-name analyse args) - (case args - (^ (list valueC)) - (do ////.monad - [toT (///.lift macro.expected-type) - to-name (check-jvm toT) - [valueT valueA] (typeA.with-inference - (analyse valueC)) - from-name (check-jvm valueT) - can-cast? (: (Operation Bit) - (case [from-name to-name] - (^template [ ] - (^or [ ] - [ ]) - (do @ - [_ (typeA.infer (#.Primitive to-name (list)))] - (wrap #1))) - (["boolean" "java.lang.Boolean"] - ["byte" "java.lang.Byte"] - ["short" "java.lang.Short"] - ["int" "java.lang.Integer"] - ["long" "java.lang.Long"] - ["float" "java.lang.Float"] - ["double" "java.lang.Double"] - ["char" "java.lang.Character"]) - - _ - (do @ - [_ (////.assert primitives-are-not-objects from-name - (not (dictionary.contains? from-name boxes))) - _ (////.assert primitives-are-not-objects to-name - (not (dictionary.contains? to-name boxes))) - to-class (load-class to-name)] - (loop [[current-name currentT] [from-name valueT]] - (if (text/= to-name current-name) - (do @ - [_ (typeA.infer toT)] - (wrap #1)) - (do @ - [current-class (load-class current-name) - _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line) - (Class::isAssignableFrom current-class to-class)) - candiate-parents (monad.map @ - (function (_ java-type) - (do @ - [class-name (java-type-to-class java-type) - class (load-class class-name)] - (wrap [[class-name java-type] (Class::isAssignableFrom class to-class)]))) - (list& (Class::getGenericSuperclass current-class) - (array.to-list (Class::getGenericInterfaces current-class))))] - (case (|> candiate-parents - (list.filter product.right) - (list/map product.left)) - (#.Cons [next-name nextJT] _) - (do @ - [mapping (correspond-type-params current-class currentT) - nextT (java-type-to-lux-type mapping nextJT)] - (recur [next-name nextT])) - - #.Nil - (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line))) - ))))))] - (if can-cast? - (wrap (#analysis.Extension extension-name (list (analysis.text from-name) - (analysis.text to-name) - valueA))) - (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line - " To class/primitive: " to-name text.new-line - " For value: " (%code valueC) text.new-line)))) - - _ - (////.throw ///.invalid-syntax extension-name)))) - -(def: bundle::object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "null" object::null) - (bundle.install "null?" object::null?) - (bundle.install "synchronized" object::synchronized) - (bundle.install "throw" object::throw) - (bundle.install "class" object::class) - (bundle.install "instance?" object::instance?) - (bundle.install "cast" object::cast) - ))) - -(def: (find-field class-name field-name) - (-> Text Text (Operation [(Class Object) Field])) - (do ////.monad - [class (load-class class-name)] - (case (Class::getDeclaredField field-name class) - (#error.Success field) - (let [owner (Field::getDeclaringClass field)] - (if (is? owner class) - (wrap [class field]) - (////.throw mistaken-field-owner - (format " Field: " field-name text.new-line - " Owner Class: " (Class::getName owner) text.new-line - "Target Class: " class-name text.new-line)))) - - (#error.Failure _) - (////.throw unknown-field (format class-name "#" field-name))))) - -(def: (static-field class-name field-name) - (-> Text Text (Operation [Type Bit])) - (do ////.monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers fieldJ)]] - (if (Modifier::isStatic modifiers) - (let [fieldJT (Field::getGenericType fieldJ)] - (do @ - [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal modifiers)]))) - (////.throw not-a-static-field (format class-name "#" field-name))))) - -(def: (virtual-field class-name field-name objectT) - (-> Text Text Type (Operation [Type Bit])) - (do ////.monad - [[class fieldJ] (find-field class-name field-name) - #let [modifiers (Field::getModifiers fieldJ)]] - (if (not (Modifier::isStatic modifiers)) - (do @ - [#let [fieldJT (Field::getGenericType fieldJ) - var-names (|> class - Class::getTypeParameters - array.to-list - (list/map (|>> TypeVariable::getName)))] - mappings (: (Operation Mappings) - (case objectT - (#.Primitive _class-name _class-params) - (do @ - [#let [num-params (list.size _class-params) - num-vars (list.size var-names)] - _ (////.assert type-parameter-mismatch - (format "Expected: " (%i (.int num-params)) text.new-line - " Actual: " (%i (.int num-vars)) text.new-line - " Class: " _class-name text.new-line - " Type: " (%type objectT)) - (n/= num-params num-vars))] - (wrap (|> (list.zip2 var-names _class-params) - (dictionary.from-list text.hash)))) - - _ - (////.throw non-object objectT))) - fieldT (java-type-to-lux-type mappings fieldJT)] - (wrap [fieldT (Modifier::isFinal modifiers)])) - (////.throw not-a-virtual-field (format class-name "#" field-name))))) - -(def: static::get - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[fieldT final?] (static-field class field)] - (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) - - _ - (////.throw ///.invalid-syntax extension-name)) - - _ - (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) - -(def: static::put - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC valueC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [_ (typeA.infer Any) - [fieldT final?] (static-field class field) - _ (////.assert cannot-set-a-final-field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA)))) - - _ - (////.throw ///.invalid-syntax extension-name)) - - _ - (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) - -(def: virtual::get - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC objectC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - [fieldT final?] (virtual-field class field objectT)] - (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA)))) - - _ - (////.throw ///.invalid-syntax extension-name)) - - _ - (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) - -(def: virtual::put - Handler - (function (_ extension-name analyse args) - (case args - (^ (list classC fieldC valueC objectC)) - (case [classC fieldC] - [[_ (#.Text class)] [_ (#.Text field)]] - (do ////.monad - [[objectT objectA] (typeA.with-inference - (analyse objectC)) - _ (typeA.infer objectT) - [fieldT final?] (virtual-field class field objectT) - _ (////.assert cannot-set-a-final-field (format class "#" field) - (not final?)) - valueA (typeA.with-type fieldT - (analyse valueC))] - (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA)))) - - _ - (////.throw ///.invalid-syntax extension-name)) - - _ - (////.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) - -(def: (java-type-to-parameter type) - (-> java/lang/reflect/Type (Operation Text)) - (cond (host.instance? Class type) - (/////wrap (Class::getName (:coerce Class type))) - - (host.instance? ParameterizedType type) - (java-type-to-parameter (ParameterizedType::getRawType (:coerce ParameterizedType type))) - - (or (host.instance? TypeVariable type) - (host.instance? WildcardType type)) - (/////wrap "java.lang.Object") - - (host.instance? GenericArrayType type) - (do ////.monad - [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType (:coerce GenericArrayType type)))] - (wrap (format componentP "[]"))) - - ## else - (////.throw cannot-convert-to-a-parameter type))) - -(type: Method-Style - #Static - #Abstract - #Virtual - #Special - #Interface) - -(def: (check-method class method-name method-style arg-classes method) - (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) - (do ////.monad - [parameters (|> (Method::getGenericParameterTypes method) - array.to-list - (monad.map @ java-type-to-parameter)) - #let [modifiers (Method::getModifiers method)]] - (wrap (and (Object::equals class (Method::getDeclaringClass method)) - (text/= method-name (Method::getName method)) - (case #Static - #Special - (Modifier::isStatic modifiers) - - _ - #1) - (case method-style - #Special - (not (or (Modifier::isInterface (Class::getModifiers class)) - (Modifier::isAbstract modifiers))) - - _ - #1) - (n/= (list.size arg-classes) (list.size parameters)) - (list/fold (function (_ [expectedJC actualJC] prev) - (and prev - (text/= expectedJC actualJC))) - #1 - (list.zip2 arg-classes parameters)))))) - -(def: (check-constructor class arg-classes constructor) - (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) - (do ////.monad - [parameters (|> (Constructor::getGenericParameterTypes constructor) - array.to-list - (monad.map @ java-type-to-parameter))] - (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) - (n/= (list.size arg-classes) (list.size parameters)) - (list/fold (function (_ [expectedJC actualJC] prev) - (and prev - (text/= expectedJC actualJC))) - #1 - (list.zip2 arg-classes parameters)))))) - -(def: idx-to-parameter - (-> Nat Type) - (|>> (n/* 2) inc #.Parameter)) - -(def: (type-vars amount offset) - (-> Nat Nat (List Type)) - (if (n/= 0 amount) - (list) - (|> (list.indices amount) - (list/map (|>> (n/+ offset) idx-to-parameter))))) - -(def: (method-signature method-style method) - (-> Method-Style Method (Operation Method-Signature)) - (let [owner (Method::getDeclaringClass method) - owner-name (Class::getName owner) - owner-tvars (case method-style - #Static - (list) - - _ - (|> (Class::getTypeParameters owner) - array.to-list - (list/map (|>> TypeVariable::getName)))) - method-tvars (|> (Method::getTypeParameters method) - array.to-list - (list/map (|>> TypeVariable::getName))) - num-owner-tvars (list.size owner-tvars) - num-method-tvars (list.size method-tvars) - all-tvars (list/compose owner-tvars method-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars 0) - method-tvarsT (type-vars num-method-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list/compose owner-tvarsT method-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dictionary.from-list text.hash))))] - (do ////.monad - [inputsT (|> (Method::getGenericParameterTypes method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method)) - exceptionsT (|> (Method::getGenericExceptionTypes method) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [methodT (<| (type.univ-q num-all-tvars) - (type.function (case method-style - #Static - inputsT - - _ - (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) - inputsT))) - outputT)]] - (wrap [methodT exceptionsT])))) - -(type: Evaluation - (#Pass Method-Signature) - (#Hint Method-Signature) - #Fail) - -(do-template [ ] - [(def: - (-> Evaluation (Maybe Method-Signature)) - (|>> (case> ( output) - (#.Some output) - - _ - #.None)))] - - [pass! #Pass] - [hint! #Hint] - ) - -(def: (method-candidate class-name method-name method-style arg-classes) - (-> Text Text Method-Style (List Text) (Operation Method-Signature)) - (do ////.monad - [class (load-class class-name) - candidates (|> class - Class::getDeclaredMethods - array.to-list - (monad.map @ (: (-> Method (Operation Evaluation)) - (function (_ method) - (do @ - [passes? (check-method class method-name method-style arg-classes method)] - (cond passes? - (:: @ map (|>> #Pass) (method-signature method-style method)) - - (text/= method-name (Method::getName method)) - (:: @ map (|>> #Hint) (method-signature method-style method)) - - ## else - (wrap #Fail)))))))] - (case (list.search-all pass! candidates) - (#.Cons method #.Nil) - (wrap method) - - #.Nil - (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) - - candidates - (////.throw too-many-candidates [class-name method-name candidates])))) - -(def: (constructor-signature constructor) - (-> (Constructor Object) (Operation Method-Signature)) - (let [owner (Constructor::getDeclaringClass constructor) - owner-name (Class::getName owner) - owner-tvars (|> (Class::getTypeParameters owner) - array.to-list - (list/map (|>> TypeVariable::getName))) - constructor-tvars (|> (Constructor::getTypeParameters constructor) - array.to-list - (list/map (|>> TypeVariable::getName))) - num-owner-tvars (list.size owner-tvars) - all-tvars (list/compose owner-tvars constructor-tvars) - num-all-tvars (list.size all-tvars) - owner-tvarsT (type-vars num-owner-tvars 0) - constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) - mappings (: Mappings - (if (list.empty? all-tvars) - fresh-mappings - (|> (list/compose owner-tvarsT constructor-tvarsT) - list.reverse - (list.zip2 all-tvars) - (dictionary.from-list text.hash))))] - (do ////.monad - [inputsT (|> (Constructor::getGenericParameterTypes constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) - array.to-list - (monad.map @ (java-type-to-lux-type mappings))) - #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) - constructorT (<| (type.univ-q num-all-tvars) - (type.function inputsT) - objectT)]] - (wrap [constructorT exceptionsT])))) - -(def: constructor-method "") - -(def: (constructor-candidate class-name arg-classes) - (-> Text (List Text) (Operation Method-Signature)) - (do ////.monad - [class (load-class class-name) - candidates (|> class - Class::getConstructors - array.to-list - (monad.map @ (function (_ constructor) - (do @ - [passes? (check-constructor class arg-classes constructor)] - (:: @ map - (if passes? (|>> #Pass) (|>> #Hint)) - (constructor-signature constructor))))))] - (case (list.search-all pass! candidates) - (#.Cons constructor #.Nil) - (wrap constructor) - - #.Nil - (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) - - candidates - (////.throw too-many-candidates [class-name ..constructor-method candidates])))) - -(def: (decorate-inputs typesT inputsA) - (-> (List Text) (List Analysis) (List Analysis)) - (|> inputsA - (list.zip2 (list/map analysis.text typesT)) - (list/map (function (_ [type value]) - (analysis.tuple (list type value)))))) - -(def: invoke::static - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text (List [Text Code])]) - (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class method argsTC]) - (do ////.monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Static argsT) - [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) - outputJC (check-jvm outputT)] - (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) - (analysis.text outputJC) (decorate-inputs argsT argsA))))) - - _ - (////.throw ///.invalid-syntax extension-name)))) - -(def: invoke::virtual - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class method objectC argsTC]) - (do ////.monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Virtual argsT) - [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - #let [[objectA argsA] (case allA - (#.Cons objectA argsA) - [objectA argsA] - - _ - (undefined))] - outputJC (check-jvm outputT)] - (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) - (analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) - - _ - (////.throw ///.invalid-syntax extension-name)))) - -(def: invoke::special - Handler - (function (_ extension-name analyse args) - (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) - (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) - (#error.Success [_ [class method objectC argsTC _]]) - (do ////.monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (method-candidate class method #Special argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) - (analysis.text outputJC) (decorate-inputs argsT argsA))))) - - _ - (////.throw ///.invalid-syntax extension-name)))) - -(def: invoke::interface - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text Text Code (List [Text Code])]) - (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class-name method objectC argsTC]) - (do ////.monad - [#let [argsT (list/map product.left argsTC)] - class (load-class class-name) - _ (////.assert non-interface class-name - (Modifier::isInterface (Class::getModifiers class))) - [methodT exceptionsT] (method-candidate class-name method #Interface argsT) - [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) - outputJC (check-jvm outputT)] - (wrap (#analysis.Extension extension-name - (list& (analysis.text class-name) (analysis.text method) (analysis.text outputJC) - (decorate-inputs argsT argsA))))) - - _ - (////.throw ///.invalid-syntax extension-name)))) - -(def: invoke::constructor - Handler - (function (_ extension-name analyse args) - (case (: (Error [Text (List [Text Code])]) - (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) - (#error.Success [class argsTC]) - (do ////.monad - [#let [argsT (list/map product.left argsTC)] - [methodT exceptionsT] (constructor-candidate class argsT) - [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] - (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA))))) - - _ - (////.throw ///.invalid-syntax extension-name)))) - -(def: bundle::member - Bundle - (<| (bundle.prefix "member") - (|> bundle.empty - (dictionary.merge (<| (bundle.prefix "static") - (|> bundle.empty - (bundle.install "get" static::get) - (bundle.install "put" static::put)))) - (dictionary.merge (<| (bundle.prefix "virtual") - (|> bundle.empty - (bundle.install "get" virtual::get) - (bundle.install "put" virtual::put)))) - (dictionary.merge (<| (bundle.prefix "invoke") - (|> bundle.empty - (bundle.install "static" invoke::static) - (bundle.install "virtual" invoke::virtual) - (bundle.install "special" invoke::special) - (bundle.install "interface" invoke::interface) - (bundle.install "constructor" invoke::constructor) - ))) - ))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "jvm") - (|> bundle.empty - (dictionary.merge bundle::conversion) - (dictionary.merge bundle::int) - (dictionary.merge bundle::long) - (dictionary.merge bundle::float) - (dictionary.merge bundle::double) - (dictionary.merge bundle::char) - (dictionary.merge bundle::array) - (dictionary.merge bundle::object) - (dictionary.merge bundle::member) - ))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux b/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux deleted file mode 100644 index 643e3b38c..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux +++ /dev/null @@ -1,28 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." text - format] - [collection - ["." list ("#/." functor)] - ["." dictionary (#+ Dictionary)]]]] - [// (#+ Handler Bundle)]) - -(def: #export empty - Bundle - (dictionary.new text.hash)) - -(def: #export (install name anonymous) - (All [s i o] - (-> Text (Handler s i o) - (-> (Bundle s i o) (Bundle s i o)))) - (dictionary.put name anonymous)) - -(def: #export (prefix prefix) - (All [s i o] - (-> Text (-> (Bundle s i o) (Bundle s i o)))) - (|>> dictionary.entries - (list/map (function (_ [key val]) [(format prefix " " key) val])) - (dictionary.from-list text.hash))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/statement.lux b/stdlib/source/lux/platform/compiler/phase/extension/statement.lux deleted file mode 100644 index c5ae87050..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/statement.lux +++ /dev/null @@ -1,199 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - [text - format] - [collection - ["." list ("#/." functor)] - ["." dictionary]]] - ["." macro] - [type (#+ :share) - ["." check]]] - ["." // - ["." bundle] - ["/." // - ["." analysis - ["." module] - ["." type]] - ["." synthesis] - ["." translation] - ["." statement (#+ Operation Handler Bundle)]]]) - -(def: (evaluate! type codeC) - (All [anchor expression statement] - (-> Type Code (Operation anchor expression statement [Type expression Any]))) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#statement.analysis #statement.phase] state) - synthesize (get@ [#statement.synthesis #statement.phase] state) - translate (get@ [#statement.translation #statement.phase] state)] - [_ code//type codeA] (statement.lift-analysis - (analysis.with-scope - (type.with-fresh-env - (type.with-type type - (do @ - [codeA (analyse codeC)] - (wrap [type codeA])))))) - codeS (statement.lift-synthesis - (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeT (translate codeS) - count translation.next - codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] - (wrap [code//type codeT codeV])))))) - -(def: (define! name ?type codeC) - (All [anchor expression statement] - (-> Name (Maybe Type) Code - (Operation anchor expression statement [Type expression Text Any]))) - (do ///.monad - [state (//.lift ///.get-state) - #let [analyse (get@ [#statement.analysis #statement.phase] state) - synthesize (get@ [#statement.synthesis #statement.phase] state) - translate (get@ [#statement.translation #statement.phase] state)] - [_ code//type codeA] (statement.lift-analysis - (analysis.with-scope - (type.with-fresh-env - (case ?type - (#.Some type) - (type.with-type type - (do @ - [codeA (analyse codeC)] - (wrap [type codeA]))) - - #.None - (do @ - [[code//type codeA] (type.with-inference (analyse codeC)) - code//type (type.with-env - (check.clean code//type))] - (wrap [code//type codeA])))))) - codeS (statement.lift-synthesis - (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeT (translate codeS) - codeN+V (translation.define! name codeT)] - (wrap [code//type codeT codeN+V])))))) - -(def: lux::def - Handler - (function (_ extension-name phase inputsC+) - (case inputsC+ - (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC)) - (do ///.monad - [current-module (statement.lift-analysis - (//.lift macro.current-module-name)) - #let [full-name [current-module short-name]] - [_ annotationsT annotationsV] (evaluate! Code annotationsC) - #let [annotationsV (:coerce Code annotationsV)] - [value//type valueT valueN valueV] (define! full-name - (if (macro.type? annotationsV) - (#.Some Type) - #.None) - valueC) - _ (statement.lift-analysis - (do @ - [_ (module.define short-name [value//type annotationsV valueV])] - (if (macro.type? annotationsV) - (case (macro.declared-tags annotationsV) - #.Nil - (wrap []) - - tags - (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) - (wrap [])))) - #let [_ (log! (format "Definition " (%name full-name)))]] - (statement.lift-translation - (translation.learn full-name valueN))) - - _ - (///.throw //.invalid-syntax [extension-name])))) - -(def: (alias! alias def-name) - (-> Text Name (analysis.Operation Any)) - (do ///.monad - [definition (//.lift (macro.find-def def-name))] - (module.define alias definition))) - -(def: def::module - Handler - (function (_ extension-name phase inputsC+) - (case inputsC+ - (^ (list annotationsC)) - (do ///.monad - [[_ annotationsT annotationsV] (evaluate! Code annotationsC) - _ (statement.lift-analysis - (module.set-annotations (:coerce Code annotationsV)))] - (wrap [])) - - _ - (///.throw //.invalid-syntax [extension-name])))) - -(def: def::alias - Handler - (function (_ extension-name phase inputsC+) - (case inputsC+ - (^ (list [_ (#.Identifier ["" alias])] [_ (#.Identifier def-name)])) - (//.lift - (///.sub [(get@ [#statement.analysis #statement.state]) - (set@ [#statement.analysis #statement.state])] - (alias! alias def-name))) - - _ - (///.throw //.invalid-syntax [extension-name])))) - -(do-template [ ] - [(def: - (All [anchor expression statement] - (Handler anchor expression statement)) - (function (handler extension-name phase inputsC+) - (case inputsC+ - (^ (list [_ (#.Text name)] valueC)) - (do ///.monad - [[_ handlerT handlerV] (evaluate! (:of (:share [anchor expression statement] - {(Handler anchor expression statement) - handler} - { - (:assume [])})) - valueC)] - (<| - (//.install name) - (:share [anchor expression statement] - {(Handler anchor expression statement) - handler} - { - (:assume handlerV)}))) - - _ - (///.throw //.invalid-syntax [extension-name]))))] - - [def::analysis analysis.Handler statement.lift-analysis] - [def::synthesis synthesis.Handler statement.lift-synthesis] - [def::translation (translation.Handler anchor expression statement) statement.lift-translation] - [def::statement (statement.Handler anchor expression statement) (<|)] - ) - -(def: bundle::def - Bundle - (<| (bundle.prefix "def") - (|> bundle.empty - (dictionary.put "module" def::module) - (dictionary.put "alias" def::alias) - (dictionary.put "analysis" def::analysis) - (dictionary.put "synthesis" def::synthesis) - (dictionary.put "translation" def::translation) - (dictionary.put "statement" def::statement) - ))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle.empty - (dictionary.put "def" lux::def) - (dictionary.merge ..bundle::def)))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux b/stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux deleted file mode 100644 index 1a2e44f6f..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #*] - [// - ["." bundle] - [// - [synthesis (#+ Bundle)]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/translation.lux b/stdlib/source/lux/platform/compiler/phase/extension/translation.lux deleted file mode 100644 index 232c8c168..000000000 --- a/stdlib/source/lux/platform/compiler/phase/extension/translation.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #*] - [// - ["." bundle] - [// - [translation (#+ Bundle)]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/platform/compiler/phase/statement.lux b/stdlib/source/lux/platform/compiler/phase/statement.lux deleted file mode 100644 index c7ff3719f..000000000 --- a/stdlib/source/lux/platform/compiler/phase/statement.lux +++ /dev/null @@ -1,45 +0,0 @@ -(.module: - [lux #*] - ["." // - ["." analysis] - ["." synthesis] - ["." translation] - ["." extension]]) - -(type: #export (Component state phase) - {#state state - #phase phase}) - -(type: #export (State anchor expression statement) - {#analysis (Component analysis.State+ - analysis.Phase) - #synthesis (Component synthesis.State+ - synthesis.Phase) - #translation (Component (translation.State+ anchor expression statement) - (translation.Phase anchor expression statement))}) - -(do-template [ ] - [(type: #export ( anchor expression statement) - ( (..State anchor expression statement) Code Any))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(do-template [ ] - [(def: #export ( operation) - (All [anchor expression statement output] - (-> ( output) - (Operation anchor expression statement output))) - (extension.lift - (//.sub [(get@ [ #..state]) - (set@ [ #..state])] - operation)))] - - [lift-analysis #..analysis analysis.Operation] - [lift-synthesis #..synthesis synthesis.Operation] - [lift-translation #..translation (translation.Operation anchor expression statement)] - ) diff --git a/stdlib/source/lux/platform/compiler/phase/statement/total.lux b/stdlib/source/lux/platform/compiler/phase/statement/total.lux deleted file mode 100644 index c494b01c6..000000000 --- a/stdlib/source/lux/platform/compiler/phase/statement/total.lux +++ /dev/null @@ -1,56 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - [text - format]] - ["." macro]] - ["." // (#+ Phase) - ["/." // - ["." analysis - ["." expression] - ["." type] - ["///." macro]] - ["." extension]]]) - -(exception: #export (not-a-statement {code Code}) - (ex.report ["Statement" (%code code)])) - -(exception: #export (not-a-macro {code Code}) - (ex.report ["Code" (%code code)])) - -(exception: #export (macro-was-not-found {name Name}) - (ex.report ["Name" (%name name)])) - -(def: #export (phase code) - Phase - (case code - (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) - (extension.apply "Statement" phase [name inputs]) - - (^ [_ (#.Form (list& macro inputs))]) - (do ///.monad - [expansion (//.lift-analysis - (do @ - [macroA (type.with-type Macro - (expression.compile macro))] - (case macroA - (^ (analysis.constant macro-name)) - (do @ - [?macro (extension.lift (macro.find-macro macro-name)) - macro (case ?macro - (#.Some macro) - (wrap macro) - - #.None - (///.throw macro-was-not-found macro-name))] - (extension.lift (///macro.expand macro-name macro inputs))) - - _ - (///.throw not-a-macro code))))] - (monad.map @ phase expansion)) - - _ - (///.throw not-a-statement code))) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis.lux b/stdlib/source/lux/platform/compiler/phase/synthesis.lux deleted file mode 100644 index 4cc9c7336..000000000 --- a/stdlib/source/lux/platform/compiler/phase/synthesis.lux +++ /dev/null @@ -1,468 +0,0 @@ -(.module: - [lux (#- i64 Scope) - [control - [monad (#+ do)] - [equivalence (#+ Equivalence)] - ["ex" exception (#+ exception:)]] - [data - ["." bit ("#/." equivalence)] - ["." text ("#/." equivalence) - format] - [collection - ["." list ("#/." functor)] - ["." dictionary (#+ Dictionary)]]]] - ["." // - ["." analysis (#+ Environment Arity Composite Analysis)] - ["." extension (#+ Extension)] - [// - ["." reference (#+ Register Variable Reference)]]]) - -(type: #export Resolver (Dictionary Variable Variable)) - -(type: #export State - {#locals Nat}) - -(def: #export fresh-resolver - Resolver - (dictionary.new reference.hash)) - -(def: #export init - State - {#locals 0}) - -(type: #export Primitive - (#Bit Bit) - (#I64 (I64 Any)) - (#F64 Frac) - (#Text Text)) - -(type: #export Side - (Either Nat Nat)) - -(type: #export Member - (Either Nat Nat)) - -(type: #export Access - (#Side Side) - (#Member Member)) - -(type: #export (Path' s) - #Pop - (#Test Primitive) - (#Access Access) - (#Bind Register) - (#Alt (Path' s) (Path' s)) - (#Seq (Path' s) (Path' s)) - (#Then s)) - -(type: #export (Abstraction' s) - {#environment Environment - #arity Arity - #body s}) - -(type: #export (Apply' s) - {#function s - #arguments (List s)}) - -(type: #export (Branch s) - (#Let s Register s) - (#If s s s) - (#Case s (Path' s))) - -(type: #export (Scope s) - {#start Register - #inits (List s) - #iteration s}) - -(type: #export (Loop s) - (#Scope (Scope s)) - (#Recur (List s))) - -(type: #export (Function s) - (#Abstraction (Abstraction' s)) - (#Apply s (List s))) - -(type: #export (Control s) - (#Branch (Branch s)) - (#Loop (Loop s)) - (#Function (Function s))) - -(type: #export #rec Synthesis - (#Primitive Primitive) - (#Structure (Composite Synthesis)) - (#Reference Reference) - (#Control (Control Synthesis)) - (#Extension (Extension Synthesis))) - -(do-template [ ] - [(type: #export - ( ..State Analysis Synthesis))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(type: #export Path - (Path' Synthesis)) - -(def: #export path/pop - Path - #Pop) - -(do-template [ ] - [(template: #export ( content) - (#..Test ( content)))] - - [path/bit #..Bit] - [path/i64 #..I64] - [path/f64 #..F64] - [path/text #..Text] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Access - - content))] - - [path/side #..Side] - [path/member #..Member] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Access - - - content))] - - [side/left #..Side #.Left] - [side/right #..Side #.Right] - [member/left #..Member #.Left] - [member/right #..Member #.Right] - ) - -(do-template [ ] - [(template: #export ( content) - ( content))] - - [path/bind #..Bind] - [path/then #..Then] - ) - -(do-template [ ] - [(template: #export ( left right) - ( [left right]))] - - [path/alt #..Alt] - [path/seq #..Seq] - ) - -(type: #export Abstraction - (Abstraction' Synthesis)) - -(type: #export Apply - (Apply' Synthesis)) - -(def: #export unit Text "") - -(do-template [ ] - [(def: #export ( value) - (-> (All [a] (-> (Operation a) (Operation a)))) - (extension.temporary (set@ value)))] - - [with-locals Nat #locals] - ) - -(def: #export (with-abstraction arity resolver) - (-> Arity Resolver - (All [a] (-> (Operation a) (Operation a)))) - (extension.with-state {#locals arity})) - -(do-template [ ] - [(def: #export - (Operation ) - (extension.read (get@ )))] - - [locals #locals Nat] - ) - -(def: #export with-new-local - (All [a] (-> (Operation a) (Operation a))) - (<<| (do //.monad - [locals ..locals]) - (..with-locals (inc locals)))) - -(do-template [ ] - [(template: #export ( content) - (#..Primitive ( content)))] - - [bit #..Bit] - [i64 #..I64] - [f64 #..F64] - [text #..Text] - ) - -(do-template [ ] - [(template: #export ( content) - (<| #..Structure - - content))] - - [variant #analysis.Variant] - [tuple #analysis.Tuple] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Reference - - content))] - - [variable/local reference.local] - [variable/foreign reference.foreign] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Reference - - content))] - - [variable reference.variable] - [constant reference.constant] - ) - -(do-template [ ] - [(template: #export ( content) - (.<| #..Control - - - content))] - - [branch/case #..Branch #..Case] - [branch/let #..Branch #..Let] - [branch/if #..Branch #..If] - - [loop/recur #..Loop #..Recur] - [loop/scope #..Loop #..Scope] - - [function/abstraction #..Function #..Abstraction] - [function/apply #..Function #..Apply] - ) - -(def: #export (%path' %then value) - (All [a] (-> (Format a) (Format (Path' a)))) - (case value - #Pop - "_" - - (#Test primitive) - (format "(? " - (case primitive - (#Bit value) - (%b value) - - (#I64 value) - (%i (.int value)) - - (#F64 value) - (%f value) - - (#Text value) - (%t value)) - ")") - - (#Access access) - (case access - (#Side side) - (case side - (#.Left lefts) - (format "(" (%n lefts) " #0" ")") - - (#.Right lefts) - (format "(" (%n lefts) " #1" ")")) - - (#Member member) - (case member - (#.Left lefts) - (format "[" (%n lefts) " #0" "]") - - (#.Right lefts) - (format "[" (%n lefts) " #1" "]"))) - - (#Bind register) - (format "(@ " (%n register) ")") - - (#Alt left right) - (format "(| " (%path' %then left) " " (%path' %then right) ")") - - (#Seq left right) - (format "(& " (%path' %then left) " " (%path' %then right) ")") - - (#Then then) - (|> (%then then) - (text.enclose ["(! " ")"])))) - -(def: #export (%synthesis value) - (Format Synthesis) - (case value - (#Primitive primitive) - (case primitive - (^template [ ] - ( value) - ( value)) - ([#Bit %b] - [#F64 %f] - [#Text %t]) - - (#I64 value) - (%i (.int value))) - - (#Structure structure) - (case structure - (#analysis.Variant [lefts right? content]) - (|> (%synthesis content) - (format (%n lefts) " " (%b right?) " ") - (text.enclose ["(" ")"])) - - (#analysis.Tuple members) - (|> members - (list/map %synthesis) - (text.join-with " ") - (text.enclose ["[" "]"]))) - - (#Reference reference) - (|> reference - reference.%reference - (text.enclose ["(#@ " ")"])) - - (#Control control) - (case control - (#Function function) - (case function - (#Abstraction [environment arity body]) - (|> (%synthesis body) - (format (%n arity) " ") - (format (|> environment - (list/map reference.%variable) - (text.join-with " ") - (text.enclose ["[" "]"])) - " ") - (text.enclose ["(" ")"])) - - (#Apply func args) - (|> (list/map %synthesis args) - (text.join-with " ") - (format (%synthesis func) " ") - (text.enclose ["(" ")"]))) - - (#Branch branch) - (case branch - (#Let input register body) - (|> (format (%synthesis input) " " (%n register) " " (%synthesis body)) - (text.enclose ["(#let " ")"])) - - (#If test then else) - (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) - (text.enclose ["(#if " ")"])) - - (#Case input path) - (|> (format (%synthesis input) " " (%path' %synthesis path)) - (text.enclose ["(#case " ")"]))) - - ## (#Loop loop) - _ - "???") - - (#Extension [name args]) - (|> (list/map %synthesis args) - (text.join-with " ") - (format (%t name)) - (text.enclose ["(" ")"])))) - -(def: #export %path - (Format Path) - (%path' %synthesis)) - -(structure: #export primitive-equivalence (Equivalence Primitive) - (def: (= reference sample) - (case [reference sample] - (^template [ ] - [( reference') ( sample')] - ( reference' sample')) - ([#Bit bit/= %b] - [#F64 f/= %f] - [#Text text/= %t]) - - [(#I64 reference') (#I64 sample')] - (i/= (.int reference') (.int sample')) - - _ - false))) - -(structure: #export access-equivalence (Equivalence Access) - (def: (= reference sample) - (case [reference sample] - (^template [] - [( reference') ( sample')] - (case [reference' sample'] - (^template [] - [( reference'') ( sample'')] - (n/= reference'' sample'')) - ([#.Left] - [#.Right]) - - _ - false)) - ([#Side] - [#Member]) - - _ - false))) - -(structure: #export (path'-equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) - - (def: (= reference sample) - (case [reference sample] - [#Pop #Pop] - true - - (^template [ ] - [( reference') ( sample')] - (:: = reference' sample')) - ([#Test primitive-equivalence] - [#Access access-equivalence] - [#Then Equivalence]) - - [(#Bind reference') (#Bind sample')] - (n/= reference' sample') - - (^template [] - [( leftR rightR) ( leftS rightS)] - (and (= leftR leftS) - (= rightR rightS))) - ([#Alt] - [#Seq]) - - _ - false))) - -(structure: #export equivalence (Equivalence Synthesis) - (def: (= reference sample) - (case [reference sample] - (^template [ ] - [( reference') ( sample')] - (:: = reference' sample')) - ([#Primitive primitive-equivalence]) - - _ - false))) - -(def: #export path-equivalence - (Equivalence Path) - (path'-equivalence equivalence)) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux deleted file mode 100644 index b1890688d..000000000 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux +++ /dev/null @@ -1,170 +0,0 @@ -(.module: - [lux #* - [control - [equivalence (#+ Equivalence)] - pipe - ["." monad (#+ do)]] - [data - ["." product] - ["." bit ("#/." equivalence)] - ["." text ("#/." equivalence) - format] - [number - ["." frac ("#/." equivalence)]] - [collection - ["." list ("#/." fold monoid)]]]] - ["." // (#+ Path Synthesis Operation Phase) - ["." function] - ["/." // ("#/." monad) - ["." analysis (#+ Pattern Match Analysis)] - [// - ["." reference]]]]) - -(def: clean-up - (-> Path Path) - (|>> (#//.Seq #//.Pop))) - -(def: (path' pattern end? thenC) - (-> Pattern Bit (Operation Path) (Operation Path)) - (case pattern - (#analysis.Simple simple) - (case simple - #analysis.Unit - thenC - - (^template [ ] - ( value) - (///map (|>> (#//.Seq (#//.Test (|> value )))) - thenC)) - ([#analysis.Bit #//.Bit] - [#analysis.Nat (<| #//.I64 .i64)] - [#analysis.Int (<| #//.I64 .i64)] - [#analysis.Rev (<| #//.I64 .i64)] - [#analysis.Frac #//.F64] - [#analysis.Text #//.Text])) - - (#analysis.Bind register) - (<| (:: ///.monad map (|>> (#//.Seq (#//.Bind register)))) - //.with-new-local - thenC) - - (#analysis.Complex (#analysis.Variant [lefts right? value-pattern])) - (<| (///map (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts))))))) - (path' value-pattern end?) - (when (not end?) (///map ..clean-up)) - thenC) - - (#analysis.Complex (#analysis.Tuple tuple)) - (let [tuple::last (dec (list.size tuple))] - (list/fold (function (_ [tuple::lefts tuple::member] nextC) - (let [right? (n/= tuple::last tuple::lefts) - end?' (and end? right?)] - (<| (///map (|>> (#//.Seq (#//.Access (#//.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) - (path' tuple::member end?') - (when (not end?') (///map ..clean-up)) - nextC))) - thenC - (list.reverse (list.enumerate tuple)))))) - -(def: #export (path synthesize pattern bodyA) - (-> Phase Pattern Analysis (Operation Path)) - (path' pattern true (///map (|>> #//.Then) (synthesize bodyA)))) - -(def: #export (weave leftP rightP) - (-> Path Path Path) - (with-expansions [ (as-is (#//.Alt leftP rightP))] - (case [leftP rightP] - [(#//.Seq preL postL) - (#//.Seq preR postR)] - (case (weave preL preR) - (#//.Alt _) - - - weavedP - (#//.Seq weavedP (weave postL postR))) - - [#//.Pop #//.Pop] - rightP - - (^template [ ] - [(#//.Test ( leftV)) - (#//.Test ( rightV))] - (if ( leftV rightV) - rightP - )) - ([#//.Bit bit/=] - [#//.I64 "lux i64 ="] - [#//.F64 frac/=] - [#//.Text text/=]) - - (^template [ ] - [(#//.Access ( ( leftL))) - (#//.Access ( ( rightL)))] - (if (n/= leftL rightL) - rightP - )) - ([#//.Side #.Left] - [#//.Side #.Right] - [#//.Member #.Left] - [#//.Member #.Right]) - - [(#//.Bind leftR) (#//.Bind rightR)] - (if (n/= leftR rightR) - rightP - ) - - _ - ))) - -(def: #export (synthesize synthesize^ inputA [headB tailB+]) - (-> Phase Analysis Match (Operation Synthesis)) - (do ///.monad - [inputS (synthesize^ inputA)] - (with-expansions [ - (as-is (^multi (^ (#analysis.Reference (reference.local outputR))) - (n/= inputR outputR)) - (wrap inputS)) - - - (as-is [[(#analysis.Bind inputR) headB/bodyA] - #.Nil] - (case headB/bodyA - - - _ - (do @ - [headB/bodyS (//.with-new-local - (synthesize^ headB/bodyA))] - (wrap (//.branch/let [inputS inputR headB/bodyS]))))) - - - (as-is (^or (^ [[(analysis.pattern/bit #1) thenA] - (list [(analysis.pattern/bit #0) elseA])]) - (^ [[(analysis.pattern/bit #0) elseA] - (list [(analysis.pattern/bit #1) thenA])])) - (do @ - [thenS (synthesize^ thenA) - elseS (synthesize^ elseA)] - (wrap (//.branch/if [inputS thenS elseS])))) - - - (as-is _ - (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) - list.reverse - (case> (#.Cons [lastP lastA] prevsPA) - [[lastP lastA] prevsPA] - - _ - (undefined)))] - (do @ - [lastSP (path synthesize^ lastP lastA) - prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] - (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] - (case [headB tailB+] - - - )))) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux deleted file mode 100644 index ac6a82ab8..000000000 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - [lux (#- primitive) - [control - ["." monad (#+ do)] - pipe] - [data - ["." maybe] - ["." error] - [collection - ["." list ("#/." functor)] - ["." dictionary (#+ Dictionary)]]]] - ["." // (#+ Synthesis Phase) - ["." function] - ["." case] - ["/." // ("#/." monad) - ["." analysis (#+ Analysis)] - ["." extension] - [// - ["." reference]]]]) - -(def: (primitive analysis) - (-> analysis.Primitive //.Primitive) - (case analysis - #analysis.Unit - (#//.Text //.unit) - - (^template [ ] - ( value) - ( value)) - ([#analysis.Bit #//.Bit] - [#analysis.Frac #//.F64] - [#analysis.Text #//.Text]) - - (^template [ ] - ( value) - ( (.i64 value))) - ([#analysis.Nat #//.I64] - [#analysis.Int #//.I64] - [#analysis.Rev #//.I64]))) - -(def: #export (phase analysis) - Phase - (case analysis - (#analysis.Primitive analysis') - (///wrap (#//.Primitive (..primitive analysis'))) - - (#analysis.Structure structure) - (case structure - (#analysis.Variant variant) - (do ///.monad - [valueS (phase (get@ #analysis.value variant))] - (wrap (//.variant (set@ #analysis.value valueS variant)))) - - (#analysis.Tuple tuple) - (|> tuple - (monad.map ///.monad phase) - (:: ///.monad map (|>> //.tuple)))) - - (#analysis.Reference reference) - (///wrap (#//.Reference reference)) - - (#analysis.Case inputA branchesAB+) - (case.synthesize phase inputA branchesAB+) - - (^ (analysis.no-op value)) - (phase value) - - (#analysis.Apply _) - (function.apply phase analysis) - - (#analysis.Function environmentA bodyA) - (function.abstraction phase environmentA bodyA) - - (#analysis.Extension name args) - (function (_ state) - (|> (extension.apply "Synthesis" phase [name args]) - (///.run' state) - (case> (#error.Success output) - (#error.Success output) - - (#error.Failure error) - (<| (///.run' state) - (do ///.monad - [argsS+ (monad.map @ phase args)] - (wrap (#//.Extension [name argsS+]))))))) - )) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux deleted file mode 100644 index ce9efe59b..000000000 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux +++ /dev/null @@ -1,211 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - format] - [collection - ["." list ("#/." functor monoid fold)] - ["dict" dictionary (#+ Dictionary)]]]] - ["." // (#+ Path Synthesis Operation Phase) - ["." loop (#+ Transform)] - ["/." // ("#/." monad) - ["." analysis (#+ Environment Arity Analysis)] - [// - ["." reference (#+ Register Variable)]]]]) - -(exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment}) - (ex.report ["Foreign" (%n foreign)] - ["Environment" (|> environment - (list/map reference.%variable) - (text.join-with " "))])) - -(def: arity-arguments - (-> Arity (List Synthesis)) - (|>> dec - (list.n/range 1) - (list/map (|>> //.variable/local)))) - -(template: #export (self-reference) - (//.variable/local 0)) - -(def: (expanded-nested-self-reference arity) - (-> Arity Synthesis) - (//.function/apply [(..self-reference) (arity-arguments arity)])) - -(def: #export (apply phase) - (-> Phase Phase) - (function (_ exprA) - (let [[funcA argsA] (analysis.application exprA)] - (do ///.monad - [funcS (phase funcA) - argsS (monad.map @ phase argsA) - ## locals //.locals - ] - (with-expansions [ (as-is (//.function/apply [funcS argsS]))] - (case funcS - ## (^ (//.function/abstraction functionS)) - ## (wrap (|> functionS - ## (loop.loop (get@ #//.environment functionS) locals argsS) - ## (maybe.default ))) - - (^ (//.function/apply [funcS' argsS'])) - (wrap (//.function/apply [funcS' (list/compose argsS' argsS)])) - - _ - (wrap ))))))) - -(def: (find-foreign environment register) - (-> Environment Register (Operation Variable)) - (case (list.nth register environment) - (#.Some aliased) - (///wrap aliased) - - #.None - (///.throw cannot-find-foreign-variable-in-environment [register environment]))) - -(def: (grow-path grow path) - (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) - (case path - (#//.Bind register) - (///wrap (#//.Bind (inc register))) - - (^template [] - ( left right) - (do ///.monad - [left' (grow-path grow left) - right' (grow-path grow right)] - (wrap ( left' right')))) - ([#//.Alt] [#//.Seq]) - - (#//.Then thenS) - (|> thenS - grow - (///map (|>> #//.Then))) - - _ - (///wrap path))) - -(def: (grow-sub-environment super sub) - (-> Environment Environment (Operation Environment)) - (monad.map ///.monad - (function (_ variable) - (case variable - (#reference.Local register) - (///wrap (#reference.Local (inc register))) - - (#reference.Foreign register) - (find-foreign super register))) - sub)) - -(def: (grow environment expression) - (-> Environment Synthesis (Operation Synthesis)) - (case expression - (#//.Structure structure) - (case structure - (#analysis.Variant [lefts right? subS]) - (|> subS - (grow environment) - (///map (|>> [lefts right?] //.variant))) - - (#analysis.Tuple membersS+) - (|> membersS+ - (monad.map ///.monad (grow environment)) - (///map (|>> //.tuple)))) - - (^ (..self-reference)) - (///wrap (//.function/apply [expression (list (//.variable/local 1))])) - - (#//.Reference reference) - (case reference - (#reference.Variable variable) - (case variable - (#reference.Local register) - (///wrap (//.variable/local (inc register))) - - (#reference.Foreign register) - (|> register - (find-foreign environment) - (///map (|>> //.variable)))) - - (#reference.Constant constant) - (///wrap expression)) - - (#//.Control control) - (case control - (#//.Branch branch) - (case branch - (#//.Let [inputS register bodyS]) - (do ///.monad - [inputS' (grow environment inputS) - bodyS' (grow environment bodyS)] - (wrap (//.branch/let [inputS' (inc register) bodyS']))) - - (#//.If [testS thenS elseS]) - (do ///.monad - [testS' (grow environment testS) - thenS' (grow environment thenS) - elseS' (grow environment elseS)] - (wrap (//.branch/if [testS' thenS' elseS']))) - - (#//.Case [inputS pathS]) - (do ///.monad - [inputS' (grow environment inputS) - pathS' (grow-path (grow environment) pathS)] - (wrap (//.branch/case [inputS' pathS'])))) - - (#//.Loop loop) - (case loop - (#//.Scope [start initsS+ iterationS]) - (do ///.monad - [initsS+' (monad.map @ (grow environment) initsS+) - iterationS' (grow environment iterationS)] - (wrap (//.loop/scope [start initsS+' iterationS']))) - - (#//.Recur argumentsS+) - (|> argumentsS+ - (monad.map ///.monad (grow environment)) - (///map (|>> //.loop/recur)))) - - (#//.Function function) - (case function - (#//.Abstraction [_env _arity _body]) - (do ///.monad - [_env' (grow-sub-environment environment _env)] - (wrap (//.function/abstraction [_env' _arity _body]))) - - (#//.Apply funcS argsS+) - (case funcS - (^ (//.function/apply [(..self-reference) pre-argsS+])) - (///wrap (//.function/apply [(..self-reference) - (list/compose pre-argsS+ argsS+)])) - - _ - (do ///.monad - [funcS' (grow environment funcS) - argsS+' (monad.map @ (grow environment) argsS+)] - (wrap (//.function/apply [funcS' argsS+'])))))) - - (#//.Extension name argumentsS+) - (|> argumentsS+ - (monad.map ///.monad (grow environment)) - (///map (|>> (#//.Extension name)))) - - _ - (///wrap expression))) - -(def: #export (abstraction phase environment bodyA) - (-> Phase Environment Analysis (Operation Synthesis)) - (do ///.monad - [bodyS (phase bodyA)] - (case bodyS - (^ (//.function/abstraction [env' down-arity' bodyS'])) - (|> bodyS' - (grow env') - (:: @ map (|>> [environment (inc down-arity')] //.function/abstraction))) - - _ - (wrap (//.function/abstraction [environment 1 bodyS]))))) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux deleted file mode 100644 index 28517bd42..000000000 --- a/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux +++ /dev/null @@ -1,291 +0,0 @@ -(.module: - [lux (#- loop) - [control - ["." monad (#+ do)] - ["p" parser]] - [data - ["." maybe ("#/." monad)] - [collection - ["." list ("#/." functor)]]] - [macro - ["." code] - ["." syntax]]] - ["." // (#+ Path Abstraction Synthesis) - [// - ["." analysis (#+ Environment)] - ["." extension] - [// - ["." reference (#+ Register Variable)]]]]) - -(type: #export (Transform a) - (-> a (Maybe a))) - -(def: (some? maybe) - (All [a] (-> (Maybe a) Bit)) - (case maybe - (#.Some _) #1 - #.None #0)) - -(template: #export (self) - (#//.Reference (reference.local 0))) - -(template: (recursive-apply args) - (#//.Apply (self) args)) - -(def: improper #0) -(def: proper #1) - -(def: (proper? exprS) - (-> Synthesis Bit) - (case exprS - (^ (self)) - improper - - (#//.Structure structure) - (case structure - (#analysis.Variant variantS) - (proper? (get@ #analysis.value variantS)) - - (#analysis.Tuple membersS+) - (list.every? proper? membersS+)) - - (#//.Control controlS) - (case controlS - (#//.Branch branchS) - (case branchS - (#//.Case inputS pathS) - (and (proper? inputS) - (.loop [pathS pathS] - (case pathS - (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS)) - (and (recur leftS) (recur rightS)) - - (#//.Then bodyS) - (proper? bodyS) - - _ - proper))) - - (#//.Let inputS register bodyS) - (and (proper? inputS) - (proper? bodyS)) - - (#//.If inputS thenS elseS) - (and (proper? inputS) - (proper? thenS) - (proper? elseS))) - - (#//.Loop loopS) - (case loopS - (#//.Scope scopeS) - (and (list.every? proper? (get@ #//.inits scopeS)) - (proper? (get@ #//.iteration scopeS))) - - (#//.Recur argsS) - (list.every? proper? argsS)) - - (#//.Function functionS) - (case functionS - (#//.Abstraction environment arity bodyS) - (list.every? reference.self? environment) - - (#//.Apply funcS argsS) - (and (proper? funcS) - (list.every? proper? argsS)))) - - (#//.Extension [name argsS]) - (list.every? proper? argsS) - - _ - proper)) - -(def: (path-recursion synthesis-recursion) - (-> (Transform Synthesis) (Transform Path)) - (function (recur pathS) - (case pathS - (#//.Alt leftS rightS) - (let [leftS' (recur leftS) - rightS' (recur rightS)] - (if (or (some? leftS') - (some? rightS')) - (#.Some (#//.Alt (maybe.default leftS leftS') - (maybe.default rightS rightS'))) - #.None)) - - (#//.Seq leftS rightS) - (maybe/map (|>> (#//.Seq leftS)) (recur rightS)) - - (#//.Then bodyS) - (maybe/map (|>> #//.Then) (synthesis-recursion bodyS)) - - _ - #.None))) - -(def: #export (recursion arity) - (-> Nat (Transform Synthesis)) - (function (recur exprS) - (case exprS - (#//.Control controlS) - (case controlS - (#//.Branch branchS) - (case branchS - (#//.Case inputS pathS) - (|> pathS - (path-recursion recur) - (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) - - (#//.Let inputS register bodyS) - (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) - (recur bodyS)) - - (#//.If inputS thenS elseS) - (let [thenS' (recur thenS) - elseS' (recur elseS)] - (if (or (some? thenS') - (some? elseS')) - (#.Some (|> (#//.If inputS - (maybe.default thenS thenS') - (maybe.default elseS elseS')) - #//.Branch #//.Control)) - #.None))) - - (^ (#//.Function (recursive-apply argsS))) - (if (n/= arity (list.size argsS)) - (#.Some (|> argsS #//.Recur #//.Loop #//.Control)) - #.None) - - _ - #.None) - - _ - #.None))) - -(def: (resolve environment) - (-> Environment (Transform Variable)) - (function (_ variable) - (case variable - (#reference.Foreign register) - (list.nth register environment) - - _ - (#.Some variable)))) - -(def: (adjust-path adjust-synthesis offset) - (-> (Transform Synthesis) Register (Transform Path)) - (function (recur pathS) - (case pathS - (#//.Bind register) - (#.Some (#//.Bind (n/+ offset register))) - - (^template [] - ( leftS rightS) - (do maybe.monad - [leftS' (recur leftS) - rightS' (recur rightS)] - (wrap ( leftS' rightS')))) - ([#//.Alt] [#//.Seq]) - - (#//.Then bodyS) - (|> bodyS adjust-synthesis (maybe/map (|>> #//.Then))) - - _ - (#.Some pathS)))) - -(def: (adjust scope-environment offset) - (-> Environment Register (Transform Synthesis)) - (function (recur exprS) - (case exprS - (#//.Structure structureS) - (case structureS - (#analysis.Variant variantS) - (do maybe.monad - [valueS' (|> variantS (get@ #analysis.value) recur)] - (wrap (|> variantS - (set@ #analysis.value valueS') - #analysis.Variant - #//.Structure))) - - (#analysis.Tuple membersS+) - (|> membersS+ - (monad.map maybe.monad recur) - (maybe/map (|>> #analysis.Tuple #//.Structure)))) - - (#//.Reference reference) - (case reference - (^ (reference.constant constant)) - (#.Some exprS) - - (^ (reference.local register)) - (#.Some (#//.Reference (reference.local (n/+ offset register)))) - - (^ (reference.foreign register)) - (|> scope-environment - (list.nth register) - (maybe/map (|>> #reference.Variable #//.Reference)))) - - (^ (//.branch/case [inputS pathS])) - (do maybe.monad - [inputS' (recur inputS) - pathS' (adjust-path recur offset pathS)] - (wrap (|> pathS' [inputS'] //.branch/case))) - - (^ (//.branch/let [inputS register bodyS])) - (do maybe.monad - [inputS' (recur inputS) - bodyS' (recur bodyS)] - (wrap (//.branch/let [inputS' register bodyS']))) - - (^ (//.branch/if [inputS thenS elseS])) - (do maybe.monad - [inputS' (recur inputS) - thenS' (recur thenS) - elseS' (recur elseS)] - (wrap (//.branch/if [inputS' thenS' elseS']))) - - (^ (//.loop/scope scopeS)) - (do maybe.monad - [inits' (|> scopeS - (get@ #//.inits) - (monad.map maybe.monad recur)) - iteration' (recur (get@ #//.iteration scopeS))] - (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset)) - #//.inits inits' - #//.iteration iteration'}))) - - (^ (//.loop/recur argsS)) - (|> argsS - (monad.map maybe.monad recur) - (maybe/map (|>> //.loop/recur))) - - - (^ (//.function/abstraction [environment arity bodyS])) - (do maybe.monad - [environment' (monad.map maybe.monad - (resolve scope-environment) - environment)] - (wrap (//.function/abstraction [environment' arity bodyS]))) - - (^ (//.function/apply [function arguments])) - (do maybe.monad - [function' (recur function) - arguments' (monad.map maybe.monad recur arguments)] - (wrap (//.function/apply [function' arguments']))) - - (#//.Extension [name argsS]) - (|> argsS - (monad.map maybe.monad recur) - (maybe/map (|>> [name] #//.Extension))) - - _ - (#.Some exprS)))) - -(def: #export (loop environment num-locals inits functionS) - (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis)) - (let [bodyS (get@ #//.body functionS)] - (if (and (n/= (list.size inits) - (get@ #//.arity functionS)) - (proper? bodyS)) - (|> bodyS - (adjust environment num-locals) - (maybe/map (|>> [(inc num-locals) inits] //.loop/scope))) - #.None))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation.lux b/stdlib/source/lux/platform/compiler/phase/translation.lux deleted file mode 100644 index d8522adcd..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation.lux +++ /dev/null @@ -1,250 +0,0 @@ -(.module: - [lux #* - [control - ["ex" exception (#+ exception:)] - [monad (#+ do)]] - [data - ["." product] - ["." error (#+ Error)] - ["." name ("#/." equivalence)] - ["." text - format] - [collection - ["." row (#+ Row)] - ["." dictionary (#+ Dictionary)]]] - [world - [file (#+ File)]]] - ["." // - ["." extension]] - [//synthesis (#+ Synthesis)]) - -(do-template [] - [(exception: #export () - "")] - - [no-active-buffer] - [no-anchor] - ) - -(exception: #export (cannot-interpret {error Text}) - (ex.report ["Error" error])) - -(exception: #export (unknown-lux-name {name Name}) - (ex.report ["Name" (%name name)])) - -(exception: #export (cannot-overwrite-lux-name {lux-name Name} - {old-host-name Text} - {new-host-name Text}) - (ex.report ["Lux Name" (%name lux-name)] - ["Old Host Name" old-host-name] - ["New Host Name" new-host-name])) - -(do-template [] - [(exception: #export ( {name Name}) - (ex.report ["Output" (%name name)]))] - - [cannot-overwrite-output] - [no-buffer-for-saving-code] - ) - -(type: #export Context - {#scope-name Text - #inner-functions Nat}) - -(signature: #export (Host expression statement) - (: (-> Text expression (Error Any)) - evaluate!) - (: (-> Text statement (Error Any)) - execute!) - (: (-> Name expression (Error [Text Any])) - define!)) - -(type: #export (Buffer statement) (Row [Name statement])) - -(type: #export (Outputs statement) (Dictionary File (Buffer statement))) - -(type: #export (State anchor expression statement) - {#context Context - #anchor (Maybe anchor) - #host (Host expression statement) - #buffer (Maybe (Buffer statement)) - #outputs (Outputs statement) - #counter Nat - #name-cache (Dictionary Name Text)}) - -(do-template [ ] - [(type: #export ( anchor expression statement) - ( (State anchor expression statement) Synthesis expression))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (state host) - (All [anchor expression statement] - (-> (Host expression statement) - (..State anchor expression statement))) - {#context {#scope-name "" - #inner-functions 0} - #anchor #.None - #host host - #buffer #.None - #outputs (dictionary.new text.hash) - #counter 0 - #name-cache (dictionary.new name.hash)}) - -(def: #export (with-context expr) - (All [anchor expression statement output] - (-> (Operation anchor expression statement output) - (Operation anchor expression statement [Text output]))) - (function (_ [bundle state]) - (let [[old-scope old-inner] (get@ #context state) - new-scope (format old-scope "c" (%n old-inner))] - (case (expr [bundle (set@ #context [new-scope 0] state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] - [new-scope output]]) - - (#error.Failure error) - (#error.Failure error))))) - -(def: #export context - (All [anchor expression statement] - (Operation anchor expression statement Text)) - (extension.read (|>> (get@ #context) - (get@ #scope-name)))) - -(do-template [ - - ] - [(def: #export - (All [anchor expression statement output] ) - (function (_ body) - (function (_ [bundle state]) - (case (body [bundle (set@ (#.Some ) state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set@ (get@ state) state')] - output]) - - (#error.Failure error) - (#error.Failure error))))) - - (def: #export - (All [anchor expression statement] - (Operation anchor expression statement )) - (function (_ (^@ stateE [bundle state])) - (case (get@ state) - (#.Some output) - (#error.Success [stateE output]) - - #.None - (ex.throw []))))] - - [#anchor - (with-anchor anchor) - (-> anchor (Operation anchor expression statement output) - (Operation anchor expression statement output)) - anchor - anchor anchor no-anchor] - - [#buffer - with-buffer - (-> (Operation anchor expression statement output) - (Operation anchor expression statement output)) - row.empty - buffer (Buffer statement) no-active-buffer] - ) - -(def: #export outputs - (All [anchor expression statement] - (Operation anchor expression statement (Outputs statement))) - (extension.read (get@ #outputs))) - -(def: #export next - (All [anchor expression statement] - (Operation anchor expression statement Nat)) - (do //.monad - [count (extension.read (get@ #counter)) - _ (extension.update (update@ #counter inc))] - (wrap count))) - -(do-template [ ] - [(def: #export ( label code) - (All [anchor expression statement] - (-> Text (Operation anchor expression statement Any))) - (function (_ (^@ state+ [bundle state])) - (case (:: (get@ #host state) label code) - (#error.Success output) - (#error.Success [state+ output]) - - (#error.Failure error) - (ex.throw cannot-interpret error))))] - - [evaluate! expression] - [execute! statement] - ) - -(def: #export (define! name code) - (All [anchor expression statement] - (-> Name expression (Operation anchor expression statement [Text Any]))) - (function (_ (^@ stateE [bundle state])) - (case (:: (get@ #host state) define! name code) - (#error.Success output) - (#error.Success [stateE output]) - - (#error.Failure error) - (ex.throw cannot-interpret error)))) - -(def: #export (save! name code) - (All [anchor expression statement] - (-> Name statement (Operation anchor expression statement Any))) - (do //.monad - [count ..next - _ (execute! (format "save" (%n count)) code) - ?buffer (extension.read (get@ #buffer))] - (case ?buffer - (#.Some buffer) - (if (row.any? (|>> product.left (name/= name)) buffer) - (//.throw cannot-overwrite-output name) - (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) - - #.None - (//.throw no-buffer-for-saving-code name)))) - -(def: #export (save-buffer! target) - (All [anchor expression statement] - (-> File (Operation anchor expression statement Any))) - (do //.monad - [buffer ..buffer] - (extension.update (update@ #outputs (dictionary.put target buffer))))) - -(def: #export (remember lux-name) - (All [anchor expression statement] - (-> Name (Operation anchor expression statement Text))) - (function (_ (^@ stateE [_ state])) - (let [cache (get@ #name-cache state)] - (case (dictionary.get lux-name cache) - (#.Some host-name) - (#error.Success [stateE host-name]) - - #.None - (ex.throw unknown-lux-name lux-name))))) - -(def: #export (learn lux-name host-name) - (All [anchor expression statement] - (-> Name Text (Operation anchor expression statement Any))) - (function (_ [bundle state]) - (let [cache (get@ #name-cache state)] - (case (dictionary.get lux-name cache) - #.None - (#error.Success [[bundle - (update@ #name-cache - (dictionary.put lux-name host-name) - state)] - []]) - - (#.Some old-host-name) - (ex.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux deleted file mode 100644 index 92b55cb80..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux +++ /dev/null @@ -1,177 +0,0 @@ -(.module: - [lux (#- case let if) - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." number] - ["." text - format] - [collection - ["." list ("#/." functor fold)] - [set (#+ Set)]]]] - [// - ["." runtime (#+ Operation Phase)] - ["." reference] - ["/." /// ("#/." monad) - ["." synthesis (#+ Synthesis Path)] - [// - [reference (#+ Register)] - [// - [host - ["_" scheme (#+ Expression Computation Var)]]]]]]) - -(def: #export (let translate [valueS register bodyS]) - (-> Phase [Synthesis Register Synthesis] - (Operation Computation)) - (do ////.monad - [valueO (translate valueS) - bodyO (translate bodyS)] - (wrap (_.let (list [(reference.local' register) valueO]) - bodyO)))) - -(def: #export (record-get translate valueS pathP) - (-> Phase Synthesis (List [Nat Bit]) - (Operation Expression)) - (do ////.monad - [valueO (translate valueS)] - (wrap (list/fold (function (_ [idx tail?] source) - (.let [method (.if tail? - runtime.product//right - runtime.product//left)] - (method source (_.int (:coerce Int idx))))) - valueO - pathP)))) - -(def: #export (if translate [testS thenS elseS]) - (-> Phase [Synthesis Synthesis Synthesis] - (Operation Computation)) - (do ////.monad - [testO (translate testS) - thenO (translate thenS) - elseO (translate elseS)] - (wrap (_.if testO thenO elseO)))) - -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) - -(def: @cursor (_.var "lux_pm_cursor")) - -(def: top _.length/1) - -(def: (push! value var) - (-> Expression Var Computation) - (_.set! var (_.cons/2 value var))) - -(def: (pop! var) - (-> Var Computation) - (_.set! var var)) - -(def: (push-cursor! value) - (-> Expression Computation) - (push! value @cursor)) - -(def: save-cursor! - Computation - (push! @cursor @savepoint)) - -(def: restore-cursor! - Computation - (_.set! @cursor (_.car/1 @savepoint))) - -(def: cursor-top - Computation - (_.car/1 @cursor)) - -(def: pop-cursor! - Computation - (pop! @cursor)) - -(def: pm-error (_.string "PM-ERROR")) - -(def: fail-pm! (_.raise/1 pm-error)) - -(def: @temp (_.var "lux_pm_temp")) - -(exception: #export (unrecognized-path) - "") - -(def: $alt_error (_.var "alt_error")) - -(def: (pm-catch handler) - (-> Expression Computation) - (_.lambda [(list $alt_error) #.None] - (_.if (|> $alt_error (_.eqv?/2 pm-error)) - handler - (_.raise/1 $alt_error)))) - -(def: (pattern-matching' translate pathP) - (-> Phase Path (Operation Expression)) - (.case pathP - (^ (synthesis.path/then bodyS)) - (translate bodyS) - - #synthesis.Pop - (/////wrap pop-cursor!) - - (#synthesis.Bind register) - (/////wrap (_.define (reference.local' register) [(list) #.None] - cursor-top)) - - (^template [ <=>] - (^ ( value)) - (/////wrap (_.when (|> value (<=> cursor-top) _.not/1) - fail-pm!))) - ([synthesis.path/bit _.bool _.eqv?/2] - [synthesis.path/i64 (<| _.int .int) _.=/2] - [synthesis.path/f64 _.float _.=/2] - [synthesis.path/text _.string _.eqv?/2]) - - (^template [ ] - (^ ( idx)) - (/////wrap (_.let (list [@temp (|> idx .int _.int (runtime.sum//get cursor-top ))]) - (_.if (_.null?/1 @temp) - fail-pm! - (push-cursor! @temp))))) - ([synthesis.side/left _.nil (<|)] - [synthesis.side/right (_.string "") inc]) - - (^template [ ] - (^ ( idx)) - (/////wrap (|> idx .int _.int ( cursor-top) push-cursor!))) - ([synthesis.member/left runtime.product//left (<|)] - [synthesis.member/right runtime.product//right inc]) - - (^template [ ] - (^ ( leftP rightP)) - (do ////.monad - [leftO (pattern-matching' translate leftP) - rightO (pattern-matching' translate rightP)] - (wrap ))) - ([synthesis.path/seq (_.begin (list leftO - rightO))] - [synthesis.path/alt (_.with-exception-handler - (pm-catch (_.begin (list restore-cursor! - rightO))) - (_.lambda [(list) #.None] - (_.begin (list save-cursor! - leftO))))]) - - _ - (////.throw unrecognized-path []))) - -(def: (pattern-matching translate pathP) - (-> Phase Path (Operation Computation)) - (do ////.monad - [pattern-matching! (pattern-matching' translate pathP)] - (wrap (_.with-exception-handler - (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (_.lambda [(list) #.None] - pattern-matching!))))) - -(def: #export (case translate [valueS pathP]) - (-> Phase [Synthesis Path] (Operation Computation)) - (do ////.monad - [valueO (translate valueS)] - (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] - [@savepoint (_.list/* (list))]))) - (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux deleted file mode 100644 index 53d7bbbcb..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux +++ /dev/null @@ -1,59 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]]] - [// - [runtime (#+ Phase)] - ["." primitive] - ["." structure] - ["." reference] - ["." function] - ["." case] - ["." loop] - ["." /// - ["." synthesis] - ["." extension]]]) - -(def: #export (translate synthesis) - Phase - (case synthesis - (^template [ ] - (^ ( value)) - ( value)) - ([synthesis.bit primitive.bit] - [synthesis.i64 primitive.i64] - [synthesis.f64 primitive.f64] - [synthesis.text primitive.text]) - - (^ (synthesis.variant variantS)) - (structure.variant translate variantS) - - (^ (synthesis.tuple members)) - (structure.tuple translate members) - - (#synthesis.Reference reference) - (reference.reference reference) - - (^ (synthesis.branch/case case)) - (case.case translate case) - - (^ (synthesis.branch/let let)) - (case.let translate let) - - (^ (synthesis.branch/if if)) - (case.if translate if) - - (^ (synthesis.loop/scope scope)) - (loop.scope translate scope) - - (^ (synthesis.loop/recur updates)) - (loop.recur translate updates) - - (^ (synthesis.function/abstraction abstraction)) - (function.function translate abstraction) - - (^ (synthesis.function/apply application)) - (function.apply translate application) - - (#synthesis.Extension extension) - (extension.apply translate extension))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux deleted file mode 100644 index a40b4953f..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common] - ["." host]]) - -(def: #export bundle - Bundle - (|> common.bundle - (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux deleted file mode 100644 index 1c55abf83..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux +++ /dev/null @@ -1,245 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["e" error] - ["." product] - ["." text - format] - [number (#+ hex)] - [collection - ["." list ("#/." functor)] - ["dict" dictionary (#+ Dictionary)]]] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax:)]] - [host (#+ import:)]] - [/// - ["." runtime (#+ Operation Phase Handler Bundle)] - ["//." /// - ["." synthesis (#+ Synthesis)] - ["." extension - ["." bundle]] - [/// - [host - ["_" scheme (#+ Expression Computation)]]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Expression) Computation)) -(type: #export Unary (-> (Vector 1 Expression) Computation)) -(type: #export Binary (-> (Vector 2 Expression) Computation)) -(type: #export Trinary (-> (Vector 3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!phase g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - Handler) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do /////.monad - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name) - (function (_ phase inputsS) - (do /////.monad - [inputsI (monad.map @ phase inputsS)] - (wrap (extension inputsI)))))) - -(def: bundle::lux - Bundle - (|> bundle.empty - (bundle.install "is?" (binary (product.uncurry _.eq?/2))) - (bundle.install "try" (unary runtime.lux//try)))) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [bit::and _.bit-and/2] - [bit::or _.bit-or/2] - [bit::xor _.bit-xor/2] - ) - -(def: (bit::left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) - subjectO)) - -(def: (bit::arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) - subjectO)) - -(def: (bit::logical-right-shift [subjectO paramO]) - Binary - (runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) - -(def: bundle::bit - Bundle - (<| (bundle.prefix "bit") - (|> bundle.empty - (bundle.install "and" (binary bit::and)) - (bundle.install "or" (binary bit::or)) - (bundle.install "xor" (binary bit::xor)) - (bundle.install "left-shift" (binary bit::left-shift)) - (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) - ))) - -(import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [ ] - [(def: ( _) - Nullary - ( ))] - - [frac::smallest (Double::MIN_VALUE) _.float] - [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] - [frac::max (Double::MAX_VALUE) _.float] - ) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - (|> subjectO ( paramO)))] - - [int::+ _.+/2] - [int::- _.-/2] - [int::* _.*/2] - [int::/ _.quotient/2] - [int::% _.remainder/2] - ) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [frac::+ _.+/2] - [frac::- _.-/2] - [frac::* _.*/2] - [frac::/ _.//2] - [frac::% _.mod/2] - [frac::= _.=/2] - [frac::< _. ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [int::= _.=/2] - [int::< _.> _.integer->char/1 _.string/1)) - -(def: bundle::int - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "+" (binary int::+)) - (bundle.install "-" (binary int::-)) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "=" (binary int::=)) - (bundle.install "<" (binary int::<)) - (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) - (bundle.install "char" (unary int::char))))) - -(def: bundle::frac - Bundle - (<| (bundle.prefix "frac") - (|> bundle.empty - (bundle.install "+" (binary frac::+)) - (bundle.install "-" (binary frac::-)) - (bundle.install "*" (binary frac::*)) - (bundle.install "/" (binary frac::/)) - (bundle.install "%" (binary frac::%)) - (bundle.install "=" (binary frac::=)) - (bundle.install "<" (binary frac::<)) - (bundle.install "smallest" (nullary frac::smallest)) - (bundle.install "min" (nullary frac::min)) - (bundle.install "max" (nullary frac::max)) - (bundle.install "to-int" (unary _.exact/1)) - (bundle.install "encode" (unary _.number->string/1)) - (bundle.install "decode" (unary runtime.frac//decode))))) - -(def: (text::char [subjectO paramO]) - Binary - (_.string/1 (_.string-ref/2 subjectO paramO))) - -(def: (text::clip [subjectO startO endO]) - Trinary - (_.substring/3 subjectO startO endO)) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary (product.uncurry _.string-append/2))) - (bundle.install "size" (unary _.string-length/1)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: (io::log input) - Unary - (_.begin (list (_.display/1 input) - _.newline/0))) - -(def: (void code) - (-> Expression Computation) - (_.begin (list code (_.string synthesis.unit)))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> io::log ..void))) - (bundle.install "error" (unary _.raise/1)) - (bundle.install "exit" (unary _.exit/1)) - (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dict.merge bundle::bit) - (dict.merge bundle::int) - (dict.merge bundle::frac) - (dict.merge bundle::text) - (dict.merge bundle::io) - ))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux deleted file mode 100644 index b8b2b7612..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux +++ /dev/null @@ -1,11 +0,0 @@ -(.module: - [lux #*] - [/// - [runtime (#+ Bundle)] - [/// - [extension - ["." bundle]]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux deleted file mode 100644 index fe08b6a50..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux +++ /dev/null @@ -1,92 +0,0 @@ -(.module: - [lux (#- function) - [control - ["." monad (#+ do)] - pipe] - [data - ["." product] - [text - format] - [collection - ["." list ("#/." functor)]]]] - [// - ["." runtime (#+ Operation Phase)] - ["." reference] - ["/." // - ["//." // ("#/." monad) - [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - [// - [reference (#+ Register Variable)] - ["." name] - [// - [host - ["_" scheme (#+ Expression Computation Var)]]]]]]]) - -(def: #export (apply translate [functionS argsS+]) - (-> Phase (Application Synthesis) (Operation Computation)) - (do ////.monad - [functionO (translate functionS) - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply/* functionO argsO+)))) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Computation (Operation Computation)) - (let [@closure (_.var (format function-name "___CLOSURE"))] - (/////wrap - (case inits - #.Nil - function-definition - - _ - (_.letrec (list [@closure - (_.lambda [(|> (list.enumerate inits) - (list/map (|>> product.left reference.foreign'))) - #.None] - function-definition)]) - (_.apply/* @closure inits)))))) - -(def: @curried (_.var "curried")) -(def: @missing (_.var "missing")) - -(def: input - (|>> inc reference.local')) - -(def: #export (function translate [environment arity bodyS]) - (-> Phase (Abstraction Synthesis) (Operation Computation)) - (do ////.monad - [[function-name bodyO] (///.with-context - (do @ - [function-name ///.context] - (///.with-anchor (_.var function-name) - (translate bodyS)))) - closureO+ (monad.map @ reference.variable environment) - #let [arityO (|> arity .int _.int) - @num-args (_.var "num_args") - @function (_.var function-name) - apply-poly (.function (_ args func) - (_.apply/2 (_.global "apply") func args))]] - (with-closure function-name closureO+ - (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] - (_.let (list [@num-args (_.length/1 @curried)]) - (<| (_.if (|> @num-args (_.=/2 arityO)) - (<| (_.let (list [(reference.local' 0) @function])) - (_.let-values (list [[(|> (list.indices arity) - (list/map ..input)) - #.None] - (_.apply/2 (_.global "apply") (_.global "values") @curried)])) - bodyO)) - (_.if (|> @num-args (_.>/2 arityO)) - (let [arity-args (runtime.slice (_.int +0) arityO @curried) - output-func-args (runtime.slice arityO - (|> @num-args (_.-/2 arityO)) - @curried)] - (|> @function - (apply-poly arity-args) - (apply-poly output-func-args)))) - ## (|> @num-args (_. @function - (apply-poly (_.append/2 @curried @missing)))))))]) - @function)) - )) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux deleted file mode 100644 index 0d85654c1..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux (#- Scope) - [control - ["." monad (#+ do)]] - [data - ["." product] - ["." text - format] - [collection - ["." list ("#/." functor)]]]] - [// - [runtime (#+ Operation Phase)] - ["." reference] - ["/." // - ["//." // - [synthesis (#+ Scope Synthesis)] - [/// - [host - ["_" scheme (#+ Computation Var)]]]]]]) - -(def: @scope (_.var "scope")) - -(def: #export (scope translate [start initsS+ bodyS]) - (-> Phase (Scope Synthesis) (Operation Computation)) - (do ////.monad - [initsO+ (monad.map @ translate initsS+) - bodyO (///.with-anchor @scope - (translate bodyS))] - (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ - list.enumerate - (list/map (|>> product.left (n/+ start) reference.local'))) - #.None] - bodyO)]) - (_.apply/* @scope initsO+))))) - -(def: #export (recur translate argsS+) - (-> Phase (List Synthesis) (Operation Computation)) - (do ////.monad - [@scope ///.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux deleted file mode 100644 index dc643bcbc..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux (#- i64)] - [// - [runtime (#+ Operation)] - [// (#+ State) - ["//." // ("#/." monad) - [/// - [host - ["_" scheme (#+ Expression)]]]]]]) - -(def: #export bit - (-> Bit (Operation Expression)) - (|>> _.bool /////wrap)) - -(def: #export i64 - (-> (I64 Any) (Operation Expression)) - (|>> .int _.int /////wrap)) - -(def: #export f64 - (-> Frac (Operation Expression)) - (|>> _.float /////wrap)) - -(def: #export text - (-> Text (Operation Expression)) - (|>> _.string /////wrap)) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux deleted file mode 100644 index 161d2adea..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux #* - [control - pipe] - [data - [text - format]]] - [// - [runtime (#+ Operation)] - ["/." // - ["//." // ("#/." monad) - [analysis (#+ Variant Tuple)] - [synthesis (#+ Synthesis)] - [// - ["." reference (#+ Register Variable Reference)] - [// - [host - ["_" scheme (#+ Expression Global Var)]]]]]]]) - -(do-template [ ] - [(def: #export - (-> Register Var) - (|>> .int %i (format ) _.var))] - - [local' "l"] - [foreign' "f"] - ) - -(def: #export variable - (-> Variable (Operation Var)) - (|>> (case> (#reference.Local register) - (local' register) - - (#reference.Foreign register) - (foreign' register)) - /////wrap)) - -(def: #export constant - (-> Name (Operation Global)) - (|>> ///.remember (/////map _.global))) - -(def: #export reference - (-> Reference (Operation Expression)) - (|>> (case> (#reference.Constant value) - (..constant value) - - (#reference.Variable value) - (..variable value)))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux deleted file mode 100644 index d254e8c7d..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,322 +0,0 @@ -(.module: - [lux #* - [control - ["p" parser ("#/." monad)] - [monad (#+ do)]] - [data - [number (#+ hex)] - [text - format] - [collection - ["." list ("#/." monad)]]] - ["." function] - [macro - ["." code] - ["s" syntax (#+ syntax:)]]] - ["." /// - ["//." // - [analysis (#+ Variant)] - ["." synthesis] - [// - ["." name] - [// - [host - ["_" scheme (#+ Expression Computation Var)]]]]]]) - -(do-template [ ] - [(type: #export - ( Var Expression Expression))] - - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] - ) - -(def: prefix Text "LuxRuntime") - -(def: unit (_.string synthesis.unit)) - -(def: #export variant-tag "lux-variant") - -(def: (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Computation) - (<| (_.cons/2 (_.symbol ..variant-tag)) - (_.cons/2 tag) - (_.cons/2 last?) - value)) - -(def: #export (variant [lefts right? value]) - (-> (Variant Expression) Computation) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - Computation - (variant [0 #0 ..unit])) - -(def: #export some - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.and s.local-identifier (p/wrap (list))) - (s.form (p.and s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format prefix "__" (name.normalize name)) - @runtime (` (_.var (~ (code.text runtime)))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Computation))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Computation - (~ (case argsC+ - #.Nil - (` (_.define (~ @runtime) [(list) #.None] (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] - (~ definition)))))))))))) - -(runtime: (slice offset length list) - (<| (_.if (_.null?/1 list) - list) - (_.if (|> offset (_.>/2 (_.int +0))) - (slice (|> offset (_.-/2 (_.int +1))) - length - (_.cdr/1 list))) - (_.if (|> length (_.>/2 (_.int +0))) - (_.cons/2 (_.car/1 list) - (slice offset - (|> length (_.-/2 (_.int +1))) - (_.cdr/1 list)))) - _.nil)) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) - list/join))] - (~ body)))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler - (_.lambda [(list error) #.None] - (..left error)) - (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) - -(runtime: (lux//program-args program-args) - (with-vars [@loop @input @output] - (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) - -(def: runtime//lux - Computation - (_.begin (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Computation) - (|>> (_.+/2 (_.int +1)))) - -(def: product-element - (-> Expression Expression Computation) - (function.flip _.vector-ref/2)) - -(def: (product-tail product) - (-> Expression Computation) - (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Computation) - (|> min-length (_.-/2 (_.length/1 product)))) - -(runtime: (product//left product index) - (let [@index_min_length (_.var "index_min_length")] - (_.begin - (list (_.define @index_min_length [(list) #.None] - (minimum-index-length index)) - (_.if (|> product _.length/1 (_.>/2 @index_min_length)) - ## No need for recursion - (product-element index product) - ## Needs recursion - (product//left (product-tail product) - (updated-index @index_min_length product))))))) - -(runtime: (product//right product index) - (let [@index_min_length (_.var "index_min_length") - @product_length (_.var "product_length") - @slice (_.var "slice") - last-element? (|> @product_length (_.=/2 @index_min_length)) - needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) - (_.vector-copy!/5 @slice (_.int +0) product index @product_length) - @slice))))))) - -(runtime: (sum//get sum last? wanted-tag) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get sum-value - (|> wanted-tag (_.-/2 sum-tag)) - last?) - no-match)] - (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] - (_.apply/* (_.global "apply") (list (_.global "values") sum))])) - (_.if (|> wanted-tag (_.=/2 sum-tag)) - (_.if (|> sum-flag (_.eqv?/2 last?)) - sum-value - test-recursion)) - (_.if (|> wanted-tag (_.>/2 sum-tag)) - test-recursion) - (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) - (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) - no-match)))) - -(def: runtime//adt - Computation - (_.begin (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.=/2 (_.int +0) shift) - input - (|> input - (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) - (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Computation - (_.begin (list @@bit//logical-right-shift))) - -(runtime: (frac//decode input) - (with-vars [@output] - (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) - (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) - (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) - ..none - (..some @output))))) - -(def: runtime//frac - Computation - (_.begin - (list @@frac//decode))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Computation) - (_.if (|> idx (_.<=/2 (_.length/1 array))) - body - (_.raise/1 (_.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (with-vars [@temp] - (<| (check-index-out-of-bounds array idx) - (_.let (list [@temp (_.vector-ref/2 array idx)]) - (_.if (|> @temp (_.eqv?/2 _.nil)) - ..none - (..some @temp)))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds array idx) - (_.begin - (list (_.vector-set!/3 array idx value) - array)))) - -(def: runtime//array - Computation - (_.begin - (list @@array//get - @@array//put))) - -(runtime: (box//write value box) - (_.begin - (list - (_.vector-set!/3 box (_.int +0) value) - ..unit))) - -(def: runtime//box - Computation - (_.begin (list @@box//write))) - -(runtime: (io//current-time _) - (|> (_.apply/* (_.global "current-second") (list)) - (_.*/2 (_.int +1_000)) - _.exact/1)) - -(def: runtime//io - (_.begin (list @@io//current-time))) - -(def: runtime - Computation - (_.begin (list @@slice - runtime//lux - runtime//bit - runtime//adt - runtime//frac - runtime//array - runtime//box - runtime//io - ))) - -(def: #export translate - (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.save! ["" ..prefix] ..runtime)] - (///.save-buffer! "")))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux deleted file mode 100644 index dc1b88591..000000000 --- a/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux +++ /dev/null @@ -1,33 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)]]] - [// - ["." runtime (#+ Operation Phase)] - ["." primitive] - ["." /// - [analysis (#+ Variant Tuple)] - ["." synthesis (#+ Synthesis)] - [/// - [host - ["_" scheme (#+ Expression)]]]]]) - -(def: #export (tuple translate elemsS+) - (-> Phase (Tuple Synthesis) (Operation Expression)) - (case elemsS+ - #.Nil - (primitive.text synthesis.unit) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do ///.monad - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (_.vector/* elemsT+))))) - -(def: #export (variant translate [lefts right? valueS]) - (-> Phase (Variant Synthesis) (Operation Expression)) - (do ///.monad - [valueT (translate valueS)] - (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/platform/compiler/reference.lux b/stdlib/source/lux/platform/compiler/reference.lux deleted file mode 100644 index a20691986..000000000 --- a/stdlib/source/lux/platform/compiler/reference.lux +++ /dev/null @@ -1,88 +0,0 @@ -(.module: - [lux #* - [control - [equivalence (#+ Equivalence)] - [hash (#+ Hash)] - pipe] - [data - [text - format]]]) - -(type: #export Register Nat) - -(type: #export Variable - (#Local Register) - (#Foreign Register)) - -(type: #export Reference - (#Variable Variable) - (#Constant Name)) - -(structure: #export equivalence (Equivalence Variable) - (def: (= reference sample) - (case [reference sample] - (^template [] - [( reference') ( sample')] - (n/= reference' sample')) - ([#Local] [#Foreign]) - - _ - #0))) - -(structure: #export hash (Hash Variable) - (def: &equivalence ..equivalence) - (def: (hash var) - (case var - (#Local register) - (n/* 1 register) - - (#Foreign register) - (n/* 2 register)))) - -(do-template [ ] - [(template: #export ( content) - (<| - - content))] - - [local #..Variable #..Local] - [foreign #..Variable #..Foreign] - ) - -(do-template [ ] - [(template: #export ( content) - (<| - content))] - - [variable #..Variable] - [constant #..Constant] - ) - -(def: #export self Reference (..local 0)) - -(def: #export self? - (-> Variable Bit) - (|>> ..variable - (case> (^ (..local 0)) - #1 - - _ - #0))) - -(def: #export (%variable variable) - (Format Variable) - (case variable - (#Local local) - (format "+" (%n local)) - - (#Foreign foreign) - (format "-" (%n foreign)))) - -(def: #export (%reference reference) - (Format Reference) - (case reference - (#Variable variable) - (%variable variable) - - (#Constant constant) - (%name constant))) diff --git a/stdlib/source/lux/platform/interpreter.lux b/stdlib/source/lux/platform/interpreter.lux deleted file mode 100644 index d2fbccfdc..000000000 --- a/stdlib/source/lux/platform/interpreter.lux +++ /dev/null @@ -1,221 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ Monad do)] - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - ["." text ("#/." equivalence) - format]] - [type (#+ :share) - ["." check]] - [compiler - ["." phase - ["." analysis - ["." module] - ["." type]] - ["." translation] - ["." statement (#+ State+ Operation) - ["." total]] - ["." extension]] - ["." default - ["." syntax] - ["." platform (#+ Platform)] - ["." init]] - ["." cli (#+ Configuration)]] - [world - ["." file (#+ File)] - ["." console (#+ Console)]]] - ["." /type]) - -(exception: #export (error {message Text}) - message) - -(def: #export module "") - -(def: fresh-source Source [[..module 1 0] 0 ""]) - -(def: (add-line line [where offset input]) - (-> Text Source Source) - [where offset (format input text.new-line line)]) - -(def: exit-command Text "exit") - -(def: welcome-message - Text - (format text.new-line - "Welcome to the interpreter!" text.new-line - "Type '" ..exit-command "' to leave." text.new-line - text.new-line)) - -(def: farewell-message - Text - "Till next time...") - -(def: enter-module - (All [anchor expression statement] - (Operation anchor expression statement Any)) - (statement.lift-analysis - (do phase.monad - [_ (module.create 0 ..module)] - (analysis.set-current-module ..module)))) - -(def: (initialize Monad Console platform configuration translation-bundle) - (All [! anchor expression statement] - (-> (Monad !) - (Console !) (Platform ! anchor expression statement) - Configuration - (translation.Bundle anchor expression statement) - (! (State+ anchor expression statement)))) - (do Monad - [state (platform.initialize platform translation-bundle) - state (platform.compile platform - (set@ #cli.module syntax.prelude configuration) - (set@ [#extension.state - #statement.analysis #statement.state - #extension.state - #.info #.mode] - #.Interpreter - state)) - [state _] (:: (get@ #platform.file-system platform) - lift (phase.run' state enter-module)) - _ (:: Console write ..welcome-message)] - (wrap state))) - -(with-expansions [ (as-is (Operation anchor expression statement [Type Any]))] - - (def: (interpret-statement code) - (All [anchor expression statement] - (-> Code )) - (do phase.monad - [_ (total.phase code) - _ init.refresh] - (wrap [Any []]))) - - (def: (interpret-expression code) - (All [anchor expression statement] - (-> Code )) - (do phase.monad - [state (extension.lift phase.get-state) - #let [analyse (get@ [#statement.analysis #statement.phase] state) - synthesize (get@ [#statement.synthesis #statement.phase] state) - translate (get@ [#statement.translation #statement.phase] state)] - [_ codeT codeA] (statement.lift-analysis - (analysis.with-scope - (type.with-fresh-env - (do @ - [[codeT codeA] (type.with-inference - (analyse code)) - codeT (type.with-env - (check.clean codeT))] - (wrap [codeT codeA]))))) - codeS (statement.lift-synthesis - (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer - (do @ - [codeH (translate codeS) - count translation.next - codeV (translation.evaluate! (format "interpretation_" (%n count)) codeH)] - (wrap [codeT codeV])))))) - - (def: (interpret configuration code) - (All [anchor expression statement] - (-> Configuration Code )) - (function (_ state) - (case (<| (phase.run' state) - (:share [anchor expression statement] - {(State+ anchor expression statement) - state} - { - (interpret-statement code)})) - (#error.Success [state' output]) - (#error.Success [state' output]) - - (#error.Failure error) - (if (ex.match? total.not-a-statement error) - (<| (phase.run' state) - (:share [anchor expression statement] - {(State+ anchor expression statement) - state} - { - (interpret-expression code)})) - (#error.Failure error))))) - ) - -(def: (execute configuration code) - (All [anchor expression statement] - (-> Configuration Code (Operation anchor expression statement Text))) - (do phase.monad - [[codeT codeV] (interpret configuration code) - state phase.get-state] - (wrap (/type.represent (get@ [#extension.state - #statement.analysis #statement.state - #extension.state] - state) - codeT - codeV)))) - -(type: (Context anchor expression statement) - {#configuration Configuration - #state (State+ anchor expression statement) - #source Source}) - -(with-expansions [ (as-is (Context anchor expression statement))] - (def: (read-eval-print context) - (All [anchor expression statement] - (-> (Error [ Text]))) - (do error.monad - [#let [[_where _offset _code] (get@ #source context)] - [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context)) - [state' representation] (let [## TODO: Simplify ASAP - state (:share [anchor expression statement] - { - context} - {(State+ anchor expression statement) - (get@ #state context)})] - (<| (phase.run' state) - ## TODO: Simplify ASAP - (:share [anchor expression statement] - { - context} - {(Operation anchor expression statement Text) - (execute (get@ #configuration context) input)})))] - (wrap [(|> context - (set@ #state state') - (set@ #source source')) - representation])))) - -(def: #export (run Monad Console platform configuration translation-bundle) - (All [! anchor expression statement] - (-> (Monad !) - (Console !) (Platform ! anchor expression statement) - Configuration - (translation.Bundle anchor expression statement) - (! Any))) - (do Monad - [state (initialize Monad Console platform configuration)] - (loop [context {#configuration configuration - #state state - #source ..fresh-source} - multi-line? #0] - (do @ - [_ (if multi-line? - (:: Console write " ") - (:: Console write "> ")) - line (:: Console read-line)] - (if (and (not multi-line?) - (text/= ..exit-command line)) - (:: Console write ..farewell-message) - (case (read-eval-print (update@ #source (add-line line) context)) - (#error.Success [context' representation]) - (do @ - [_ (:: Console write representation)] - (recur context' #0)) - - (#error.Failure error) - (if (ex.match? syntax.end-of-file error) - (recur context #1) - (exec (log! (ex.construct ..error error)) - (recur (set@ #source ..fresh-source context) #0)))))) - ))) diff --git a/stdlib/source/lux/platform/interpreter/type.lux b/stdlib/source/lux/platform/interpreter/type.lux deleted file mode 100644 index f6a66a76a..000000000 --- a/stdlib/source/lux/platform/interpreter/type.lux +++ /dev/null @@ -1,203 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)] - ["p" parser] - pipe] - [data - ["." error (#+ Error)] - [text - format] - [format - [xml (#+ XML)] - [json (#+ JSON)]] - [collection - ["." list]]] - [time - [instant (#+ Instant)] - [duration (#+ Duration)] - [date (#+ Date)]] - ["." function] - ["." type] - ["." macro - ["." code] - ["." poly (#+ Poly)]]]) - -(exception: #export (cannot-represent-value {type Type}) - (ex.report ["Type" (%type type)])) - -(type: Representation (-> Any Text)) - -(def: primitive-representation - (Poly Representation) - (`` ($_ p.either - (do p.monad - [_ (poly.exactly Any)] - (wrap (function.constant "[]"))) - - (~~ (do-template [ ] - [(do p.monad - [_ (poly.sub )] - (wrap (|>> (:coerce ) )))] - - [Bit %b] - [Nat %n] - [Int %i] - [Rev %r] - [Frac %f] - [Text %t]))))) - -(def: (special-representation representation) - (-> (Poly Representation) (Poly Representation)) - (`` ($_ p.either - (~~ (do-template [ ] - [(do p.monad - [_ (poly.sub )] - (wrap (|>> (:coerce ) )))] - - [Type %type] - [Code %code] - [Instant %instant] - [Duration %duration] - [Date %date] - [JSON %json] - [XML %xml])) - - (do p.monad - [[_ elemT] (poly.apply (p.and (poly.exactly List) poly.any)) - elemR (poly.local (list elemT) representation)] - (wrap (|>> (:coerce (List Any)) (%list elemR)))) - - (do p.monad - [[_ elemT] (poly.apply (p.and (poly.exactly Maybe) poly.any)) - elemR (poly.local (list elemT) representation)] - (wrap (|>> (:coerce (Maybe Any)) - (case> #.None - "#.None" - - (#.Some elemV) - (format "(#.Some " (elemR elemV) ")")))))))) - -(def: (record-representation tags representation) - (-> (List Name) (Poly Representation) (Poly Representation)) - (do p.monad - [membersR+ (poly.tuple (p.many representation)) - _ (p.assert "Number of tags does not match record type size." - (n/= (list.size tags) (list.size membersR+)))] - (wrap (function (_ recordV) - (let [record-body (loop [pairs-left (list.zip2 tags membersR+) - recordV recordV] - (case pairs-left - #.Nil - "" - - (#.Cons [tag repr] #.Nil) - (format (%code (code.tag tag)) " " (repr recordV)) - - (#.Cons [tag repr] tail) - (let [[leftV rightV] (:coerce [Any Any] recordV)] - (format (%code (code.tag tag)) " " (repr leftV) " " - (recur tail rightV)))))] - (format "{" record-body "}")))))) - -(def: (variant-representation tags representation) - (-> (List Name) (Poly Representation) (Poly Representation)) - (do p.monad - [casesR+ (poly.variant (p.many representation)) - #let [num-tags (list.size tags)] - _ (p.assert "Number of tags does not match variant type size." - (n/= num-tags (list.size casesR+)))] - (wrap (function (_ variantV) - (loop [cases-left (list.zip3 tags - (list.indices num-tags) - casesR+) - variantV variantV] - (case cases-left - #.Nil - "" - - (#.Cons [tag-name tag-idx repr] #.Nil) - (let [[_tag _last? _value] (:coerce [Nat Text Any] variantV)] - (if (n/= tag-idx _tag) - (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") - (undefined))) - - (#.Cons [tag-name tag-idx repr] tail) - (let [[_tag _last? _value] (:coerce [Nat Text Any] variantV)] - (if (n/= tag-idx _tag) - (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") - (recur tail variantV))))))))) - -(def: (tagged-representation compiler representation) - (-> Lux (Poly Representation) (Poly Representation)) - (do p.monad - [[name anonymous] poly.named] - (case (macro.run compiler (macro.tags-of name)) - (#error.Success ?tags) - (case ?tags - (#.Some tags) - (poly.local (list anonymous) - (p.either (record-representation tags representation) - (variant-representation tags representation))) - - #.None - representation) - - (#error.Failure error) - (p.fail error)))) - -(def: (tuple-representation representation) - (-> (Poly Representation) (Poly Representation)) - (do p.monad - [membersR+ (poly.tuple (p.many representation))] - (wrap (function (_ tupleV) - (let [tuple-body (loop [representations membersR+ - tupleV tupleV] - (case representations - #.Nil - "" - - (#.Cons lastR #.Nil) - (lastR tupleV) - - (#.Cons headR tailR) - (let [[leftV rightV] (:coerce [Any Any] tupleV)] - (format (headR leftV) " " (recur tailR rightV)))))] - (format "[" tuple-body "]")))))) - -(def: (representation compiler) - (-> Lux (Poly Representation)) - (p.rec - (function (_ representation) - ($_ p.either - primitive-representation - (special-representation representation) - (tagged-representation compiler representation) - (tuple-representation representation) - - (do p.monad - [[funcT inputsT+] (poly.apply (p.and poly.any (p.many poly.any)))] - (case (type.apply inputsT+ funcT) - (#.Some outputT) - (poly.local (list outputT) representation) - - #.None - (p.fail ""))) - - (do p.monad - [[name anonymous] poly.named] - (poly.local (list anonymous) representation)) - - (p.fail "") - )))) - -(def: #export (represent compiler type value) - (-> Lux Type Any Text) - (case (poly.run type (representation compiler)) - (#error.Success representation) - (ex.report ["Type" (%type type)] - ["Value" (representation value)]) - - (#error.Failure error) - (ex.construct cannot-represent-value [type]))) diff --git a/stdlib/source/lux/platform/mediator.lux b/stdlib/source/lux/platform/mediator.lux deleted file mode 100644 index 4481b6e2e..000000000 --- a/stdlib/source/lux/platform/mediator.lux +++ /dev/null @@ -1,20 +0,0 @@ -(.module: - [lux (#- Source Module) - [data - ["." error (#+ Error)]] - [world - ["." binary (#+ Binary)] - ["." file (#+ File)]]] - [// - [compiler (#+ Compiler) - [meta - ["." archive (#+ Archive) - [descriptor (#+ Module)]]]]]) - -(type: #export Source File) - -(type: #export (Mediator !) - (-> Archive Module (! Archive))) - -(type: #export (Instancer ! d o) - (-> (file.System !) (List Source) (Compiler d o) (Mediator !))) diff --git a/stdlib/source/lux/platform/mediator/parallelism.lux b/stdlib/source/lux/platform/mediator/parallelism.lux deleted file mode 100644 index c694f0490..000000000 --- a/stdlib/source/lux/platform/mediator/parallelism.lux +++ /dev/null @@ -1,169 +0,0 @@ -(.module: - [lux (#- Source Module) - [control - ["." monad (#+ Monad do)] - ["ex" exception (#+ exception:)]] - [concurrency - ["." promise (#+ Promise) ("#/." functor)] - ["." task (#+ Task)] - ["." stm (#+ Var STM)]] - [data - ["." error (#+ Error) ("#/." monad)] - ["." text ("#/." equivalence) - format] - [collection - ["." list ("#/." functor)] - ["." dictionary (#+ Dictionary)]]] - ["." io]] - ["." // (#+ Source Mediator) - [// - ["." compiler (#+ Input Output Compilation Compiler) - [meta - ["." archive (#+ Archive) - ["." descriptor (#+ Module Descriptor)] - [document (#+ Document)]] - [io - ["." context]]]]]]) - -(exception: #export (self-dependency {module Module}) - (ex.report ["Module" module])) - -(exception: #export (circular-dependency {module Module} {dependency Module}) - (ex.report ["Module" module] - ["Dependency" dependency])) - -(type: Pending-Compilation - (Promise (Error (Ex [d] (Document d))))) - -(type: Active-Compilations - (Dictionary Module [Descriptor Pending-Compilation])) - -(def: (self-dependence? module dependency) - (-> Module Module Bit) - (text/= module dependency)) - -(def: (circular-dependence? active dependency) - (-> Active-Compilations Module Bit) - (case (dictionary.get dependency active) - (#.Some [descriptor pending]) - (case (get@ #descriptor.state descriptor) - #.Active - true - - _ - false) - - #.None - false)) - -(def: (ensure-valid-dependencies! active dependencies module) - (-> Active-Compilations (List Module) Module (Task Any)) - (do task.monad - [_ (: (Task Any) - (if (list.any? (self-dependence? module) dependencies) - (task.throw self-dependency module) - (wrap [])))] - (: (Task Any) - (case (list.find (circular-dependence? active) dependencies) - (#.Some dependency) - (task.throw circular-dependency module dependency) - - #.None - (wrap []))))) - -(def: (share-compilation archive pending) - (-> Active-Compilations Pending-Compilation (Task Archive)) - (promise/map (|>> (error/map (function (_ document) - (archive.add module document archive))) - error/join) - pending)) - -(def: (import Monad mediate archive dependencies) - (All [!] (-> (Monad !) (Mediator !) Active-Compilations (List Module) (! (List Archive)))) - (|> dependencies - (list/map (mediate archive)) - (monad.seq Monad))) - -(def: (step-compilation archive imports [dependencies process]) - (All [d o] (-> Archive (List Archive) (Compilation d o) - [Archive (Either (Compilation d o) - [(Document d) (Output o)])])) - (do error.monad - [archive' (monad.fold error.monad archive.merge archive imports) - outcome (process archive')] - (case outcome - (#.Right [document output]) - (do @ - [archive'' (archive.add module document archive')] - (wrap [archive'' (#.Right [document output])])) - - (#.Left continue) - (wrap [archive' outcome])))) - -(def: (request-compilation file-system sources module compilations) - (All [!] - (-> (file.System Task) (List Source) Module (Var Active-Compilations) - (Task (Either Pending-Compilation - [Pending-Compilation Active-Compilations Input])))) - (do (:: file-system &monad) - [current (|> (stm.read compilations) - stm.commit - task.from-promise)] - (case (dictionary.get module current) - (#.Some [descriptor pending]) - (wrap (#.Left pending)) - - #.None - (do @ - [input (context.read file-system sources module)] - (do stm.monad - [stale (stm.read compilations)] - (case (dictionary.get module stale) - (#.Some [descriptor pending]) - (wrap (#.Left [pending current])) - - #.None - (do @ - [#let [base-descriptor {#descriptor.hash (get@ #compiler.hash input) - #descriptor.name (get@ #compiler.module input) - #descriptor.file (get@ #compiler.file input) - #descriptor.references (list) - #descriptor.state #.Active} - pending (promise.promise (: (Maybe (Error (Ex [d] (Document d)))) - #.None))] - updated (stm.update (dictionary.put (get@ #compiler.module input) - [base-descriptor pending]) - compilations)] - (wrap (is? current stale) - (#.Right [pending updated input]))))))))) - -(def: (mediate-compilation Monad mediate compiler input archive pending) - (All [! d o] (-> (Monad !) (Mediator ! d o) (Compiler d o) Input Archive Pending-Compilation (Task Archive))) - (loop [archive archive - compilation (compiler input)] - (do Monad - [#let [[dependencies process] compilation] - _ (ensure-valid-dependencies! active dependencies (get@ #compiler.module input)) - imports (import @ mediate archive dependencies) - [archive' next] (promise/wrap (step-compilation archive imports compilation))] - (case next - (#.Left continue) - (recur archive' continue) - - (#.Right [document output]) - (exec (io.run (promise.resolve (#error.Success document) pending)) - (wrap archive')))))) - -(def: #export (mediator file-system sources compiler) - (//.Instancer Task) - (let [compilations (: (Var Active-Compilations) - (stm.var (dictionary.new text.hash)))] - (function (mediate archive module) - (do (:: file-system &monad) - [request (request-compilation file-system sources module compilations)] - (case request - (#.Left pending) - (share-compilation archive pending) - - (#.Right [pending active input]) - (mediate-compilation @ mediate compiler input archive pending)))))) diff --git a/stdlib/source/lux/tool/compiler.lux b/stdlib/source/lux/tool/compiler.lux new file mode 100644 index 000000000..b4fdd541e --- /dev/null +++ b/stdlib/source/lux/tool/compiler.lux @@ -0,0 +1,46 @@ +(.module: + [lux (#- Module Source Code) + [control + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + [collection + ["." dictionary (#+ Dictionary)]]] + [world + ["." file (#+ File)]]] + [/ + [meta + ["." archive (#+ Archive) + [key (#+ Key)] + [descriptor (#+ Module)] + [document (#+ Document)]]]]) + +(type: #export Code + Text) + +(type: #export Parameter + Text) + +(type: #export Input + {#module Module + #file File + #hash Nat + #code Code}) + +(type: #export (Output o) + (Dictionary Text o)) + +(type: #export (Compilation d o) + {#dependencies (List Module) + #process (-> Archive + (Error (Either (Compilation d o) + [(Document d) (Output o)])))}) + +(type: #export (Compiler d o) + (-> Input (Compilation d o))) + +(type: #export (Instancer d o) + (-> (Key d) (List Parameter) (Compiler d o))) + +(exception: #export (cannot-compile {module Module}) + (ex.report ["Module" module])) diff --git a/stdlib/source/lux/tool/compiler/cli.lux b/stdlib/source/lux/tool/compiler/cli.lux new file mode 100644 index 000000000..7e92b2c34 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/cli.lux @@ -0,0 +1,41 @@ +(.module: + [lux #* + [control + ["p" parser]] + ["." cli (#+ CLI)] + [world + [file (#+ File)]]] + [/// + [importer (#+ Source)]]) + +(type: #export Configuration + {#sources (List Source) + #target File + #module Text}) + +(type: #export Service + (#Compilation Configuration) + (#Interpretation Configuration)) + +(do-template [ ] + [(def: #export + (CLI Text) + (cli.parameter [ ]))] + + [source "-s" "--source"] + [target "-t" "--target"] + [module "-m" "--module"] + ) + +(def: #export configuration + (CLI Configuration) + ($_ p.and + (p.some ..source) + ..target + ..module)) + +(def: #export service + (CLI Service) + ($_ p.or + (p.after (cli.this "build") ..configuration) + (p.after (cli.this "repl") ..configuration))) diff --git a/stdlib/source/lux/tool/compiler/default.lux b/stdlib/source/lux/tool/compiler/default.lux new file mode 100644 index 000000000..726562cc8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/default.lux @@ -0,0 +1,6 @@ +(.module: + [lux #*]) + +(type: #export Version Text) + +(def: #export version Version "0.6.0") diff --git a/stdlib/source/lux/tool/compiler/default/cache.lux b/stdlib/source/lux/tool/compiler/default/cache.lux new file mode 100644 index 000000000..1770b4a82 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/default/cache.lux @@ -0,0 +1,35 @@ +(.module: + [lux #* + [data + [format + ["_" binary (#+ Format)]]]]) + +(def: definition + (Format Definition) + ($_ _.and _.type _.code _.any)) + +(def: alias + (Format [Text Text]) + (_.and _.text _.text)) + +## TODO: Remove #module-hash, #imports & #module-state ASAP. +## TODO: Not just from this parser, but from the lux.Module type. +(def: #export module + (Format Module) + ($_ _.and + ## #module-hash + (_.ignore 0) + ## #module-aliases + (_.list ..alias) + ## #definitions + (_.list (_.and _.text ..definition)) + ## #imports + (_.list _.text) + ## #tags + (_.ignore (list)) + ## #types + (_.ignore (list)) + ## #module-annotations + (_.maybe _.code) + ## #module-state + (_.ignore #.Cached))) diff --git a/stdlib/source/lux/tool/compiler/default/evaluation.lux b/stdlib/source/lux/tool/compiler/default/evaluation.lux new file mode 100644 index 000000000..1f21304ca --- /dev/null +++ b/stdlib/source/lux/tool/compiler/default/evaluation.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." error] + [text + format]]] + [/// + ["." phase + [analysis (#+ Operation) + [".A" expression] + ["." type]] + ["." synthesis + [".S" expression]] + ["." translation]]]) + +(type: #export Eval + (-> Nat Type Code (Operation Any))) + +(def: #export (evaluator synthesis-state translation-state translate) + (All [anchor expression statement] + (-> synthesis.State+ + (translation.State+ anchor expression statement) + (translation.Phase anchor expression statement) + Eval)) + (function (eval count type exprC) + (do phase.monad + [exprA (type.with-type type + (expressionA.compile exprC))] + (phase.lift (do error.monad + [exprS (|> exprA expressionS.phase (phase.run synthesis-state))] + (phase.run translation-state + (do phase.monad + [exprO (translate exprS)] + (translation.evaluate! (format "eval" (%n count)) exprO)))))))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux new file mode 100644 index 000000000..a416c0a3b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -0,0 +1,198 @@ +(.module: + [lux (#- Module loop) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error (#+ Error)] + ["." text ("#/." hash)] + [collection + ["." dictionary]]] + ["." macro] + [world + ["." file]]] + ["." // + ["." syntax (#+ Aliases)] + ["." evaluation] + ["/." // (#+ Compiler) + ["." host] + ["." phase + ["." analysis + ["." module] + [".A" expression]] + ["." synthesis + [".S" expression]] + ["." translation] + ["." statement + [".S" total]] + ["." extension + [".E" analysis] + [".E" synthesis] + [".E" statement]]] + [meta + [archive + ["." signature] + ["." key (#+ Key)] + ["." descriptor (#+ Module)] + ["." document]]]]]) + +(def: #export info + Info + {#.target (`` (for {(~~ (static host.common-lisp)) host.common-lisp + (~~ (static host.js)) host.js + (~~ (static host.jvm)) host.jvm + (~~ (static host.lua)) host.lua + (~~ (static host.php)) host.php + (~~ (static host.python)) host.python + (~~ (static host.r)) host.r + (~~ (static host.ruby)) host.ruby + (~~ (static host.scheme)) host.scheme})) + #.version //.version + #.mode #.Build}) + +(def: refresh + (All [anchor expression statement] + (statement.Operation anchor expression statement Any)) + (do phase.monad + [[bundle state] phase.get-state + #let [eval (evaluation.evaluator (get@ [#statement.synthesis #statement.state] state) + (get@ [#statement.translation #statement.state] state) + (get@ [#statement.translation #statement.phase] state))]] + (phase.set-state [statementE.bundle + (update@ [#statement.analysis #statement.state] + (: (-> analysis.State+ analysis.State+) + (|>> product.right + [(analysisE.bundle eval)])) + state)]))) + +(def: #export (state host translate translation-bundle) + (All [anchor expression statement] + (-> (translation.Host expression statement) + (translation.Phase anchor expression statement) + (translation.Bundle anchor expression statement) + (statement.State+ anchor expression statement))) + (let [synthesis-state [synthesisE.bundle synthesis.init] + translation-state [translation-bundle (translation.state host)] + eval (evaluation.evaluator synthesis-state translation-state translate) + analysis-state [(analysisE.bundle eval) (analysis.state ..info host)]] + [statementE.bundle + {#statement.analysis {#statement.state analysis-state + #statement.phase expressionA.compile} + #statement.synthesis {#statement.state synthesis-state + #statement.phase expressionS.phase} + #statement.translation {#statement.state translation-state + #statement.phase translate}}])) + +(type: Reader + (-> Source (Error [Source Code]))) + +(def: (reader current-module aliases) + (-> Module Aliases (analysis.Operation Reader)) + (function (_ [bundle state]) + (let [[cursor offset source-code] (get@ #.source state)] + (#error.Success [[bundle state] + (syntax.parse current-module aliases ("lux text size" source-code))])))) + +(def: (read reader) + (-> Reader (analysis.Operation Code)) + (function (_ [bundle compiler]) + (case (reader (get@ #.source compiler)) + (#error.Failure error) + (#error.Failure error) + + (#error.Success [source' output]) + (let [[cursor _] output] + (#error.Success [[bundle (|> compiler + (set@ #.source source') + (set@ #.cursor cursor))] + output]))))) + +(with-expansions [ (as-is (All [anchor expression statement] + (statement.Operation anchor expression statement Any)))] + + (def: (begin hash input) + (-> Nat ///.Input ) + (statement.lift-analysis + (do phase.monad + [#let [module (get@ #///.module input)] + _ (module.create hash module) + _ (analysis.set-current-module module)] + (analysis.set-source-code (analysis.source (get@ #///.module input) (get@ #///.code input)))))) + + (def: end + (-> Module ) + (|>> module.set-compiled + statement.lift-analysis)) + + (def: (iteration reader) + (-> Reader ) + (do phase.monad + [code (statement.lift-analysis + (..read reader)) + _ (totalS.phase code)] + ..refresh)) + + (def: (loop module) + (-> Module ) + (do phase.monad + [reader (statement.lift-analysis + (..reader module syntax.no-aliases))] + (function (_ state) + (.loop [state state] + (case (..iteration reader state) + (#error.Success [state' output]) + (recur state') + + (#error.Failure error) + (if (ex.match? syntax.end-of-file error) + (#error.Success [state []]) + (ex.with-stack ///.cannot-compile module (#error.Failure error)))))))) + + (def: (compile hash input) + (-> Nat ///.Input ) + (do phase.monad + [#let [module (get@ #///.module input)] + _ (..begin hash input) + _ (..loop module)] + (..end module))) + + (def: (default-dependencies prelude input) + (-> Module ///.Input (List Module)) + (if (text/= prelude (get@ #///.module input)) + (list) + (list prelude))) + ) + +(def: #export (compiler prelude state) + (All [anchor expression statement] + (-> Module + (statement.State+ anchor expression statement) + (Compiler .Module))) + (function (_ key parameters input) + (let [hash (text/hash (get@ #///.code input)) + dependencies (default-dependencies prelude input)] + {#///.dependencies dependencies + #///.process (function (_ archive) + (do error.monad + [[state' analysis-module] (phase.run' state + (: (All [anchor expression statement] + (statement.Operation anchor expression statement .Module)) + (do phase.monad + [_ (compile hash input)] + (statement.lift-analysis + (extension.lift + macro.current-module))))) + #let [descriptor {#descriptor.hash hash + #descriptor.name (get@ #///.module input) + #descriptor.file (get@ #///.file input) + #descriptor.references dependencies + #descriptor.state #.Compiled}]] + (wrap (#.Right [(document.write key descriptor analysis-module) + (dictionary.new text.hash)]))))}))) + +(def: #export key + (Key .Module) + (key.key {#signature.name (name-of ..compiler) + #signature.version //.version} + (module.new 0))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux new file mode 100644 index 000000000..7e3846c09 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -0,0 +1,109 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." product] + ["." error]] + [world + ["." file (#+ File)]]] + [// + ["." init] + ["." syntax] + ["/." // + ["." phase + ["." translation] + ["." statement]] + ["." cli (#+ Configuration)] + [meta + ["." archive] + [io + ["." context]]]]]) + +(type: #export (Platform ! anchor expression statement) + {#host (translation.Host expression statement) + #phase (translation.Phase anchor expression statement) + #runtime (translation.Operation anchor expression statement Any) + #file-system (file.System !)}) + +## (def: (write-module target-dir file-name module-name module outputs) +## (-> File Text Text Module Outputs (Process Any)) +## (do (error.with-error io.monad) +## [_ (monad.map @ (product.uncurry (&io.write target-dir)) +## (dictionary.entries outputs))] +## (&io.write target-dir +## (format module-name "/" cache.descriptor-name) +## (encoding.to-utf8 (%code (cache/description.write file-name module)))))) + +(with-expansions [ (as-is (Platform ! anchor expression statement)) + (as-is (statement.State+ anchor expression statement)) + (as-is (translation.Bundle anchor expression statement))] + + (def: #export (initialize platform translation-bundle) + (All [! anchor expression statement] + (-> (! ))) + (|> platform + (get@ #runtime) + statement.lift-translation + (phase.run' (init.state (get@ #host platform) + (get@ #phase platform) + translation-bundle)) + (:: error.functor map product.left) + (:: (get@ #file-system platform) lift)) + + ## (case (runtimeT.translate ## (initL.compiler (io.run js.init)) + ## (initL.compiler (io.run hostL.init-host)) + ## ) + ## ## (#error.Success [state disk-write]) + ## ## (do @ + ## ## [_ (&io.prepare-target target) + ## ## _ disk-write + ## ## ## _ (cache/io.pre-load sources target (commonT.load-definition state)) + ## ## ] + ## ## (wrap (|> state + ## ## (set@ [#.info #.mode] #.Build)))) + + ## (#error.Success [state [runtime-bc function-bc]]) + ## (do @ + ## [_ (&io.prepare-target target) + ## ## _ (&io.write target (format hostL.runtime-class ".class") runtime-bc) + ## ## _ (&io.write target (format hostL.function-class ".class") function-bc) + ## ## _ (cache/io.pre-load sources target (commonT.load-definition state)) + ## ] + ## (wrap (|> state + ## (set@ [#.info #.mode] #.Build)))) + + ## (#error.Failure error) + ## (io.fail error)) + ) + + (def: #export (compile platform configuration state) + (All [! anchor expression statement] + (-> Configuration (! Any))) + (do (:: (get@ #file-system platform) &monad) + [input (context.read (get@ #file-system platform) + (get@ #cli.sources configuration) + (get@ #cli.module configuration)) + ## _ (&io.prepare-module target-dir (get@ #cli.module configuration)) + ## _ (write-module target-dir file-name (get@ #cli.module configuration) module outputs) + ] + ## (case (compiler input) + ## (#error.Failure error) + ## (:: (get@ #file-system platform) lift (#error.Failure error)) + + ## (#error.Success)) + (let [compiler (init.compiler syntax.prelude state) + compilation (compiler init.key (list) input)] + (case ((get@ #///.process compilation) + archive.empty) + (#error.Success more|done) + (case more|done + (#.Left more) + (:: (get@ #file-system platform) lift (#error.Failure "NOT DONE!")) + + (#.Right done) + (wrap [])) + + (#error.Failure error) + (:: (get@ #file-system platform) lift (#error.Failure error)))))) + ) diff --git a/stdlib/source/lux/tool/compiler/default/syntax.lux b/stdlib/source/lux/tool/compiler/default/syntax.lux new file mode 100644 index 000000000..c76857aab --- /dev/null +++ b/stdlib/source/lux/tool/compiler/default/syntax.lux @@ -0,0 +1,561 @@ +## This is LuxC's parser. +## It takes the source code of a Lux file in raw text form and +## extracts the syntactic structure of the code from it. +## It only produces Lux Code nodes, and thus removes any white-space +## and comments while processing its inputs. + +## Another important aspect of the parser is that it keeps track of +## its position within the input data. +## That is, the parser takes into account the line and column +## information in the input text (it doesn't really touch the +## file-name aspect of the cursor, leaving it intact in whatever +## base-line cursor it is given). + +## This particular piece of functionality is not located in one +## function, but it is instead scattered throughout several parsers, +## since the logic for how to update the cursor varies, depending on +## what is being parsed, and the rules involved. + +## You will notice that several parsers have a "where" parameter, that +## tells them the cursor position prior to the parser being run. +## They are supposed to produce some parsed output, alongside an +## updated cursor pointing to the end position, after the parser was run. + +## Lux Code nodes/tokens are annotated with cursor meta-data +## [file-name, line, column] to keep track of their provenance and +## location, which is helpful for documentation and debugging. +(.module: + [lux #* + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + [number + ["." nat] + ["." int] + ["." rev] + ["." frac]] + ["." text + [lexer (#+ Offset)] + format] + [collection + ["." list] + ["." dictionary (#+ Dictionary)]]]]) + +## TODO: Optimize how forms, tuples & records are parsed in the end. +## There is repeated-work going on when parsing the white-space before the +## closing parenthesis/bracket/brace. +## That repeated-work should be avoided. + +## TODO: Implement "lux syntax char case!" as a custom extension. +## That way, it should be possible to obtain the char without wrapping +## it into a java.lang.Long, thereby improving performance. + +## TODO: Make an extension to take advantage of java/lang/String::indexOf +## to get better performance than the current "lux text index" extension. + +(type: Char Nat) + +(do-template [ ] + [(template: ( value) + ( value ))] + + [!inc "lux i64 +" 1] + [!inc/2 "lux i64 +" 2] + [!dec "lux i64 -" 1] + ) + +(template: (!clip from to text) + ("lux text clip" text from to)) + +(do-template [ ] + [(template: ( reference subject) + ( subject reference))] + + [!n/= "lux i64 ="] + [!i/< "lux int <"] + ) + +(do-template [ ] + [(template: ( param subject) + ( subject param))] + + [!n/+ "lux i64 +"] + [!n/- "lux i64 -"] + ) + +(type: #export Aliases (Dictionary Text Text)) +(def: #export no-aliases Aliases (dictionary.new text.hash)) + +(def: #export prelude "lux") + +(def: #export space " ") + +(def: #export text-delimiter text.double-quote) + +(def: #export open-form "(") +(def: #export close-form ")") + +(def: #export open-tuple "[") +(def: #export close-tuple "]") + +(def: #export open-record "{") +(def: #export close-record "}") + +(def: #export sigil "#") + +(def: #export digit-separator "_") + +(def: #export positive-sign "+") +(def: #export negative-sign "-") + +(def: #export frac-separator ".") + +## The parts of an name are separated by a single mark. +## E.g. module.short. +## Only one such mark may be used in an name, since there +## can only be 2 parts to an name (the module [before the +## mark], and the short [after the mark]). +## There are also some extra rules regarding name syntax, +## encoded on the parser. +(def: #export name-separator ".") + +(exception: #export (end-of-file {module Text}) + (ex.report ["Module" (%t module)])) + +(def: amount-of-input-shown 64) + +(def: (input-at start input) + (-> Offset Text Text) + (let [end (|> start (n/+ amount-of-input-shown) (n/min ("lux text size" input)))] + (!clip start end input))) + +(exception: #export (unrecognized-input {[file line column] Cursor} {context Text} {input Text} {offset Offset}) + (ex.report ["File" file] + ["Line" (%n line)] + ["Column" (%n column)] + ["Context" (%t context)] + ["Input" (input-at offset input)])) + +(exception: #export (text-cannot-contain-new-lines {text Text}) + (ex.report ["Text" (%t text)])) + +(exception: #export (invalid-escape-syntax) + "") + +(exception: #export (cannot-close-composite-expression {closing-char Char} {source-code Text} {offset Offset}) + (ex.report ["Closing Character" (text.from-code closing-char)] + ["Input" (format text.new-line + (input-at offset source-code))])) + +(type: Parser + (-> Source (Error [Source Code]))) + +(template: (!with-char+ @source-code-size @source-code @offset @char @else @body) + (if (!i/< (:coerce Int @source-code-size) + (:coerce Int @offset)) + (let [@char ("lux text char" @source-code @offset)] + @body) + @else)) + +(template: (!with-char @source-code @offset @char @else @body) + (!with-char+ ("lux text size" @source-code) @source-code @offset @char @else @body)) + +(def: close-signal "CLOSE") + +(with-expansions [ (as-is (ex.throw cannot-close-composite-expression [closing-char source-code end]))] + (def: (read-close closing-char source-code//size source-code offset) + (-> Char Nat Text Offset (Error Offset)) + (loop [end offset] + (<| (!with-char+ source-code//size source-code end char + (if (!n/= closing-char char) + (#error.Success (!inc end)) + (`` ("lux syntax char case!" char + [[(~~ (static ..space)) + (~~ (static text.carriage-return)) + (~~ (static text.new-line))] + (recur (!inc end))] + + ## else + )))))))) + +(`` (do-template [ ] + [(def: ( parse source) + (-> Parser Parser) + (let [[_ _ source-code] source + source-code//size ("lux text size" source-code)] + (loop [source source + stack (: (List Code) #.Nil)] + (case (parse source) + (#error.Success [source' top]) + (recur source' (#.Cons top stack)) + + (#error.Failure error) + (let [[where offset _] source] + (case (read-close (char ) source-code//size source-code offset) + (#error.Success offset') + (#error.Success [[(update@ #.column inc where) offset' source-code] + [where ( (list.reverse stack))]]) + + (#error.Failure error) + (#error.Failure error)))))))] + + ## Form and tuple syntax is mostly the same, differing only in the + ## delimiters involved. + ## They may have an arbitrary number of arbitrary Code nodes as elements. + [parse-form (~~ (static ..close-form)) #.Form "Form"] + [parse-tuple (~~ (static ..close-tuple)) #.Tuple "Tuple"] + )) + +(def: (parse-record parse source) + (-> Parser Parser) + (let [[_ _ source-code] source + source-code//size ("lux text size" source-code)] + (loop [source source + stack (: (List [Code Code]) #.Nil)] + (case (parse source) + (#error.Success [sourceF field]) + (case (parse sourceF) + (#error.Success [sourceFV value]) + (recur sourceFV (#.Cons [field value] stack)) + + (#error.Failure error) + (#error.Failure error)) + + (#error.Failure error) + (let [[where offset _] source] + (<| (!with-char+ source-code//size source-code offset closing-char (#error.Failure error)) + (case (read-close (`` (char (~~ (static ..close-record)))) source-code//size source-code offset) + (#error.Success offset') + (#error.Success [[(update@ #.column inc where) offset' source-code] + [where (#.Record (list.reverse stack))]]) + + (#error.Failure error) + (#error.Failure error)))))))) + +(template: (!guarantee-no-new-lines content body) + (case ("lux text index" content (static text.new-line) 0) + #.None + body + + g!_ + (ex.throw ..text-cannot-contain-new-lines content))) + +(template: (!read-text where offset source-code) + (case ("lux text index" source-code (static ..text-delimiter) offset) + (#.Some g!end) + (let [g!content (!clip offset g!end source-code)] + (<| (!guarantee-no-new-lines g!content) + (#error.Success [[(update@ #.column (n/+ (!n/- offset g!end)) where) + (!inc g!end) + source-code] + [where + (#.Text g!content)]]))) + + _ + (ex.throw unrecognized-input [where "Text" source-code offset]))) + +(def: digit-bottom Nat (!dec (char "0"))) +(def: digit-top Nat (!inc (char "9"))) + +(template: (!digit? char) + (and (!i/< (:coerce Int char) (:coerce Int (static ..digit-bottom))) + (!i/< (:coerce Int (static ..digit-top)) (:coerce Int char)))) + +(`` (template: (!digit?+ char) + (or (!digit? char) + ("lux i64 =" (.char (~~ (static ..digit-separator))) char)))) + +(`` (template: (!strict-name-char? char) + (not (or ("lux i64 =" (.char (~~ (static ..space))) char) + ("lux i64 =" (.char (~~ (static text.new-line))) char) + + ("lux i64 =" (.char (~~ (static ..name-separator))) char) + + ("lux i64 =" (.char (~~ (static ..open-form))) char) + ("lux i64 =" (.char (~~ (static ..close-form))) char) + + ("lux i64 =" (.char (~~ (static ..open-tuple))) char) + ("lux i64 =" (.char (~~ (static ..close-tuple))) char) + + ("lux i64 =" (.char (~~ (static ..open-record))) char) + ("lux i64 =" (.char (~~ (static ..close-record))) char) + + ("lux i64 =" (.char (~~ (static ..text-delimiter))) char) + ("lux i64 =" (.char (~~ (static ..sigil))) char))))) + +(template: (!name-char?|head char) + (and (!strict-name-char? char) + (not (!digit? char)))) + +(template: (!name-char? char) + (or (!strict-name-char? char) + (!digit? char))) + +(template: (!number-output ) + (case (:: decode (!clip source-code)) + (#error.Success output) + (#error.Success [[(update@ #.column (n/+ (!n/- )) where) + + source-code] + [where ( output)]]) + + (#error.Failure error) + (#error.Failure error))) + +(def: no-exponent Offset 0) + +(with-expansions [ (as-is (!number-output start end int.decimal #.Int)) + (as-is (!number-output start end frac.decimal #.Frac)) + (ex.throw unrecognized-input [where "Frac" source-code offset])] + (def: (parse-frac source-code//size start [where offset source-code]) + (-> Nat Offset Parser) + (loop [end offset + exponent ..no-exponent] + (<| (!with-char+ source-code//size source-code end char/0 ) + (cond (!digit?+ char/0) + (recur (!inc end) exponent) + + (and (or (!n/= (char "e") char/0) + (!n/= (char "E") char/0)) + (not (is? ..no-exponent exponent))) + (<| (!with-char+ source-code//size source-code (!inc end) char/1 ) + (if (or (!n/= (`` (char (~~ (static ..positive-sign)))) char/1) + (!n/= (`` (char (~~ (static ..negative-sign)))) char/1)) + (<| (!with-char+ source-code//size source-code (!n/+ 2 end) char/2 ) + (if (!digit?+ char/2) + (recur (!n/+ 3 end) char/0) + )) + )) + + ## else + )))) + + (def: (parse-signed start [where offset source-code]) + (-> Offset Parser) + (let [source-code//size ("lux text size" source-code)] + (loop [end offset] + (<| (!with-char+ source-code//size source-code end char ) + (cond (!digit?+ char) + (recur (!inc end)) + + (!n/= (`` (.char (~~ (static ..frac-separator)))) + char) + (parse-frac source-code//size start [where (!inc end) source-code]) + + ## else + )))))) + +(do-template [ ] + [(template: ( source-code//size start where offset source-code) + (loop [g!end offset] + (<| (!with-char+ source-code//size source-code g!end g!char (!number-output start g!end )) + (if (!digit?+ g!char) + (recur (!inc g!end)) + (!number-output start g!end )))))] + + [!parse-nat nat.decimal #.Nat] + [!parse-rev rec.decimal #.Rev] + ) + +(template: (!parse-signed source-code//size offset where source-code @end) + (let [g!offset/1 (!inc offset)] + (<| (!with-char+ source-code//size source-code g!offset/1 g!char/1 @end) + (if (!digit? g!char/1) + (parse-signed offset [where (!inc/2 offset) source-code]) + (!parse-full-name offset [where (!inc offset) source-code] where #.Identifier))))) + +(with-expansions [ (#error.Success [[(update@ #.column (n/+ (!n/- start end)) where) + end + source-code] + (!clip start end source-code)])] + (def: (parse-name-part start [where offset source-code]) + (-> Offset Source (Error [Source Text])) + (let [source-code//size ("lux text size" source-code)] + (loop [end offset] + (<| (!with-char+ source-code//size source-code end char ) + (if (!name-char? char) + (recur (!inc end)) + )))))) + +(template: (!new-line where) + ## (-> Cursor Cursor) + (let [[where::file where::line where::column] where] + [where::file (!inc where::line) 0])) + +(with-expansions [ (ex.throw end-of-file current-module) + (ex.throw unrecognized-input [where "General" source-code offset/0]) + (#error.Failure close-signal) + (as-is [where (!inc offset/0) source-code]) + (as-is [where (!inc/2 offset/0) source-code])] + + (template: (!parse-half-name @offset @char @module) + (cond (!name-char?|head @char) + (case (..parse-name-part @offset [where (!inc @offset) source-code]) + (#error.Success [source' name]) + (#error.Success [source' [@module name]]) + + (#error.Failure error) + (#error.Failure error)) + + ## else + )) + + (`` (def: (parse-short-name current-module [where offset/0 source-code]) + (-> Text Source (Error [Source Name])) + (<| (!with-char source-code offset/0 char/0 ) + (if (!n/= (char (~~ (static ..name-separator))) char/0) + (let [offset/1 (!inc offset/0)] + (<| (!with-char source-code offset/1 char/1 ) + (!parse-half-name offset/1 char/1 current-module))) + (!parse-half-name offset/0 char/0 ..prelude))))) + + (template: (!parse-short-name @current-module @source @where @tag) + (case (..parse-short-name @current-module @source) + (#error.Success [source' name]) + (#error.Success [source' [@where (@tag name)]]) + + (#error.Failure error) + (#error.Failure error))) + + (with-expansions [ (as-is (#error.Success [source' ["" simple]]))] + (`` (def: (parse-full-name start source) + (-> Offset Source (Error [Source Name])) + (case (..parse-name-part start source) + (#error.Success [source' simple]) + (let [[where' offset' source-code'] source'] + (<| (!with-char source-code' offset' char/separator ) + (if (!n/= (char (~~ (static ..name-separator))) char/separator) + (let [offset'' (!inc offset')] + (case (..parse-name-part offset'' [where' offset'' source-code']) + (#error.Success [source'' complex]) + (#error.Success [source'' [simple complex]]) + + (#error.Failure error) + (#error.Failure error))) + ))) + + (#error.Failure error) + (#error.Failure error))))) + + (template: (!parse-full-name @offset @source @where @tag) + (case (..parse-full-name @offset @source) + (#error.Success [source' full-name]) + (#error.Success [source' [@where (@tag full-name)]]) + + (#error.Failure error) + (#error.Failure error))) + + (`` (template: (<>) + [(~~ (static ..close-form)) + (~~ (static ..close-tuple)) + (~~ (static ..close-record))])) + + ## TODO: Grammar macro for specifying syntax. + ## (grammar: lux-grammar + ## [expression ...] + ## [form "(" [#* expression] ")"]) + + (with-expansions [ (as-is (parse current-module aliases source-code//size)) + (as-is (recur [(update@ #.column inc where) + (!inc offset/0) + source-code]))] + (def: #export (parse current-module aliases source-code//size) + (-> Text Aliases Nat (-> Source (Error [Source Code]))) + ## The "exec []" is only there to avoid function fusion. + ## This is to preserve the loop as much as possible and keep it tight. + (exec [] + (function (recur [where offset/0 source-code]) + (<| (!with-char+ source-code//size source-code offset/0 char/0 ) + ## The space was singled-out for special treatment + ## because of how common it is. + (`` (if (!n/= (char (~~ (static ..space))) char/0) + + ("lux syntax char case!" char/0 + [## New line + [(~~ (static text.carriage-return))] + + + [(~~ (static text.new-line))] + (recur [(!new-line where) (!inc offset/0) source-code]) + + ## Form + [(~~ (static ..open-form))] + (parse-form ) + + ## Tuple + [(~~ (static ..open-tuple))] + (parse-tuple ) + + ## Record + [(~~ (static ..open-record))] + (parse-record ) + + ## Text + [(~~ (static ..text-delimiter))] + (let [offset/1 (!inc offset/0)] + (!read-text where offset/1 source-code)) + + ## Special code + [(~~ (static ..sigil))] + (let [offset/1 (!inc offset/0)] + (<| (!with-char+ source-code//size source-code offset/1 char/1 ) + ("lux syntax char case!" char/1 + [(~~ (do-template [ ] + [[] + (#error.Success [[(update@ #.column (|>> !inc/2) where) + (!inc offset/1) + source-code] + [where (#.Bit )]])] + + ["0" #0] + ["1" #1])) + + ## Single-line comment + [(~~ (static ..sigil))] + (case ("lux text index" source-code (static text.new-line) offset/1) + (#.Some end) + (recur [(!new-line where) (!inc end) source-code]) + + _ + ) + + [(~~ (static ..name-separator))] + (!parse-short-name current-module where #.Tag)] + + ## else + (cond (!name-char?|head char/1) ## Tag + (!parse-full-name offset/1 where #.Tag) + + ## else + )))) + + ## Coincidentally (= name-separator frac-separator) + [(~~ (static ..name-separator))] + (let [offset/1 (!inc offset/0)] + (<| (!with-char+ source-code//size source-code offset/1 char/1 ) + (if (!digit? char/1) + (let [offset/2 (!inc offset/1)] + (!parse-rev source-code//size offset/0 where offset/2 source-code)) + (!parse-short-name current-module [where offset/1 source-code] where #.Identifier)))) + + [(~~ (static ..positive-sign)) + (~~ (static ..negative-sign))] + (!parse-signed source-code//size offset/0 where source-code ) + + ## Invalid characters at this point... + (~~ (<>)) + ] + + ## else + (if (!digit? char/0) + ## Natural number + (let [offset/1 (!inc offset/0)] + (!parse-nat source-code//size offset/0 where offset/1 source-code)) + ## Identifier + (!parse-full-name offset/0 where #.Identifier)) + ))) + ))) + )) + ) diff --git a/stdlib/source/lux/tool/compiler/host.lux b/stdlib/source/lux/tool/compiler/host.lux new file mode 100644 index 000000000..218de67a4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/host.lux @@ -0,0 +1,18 @@ +(.module: + lux) + +(type: #export Host Text) + +(do-template [ ] + [(def: #export Host )] + + [common-lisp "Common Lisp"] + [js "JavaScript"] + [jvm "JVM"] + [lua "Lua"] + [php "PHP"] + [python "Python"] + [r "R"] + [ruby "Ruby"] + [scheme "Scheme"] + ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive.lux b/stdlib/source/lux/tool/compiler/meta/archive.lux new file mode 100644 index 000000000..c318bfaf7 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/archive.lux @@ -0,0 +1,77 @@ +(.module: + [lux (#- Module) + [control + ["ex" exception (#+ exception:)] + ["." equivalence (#+ Equivalence)] + ["." monad (#+ do)]] + [data + ["." error (#+ Error)] + ["." name] + ["." text + format] + [collection + ["." dictionary (#+ Dictionary)]]] + [type (#+ :share) + abstract] + [world + [file (#+ File)]]] + [/// + [default (#+ Version)]] + [/ + ["." signature (#+ Signature)] + ["." key (#+ Key)] + ["." descriptor (#+ Module Descriptor)] + ["." document (#+ Document)]]) + +## Archive +(exception: #export (unknown-document {name Module}) + (ex.report ["Module" name])) + +(exception: #export (cannot-replace-document {name Module} + {old (Document Any)} + {new (Document Any)}) + (ex.report ["Module" name] + ["Old key" (signature.description (document.signature old))] + ["New key" (signature.description (document.signature new))])) + +(with-expansions [ (as-is (type (Ex [d] (Document d))))] + (abstract: #export Archive + {} + + (Dictionary Text [Descriptor ]) + + (def: #export empty + Archive + (:abstraction (dictionary.new text.hash))) + + (def: #export (add name descriptor document archive) + (-> Module Descriptor Archive (Error Archive)) + (case (dictionary.get name (:representation archive)) + (#.Some existing) + (if (is? document existing) + (#error.Success archive) + (ex.throw cannot-replace-document [name existing document])) + + #.None + (#error.Success (|> archive + :representation + (dictionary.put name [descriptor document]) + :abstraction)))) + + (def: #export (find name archive) + (-> Module Archive (Error [Descriptor ])) + (case (dictionary.get name (:representation archive)) + (#.Some document) + (#error.Success document) + + #.None + (ex.throw unknown-document [name]))) + + (def: #export (merge additions archive) + (-> Archive Archive (Error Archive)) + (monad.fold error.monad + (function (_ [name' descriptor+document'] archive') + (..add name' descriptor+document' archive')) + archive + (dictionary.entries (:representation additions)))) + )) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux new file mode 100644 index 000000000..328240e6c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/archive/descriptor.lux @@ -0,0 +1,16 @@ +(.module: + [lux (#- Module) + [data + [collection + [set (#+ Set)]]] + [world + [file (#+ File)]]]) + +(type: #export Module Text) + +(type: #export Descriptor + {#hash Nat + #name Module + #file File + #references (Set Module) + #state Module-State}) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/document.lux b/stdlib/source/lux/tool/compiler/meta/archive/document.lux new file mode 100644 index 000000000..5c077080f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/archive/document.lux @@ -0,0 +1,49 @@ +(.module: + [lux (#- Module) + [control + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + [collection + ["." dictionary (#+ Dictionary)]]] + [type (#+ :share) + abstract]] + [// + ["." signature (#+ Signature)] + ["." key (#+ Key)] + [descriptor (#+ Module)]]) + +## Document +(exception: #export (invalid-signature {expected Signature} {actual Signature}) + (ex.report ["Expected" (signature.description expected)] + ["Actual" (signature.description actual)])) + +(abstract: #export (Document d) + {} + + {#signature Signature + #content d} + + (def: #export (read key document) + (All [d] (-> (Key d) (Document Any) (Error d))) + (let [[document//signature document//content] (:representation document)] + (if (:: signature.equivalence = + (key.signature key) + document//signature) + (#error.Success (:share [e] + {(Key e) + key} + {e + document//content})) + (ex.throw invalid-signature [(key.signature key) + document//signature])))) + + (def: #export (write key content) + (All [d] (-> (Key d) d (Document d))) + (:abstraction {#signature (key.signature key) + #content content})) + + (def: #export signature + (-> (Document Any) Signature) + (|>> :representation (get@ #signature))) + ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/key.lux b/stdlib/source/lux/tool/compiler/meta/archive/key.lux new file mode 100644 index 000000000..50c10ac01 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/archive/key.lux @@ -0,0 +1,20 @@ +(.module: + [lux #* + [type + abstract]] + [// + [signature (#+ Signature)]]) + +(abstract: #export (Key k) + {} + + Signature + + (def: #export signature + (-> (Key Any) Signature) + (|>> :representation)) + + (def: #export (key signature sample) + (All [d] (-> Signature d (Key d))) + (:abstraction signature)) + ) diff --git a/stdlib/source/lux/tool/compiler/meta/archive/signature.lux b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux new file mode 100644 index 000000000..fb96aec58 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/archive/signature.lux @@ -0,0 +1,23 @@ +(.module: + [lux #* + [control + ["." equivalence (#+ Equivalence)]] + [data + ["." name] + ["." text + format]]] + [//// + [default (#+ Version)]]) + +## Key +(type: #export Signature + {#name Name + #version Version}) + +(def: #export equivalence + (Equivalence Signature) + (equivalence.product name.equivalence text.equivalence)) + +(def: #export (description signature) + (-> Signature Text) + (format (%name (get@ #name signature)) " " (get@ #version signature))) diff --git a/stdlib/source/lux/tool/compiler/meta/cache.lux b/stdlib/source/lux/tool/compiler/meta/cache.lux new file mode 100644 index 000000000..7ba16878a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/cache.lux @@ -0,0 +1,178 @@ +(.module: + [lux (#- Module) + [control + ["." monad (#+ Monad do)] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." bit ("#/." equivalence)] + ["." maybe] + ["." error] + ["." product] + [format + ["." binary (#+ Format)]] + ["." text + [format (#- Format)]] + [collection + ["." list ("#/." functor fold)] + ["dict" dictionary (#+ Dictionary)] + ["." set (#+ Set)]]] + [world + [file (#+ File System)]]] + [// + [io (#+ Context Module) + ["io/." context] + ["io/." archive]] + ["." archive (#+ Signature Key Descriptor Document Archive)] + ["/." //]] + ["." /dependency (#+ Dependency Graph)]) + +(exception: #export (cannot-delete-file {file File}) + (ex.report ["File" file])) + +(exception: #export (stale-document {module ///.Module} {current-hash Nat} {stale-hash Nat}) + (ex.report ["Module" module] + ["Current hash" (%n current-hash)] + ["Stale hash" (%n stale-hash)])) + +(exception: #export (mismatched-signature {module ///.Module} {expected Signature} {actual Signature}) + (ex.report ["Module" module] + ["Expected" (archive.describe expected)] + ["Actual" (archive.describe actual)])) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [cannot-load-definition] + ) + +## General +(def: #export (cached System root) + (All [m] (-> (System m) File (m (List File)))) + (|> root + (io/archive.archive System) + (do> (:: System &monad) + [(:: System files)] + [(monad.map @ (function (recur file) + (do @ + [is-dir? (:: System directory? file)] + (if is-dir? + (|> file + (do> @ + [(:: System files)] + [(monad.map @ recur)] + [list.concat + (list& (maybe.assume (io/archive.module System root file))) + wrap])) + (wrap (list))))))] + [list.concat wrap]))) + +## Clean +(def: (delete System document) + (All [m] (-> (System m) File (m Any))) + (do (:: System &monad) + [deleted? (:: System delete document)] + (if deleted? + (wrap []) + (:: System throw cannot-delete-file document)))) + +(def: (un-install System root module) + (All [m] (-> (System m) File Module (m Any))) + (let [document (io/archive.document System root module)] + (|> document + (do> (:: System &monad) + [(:: System files)] + [(monad.map @ (function (_ file) + (do @ + [? (:: System directory? file)] + (if ? + (wrap #0) + (do @ + [_ (..delete System file)] + (wrap #1))))))] + [(list.every? (bit/= #1)) + (if> [(..delete System document)] + [(wrap [])])])))) + +(def: #export (clean System root wanted-modules) + (All [m] (-> (System m) File (Set Module) (m Any))) + (|> root + (do> (:: System &monad) + [(..cached System)] + [(list.filter (bit.complement (set.member? wanted-modules))) + (monad.map @ (un-install System root))]))) + +## Load +(def: signature + (Format Signature) + ($_ binary.and binary.name binary.text)) + +(def: descriptor + (Format Descriptor) + ($_ binary.and binary.nat binary.text (binary.list binary.text) (binary.ignore #.Cached))) + +(def: document + (All [a] (-> (Format a) (Format [Signature Descriptor a]))) + (|>> ($_ binary.and ..signature ..descriptor))) + +(def: (load-document System contexts root key binary module) + (All [m d] (-> (System m) (List File) File (Key d) (Format d) Module + (m (Maybe [Dependency (Document d)])))) + (do (:: System &monad) + [document' (:: System read (io/archive.document System root module)) + [module' source-code] (io/context.read System contexts module) + #let [current-hash (:: text.hash hash source-code)]] + (case (do error.monad + [[signature descriptor content] (binary.read (..document binary) document') + #let [[document-hash _file references _state] descriptor] + _ (ex.assert mismatched-signature [module (get@ #archive.signature key) signature] + (:: archive.equivalence = + (get@ #archive.signature key) + signature)) + _ (ex.assert stale-document [module current-hash document-hash] + (n/= current-hash document-hash)) + document (archive.write key signature descriptor content)] + (wrap [[module references] document])) + (#error.Success [dependency document]) + (wrap (#.Some [dependency document])) + + (#error.Failure error) + (do @ + [_ (un-install System root module)] + (wrap #.None))))) + +(def: #export (load-archive System contexts root key binary) + (All [m d] (-> (System m) (List Context) File (Key d) (Format d) (m Archive))) + (do (:: System &monad) + [candidate (|> root + (do> @ + [(..cached System)] + [(monad.map @ (load-document System contexts root key binary)) + (:: @ map (list/fold (function (_ full-document archive) + (case full-document + (#.Some [[module references] document]) + (dict.put module [references document] archive) + + #.None + archive)) + (: (Dictionary Text [(List Module) (Ex [d] (Document d))]) + (dict.new text.hash))))])) + #let [candidate-entries (dict.entries candidate) + candidate-dependencies (list/map (product.both id product.left) + candidate-entries) + candidate-archive (|> candidate-entries + (list/map (product.both id product.right)) + (dict.from-list text.hash)) + graph (|> candidate + dict.entries + (list/map (product.both id product.left)) + /dependency.graph + (/dependency.prune candidate-archive)) + archive (list/fold (function (_ module archive) + (if (dict.contains? module graph) + archive + (dict.remove module archive))) + candidate-archive + (dict.keys candidate))]] + (wrap archive))) diff --git a/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux new file mode 100644 index 000000000..4664ade1d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/cache/dependency.lux @@ -0,0 +1,53 @@ +(.module: + [lux (#- Module) + [data + ["." text] + [collection + ["." list ("#/." functor fold)] + ["dict" dictionary (#+ Dictionary)]]]] + [///io (#+ Module)] + [///archive (#+ Archive)]) + +(type: #export Graph (Dictionary Module (List Module))) + +(def: #export empty Graph (dict.new text.hash)) + +(def: #export (add to from) + (-> Module Module Graph Graph) + (|>> (dict.update~ from (list) (|>> (#.Cons to))) + (dict.update~ to (list) id))) + +(def: dependents + (-> Module Graph (Maybe (List Text))) + dict.get) + +(def: #export (remove module dependency) + (-> Module Graph Graph) + (case (dependents module dependency) + (#.Some dependents) + (list/fold remove (dict.remove module dependency) dependents) + + #.None + dependency)) + +(type: #export Dependency + {#module Module + #imports (List Module)}) + +(def: #export (dependency [module imports]) + (-> Dependency Graph) + (list/fold (..add module) ..empty imports)) + +(def: #export graph + (-> (List Dependency) Graph) + (|>> (list/map ..dependency) + (list/fold dict.merge empty))) + +(def: #export (prune archive graph) + (-> Archive Graph Graph) + (list/fold (function (_ module graph) + (if (dict.contains? module archive) + graph + (..remove module graph))) + graph + (dict.keys graph))) diff --git a/stdlib/source/lux/tool/compiler/meta/io.lux b/stdlib/source/lux/tool/compiler/meta/io.lux new file mode 100644 index 000000000..dd261a539 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/io.lux @@ -0,0 +1,16 @@ +(.module: + [lux (#- Module Code) + [data + ["." text]] + [world + [file (#+ File System)]]]) + +(type: #export Context File) + +(type: #export Module Text) + +(type: #export Code Text) + +(def: #export (sanitize system) + (All [m] (-> (System m) Text Text)) + (text.replace-all "/" (:: system separator))) diff --git a/stdlib/source/lux/tool/compiler/meta/io/archive.lux b/stdlib/source/lux/tool/compiler/meta/io/archive.lux new file mode 100644 index 000000000..354f84460 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/io/archive.lux @@ -0,0 +1,74 @@ +(.module: + [lux (#- Module) + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." error] + ["." text + format]] + [world + ["." file (#+ File System)] + [binary (#+ Binary)]]] + ["." // (#+ Module) + [/// + ["." host]]]) + +(type: #export Document File) + +(exception: #export (cannot-prepare {archive File} {module Module}) + (ex.report ["Archive" archive] + ["Module" module])) + +(def: #export (archive System root) + (All [m] (-> (System m) File File)) + (<| (format root (:: System separator)) + (`` (for {(~~ (static host.common-lisp)) host.common-lisp + (~~ (static host.js)) host.js + (~~ (static host.jvm)) host.jvm + (~~ (static host.lua)) host.lua + (~~ (static host.php)) host.php + (~~ (static host.python)) host.python + (~~ (static host.r)) host.r + (~~ (static host.ruby)) host.ruby + (~~ (static host.scheme)) host.scheme})))) + +(def: #export (document System root module) + (All [m] (-> (System m) File Module Document)) + (let [archive (..archive System root)] + (|> module + (//.sanitize System) + (format archive (:: System separator))))) + +(def: #export (prepare System root module) + (All [m] (-> (System m) File Module (m Any))) + (do (:: System &monad) + [#let [archive (..archive System root) + document (..document System root module)] + document-exists? (file.exists? System document)] + (if document-exists? + (wrap []) + (do @ + [outcome (:: System try (:: System make-directory document))] + (case outcome + (#error.Success output) + (wrap output) + + (#error.Failure _) + (:: System throw cannot-prepare [archive module])))))) + +(def: #export (write System root content name) + (All [m] (-> (System m) File Binary Text (m Any))) + (:: System write content (..document System root name))) + +(def: #export (module System root document) + (All [m] (-> (System m) File Document (Maybe Module))) + (case (text.split-with (..archive System root) document) + (#.Some ["" post]) + (let [raw (text.replace-all (:: System separator) "/" post)] + (if (text.starts-with? "/" raw) + (text.clip' 1 raw) + (#.Some raw))) + + _ + #.None)) diff --git a/stdlib/source/lux/tool/compiler/meta/io/context.lux b/stdlib/source/lux/tool/compiler/meta/io/context.lux new file mode 100644 index 000000000..be72e4ccc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/meta/io/context.lux @@ -0,0 +1,107 @@ +(.module: + [lux (#- Module Code) + [control + monad + ["ex" exception (#+ Exception exception:)]] + [data + ["." error] + [text + format + ["." encoding]]] + [world + ["." file (#+ File)] + [binary (#+ Binary)]]] + ["." // (#+ Context Code) + [// + [archive + [descriptor (#+ Module)]] + ["//." // (#+ Input) + ["." host]]]]) + +(do-template [] + [(exception: #export ( {module Module}) + (ex.report ["Module" module]))] + + [cannot-find-module] + [cannot-read-module] + ) + +(type: #export Extension Text) + +(def: lux-extension + Extension + ".lux") + +(def: partial-host-extension + Extension + (`` (for {(~~ (static host.common-lisp)) ".cl" + (~~ (static host.js)) ".js" + (~~ (static host.jvm)) ".jvm" + (~~ (static host.lua)) ".lua" + (~~ (static host.php)) ".php" + (~~ (static host.python)) ".py" + (~~ (static host.r)) ".r" + (~~ (static host.ruby)) ".rb" + (~~ (static host.scheme)) ".scm"}))) + +(def: full-host-extension + Extension + (format partial-host-extension lux-extension)) + +(def: #export (file System context module) + (All [m] (-> (file.System m) Context Module File)) + (|> module + (//.sanitize System) + (format context (:: System separator)))) + +(def: (find-source-file System contexts module extension) + (All [!] + (-> (file.System !) (List Context) Module Extension + (! (Maybe File)))) + (case contexts + #.Nil + (:: (:: System &monad) wrap #.None) + + (#.Cons context contexts') + (do (:: System &monad) + [#let [file (format (..file System context module) extension)] + ? (file.exists? System file)] + (if ? + (wrap (#.Some file)) + (find-source-file System contexts' module extension))))) + +(def: (try System computations exception message) + (All [m a e] (-> (file.System m) (List (m (Maybe a))) (Exception e) e (m a))) + (case computations + #.Nil + (:: System throw exception message) + + (#.Cons computation computations') + (do (:: System &monad) + [outcome computation] + (case outcome + (#.Some output) + (wrap output) + + #.None + (try System computations' exception message))))) + +(def: #export (read System contexts module) + (All [!] + (-> (file.System !) (List Context) Module + (! Input))) + (let [find-source-file' (find-source-file System contexts module)] + (do (:: System &monad) + [file (try System + (list (find-source-file' ..full-host-extension) + (find-source-file' ..lux-extension)) + ..cannot-find-module [module]) + binary (:: System read file)] + (case (encoding.from-utf8 binary) + (#error.Success code) + (wrap {#////.module module + #////.file file + #////.code code}) + + (#error.Failure _) + (:: System throw ..cannot-read-module [module]))))) diff --git a/stdlib/source/lux/tool/compiler/name.lux b/stdlib/source/lux/tool/compiler/name.lux new file mode 100644 index 000000000..394bdb2db --- /dev/null +++ b/stdlib/source/lux/tool/compiler/name.lux @@ -0,0 +1,47 @@ +(.module: + [lux #* + [data + ["." maybe] + ["." text + format]]]) + +(`` (template: (!sanitize char) + ("lux syntax char case!" char + [["*"] "_AS" + ["+"] "_PL" + ["-"] "_DS" + ["/"] "_SL" + ["\"] "_BS" + ["_"] "_US" + ["%"] "_PC" + ["$"] "_DL" + ["'"] "_QU" + ["`"] "_BQ" + ["@"] "_AT" + ["^"] "_CR" + ["&"] "_AA" + ["="] "_EQ" + ["!"] "_BG" + ["?"] "_QM" + [":"] "_CO" + ["."] "_PD" + [","] "_CM" + ["<"] "_LT" + [">"] "_GT" + ["~"] "_TI" + ["|"] "_PI"] + (text.from-code char)))) + +(def: #export (normalize name) + (-> Text Text) + (let [name/size (text.size name)] + (loop [idx 0 + output ""] + (if (n/< name/size idx) + (recur (inc idx) + (|> ("lux text char" name idx) !sanitize (format output))) + output)))) + +(def: #export (definition [module short]) + (-> Name Text) + (format (normalize module) "___" (normalize short))) diff --git a/stdlib/source/lux/tool/compiler/phase.lux b/stdlib/source/lux/tool/compiler/phase.lux new file mode 100644 index 000000000..66abcc6cd --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase.lux @@ -0,0 +1,115 @@ +(.module: + [lux #* + [control + ["." state] + ["ex" exception (#+ Exception exception:)] + [monad (#+ do)]] + [data + ["." product] + ["." error (#+ Error) ("#/." functor)] + ["." text + format]] + [time + ["." instant] + ["." duration]] + ["." io] + [macro + ["s" syntax (#+ syntax:)]]]) + +(type: #export (Operation s o) + (state.State' Error s o)) + +(def: #export monad + (state.monad error.monad)) + +(type: #export (Phase s i o) + (-> i (Operation s o))) + +(def: #export (run' state operation) + (All [s o] + (-> s (Operation s o) (Error [s o]))) + (operation state)) + +(def: #export (run state operation) + (All [s o] + (-> s (Operation s o) (Error o))) + (|> state + operation + (:: error.monad map product.right))) + +(def: #export get-state + (All [s o] + (Operation s s)) + (function (_ state) + (#error.Success [state state]))) + +(def: #export (set-state state) + (All [s o] + (-> s (Operation s Any))) + (function (_ _) + (#error.Success [state []]))) + +(def: #export (sub [get set] operation) + (All [s s' o] + (-> [(-> s s') (-> s' s s)] + (Operation s' o) + (Operation s o))) + (function (_ state) + (do error.monad + [[state' output] (operation (get state))] + (wrap [(set state' state) output])))) + +(def: #export fail + (-> Text Operation) + (|>> error.fail (state.lift error.monad))) + +(def: #export (throw exception parameters) + (All [e] (-> (Exception e) e Operation)) + (state.lift error.monad + (ex.throw exception parameters))) + +(def: #export (lift error) + (All [s a] (-> (Error a) (Operation s a))) + (function (_ state) + (error/map (|>> [state]) error))) + +(syntax: #export (assert exception message test) + (wrap (list (` (if (~ test) + (:: ..monad (~' wrap) []) + (..throw (~ exception) (~ message))))))) + +(def: #export (with-stack exception message action) + (All [e s o] (-> (Exception e) e (Operation s o) (Operation s o))) + (<<| (ex.with-stack exception message) + action)) + +(def: #export identity + (All [s a] (Phase s a a)) + (function (_ input state) + (#error.Success [state input]))) + +(def: #export (compose pre post) + (All [s0 s1 i t o] + (-> (Phase s0 i t) + (Phase s1 t o) + (Phase [s0 s1] i o))) + (function (_ input [pre/state post/state]) + (do error.monad + [[pre/state' temp] (pre input pre/state) + [post/state' output] (post temp post/state)] + (wrap [[pre/state' post/state'] output])))) + +(def: #export (timed definition description operation) + (All [s a] + (-> Name Text (Operation s a) (Operation s a))) + (do ..monad + [_ (wrap []) + #let [pre (io.run instant.now)] + output operation + #let [_ (log! (|> instant.now + io.run + instant.relative + (duration.difference (instant.relative pre)) + %duration + (format (%name definition) " [" description "]: ")))]] + (wrap output))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis.lux b/stdlib/source/lux/tool/compiler/phase/analysis.lux new file mode 100644 index 000000000..845346482 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis.lux @@ -0,0 +1,349 @@ +(.module: + [lux (#- nat int rev) + [control + [monad (#+ do)]] + [data + ["." product] + ["." error] + ["." maybe] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." functor fold)]]] + ["." function]] + [// + ["." extension (#+ Extension)] + [// + ["." reference (#+ Register Variable Reference)]]]) + +(type: #export #rec Primitive + #Unit + (#Bit Bit) + (#Nat Nat) + (#Int Int) + (#Rev Rev) + (#Frac Frac) + (#Text Text)) + +(type: #export Tag Nat) + +(type: #export (Variant a) + {#lefts Nat + #right? Bit + #value a}) + +(type: #export (Tuple a) (List a)) + +(type: #export (Composite a) + (#Variant (Variant a)) + (#Tuple (Tuple a))) + +(type: #export #rec Pattern + (#Simple Primitive) + (#Complex (Composite Pattern)) + (#Bind Register)) + +(type: #export (Branch' e) + {#when Pattern + #then e}) + +(type: #export (Match' e) + [(Branch' e) (List (Branch' e))]) + +(type: #export Environment + (List Variable)) + +(type: #export #rec Analysis + (#Primitive Primitive) + (#Structure (Composite Analysis)) + (#Reference Reference) + (#Case Analysis (Match' Analysis)) + (#Function Environment Analysis) + (#Apply Analysis Analysis) + (#Extension (Extension Analysis))) + +(type: #export Branch + (Branch' Analysis)) + +(type: #export Match + (Match' Analysis)) + +(do-template [ ] + [(template: #export ( content) + ( content))] + + [control/case #..Case] + ) + +(do-template [ ] + [(def: #export + (-> Analysis) + (|>> #..Primitive))] + + [bit Bit #..Bit] + [nat Nat #..Nat] + [int Int #..Int] + [rev Rev #..Rev] + [frac Frac #..Frac] + [text Text #..Text] + ) + +(type: #export Arity Nat) + +(type: #export (Abstraction c) [Environment Arity c]) + +(type: #export (Application c) [c (List c)]) + +(def: (last? size tag) + (-> Nat Tag Bit) + (n/= (dec size) tag)) + +(template: #export (no-op value) + (|> 1 #reference.Local #reference.Variable #..Reference + (#..Function (list)) + (#..Apply value))) + +(def: #export (apply [abstraction inputs]) + (-> (Application Analysis) Analysis) + (list/fold (function (_ input abstraction') + (#Apply input abstraction')) + abstraction + inputs)) + +(def: #export (application analysis) + (-> Analysis (Application Analysis)) + (loop [abstraction analysis + inputs (list)] + (case abstraction + (#Apply input next) + (recur next (#.Cons input inputs)) + + _ + [abstraction inputs]))) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Reference + + content))] + + [variable #reference.Variable] + [constant #reference.Constant] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Complex + + content))] + + [pattern/variant #..Variant] + [pattern/tuple #..Tuple] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Structure + + content))] + + [variant #..Variant] + [tuple #..Tuple] + ) + +(template: #export (pattern/unit) + (#..Simple #..Unit)) + +(do-template [ ] + [(template: #export ( content) + (#..Simple ( content)))] + + [pattern/bit #..Bit] + [pattern/nat #..Nat] + [pattern/int #..Int] + [pattern/rev #..Rev] + [pattern/frac #..Frac] + [pattern/text #..Text] + ) + +(template: #export (pattern/bind register) + (#..Bind register)) + +(def: #export (%analysis analysis) + (Format Analysis) + (case analysis + (#Primitive primitive) + (case primitive + #Unit + "[]" + + (^template [ ] + ( value) + ( value)) + ([#Bit %b] + [#Nat %n] + [#Int %i] + [#Rev %r] + [#Frac %f] + [#Text %t])) + + (#Structure structure) + (case structure + (#Variant [lefts right? value]) + (format "(" (%n lefts) " " (%b right?) " " (%analysis value) ")") + + (#Tuple members) + (|> members + (list/map %analysis) + (text.join-with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (case reference + (#reference.Variable variable) + (reference.%variable variable) + + (#reference.Constant constant) + (%name constant)) + + (#Case analysis match) + "{?}" + + (#Function environment body) + (|> (%analysis body) + (format " ") + (format (|> environment + (list/map reference.%variable) + (text.join-with " ") + (text.enclose ["[" "]"]))) + (text.enclose ["(" ")"])) + + (#Apply _) + (|> analysis + ..application + #.Cons + (list/map %analysis) + (text.join-with " ") + (text.enclose ["(" ")"])) + + (#Extension name parameters) + (|> parameters + (list/map %analysis) + (text.join-with " ") + (format (%t name) " ") + (text.enclose ["(" ")"])))) + +(do-template [ ] + [(type: #export + ( .Lux Code Analysis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (with-source-code source action) + (All [a] (-> Source (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [old-source (get@ #.source state)] + (case (action [bundle (set@ #.source source state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #.source old-source state')] + output]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: fresh-bindings + (All [k v] (Bindings k v)) + {#.counter 0 + #.mappings (list)}) + +(def: fresh-scope + Scope + {#.name (list) + #.inner 0 + #.locals fresh-bindings + #.captured fresh-bindings}) + +(def: #export (with-scope action) + (All [a] (-> (Operation a) (Operation [Scope a]))) + (function (_ [bundle state]) + (case (action [bundle (update@ #.scopes (|>> (#.Cons fresh-scope)) state)]) + (#error.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head tail) + (#error.Success [[bundle' (set@ #.scopes tail state')] + [head output]]) + + #.Nil + (#error.Failure "Impossible error: Drained scopes!")) + + (#error.Failure error) + (#error.Failure error)))) + +(def: #export (with-current-module name) + (All [a] (-> Text (Operation a) (Operation a))) + (extension.localized (get@ #.current-module) + (set@ #.current-module) + (function.constant (#.Some name)))) + +(def: #export (with-cursor cursor action) + (All [a] (-> Cursor (Operation a) (Operation a))) + (if (text/= "" (product.left cursor)) + action + (function (_ [bundle state]) + (let [old-cursor (get@ #.cursor state)] + (case (action [bundle (set@ #.cursor cursor state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #.cursor old-cursor state')] + output]) + + (#error.Failure error) + (#error.Failure (format "@ " (%cursor cursor) text.new-line + error))))))) + +(do-template [ ] + [(def: #export ( value) + (-> (Operation Any)) + (extension.update (set@ )))] + + [set-source-code Source #.source value] + [set-current-module Text #.current-module (#.Some value)] + [set-cursor Cursor #.cursor value] + ) + +(def: #export (cursor file) + (-> Text Cursor) + [file 1 0]) + +(def: #export (source file code) + (-> Text Text Source) + [(cursor file) 0 code]) + +(def: dummy-source + Source + [.dummy-cursor 0 ""]) + +(def: type-context + Type-Context + {#.ex-counter 0 + #.var-counter 0 + #.var-bindings (list)}) + +(def: #export (state info host) + (-> Info Any Lux) + {#.info info + #.source ..dummy-source + #.cursor .dummy-cursor + #.current-module #.None + #.modules (list) + #.scopes (list) + #.type-context ..type-context + #.expected #.None + #.seed 0 + #.scope-type-vars (list) + #.extensions [] + #.host host}) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux new file mode 100644 index 000000000..37bcfef6e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case.lux @@ -0,0 +1,300 @@ +(.module: + [lux (#- case) + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error] + ["." maybe] + [text + format] + [collection + ["." list ("#/." fold monoid functor)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Pattern Analysis Operation Phase) + ["." scope] + ["//." type] + ["." structure] + ["/." // + ["." extension]]] + [/ + ["." coverage (#+ Coverage)]]) + +(exception: #export (cannot-match-with-pattern {type Type} {pattern Code}) + (ex.report ["Type" (%type type)] + ["Pattern" (%code pattern)])) + +(exception: #export (sum-has-no-case {case Nat} {type Type}) + (ex.report ["Case" (%n case)] + ["Type" (%type type)])) + +(exception: #export (not-a-pattern {code Code}) + (ex.report ["Code" (%code code)])) + +(exception: #export (cannot-simplify-for-pattern-matching {type Type}) + (ex.report ["Type" (%type type)])) + +(exception: #export (non-exhaustive-pattern-matching {input Code} {branches (List [Code Code])} {coverage Coverage}) + (ex.report ["Input" (%code input)] + ["Branches" (%code (code.record branches))] + ["Coverage" (coverage.%coverage coverage)])) + +(exception: #export (cannot-have-empty-branches {message Text}) + message) + +(def: (re-quantify envs baseT) + (-> (List (List Type)) Type Type) + (.case envs + #.Nil + baseT + + (#.Cons head tail) + (re-quantify tail (#.UnivQ head baseT)))) + +## Type-checking on the input value is done during the analysis of a +## "case" expression, to ensure that the patterns being used make +## sense for the type of the input value. +## Sometimes, that input value is complex, by depending on +## type-variables or quantifications. +## This function makes it easier for "case" analysis to properly +## type-check the input with respect to the patterns. +(def: (simplify-case caseT) + (-> Type (Operation Type)) + (loop [envs (: (List (List Type)) + (list)) + caseT caseT] + (.case caseT + (#.Var id) + (do ///.monad + [?caseT' (//type.with-env + (check.read id))] + (.case ?caseT' + (#.Some caseT') + (recur envs caseT') + + _ + (///.throw cannot-simplify-for-pattern-matching caseT))) + + (#.Named name unnamedT) + (recur envs unnamedT) + + (#.UnivQ env unquantifiedT) + (recur (#.Cons env envs) unquantifiedT) + + (#.ExQ _) + (do ///.monad + [[ex-id exT] (//type.with-env + check.existential)] + (recur envs (maybe.assume (type.apply (list exT) caseT)))) + + (#.Apply inputT funcT) + (.case funcT + (#.Var funcT-id) + (do ///.monad + [funcT' (//type.with-env + (do check.monad + [?funct' (check.read funcT-id)] + (.case ?funct' + (#.Some funct') + (wrap funct') + + _ + (check.throw cannot-simplify-for-pattern-matching caseT))))] + (recur envs (#.Apply inputT funcT'))) + + _ + (.case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur envs outputT) + + #.None + (///.throw cannot-simplify-for-pattern-matching caseT))) + + (#.Product _) + (|> caseT + type.flatten-tuple + (list/map (re-quantify envs)) + type.tuple + (:: ///.monad wrap)) + + _ + (:: ///.monad wrap (re-quantify envs caseT))))) + +(def: (analyse-primitive type inputT cursor output next) + (All [a] (-> Type Type Cursor Pattern (Operation a) (Operation [Pattern a]))) + (//.with-cursor cursor + (do ///.monad + [_ (//type.with-env + (check.check inputT type)) + outputA next] + (wrap [output outputA])))) + +## This function handles several concerns at once, but it must be that +## way because those concerns are interleaved when doing +## pattern-matching and they cannot be separated. +## The pattern is analysed in order to get a general feel for what is +## expected of the input value. This, in turn, informs the +## type-checking of the input. +## A kind of "continuation" value is passed around which signifies +## what needs to be done _after_ analysing a pattern. +## In general, this is done to analyse the "body" expression +## associated to a particular pattern _in the context of_ said +## pattern. +## The reason why *context* is important is because patterns may bind +## values to local variables, which may in turn be referenced in the +## body expressions. +## That is why the body must be analysed in the context of the +## pattern, and not separately. +(def: (analyse-pattern num-tags inputT pattern next) + (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + (.case pattern + [cursor (#.Identifier ["" name])] + (//.with-cursor cursor + (do ///.monad + [outputA (scope.with-local [name inputT] + next) + idx scope.next-local] + (wrap [(#//.Bind idx) outputA]))) + + (^template [ ] + [cursor ] + (analyse-primitive inputT cursor (#//.Simple ) next)) + ([Bit (#.Bit pattern-value) (#//.Bit pattern-value)] + [Nat (#.Nat pattern-value) (#//.Nat pattern-value)] + [Int (#.Int pattern-value) (#//.Int pattern-value)] + [Rev (#.Rev pattern-value) (#//.Rev pattern-value)] + [Frac (#.Frac pattern-value) (#//.Frac pattern-value)] + [Text (#.Text pattern-value) (#//.Text pattern-value)] + [Any (#.Tuple #.Nil) #//.Unit]) + + (^ [cursor (#.Tuple (list singleton))]) + (analyse-pattern #.None inputT singleton next) + + [cursor (#.Tuple sub-patterns)] + (//.with-cursor cursor + (do ///.monad + [inputT' (simplify-case inputT)] + (.case inputT' + (#.Product _) + (let [subs (type.flatten-tuple inputT') + num-subs (maybe.default (list.size subs) + num-tags) + num-sub-patterns (list.size sub-patterns) + matches (cond (n/< num-subs num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-sub-patterns) subs)] + (list.zip2 (list/compose prefix (list (type.tuple suffix))) sub-patterns)) + + (n/> num-subs num-sub-patterns) + (let [[prefix suffix] (list.split (dec num-subs) sub-patterns)] + (list.zip2 subs (list/compose prefix (list (code.tuple suffix))))) + + ## (n/= num-subs num-sub-patterns) + (list.zip2 subs sub-patterns))] + (do @ + [[memberP+ thenA] (list/fold (: (All [a] + (-> [Type Code] (Operation [(List Pattern) a]) + (Operation [(List Pattern) a]))) + (function (_ [memberT memberC] then) + (do @ + [[memberP [memberP+ thenA]] ((:coerce (All [a] (-> (Maybe Nat) Type Code (Operation a) (Operation [Pattern a]))) + analyse-pattern) + #.None memberT memberC then)] + (wrap [(list& memberP memberP+) thenA])))) + (do @ + [nextA next] + (wrap [(list) nextA])) + (list.reverse matches))] + (wrap [(//.pattern/tuple memberP+) + thenA]))) + + _ + (///.throw cannot-match-with-pattern [inputT pattern]) + ))) + + [cursor (#.Record record)] + (do ///.monad + [record (structure.normalize record) + [members recordT] (structure.order record) + _ (//type.with-env + (check.check inputT recordT))] + (analyse-pattern (#.Some (list.size members)) inputT [cursor (#.Tuple members)] next)) + + [cursor (#.Tag tag)] + (//.with-cursor cursor + (analyse-pattern #.None inputT (` ((~ pattern))) next)) + + (^ [cursor (#.Form (list& [_ (#.Nat idx)] values))]) + (//.with-cursor cursor + (do ///.monad + [inputT' (simplify-case inputT)] + (.case inputT' + (#.Sum _) + (let [flat-sum (type.flatten-variant inputT') + size-sum (list.size flat-sum) + num-cases (maybe.default size-sum num-tags)] + (.case (list.nth idx flat-sum) + (^multi (#.Some caseT) + (n/< num-cases idx)) + (do ///.monad + [[testP nextA] (if (and (n/> num-cases size-sum) + (n/= (dec num-cases) idx)) + (analyse-pattern #.None + (type.variant (list.drop (dec num-cases) flat-sum)) + (` [(~+ values)]) + next) + (analyse-pattern #.None caseT (` [(~+ values)]) next)) + #let [right? (n/= (dec num-cases) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap [(//.pattern/variant [lefts right? testP]) + nextA])) + + _ + (///.throw sum-has-no-case [idx inputT]))) + + _ + (///.throw cannot-match-with-pattern [inputT pattern])))) + + (^ [cursor (#.Form (list& [_ (#.Tag tag)] values))]) + (//.with-cursor cursor + (do ///.monad + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + _ (//type.with-env + (check.check inputT variantT))] + (analyse-pattern (#.Some (list.size group)) inputT (` ((~ (code.nat idx)) (~+ values))) next))) + + _ + (///.throw not-a-pattern pattern) + )) + +(def: #export (case analyse inputC branches) + (-> Phase Code (List [Code Code]) (Operation Analysis)) + (.case branches + (#.Cons [patternH bodyH] branchesT) + (do ///.monad + [[inputT inputA] (//type.with-inference + (analyse inputC)) + outputH (analyse-pattern #.None inputT patternH (analyse bodyH)) + outputT (monad.map @ + (function (_ [patternT bodyT]) + (analyse-pattern #.None inputT patternT (analyse bodyT))) + branchesT) + outputHC (|> outputH product.left coverage.determine) + outputTC (monad.map @ (|>> product.left coverage.determine) outputT) + _ (.case (monad.fold error.monad coverage.merge outputHC outputTC) + (#error.Success coverage) + (///.assert non-exhaustive-pattern-matching [inputC branches coverage] + (coverage.exhaustive? coverage)) + + (#error.Failure error) + (///.fail error))] + (wrap (#//.Case inputA [outputH outputT]))) + + #.Nil + (///.throw cannot-have-empty-branches ""))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux new file mode 100644 index 000000000..cd6ccd83d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/case/coverage.lux @@ -0,0 +1,366 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + equivalence] + [data + ["." bit ("#/." equivalence)] + ["." number] + ["." error (#+ Error) ("#/." monad)] + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." functor fold)] + ["." dictionary (#+ Dictionary)]]]] + ["." //// ("#/." monad)] + ["." /// (#+ Pattern Variant Operation)]) + +(exception: #export (invalid-tuple-pattern) + "Tuple size must be >= 2") + +(def: cases + (-> (Maybe Nat) Nat) + (|>> (maybe.default 0))) + +(def: known-cases? + (-> Nat Bit) + (n/> 0)) + +## The coverage of a pattern-matching expression summarizes how well +## all the possible values of an input are being covered by the +## different patterns involved. +## Ideally, the pattern-matching has "exhaustive" coverage, which just +## means that every possible value can be matched by at least 1 +## pattern. +## Every other coverage is considered partial, and it would be valued +## as insuficient (since it could lead to runtime errors due to values +## not being handled by any pattern). +## The #Partial tag covers arbitrary partial coverages in a general +## way, while the other tags cover more specific cases for bits +## and variants. +(type: #export #rec Coverage + #Partial + (#Bit Bit) + (#Variant (Maybe Nat) (Dictionary Nat Coverage)) + (#Seq Coverage Coverage) + (#Alt Coverage Coverage) + #Exhaustive) + +(def: #export (exhaustive? coverage) + (-> Coverage Bit) + (case coverage + (#Exhaustive _) + #1 + + _ + #0)) + +(def: #export (%coverage value) + (Format Coverage) + (case value + #Partial + "#Partial" + + (#Bit value') + (|> value' + %b + (text.enclose ["(#Bit " ")"])) + + (#Variant ?max-cases cases) + (|> cases + dictionary.entries + (list/map (function (_ [idx coverage]) + (format (%n idx) " " (%coverage coverage)))) + (text.join-with " ") + (text.enclose ["{" "}"]) + (format (%n (..cases ?max-cases)) " ") + (text.enclose ["(#Variant " ")"])) + + (#Seq left right) + (format "(#Seq " (%coverage left) " " (%coverage right) ")") + + (#Alt left right) + (format "(#Alt " (%coverage left) " " (%coverage right) ")") + + #Exhaustive + "#Exhaustive")) + +(def: #export (determine pattern) + (-> Pattern (Operation Coverage)) + (case pattern + (^or (#///.Simple #///.Unit) + (#///.Bind _)) + (/////wrap #Exhaustive) + + ## Primitive patterns always have partial coverage because there + ## are too many possibilities as far as values go. + (^template [] + (#///.Simple ( _)) + (/////wrap #Partial)) + ([#///.Nat] + [#///.Int] + [#///.Rev] + [#///.Frac] + [#///.Text]) + + ## Bits are the exception, since there is only "#1" and + ## "#0", which means it is possible for bit + ## pattern-matching to become exhaustive if complementary parts meet. + (#///.Simple (#///.Bit value)) + (/////wrap (#Bit value)) + + ## Tuple patterns can be exhaustive if there is exhaustiveness for all of + ## their sub-patterns. + (#///.Complex (#///.Tuple membersP+)) + (case (list.reverse membersP+) + (^or #.Nil (#.Cons _ #.Nil)) + (////.throw invalid-tuple-pattern []) + + (#.Cons lastP prevsP+) + (do ////.monad + [lastC (determine lastP)] + (monad.fold ////.monad + (function (_ leftP rightC) + (do ////.monad + [leftC (determine leftP)] + (case rightC + #Exhaustive + (wrap leftC) + + _ + (wrap (#Seq leftC rightC))))) + lastC prevsP+))) + + ## Variant patterns can be shown to be exhaustive if all the possible + ## cases are handled exhaustively. + (#///.Complex (#///.Variant [lefts right? value])) + (do ////.monad + [value-coverage (determine value) + #let [idx (if right? + (inc lefts) + lefts)]] + (wrap (#Variant (if right? + (#.Some idx) + #.None) + (|> (dictionary.new number.hash) + (dictionary.put idx value-coverage))))))) + +(def: (xor left right) + (-> Bit Bit Bit) + (or (and left (not right)) + (and (not left) right))) + +## The coverage checker not only verifies that pattern-matching is +## exhaustive, but also that there are no redundant patterns. +## Redundant patterns will never be executed, since there will +## always be a pattern prior to them that would match the input. +## Because of that, the presence of redundant patterns is assumed to +## be a bug, likely due to programmer carelessness. +(exception: #export (redundant-pattern {so-far Coverage} {addition Coverage}) + (ex.report ["Coverage so-far" (%coverage so-far)] + ["Coverage addition" (%coverage addition)])) + +(def: (flatten-alt coverage) + (-> Coverage (List Coverage)) + (case coverage + (#Alt left right) + (list& left (flatten-alt right)) + + _ + (list coverage))) + +(structure: _ (Equivalence Coverage) + (def: (= reference sample) + (case [reference sample] + [#Exhaustive #Exhaustive] + #1 + + [(#Bit sideR) (#Bit sideS)] + (bit/= sideR sideS) + + [(#Variant allR casesR) (#Variant allS casesS)] + (and (n/= (cases allR) + (cases allS)) + (:: (dictionary.equivalence =) = casesR casesS)) + + [(#Seq leftR rightR) (#Seq leftS rightS)] + (and (= leftR leftS) + (= rightR rightS)) + + [(#Alt _) (#Alt _)] + (let [flatR (flatten-alt reference) + flatS (flatten-alt sample)] + (and (n/= (list.size flatR) (list.size flatS)) + (list.every? (function (_ [coverageR coverageS]) + (= coverageR coverageS)) + (list.zip2 flatR flatS)))) + + _ + #0))) + +(open: "coverage/." ..equivalence) + +(exception: #export (variants-do-not-match {addition-cases Nat} {so-far-cases Nat}) + (ex.report ["So-far Cases" (%n so-far-cases)] + ["Addition Cases" (%n addition-cases)])) + +## After determining the coverage of each individual pattern, it is +## necessary to merge them all to figure out if the entire +## pattern-matching expression is exhaustive and whether it contains +## redundant patterns. +(def: #export (merge addition so-far) + (-> Coverage Coverage (Error Coverage)) + (case [addition so-far] + [#Partial #Partial] + (error/wrap #Partial) + + ## 2 bit coverages are exhaustive if they complement one another. + (^multi [(#Bit sideA) (#Bit sideSF)] + (xor sideA sideSF)) + (error/wrap #Exhaustive) + + [(#Variant allA casesA) (#Variant allSF casesSF)] + (let [addition-cases (cases allSF) + so-far-cases (cases allA)] + (cond (and (known-cases? addition-cases) + (known-cases? so-far-cases) + (not (n/= addition-cases so-far-cases))) + (ex.throw variants-do-not-match [addition-cases so-far-cases]) + + (:: (dictionary.equivalence ..equivalence) = casesSF casesA) + (ex.throw redundant-pattern [so-far addition]) + + ## else + (do error.monad + [casesM (monad.fold @ + (function (_ [tagA coverageA] casesSF') + (case (dictionary.get tagA casesSF') + (#.Some coverageSF) + (do @ + [coverageM (merge coverageA coverageSF)] + (wrap (dictionary.put tagA coverageM casesSF'))) + + #.None + (wrap (dictionary.put tagA coverageA casesSF')))) + casesSF (dictionary.entries casesA))] + (wrap (if (and (or (known-cases? addition-cases) + (known-cases? so-far-cases)) + (n/= (inc (n/max addition-cases so-far-cases)) + (dictionary.size casesM)) + (list.every? exhaustive? (dictionary.values casesM))) + #Exhaustive + (#Variant (case allSF + (#.Some _) + allSF + + _ + allA) + casesM)))))) + + [(#Seq leftA rightA) (#Seq leftSF rightSF)] + (case [(coverage/= leftSF leftA) (coverage/= rightSF rightA)] + ## Same prefix + [#1 #0] + (do error.monad + [rightM (merge rightA rightSF)] + (if (exhaustive? rightM) + ## If all that follows is exhaustive, then it can be safely dropped + ## (since only the "left" part would influence whether the + ## merged coverage is exhaustive or not). + (wrap leftSF) + (wrap (#Seq leftSF rightM)))) + + ## Same suffix + [#0 #1] + (do error.monad + [leftM (merge leftA leftSF)] + (wrap (#Seq leftM rightA))) + + ## The 2 sequences cannot possibly be merged. + [#0 #0] + (error/wrap (#Alt so-far addition)) + + ## There is nothing the addition adds to the coverage. + [#1 #1] + (ex.throw redundant-pattern [so-far addition])) + + ## The addition cannot possibly improve the coverage. + [_ #Exhaustive] + (ex.throw redundant-pattern [so-far addition]) + + ## The addition completes the coverage. + [#Exhaustive _] + (error/wrap #Exhaustive) + + ## The left part will always match, so the addition is redundant. + (^multi [(#Seq left right) single] + (coverage/= left single)) + (ex.throw redundant-pattern [so-far addition]) + + ## The right part is not necessary, since it can always match the left. + (^multi [single (#Seq left right)] + (coverage/= left single)) + (error/wrap single) + + ## When merging a new coverage against one based on Alt, it may be + ## that one of the many coverages in the Alt is complementary to + ## the new one, so effort must be made to fuse carefully, to match + ## the right coverages together. + ## If one of the Alt sub-coverages matches the new one, the cycle + ## must be repeated, in case the resulting coverage can now match + ## other ones in the original Alt. + ## This process must be repeated until no further productive + ## merges can be done. + [_ (#Alt leftS rightS)] + (do error.monad + [#let [fuse-once (: (-> Coverage (List Coverage) + (Error [(Maybe Coverage) + (List Coverage)])) + (function (_ coverageA possibilitiesSF) + (loop [altsSF possibilitiesSF] + (case altsSF + #.Nil + (wrap [#.None (list coverageA)]) + + (#.Cons altSF altsSF') + (case (merge coverageA altSF) + (#error.Success altMSF) + (case altMSF + (#Alt _) + (do @ + [[success altsSF+] (recur altsSF')] + (wrap [success (#.Cons altSF altsSF+)])) + + _ + (wrap [(#.Some altMSF) altsSF'])) + + (#error.Failure error) + (error.fail error)) + ))))] + [successA possibilitiesSF] (fuse-once addition (flatten-alt so-far))] + (loop [successA successA + possibilitiesSF possibilitiesSF] + (case successA + (#.Some coverageA') + (do @ + [[successA' possibilitiesSF'] (fuse-once coverageA' possibilitiesSF)] + (recur successA' possibilitiesSF')) + + #.None + (case (list.reverse possibilitiesSF) + (#.Cons last prevs) + (wrap (list/fold (function (_ left right) (#Alt left right)) + last + prevs)) + + #.Nil + (undefined))))) + + _ + (if (coverage/= so-far addition) + ## The addition cannot possibly improve the coverage. + (ex.throw redundant-pattern [so-far addition]) + ## There are now 2 alternative paths. + (error/wrap (#Alt so-far addition))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux new file mode 100644 index 000000000..3ce70fe9b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/expression.lux @@ -0,0 +1,109 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error] + [text + format]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." type] + ["." primitive] + ["." structure] + ["//." reference] + ["." case] + ["." function] + ["//." macro] + ["/." // + ["." extension] + [// + ["." reference]]]]) + +(exception: #export (unrecognized-syntax {code Code}) + (ex.report ["Code" (%code code)])) + +(def: #export (compile code) + Phase + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (case code' + (^template [ ] + ( value) + ( value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + (^template [ ] + (^ (#.Form (list& [_ ( tag)] + values))) + (case values + (#.Cons value #.Nil) + ( compile tag value) + + _ + ( compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + (#.Identifier reference) + (//reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply "Analysis" compile [extension-name extension-args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] + [_ (#.Identifier ["" arg-name])]))] + body))) + (function.function compile function-name arg-name body) + + (^ (#.Form (list& functionC argsC+))) + (do @ + [[functionT functionA] (type.with-inference + (compile functionC))] + (case functionA + (#//.Reference (#reference.Constant def-name)) + (do @ + [?macro (extension.lift (macro.find-macro def-name))] + (case ?macro + (#.Some macro) + (do @ + [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] + (compile expansion)) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (///.throw unrecognized-syntax code) + ))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/function.lux b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux new file mode 100644 index 000000000..cbea165f8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/function.lux @@ -0,0 +1,102 @@ +(.module: + [lux (#- function) + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." fold monoid monad)]]] + ["." type + ["." check]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." scope] + ["//." type] + ["." inference] + ["/." // + ["." extension]]]) + +(exception: #export (cannot-analyse {expected Type} {function Text} {argument Text} {body Code}) + (ex.report ["Type" (%type expected)] + ["Function" function] + ["Argument" argument] + ["Body" (%code body)])) + +(exception: #export (cannot-apply {function Type} {arguments (List Code)}) + (ex.report ["Function" (%type function)] + ["Arguments" (|> arguments + list.enumerate + (list/map (.function (_ [idx argC]) + (format text.new-line " " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(def: #export (function analyse function-name arg-name body) + (-> Phase Text Text Code (Operation Analysis)) + (do ///.monad + [functionT (extension.lift macro.expected-type)] + (loop [expectedT functionT] + (///.with-stack cannot-analyse [expectedT function-name arg-name body] + (case expectedT + (#.Named name unnamedT) + (recur unnamedT) + + (#.Apply argT funT) + (case (type.apply (list argT) funT) + (#.Some value) + (recur value) + + #.None + (///.fail (ex.construct cannot-analyse [expectedT function-name arg-name body]))) + + (^template [ ] + ( _) + (do @ + [[_ instanceT] (//type.with-env )] + (recur (maybe.assume (type.apply (list instanceT) expectedT))))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (recur expectedT') + + ## Inference + _ + (do @ + [[input-id inputT] (//type.with-env check.var) + [output-id outputT] (//type.with-env check.var) + #let [functionT (#.Function inputT outputT)] + functionA (recur functionT) + _ (//type.with-env + (check.check expectedT functionT))] + (wrap functionA)) + )) + + (#.Function inputT outputT) + (<| (:: @ map (.function (_ [scope bodyA]) + (#//.Function (scope.environment scope) bodyA))) + //.with-scope + ## Functions have access not only to their argument, but + ## also to themselves, through a local variable. + (scope.with-local [function-name expectedT]) + (scope.with-local [arg-name inputT]) + (//type.with-type outputT) + (analyse body)) + + _ + (///.fail "") + ))))) + +(def: #export (apply analyse functionT functionA argsC+) + (-> Phase Type Analysis (List Code) (Operation Analysis)) + (<| (///.with-stack cannot-apply [functionT argsC+]) + (do ///.monad + [[applyT argsA+] (inference.general analyse functionT argsC+)]) + (wrap (//.apply [functionA argsA+])))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux new file mode 100644 index 000000000..4ce9c6985 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/inference.lux @@ -0,0 +1,259 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." functor)]]] + ["." type + ["." check]] + ["." macro]] + ["." /// ("#/." monad) + ["." extension]] + [// (#+ Tag Analysis Operation Phase)] + ["." //type]) + +(exception: #export (variant-tag-out-of-bounds {size Nat} {tag Tag} {type Type}) + (ex.report ["Tag" (%n tag)] + ["Variant size" (%i (.int size))] + ["Variant type" (%type type)])) + +(exception: #export (cannot-infer {type Type} {args (List Code)}) + (ex.report ["Type" (%type type)] + ["Arguments" (|> args + list.enumerate + (list/map (function (_ [idx argC]) + (format text.new-line " " (%n idx) " " (%code argC)))) + (text.join-with ""))])) + +(exception: #export (cannot-infer-argument {inferred Type} {argument Code}) + (ex.report ["Inferred Type" (%type inferred)] + ["Argument" (%code argument)])) + +(exception: #export (smaller-variant-than-expected {expected Nat} {actual Nat}) + (ex.report ["Expected" (%i (.int expected))] + ["Actual" (%i (.int actual))])) + +(do-template [] + [(exception: #export ( {type Type}) + (%type type))] + + [not-a-variant-type] + [not-a-record-type] + [invalid-type-application] + ) + +(def: (replace parameter-idx replacement type) + (-> Nat Type Type Type) + (case type + (#.Primitive name params) + (#.Primitive name (list/map (replace parameter-idx replacement) params)) + + (^template [] + ( left right) + ( (replace parameter-idx replacement left) + (replace parameter-idx replacement right))) + ([#.Sum] + [#.Product] + [#.Function] + [#.Apply]) + + (#.Parameter idx) + (if (n/= parameter-idx idx) + replacement + type) + + (^template [] + ( env quantified) + ( (list/map (replace parameter-idx replacement) env) + (replace (n/+ 2 parameter-idx) replacement quantified))) + ([#.UnivQ] + [#.ExQ]) + + _ + type)) + +(def: (named-type cursor id) + (-> Cursor Nat Type) + (let [name (format "{New Type @ " (.cursor-description cursor) " " (%n id) "}")] + (#.Primitive name (list)))) + +(def: new-named-type + (Operation Type) + (do ///.monad + [cursor (extension.lift macro.cursor) + [ex-id _] (//type.with-env check.existential)] + (wrap (named-type cursor ex-id)))) + +## Type-inference works by applying some (potentially quantified) type +## to a sequence of values. +## Function types are used for this, although inference is not always +## done for function application (alternative uses may be records and +## tagged variants). +## But, so long as the type being used for the inference can be treated +## as a function type, this method of inference should work. +(def: #export (general analyse inferT args) + (-> Phase Type (List Code) (Operation [Type (List Analysis)])) + (case args + #.Nil + (do ///.monad + [_ (//type.infer inferT)] + (wrap [inferT (list)])) + + (#.Cons argC args') + (case inferT + (#.Named name unnamedT) + (general analyse unnamedT args) + + (#.UnivQ _) + (do ///.monad + [[var-id varT] (//type.with-env check.var)] + (general analyse (maybe.assume (type.apply (list varT) inferT)) args)) + + (#.ExQ _) + (do ///.monad + [[var-id varT] (//type.with-env check.var) + output (general analyse + (maybe.assume (type.apply (list varT) inferT)) + args) + bound? (//type.with-env + (check.bound? var-id)) + _ (if bound? + (wrap []) + (do @ + [newT new-named-type] + (//type.with-env + (check.check varT newT))))] + (wrap output)) + + (#.Apply inputT transT) + (case (type.apply (list inputT) transT) + (#.Some outputT) + (general analyse outputT args) + + #.None + (///.throw invalid-type-application inferT)) + + ## Arguments are inferred back-to-front because, by convention, + ## Lux functions take the most important arguments *last*, which + ## means that the most information for doing proper inference is + ## located in the last arguments to a function call. + ## By inferring back-to-front, a lot of type-annotations can be + ## avoided in Lux code, since the inference algorithm can piece + ## things together more easily. + (#.Function inputT outputT) + (do ///.monad + [[outputT' args'A] (general analyse outputT args') + argA (<| (///.with-stack cannot-infer-argument [inputT argC]) + (//type.with-type inputT) + (analyse argC))] + (wrap [outputT' (list& argA args'A)])) + + (#.Var infer-id) + (do ///.monad + [?inferT' (//type.with-env (check.read infer-id))] + (case ?inferT' + (#.Some inferT') + (general analyse inferT' args) + + _ + (///.throw cannot-infer [inferT args]))) + + _ + (///.throw cannot-infer [inferT args])) + )) + +## Turns a record type into the kind of function type suitable for inference. +(def: #export (record inferT) + (-> Type (Operation Type)) + (case inferT + (#.Named name unnamedT) + (record unnamedT) + + (^template [] + ( env bodyT) + (do ///.monad + [bodyT+ (record bodyT)] + (wrap ( env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (record outputT) + + #.None + (///.throw invalid-type-application inferT)) + + (#.Product _) + (////wrap (type.function (type.flatten-tuple inferT) inferT)) + + _ + (///.throw not-a-record-type inferT))) + +## Turns a variant type into the kind of function type suitable for inference. +(def: #export (variant tag expected-size inferT) + (-> Nat Nat Type (Operation Type)) + (loop [depth 0 + currentT inferT] + (case currentT + (#.Named name unnamedT) + (do ///.monad + [unnamedT+ (recur depth unnamedT)] + (wrap unnamedT+)) + + (^template [] + ( env bodyT) + (do ///.monad + [bodyT+ (recur (inc depth) bodyT)] + (wrap ( env bodyT+)))) + ([#.UnivQ] + [#.ExQ]) + + (#.Sum _) + (let [cases (type.flatten-variant currentT) + actual-size (list.size cases) + boundary (dec expected-size)] + (cond (or (n/= expected-size actual-size) + (and (n/> expected-size actual-size) + (n/< boundary tag))) + (case (list.nth tag cases) + (#.Some caseT) + (////wrap (if (n/= 0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n/* 2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT))))) + + #.None + (///.throw variant-tag-out-of-bounds [expected-size tag inferT])) + + (n/< expected-size actual-size) + (///.throw smaller-variant-than-expected [expected-size actual-size]) + + (n/= boundary tag) + (let [caseT (type.variant (list.drop boundary cases))] + (////wrap (if (n/= 0 depth) + (type.function (list caseT) currentT) + (let [replace' (replace (|> depth dec (n/* 2)) inferT)] + (type.function (list (replace' caseT)) + (replace' currentT)))))) + + ## else + (///.throw variant-tag-out-of-bounds [expected-size tag inferT]))) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (variant tag expected-size outputT) + + #.None + (///.throw invalid-type-application inferT)) + + _ + (///.throw not-a-variant-type inferT)))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux b/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux new file mode 100644 index 000000000..18455b837 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/macro.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + [array (#+ Array)] + ["." list ("#/." functor)]]] + ["." macro] + ["." host (#+ import:)]] + ["." ///]) + +(exception: #export (expansion-failed {macro Name} {inputs (List Code)} {error Text}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format text.new-line text.tab))) + (text.join-with ""))] + ["Error" error])) + +(exception: #export (must-have-single-expansion {macro Name} {inputs (List Code)}) + (ex.report ["Macro" (%name macro)] + ["Inputs" (|> inputs + (list/map (|>> %code (format text.new-line text.tab))) + (text.join-with ""))])) + +(import: java/lang/reflect/Method + (invoke [Object (Array Object)] #try Object)) + +(import: (java/lang/Class c) + (getMethod [String (Array (Class Object))] #try Method)) + +(import: java/lang/Object + (getClass [] (Class Object))) + +(def: _object-class + (Class Object) + (host.class-for Object)) + +(def: _apply-args + (Array (Class Object)) + (|> (host.array (Class Object) 2) + (host.array-write 0 _object-class) + (host.array-write 1 _object-class))) + +(def: #export (expand name macro inputs) + (-> Name Macro (List Code) (Meta (List Code))) + (function (_ state) + (do error.monad + [apply-method (|> macro + (:coerce Object) + (Object::getClass) + (Class::getMethod "apply" _apply-args)) + output (Method::invoke (:coerce Object macro) + (|> (host.array Object 2) + (host.array-write 0 (:coerce Object inputs)) + (host.array-write 1 (:coerce Object state))) + apply-method)] + (case (:coerce (Error [Lux (List Code)]) + output) + (#error.Success output) + (#error.Success output) + + (#error.Failure error) + ((///.throw expansion-failed [name inputs error]) state))))) + +(def: #export (expand-one name macro inputs) + (-> Name Macro (List Code) (Meta Code)) + (do macro.monad + [expansion (expand name macro inputs)] + (case expansion + (^ (list single)) + (wrap single) + + _ + (///.throw must-have-single-expansion [name inputs])))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/module.lux b/stdlib/source/lux/tool/compiler/phase/analysis/module.lux new file mode 100644 index 000000000..29865f352 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/module.lux @@ -0,0 +1,255 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." text ("#/." equivalence) + format] + ["." error] + [collection + ["." list ("#/." fold functor)] + [dictionary + ["." plist]]]] + ["." macro]] + ["." // (#+ Operation) + ["/." // + ["." extension]]]) + +(type: #export Tag Text) + +(exception: #export (unknown-module {module Text}) + (ex.report ["Module" module])) + +(exception: #export (cannot-declare-tag-twice {module Text} {tag Text}) + (ex.report ["Module" module] + ["Tag" tag])) + +(do-template [] + [(exception: #export ( {tags (List Text)} {owner Type}) + (ex.report ["Tags" (text.join-with " " tags)] + ["Type" (%type owner)]))] + + [cannot-declare-tags-for-unnamed-type] + [cannot-declare-tags-for-foreign-type] + ) + +(exception: #export (cannot-define-more-than-once {name Name}) + (ex.report ["Definition" (%name name)])) + +(exception: #export (can-only-change-state-of-active-module {module Text} {state Module-State}) + (ex.report ["Module" module] + ["Desired state" (case state + #.Active "Active" + #.Compiled "Compiled" + #.Cached "Cached")])) + +(exception: #export (cannot-set-module-annotations-more-than-once {module Text} {old Code} {new Code}) + (ex.report ["Module" module] + ["Old annotations" (%code old)] + ["New annotations" (%code new)])) + +(def: #export (new hash) + (-> Nat Module) + {#.module-hash hash + #.module-aliases (list) + #.definitions (list) + #.imports (list) + #.tags (list) + #.types (list) + #.module-annotations #.None + #.module-state #.Active}) + +(def: #export (set-annotations annotations) + (-> Code (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (case (get@ #.module-annotations self) + #.None + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.put self-name (set@ #.module-annotations (#.Some annotations) self)) + state) + []]))) + + (#.Some old) + (///.throw cannot-set-module-annotations-more-than-once [self-name old annotations])))) + +(def: #export (import module) + (-> Text (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.update self-name (update@ #.imports (|>> (#.Cons module)))) + state) + []]))))) + +(def: #export (alias alias module) + (-> Text Text (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name)] + (extension.lift + (function (_ state) + (#error.Success [(update@ #.modules + (plist.update self-name (update@ #.module-aliases (: (-> (List [Text Text]) (List [Text Text])) + (|>> (#.Cons [alias module]))))) + state) + []]))))) + +(def: #export (exists? module) + (-> Text (Operation Bit)) + (extension.lift + (function (_ state) + (|> state + (get@ #.modules) + (plist.get module) + (case> (#.Some _) #1 #.None #0) + [state] #error.Success)))) + +(def: #export (define name definition) + (-> Text Definition (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name) + self (extension.lift macro.current-module)] + (extension.lift + (function (_ state) + (case (plist.get name (get@ #.definitions self)) + #.None + (#error.Success [(update@ #.modules + (plist.put self-name + (update@ #.definitions + (: (-> (List [Text Definition]) (List [Text Definition])) + (|>> (#.Cons [name definition]))) + self)) + state) + []]) + + (#.Some already-existing) + ((///.throw cannot-define-more-than-once [self-name name]) state)))))) + +(def: #export (create hash name) + (-> Nat Text (Operation Any)) + (extension.lift + (function (_ state) + (let [module (new hash)] + (#error.Success [(update@ #.modules + (plist.put name module) + state) + []]))))) + +(def: #export (with-module hash name action) + (All [a] (-> Nat Text (Operation a) (Operation [Module a]))) + (do ///.monad + [_ (create hash name) + output (//.with-current-module name + action) + module (extension.lift (macro.find-module name))] + (wrap [module output]))) + +(do-template [ ] + [(def: #export ( module-name) + (-> Text (Operation Any)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (let [active? (case (get@ #.module-state module) + #.Active #1 + _ #0)] + (if active? + (#error.Success [(update@ #.modules + (plist.put module-name (set@ #.module-state module)) + state) + []]) + ((///.throw can-only-change-state-of-active-module [module-name ]) + state))) + + #.None + ((///.throw unknown-module module-name) state))))) + + (def: #export ( module-name) + (-> Text (Operation Bit)) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#error.Success [state + (case (get@ #.module-state module) + #1 + _ #0)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [set-active active? #.Active] + [set-compiled compiled? #.Compiled] + [set-cached cached? #.Cached] + ) + +(do-template [ ] + [(def: ( module-name) + (-> Text (Operation )) + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get module-name)) + (#.Some module) + (#error.Success [state (get@ module)]) + + #.None + ((///.throw unknown-module module-name) state)))))] + + [tags #.tags (List [Text [Nat (List Name) Bit Type]])] + [types #.types (List [Text [(List Name) Bit Type]])] + [hash #.module-hash Nat] + ) + +(def: (ensure-undeclared-tags module-name tags) + (-> Text (List Tag) (Operation Any)) + (do ///.monad + [bindings (..tags module-name) + _ (monad.map @ + (function (_ tag) + (case (plist.get tag bindings) + #.None + (wrap []) + + (#.Some _) + (///.throw cannot-declare-tag-twice [module-name tag]))) + tags)] + (wrap []))) + +(def: #export (declare-tags tags exported? type) + (-> (List Tag) Bit Type (Operation Any)) + (do ///.monad + [self-name (extension.lift macro.current-module-name) + [type-module type-name] (case type + (#.Named type-name _) + (wrap type-name) + + _ + (///.throw cannot-declare-tags-for-unnamed-type [tags type])) + _ (ensure-undeclared-tags self-name tags) + _ (///.assert cannot-declare-tags-for-foreign-type [tags type] + (text/= self-name type-module))] + (extension.lift + (function (_ state) + (case (|> state (get@ #.modules) (plist.get self-name)) + (#.Some module) + (let [namespaced-tags (list/map (|>> [self-name]) tags)] + (#error.Success [(update@ #.modules + (plist.update self-name + (|>> (update@ #.tags (function (_ tag-bindings) + (list/fold (function (_ [idx tag] table) + (plist.put tag [idx namespaced-tags exported? type] table)) + tag-bindings + (list.enumerate tags)))) + (update@ #.types (plist.put type-name [namespaced-tags exported? type])))) + state) + []])) + #.None + ((///.throw unknown-module self-name) state)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux new file mode 100644 index 000000000..b46983293 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/primitive.lux @@ -0,0 +1,29 @@ +(.module: + [lux (#- nat int rev) + [control + monad]] + ["." // (#+ Analysis Operation) + [".A" type] + ["/." //]]) + +## [Analysers] +(do-template [ ] + [(def: #export ( value) + (-> (Operation Analysis)) + (do ///.monad + [_ (typeA.infer )] + (wrap (#//.Primitive ( value)))))] + + [bit Bit #//.Bit] + [nat Nat #//.Nat] + [int Int #//.Int] + [rev Rev #//.Rev] + [frac Frac #//.Frac] + [text Text #//.Text] + ) + +(def: #export unit + (Operation Analysis) + (do ///.monad + [_ (typeA.infer Any)] + (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux new file mode 100644 index 000000000..5969b9f5c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/reference.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [control + monad + ["ex" exception (#+ exception:)]] + ["." macro] + [data + ["." text ("#/." equivalence) + format]]] + ["." // (#+ Analysis Operation) + ["." scope] + ["." type] + ["/." // + ["." extension] + [// + ["." reference]]]]) + +(exception: #export (foreign-module-has-not-been-imported {current Text} {foreign Text}) + (ex.report ["Current" current] + ["Foreign" foreign])) + +(exception: #export (definition-has-not-been-expored {definition Name}) + (ex.report ["Definition" (%name definition)])) + +## [Analysers] +(def: (definition def-name) + (-> Name (Operation Analysis)) + (with-expansions [ (wrap (|> def-name reference.constant #//.Reference))] + (do ///.monad + [[actualT def-anns _] (extension.lift (macro.find-def def-name))] + (case (macro.get-identifier-ann (name-of #.alias) def-anns) + (#.Some real-def-name) + (definition real-def-name) + + _ + (do @ + [_ (type.infer actualT) + (^@ def-name [::module ::name]) (extension.lift (macro.normalize def-name)) + current (extension.lift macro.current-module-name)] + (if (text/= current ::module) + + (if (macro.export? def-anns) + (do @ + [imported! (extension.lift (macro.imported-by? ::module current))] + (if imported! + + (///.throw foreign-module-has-not-been-imported [current ::module]))) + (///.throw definition-has-not-been-expored def-name)))))))) + +(def: (variable var-name) + (-> Text (Operation (Maybe Analysis))) + (do ///.monad + [?var (scope.find var-name)] + (case ?var + (#.Some [actualT ref]) + (do @ + [_ (type.infer actualT)] + (wrap (#.Some (|> ref reference.variable #//.Reference)))) + + #.None + (wrap #.None)))) + +(def: #export (reference reference) + (-> Name (Operation Analysis)) + (case reference + ["" simple-name] + (do ///.monad + [?var (variable simple-name)] + (case ?var + (#.Some varA) + (wrap varA) + + #.None + (do @ + [this-module (extension.lift macro.current-module-name)] + (definition [this-module simple-name])))) + + _ + (definition reference))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/scope.lux b/stdlib/source/lux/tool/compiler/phase/analysis/scope.lux new file mode 100644 index 000000000..69d7c80a9 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/scope.lux @@ -0,0 +1,206 @@ +(.module: + [lux #* + [control + monad + ["ex" exception (#+ exception:)]] + [data + ["." text ("#/." equivalence) + format] + ["." maybe ("#/." monad)] + ["." product] + ["e" error] + [collection + ["." list ("#/." functor fold monoid)] + [dictionary + ["." plist]]]]] + [// (#+ Operation Phase) + ["/." // + ["." extension] + [// + ["." reference (#+ Register Variable)]]]]) + +(type: Local (Bindings Text [Type Register])) +(type: Foreign (Bindings Text [Type Variable])) + +(def: (local? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.locals #.mappings]) + (plist.contains? name))) + +(def: (local name scope) + (-> Text Scope (Maybe [Type Variable])) + (|> scope + (get@ [#.locals #.mappings]) + (plist.get name) + (maybe/map (function (_ [type value]) + [type (#reference.Local value)])))) + +(def: (captured? name scope) + (-> Text Scope Bit) + (|> scope + (get@ [#.captured #.mappings]) + (plist.contains? name))) + +(def: (captured name scope) + (-> Text Scope (Maybe [Type Variable])) + (loop [idx 0 + mappings (get@ [#.captured #.mappings] scope)] + (case mappings + (#.Cons [_name [_source-type _source-ref]] mappings') + (if (text/= name _name) + (#.Some [_source-type (#reference.Foreign idx)]) + (recur (inc idx) mappings')) + + #.Nil + #.None))) + +(def: (reference? name scope) + (-> Text Scope Bit) + (or (local? name scope) + (captured? name scope))) + +(def: (reference name scope) + (-> Text Scope (Maybe [Type Variable])) + (case (..local name scope) + (#.Some type) + (#.Some type) + + _ + (..captured name scope))) + +(def: #export (find name) + (-> Text (Operation (Maybe [Type Variable]))) + (extension.lift + (function (_ state) + (let [[inner outer] (|> state + (get@ #.scopes) + (list.split-with (|>> (reference? name) not)))] + (case outer + #.Nil + (#.Right [state #.None]) + + (#.Cons top-outer _) + (let [[ref-type init-ref] (maybe.default (undefined) + (..reference name top-outer)) + [ref inner'] (list/fold (: (-> Scope [Variable (List Scope)] [Variable (List Scope)]) + (function (_ scope ref+inner) + [(#reference.Foreign (get@ [#.captured #.counter] scope)) + (#.Cons (update@ #.captured + (: (-> Foreign Foreign) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [ref-type (product.left ref+inner)])))) + scope) + (product.right ref+inner))])) + [init-ref #.Nil] + (list.reverse inner)) + scopes (list/compose inner' outer)] + (#.Right [(set@ #.scopes scopes state) + (#.Some [ref-type ref])])) + ))))) + +(exception: #export (cannot-create-local-binding-without-a-scope) + "") + +(exception: #export (invalid-scope-alteration) + "") + +(def: #export (with-local [name type] action) + (All [a] (-> [Text Type] (Operation a) (Operation a))) + (function (_ [bundle state]) + (case (get@ #.scopes state) + (#.Cons head tail) + (let [old-mappings (get@ [#.locals #.mappings] head) + new-var-id (get@ [#.locals #.counter] head) + new-head (update@ #.locals + (: (-> Local Local) + (|>> (update@ #.counter inc) + (update@ #.mappings (plist.put name [type new-var-id])))) + head)] + (case (///.run' [bundle (set@ #.scopes (#.Cons new-head tail) state)] + action) + (#e.Success [[bundle' state'] output]) + (case (get@ #.scopes state') + (#.Cons head' tail') + (let [scopes' (#.Cons (set@ #.locals (get@ #.locals head) head') + tail')] + (#e.Success [[bundle' (set@ #.scopes scopes' state')] + output])) + + _ + (ex.throw invalid-scope-alteration [])) + + (#e.Failure error) + (#e.Failure error))) + + _ + (ex.throw cannot-create-local-binding-without-a-scope [])) + )) + +(do-template [ ] + [(def: + (Bindings Text [Type ]) + {#.counter 0 + #.mappings (list)})] + + [init-locals Nat] + [init-captured Variable] + ) + +(def: (scope parent-name child-name) + (-> (List Text) Text Scope) + {#.name (list& child-name parent-name) + #.inner 0 + #.locals init-locals + #.captured init-captured}) + +(def: #export (with-scope name action) + (All [a] (-> Text (Operation a) (Operation a))) + (function (_ [bundle state]) + (let [parent-name (case (get@ #.scopes state) + #.Nil + (list) + + (#.Cons top _) + (get@ #.name top))] + (case (action [bundle (update@ #.scopes + (|>> (#.Cons (scope parent-name name))) + state)]) + (#e.Success [[bundle' state'] output]) + (#e.Success [[bundle' (update@ #.scopes + (|>> list.tail (maybe.default (list))) + state')] + output]) + + (#e.Failure error) + (#e.Failure error))) + )) + +(exception: #export (cannot-get-next-reference-when-there-is-no-scope) + "") + +(def: #export next-local + (Operation Register) + (extension.lift + (function (_ state) + (case (get@ #.scopes state) + (#.Cons top _) + (#e.Success [state (get@ [#.locals #.counter] top)]) + + #.Nil + (ex.throw cannot-get-next-reference-when-there-is-no-scope []))))) + +(def: (ref-to-variable ref) + (-> Ref Variable) + (case ref + (#.Local register) + (#reference.Local register) + + (#.Captured register) + (#reference.Foreign register))) + +(def: #export (environment scope) + (-> Scope (List Variable)) + (|> scope + (get@ [#.captured #.mappings]) + (list/map (function (_ [_ [_ ref]]) (ref-to-variable ref))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux new file mode 100644 index 000000000..6991c67f7 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/structure.lux @@ -0,0 +1,358 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + ["." state]] + [data + ["." name] + ["." number] + ["." product] + ["." maybe] + ["." error] + [text + format] + [collection + ["." list ("#/." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Tag Analysis Operation Phase) + ["//." type] + ["." primitive] + ["." inference] + ["/." // + ["." extension]]]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)])) + +(do-template [] + [(exception: #export ( {type Type} {members (List Code)}) + (ex.report ["Type" (%type type)] + ["Expression" (%code (` [(~+ members)]))]))] + + [invalid-tuple-type] + [cannot-analyse-tuple] + ) + +(exception: #export (not-a-quantified-type {type Type}) + (%type type)) + +(do-template [] + [(exception: #export ( {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)]))] + + [cannot-analyse-variant] + [cannot-infer-numeric-tag] + ) + +(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])}) + (ex.report ["Key" (%code key)] + ["Record" (%code (code.record record))])) + +(do-template [] + [(exception: #export ( {key Name} {record (List [Name Code])}) + (ex.report ["Tag" (%code (code.tag key))] + ["Record" (%code (code.record (list/map (function (_ [keyI valC]) + [(code.tag keyI) valC]) + record)))]))] + + [cannot-repeat-tag] + ) + +(exception: #export (tag-does-not-belong-to-record {key Name} {type Type}) + (ex.report ["Tag" (%code (code.tag key))] + ["Type" (%type type)])) + +(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) + (ex.report ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)] + ["Type" (%type type)] + ["Expression" (%code (|> record + (list/map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse tag valueC) + (-> Phase Nat Code (Operation Analysis)) + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-variant [expectedT tag valueC] + (case expectedT + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat) + right? (n/= (dec type-size) + tag) + lefts (if right? + (dec tag) + tag)] + (case (list.nth tag flat) + (#.Some variant-type) + (do @ + [valueA (//type.with-type variant-type + (analyse valueC))] + (wrap (//.variant [lefts right? valueA]))) + + #.None + (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (sum analyse tag valueC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (sum analyse tag valueC)) + + _ + ## Cannot do inference when the tag is numeric. + ## This is because there is no way of knowing how many + ## cases the inferred sum type would have. + (///.throw cannot-infer-numeric-tag [expectedT tag valueC]) + )) + + (^template [ ] + ( _) + (do @ + [[instance-id instanceT] (//type.with-env )] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (sum analyse tag valueC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (sum analyse tag valueC)) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (sum analyse tag valueC)) + + #.None + (///.throw not-a-quantified-type funT))) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse members) + (-> Phase (List Code) (Operation Analysis)) + (do ///.monad + [expectedT (extension.lift macro.expected-type) + membersA+ (: (Operation (List Analysis)) + (loop [membersT+ (type.flatten-tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [(#.Cons memberT #.Nil) _] + (//type.with-type memberT + (:: @ map (|>> list) (analyse (code.tuple membersC+)))) + + [_ (#.Cons memberC #.Nil)] + (//type.with-type (type.tuple membersT+) + (:: @ map (|>> list) (analyse memberC))) + + [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] + (do @ + [memberA (//type.with-type memberT + (analyse memberC)) + memberA+ (recur membersT+' membersC+')] + (wrap (#.Cons memberA memberA+))) + + _ + (///.throw cannot-analyse-tuple [expectedT members]))))] + (wrap (//.tuple membersA+)))) + +(def: #export (product analyse membersC) + (-> Phase (List Code) (Operation Analysis)) + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-tuple [expectedT membersC] + (case expectedT + (#.Product _) + (..typed-product analyse membersC) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (product analyse membersC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (product analyse membersC)) + + _ + ## Must do inference... + (do @ + [membersTA (monad.map @ (|>> analyse //type.with-inference) + membersC) + _ (//type.with-env + (check.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (//.tuple (list/map product.right membersTA)))))) + + (^template [ ] + ( _) + (do @ + [[instance-id instanceT] (//type.with-env )] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (product analyse membersC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (product analyse membersC)) + + _ + (///.throw invalid-tuple-type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (product analyse membersC)) + + #.None + (///.throw not-a-quantified-type funT))) + + _ + (///.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Phase Name Code (Operation Analysis)) + (do ///.monad + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [#let [case-size (list.size group)] + inferenceT (inference.variant idx case-size variantT) + [inferredT valueA+] (inference.general analyse inferenceT (list valueC)) + #let [right? (n/= (dec case-size) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap (//.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) + + _ + (..sum analyse idx valueC)))) + +## There cannot be any ambiguity or improper syntax when analysing +## records, so they must be normalized for further analysis. +## Normalization just means that all the tags get resolved to their +## canonical form (with their corresponding module identified). +(def: #export (normalize record) + (-> (List [Code Code]) (Operation (List [Name Code]))) + (monad.map ///.monad + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do ///.monad + [key (extension.lift (macro.normalize key))] + (wrap [key val])) + + _ + (///.throw record-keys-must-be-tags [key record]))) + record)) + +## Lux already possesses the means to analyse tuples, so +## re-implementing the same functionality for records makes no sense. +## Records, thus, get transformed into tuples by ordering the elements. +(def: #export (order record) + (-> (List [Name Code]) (Operation [(List Code) Type])) + (case record + ## empty-record = empty-tuple = unit = [] + #.Nil + (:: ///.monad wrap [(list) Any]) + + (#.Cons [head-k head-v] _) + (do ///.monad + [head-k (extension.lift (macro.normalize head-k)) + [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) + #let [size-record (list.size record) + size-ts (list.size tag-set)] + _ (if (n/= size-ts size-record) + (wrap []) + (///.throw record-size-mismatch [size-ts size-record recordT record])) + #let [tuple-range (list.indices size-ts) + tag->idx (dict.from-list name.hash (list.zip2 tag-set tuple-range))] + idx->val (monad.fold @ + (function (_ [key val] idx->val) + (do @ + [key (extension.lift (macro.normalize key))] + (case (dict.get key tag->idx) + (#.Some idx) + (if (dict.contains? idx idx->val) + (///.throw cannot-repeat-tag [key record]) + (wrap (dict.put idx val idx->val))) + + #.None + (///.throw tag-does-not-belong-to-record [key recordT])))) + (: (Dictionary Nat Code) + (dict.new number.hash)) + record) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (record analyse members) + (-> Phase (List [Code Code]) (Operation Analysis)) + (do ///.monad + [members (normalize members) + [membersC recordT] (order members)] + (case membersC + (^ (list)) + primitive.unit + + (^ (list singletonC)) + (analyse singletonC) + + _ + (do @ + [expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [inferenceT (inference.record recordT) + [inferredT membersA] (inference.general analyse inferenceT membersC)] + (wrap (//.tuple membersA))) + + _ + (..product analyse membersC)))))) diff --git a/stdlib/source/lux/tool/compiler/phase/analysis/type.lux b/stdlib/source/lux/tool/compiler/phase/analysis/type.lux new file mode 100644 index 000000000..75d691628 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/analysis/type.lux @@ -0,0 +1,52 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." error]] + ["." function] + [type + ["tc" check]] + ["." macro]] + [// (#+ Operation) + ["/." // + ["." extension]]]) + +(def: #export (with-type expected) + (All [a] (-> Type (Operation a) (Operation a))) + (extension.localized (get@ #.expected) (set@ #.expected) + (function.constant (#.Some expected)))) + +(def: #export (with-env action) + (All [a] (-> (tc.Check a) (Operation a))) + (function (_ (^@ stateE [bundle state])) + (case (action (get@ #.type-context state)) + (#error.Success [context' output]) + (#error.Success [[bundle (set@ #.type-context context' state)] + output]) + + (#error.Failure error) + ((///.fail error) stateE)))) + +(def: #export with-fresh-env + (All [a] (-> (Operation a) (Operation a))) + (extension.localized (get@ #.type-context) (set@ #.type-context) + (function.constant tc.fresh-context))) + +(def: #export (infer actualT) + (-> Type (Operation Any)) + (do ///.monad + [expectedT (extension.lift macro.expected-type)] + (with-env + (tc.check expectedT actualT)))) + +(def: #export (with-inference action) + (All [a] (-> (Operation a) (Operation [Type a]))) + (do ///.monad + [[_ varT] (..with-env + tc.var) + output (with-type varT + action) + knownT (..with-env + (tc.clean varT))] + (wrap [knownT output]))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension.lux b/stdlib/source/lux/tool/compiler/phase/extension.lux new file mode 100644 index 000000000..0d58cf37a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension.lux @@ -0,0 +1,140 @@ +(.module: + [lux (#- Name) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + ["." text ("#/." order) + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]] + ["." function]] + ["." //]) + +(type: #export Name Text) + +(type: #export (Extension i) + [Name (List i)]) + +(with-expansions [ (as-is (Dictionary Name (Handler s i o)))] + (type: #export (Handler s i o) + (-> Name + (//.Phase [ s] i o) + (//.Phase [ s] (List i) o))) + + (type: #export (Bundle s i o) + )) + +(type: #export (State s i o) + {#bundle (Bundle s i o) + #state s}) + +(type: #export (Operation s i o v) + (//.Operation (State s i o) v)) + +(type: #export (Phase s i o) + (//.Phase (State s i o) i o)) + +(do-template [] + [(exception: #export ( {name Name}) + (ex.report ["Extension" (%t name)]))] + + [cannot-overwrite] + [invalid-syntax] + ) + +(exception: #export [s i o] (unknown {where Text} {name Name} {bundle (Bundle s i o)}) + (ex.report ["Where" (%t where)] + ["Extension" (%t name)] + ["Available" (|> bundle + dictionary.keys + (list.sort text/<) + (list/map (|>> %t (format text.new-line text.tab))) + (text.join-with ""))])) + +(exception: #export (incorrect-arity {name Name} {arity Nat} {args Nat}) + (ex.report ["Extension" (%t name)] + ["Expected" (%n arity)] + ["Actual" (%n args)])) + +(def: #export (install name handler) + (All [s i o] + (-> Text (Handler s i o) (Operation s i o Any))) + (function (_ [bundle state]) + (case (dictionary.get name bundle) + #.None + (#error.Success [[(dictionary.put name handler bundle) state] + []]) + + _ + (ex.throw cannot-overwrite name)))) + +(def: #export (apply where phase [name parameters]) + (All [s i o] + (-> Text (Phase s i o) (Extension i) (Operation s i o o))) + (function (_ (^@ stateE [bundle state])) + (case (dictionary.get name bundle) + (#.Some handler) + (((handler name phase) parameters) + stateE) + + #.None + (ex.throw unknown [where name bundle])))) + +(def: #export (localized get set transform) + (All [s s' i o v] + (-> (-> s s') (-> s' s s) (-> s' s') + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (let [old (get state)] + (case (operation [bundle (set (transform old) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set old state')] output]) + + (#error.Failure error) + (#error.Failure error)))))) + +(def: #export (temporary transform) + (All [s i o v] + (-> (-> s s) + (-> (Operation s i o v) (Operation s i o v)))) + (function (_ operation) + (function (_ [bundle state]) + (case (operation [bundle (transform state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' state] output]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: #export (with-state state) + (All [s i o v] + (-> s (-> (Operation s i o v) (Operation s i o v)))) + (..temporary (function.constant state))) + +(def: #export (read get) + (All [s i o v] + (-> (-> s v) (Operation s i o v))) + (function (_ [bundle state]) + (#error.Success [[bundle state] (get state)]))) + +(def: #export (update transform) + (All [s i o] + (-> (-> s s) (Operation s i o Any))) + (function (_ [bundle state]) + (#error.Success [[bundle (transform state)] []]))) + +(def: #export (lift action) + (All [s i o v] + (-> (//.Operation s v) + (//.Operation [(Bundle s i o) s] v))) + (function (_ [bundle state]) + (case (action state) + (#error.Success [state' output]) + (#error.Success [[bundle state'] output]) + + (#error.Failure error) + (#error.Failure error)))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux new file mode 100644 index 000000000..3b31f3d46 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis.lux @@ -0,0 +1,18 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [/// + [analysis (#+ Bundle)] + [// + [default + [evaluation (#+ Eval)]]]] + [/ + ["." common] + ["." host]]) + +(def: #export (bundle eval) + (-> Eval Bundle) + (dictionary.merge host.bundle + (common.bundle eval))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux new file mode 100644 index 000000000..fa9b36270 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/common.lux @@ -0,0 +1,219 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]] + [data + ["." text + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]] + [type + ["." check]] + ["." macro] + [io (#+ IO)]] + ["." /// + ["." bundle] + ["//." // + ["." analysis (#+ Analysis Handler Bundle) + [".A" type] + [".A" case] + [".A" function]] + [// + [default + [evaluation (#+ Eval)]]]]]) + +## [Utils] +(def: (simple inputsT+ outputT) + (-> (List Type) Type Handler) + (let [num-expected (list.size inputsT+)] + (function (_ extension-name analyse args) + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do ////.monad + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#analysis.Extension extension-name argsA))) + (////.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) + +(def: #export (nullary valueT) + (-> Type Handler) + (simple (list) valueT)) + +(def: #export (unary inputT outputT) + (-> Type Type Handler) + (simple (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type Handler) + (simple (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type Handler) + (simple (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: lux::is + Handler + (function (_ extension-name analyse args) + (do ////.monad + [[var-id varT] (typeA.with-env check.var)] + ((binary varT varT Bit extension-name) + analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: lux::try + Handler + (function (_ extension-name analyse args) + (case args + (^ (list opC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (IO varT)) + (analyse opC))] + (wrap (#analysis.Extension extension-name (list opA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: lux::in-module + Handler + (function (_ extension-name analyse argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (analysis.with-current-module module-name + (analyse exprC)) + + _ + (////.throw ///.invalid-syntax [extension-name])))) + +(do-template [ ] + [(def: ( eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT)] + (typeA.with-type + (analyse valueC))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] + + [lux::check actualT] + [lux::coerce Any] + ) + +(def: lux::check::type + Handler + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [_ (typeA.infer Type) + valueA (typeA.with-type Type + (analyse valueC))] + (wrap valueA)) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (bundle::lux eval) + (-> Eval Bundle) + (|> bundle.empty + (bundle.install "is" lux::is) + (bundle.install "try" lux::try) + (bundle.install "check" (lux::check eval)) + (bundle.install "coerce" (lux::coerce eval)) + (bundle.install "check type" lux::check::type) + (bundle.install "in-module" lux::in-module))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary Text Any)) + (bundle.install "error" (unary Text Nothing)) + (bundle.install "exit" (unary Int Nothing)) + (bundle.install "current-time" (nullary Int))))) + +(def: I64* (type (I64 Any))) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary I64* I64* I64)) + (bundle.install "or" (binary I64* I64* I64)) + (bundle.install "xor" (binary I64* I64* I64)) + (bundle.install "left-shift" (binary Nat I64* I64)) + (bundle.install "logical-right-shift" (binary Nat I64* I64)) + (bundle.install "arithmetic-right-shift" (binary Nat I64* I64)) + (bundle.install "+" (binary I64* I64* I64)) + (bundle.install "-" (binary I64* I64* I64)) + (bundle.install "=" (binary I64* I64* Bit))))) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "*" (binary Int Int Int)) + (bundle.install "/" (binary Int Int Int)) + (bundle.install "%" (binary Int Int Int)) + (bundle.install "<" (binary Int Int Bit)) + (bundle.install "frac" (unary Int Frac)) + (bundle.install "char" (unary Int Text))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary Frac Frac Frac)) + (bundle.install "-" (binary Frac Frac Frac)) + (bundle.install "*" (binary Frac Frac Frac)) + (bundle.install "/" (binary Frac Frac Frac)) + (bundle.install "%" (binary Frac Frac Frac)) + (bundle.install "=" (binary Frac Frac Bit)) + (bundle.install "<" (binary Frac Frac Bit)) + (bundle.install "smallest" (nullary Frac)) + (bundle.install "min" (nullary Frac)) + (bundle.install "max" (nullary Frac)) + (bundle.install "int" (unary Frac Int)) + (bundle.install "encode" (unary Frac Text)) + (bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary Text Text Bit)) + (bundle.install "<" (binary Text Text Bit)) + (bundle.install "concat" (binary Text Text Text)) + (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (bundle.install "size" (unary Text Nat)) + (bundle.install "char" (binary Text Nat Nat)) + (bundle.install "clip" (trinary Text Nat Nat Text)) + ))) + +(def: #export (bundle eval) + (-> Eval Bundle) + (<| (bundle.prefix "lux") + (|> bundle.empty + (dictionary.merge (bundle::lux eval)) + (dictionary.merge bundle::i64) + (dictionary.merge bundle::int) + (dictionary.merge bundle::frac) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux new file mode 100644 index 000000000..0654e79c4 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/analysis/host.jvm.lux @@ -0,0 +1,1271 @@ +(.module: + [lux (#- char int) + [control + ["." monad (#+ do)] + ["p" parser] + ["ex" exception (#+ exception:)] + pipe] + [data + ["." error (#+ Error)] + ["." maybe] + ["." product] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." fold functor monoid)] + ["." array (#+ Array)] + ["." dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["s" syntax]] + ["." host (#+ import:)]] + [// + ["." common] + ["/." // + ["." bundle] + ["//." // ("#/." monad) + ["." analysis (#+ Analysis Operation Handler Bundle) + [".A" type] + [".A" inference]]]]] + ) + +(type: Method-Signature + {#method Type + #exceptions (List Type)}) + +(import: #long java/lang/reflect/Type + (getTypeName [] String)) + +(do-template [] + [(exception: #export ( {jvm-type java/lang/reflect/Type}) + (ex.report ["JVM Type" (java/lang/reflect/Type::getTypeName jvm-type)]))] + + [jvm-type-is-not-a-class] + [cannot-convert-to-a-class] + [cannot-convert-to-a-parameter] + [cannot-convert-to-a-lux-type] + ) + +(do-template [] + [(exception: #export ( {type Type}) + (%type type))] + + [non-object] + [non-array] + [non-jvm-type] + ) + +(do-template [] + [(exception: #export ( {name Text}) + name)] + + [non-interface] + [non-throwable] + ) + +(do-template [] + [(exception: #export ( {message Text}) + message)] + + [unknown-class] + [primitives-cannot-have-type-parameters] + [primitives-are-not-objects] + [invalid-type-for-array-element] + + [unknown-field] + [mistaken-field-owner] + [not-a-virtual-field] + [not-a-static-field] + [cannot-set-a-final-field] + + [cannot-cast] + + [cannot-possibly-be-an-instance] + + [unknown-type-var] + [type-parameter-mismatch] + [cannot-correspond-type-with-a-class] + ) + +(do-template [] + [(exception: #export ( {class Text} + {method Text} + {hints (List Method-Signature)}) + (ex.report ["Class" class] + ["Method" method] + ["Hints" (|> hints + (list/map (|>> product.left %type (format text.new-line text.tab))) + (text.join-with ""))]))] + + [no-candidates] + [too-many-candidates] + ) + +(do-template [ ] + [(def: #export Type (#.Primitive (list)))] + + ## Boxes + [Boolean "java.lang.Boolean"] + [Byte "java.lang.Byte"] + [Short "java.lang.Short"] + [Integer "java.lang.Integer"] + [Long "java.lang.Long"] + [Float "java.lang.Float"] + [Double "java.lang.Double"] + [Character "java.lang.Character"] + [String "java.lang.String"] + + ## Primitives + [boolean "boolean"] + [byte "byte"] + [short "short"] + [int "int"] + [long "long"] + [float "float"] + [double "double"] + [char "char"] + ) + +(def: bundle::conversion + Bundle + (<| (bundle.prefix "convert") + (|> bundle.empty + (bundle.install "double-to-float" (common.unary Double Float)) + (bundle.install "double-to-int" (common.unary Double Integer)) + (bundle.install "double-to-long" (common.unary Double Long)) + (bundle.install "float-to-double" (common.unary Float Double)) + (bundle.install "float-to-int" (common.unary Float Integer)) + (bundle.install "float-to-long" (common.unary Float Long)) + (bundle.install "int-to-byte" (common.unary Integer Byte)) + (bundle.install "int-to-char" (common.unary Integer Character)) + (bundle.install "int-to-double" (common.unary Integer Double)) + (bundle.install "int-to-float" (common.unary Integer Float)) + (bundle.install "int-to-long" (common.unary Integer Long)) + (bundle.install "int-to-short" (common.unary Integer Short)) + (bundle.install "long-to-double" (common.unary Long Double)) + (bundle.install "long-to-float" (common.unary Long Float)) + (bundle.install "long-to-int" (common.unary Long Integer)) + (bundle.install "long-to-short" (common.unary Long Short)) + (bundle.install "long-to-byte" (common.unary Long Byte)) + (bundle.install "char-to-byte" (common.unary Character Byte)) + (bundle.install "char-to-short" (common.unary Character Short)) + (bundle.install "char-to-int" (common.unary Character Integer)) + (bundle.install "char-to-long" (common.unary Character Long)) + (bundle.install "byte-to-long" (common.unary Byte Long)) + (bundle.install "short-to-long" (common.unary Short Long)) + ))) + +(do-template [ ] + [(def: + Bundle + (<| (bundle.prefix ) + (|> bundle.empty + (bundle.install "+" (common.binary )) + (bundle.install "-" (common.binary )) + (bundle.install "*" (common.binary )) + (bundle.install "/" (common.binary )) + (bundle.install "%" (common.binary )) + (bundle.install "=" (common.binary Bit)) + (bundle.install "<" (common.binary Bit)) + (bundle.install "and" (common.binary )) + (bundle.install "or" (common.binary )) + (bundle.install "xor" (common.binary )) + (bundle.install "shl" (common.binary Integer )) + (bundle.install "shr" (common.binary Integer )) + (bundle.install "ushr" (common.binary Integer )) + )))] + + [bundle::int "int" Integer] + [bundle::long "long" Long] + ) + +(do-template [ ] + [(def: + Bundle + (<| (bundle.prefix ) + (|> bundle.empty + (bundle.install "+" (common.binary )) + (bundle.install "-" (common.binary )) + (bundle.install "*" (common.binary )) + (bundle.install "/" (common.binary )) + (bundle.install "%" (common.binary )) + (bundle.install "=" (common.binary Bit)) + (bundle.install "<" (common.binary Bit)) + )))] + + [bundle::float "float" Float] + [bundle::double "double" Double] + ) + +(def: bundle::char + Bundle + (<| (bundle.prefix "char") + (|> bundle.empty + (bundle.install "=" (common.binary Character Character Bit)) + (bundle.install "<" (common.binary Character Character Bit)) + ))) + +(def: #export boxes + (Dictionary Text Text) + (|> (list ["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + (dictionary.from-list text.hash))) + +(def: array::length + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC)) + (do ////.monad + [_ (typeA.infer Nat) + [var-id varT] (typeA.with-env check.var) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC))] + (wrap (#analysis.Extension extension-name (list arrayA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: array::new + Handler + (function (_ extension-name analyse args) + (case args + (^ (list lengthC)) + (do ////.monad + [lengthA (typeA.with-type Nat + (analyse lengthC)) + expectedT (///.lift macro.expected-type) + [level elem-class] (: (Operation [Nat Text]) + (loop [analysisT expectedT + level 0] + (case analysisT + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (recur outputT level) + + #.None + (////.throw non-array expectedT)) + + (^ (#.Primitive "#Array" (list elemT))) + (recur elemT (inc level)) + + (#.Primitive class _) + (wrap [level class]) + + _ + (////.throw non-array expectedT)))) + _ (if (n/> 0 level) + (wrap []) + (////.throw non-array expectedT))] + (wrap (#analysis.Extension extension-name (list (analysis.nat (dec level)) + (analysis.text elem-class) + lengthA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (check-jvm objectT) + (-> Type (Operation Text)) + (case objectT + (#.Primitive name _) + (/////wrap name) + + (#.Named name unnamed) + (check-jvm unnamed) + + (#.Var id) + (/////wrap "java.lang.Object") + + (^template [] + ( env unquantified) + (check-jvm unquantified)) + ([#.UnivQ] + [#.ExQ]) + + (#.Apply inputT funcT) + (case (type.apply (list inputT) funcT) + (#.Some outputT) + (check-jvm outputT) + + #.None + (////.throw non-object objectT)) + + _ + (////.throw non-object objectT))) + +(def: (check-object objectT) + (-> Type (Operation Text)) + (do ////.monad + [name (check-jvm objectT)] + (if (dictionary.contains? name boxes) + (////.throw primitives-are-not-objects name) + (/////wrap name)))) + +(def: (box-array-element-type elemT) + (-> Type (Operation [Type Text])) + (case elemT + (#.Primitive name #.Nil) + (let [boxed-name (|> (dictionary.get name boxes) + (maybe.default name))] + (/////wrap [(#.Primitive boxed-name #.Nil) + boxed-name])) + + (#.Primitive name _) + (if (dictionary.contains? name boxes) + (////.throw primitives-cannot-have-type-parameters name) + (/////wrap [elemT name])) + + _ + (////.throw invalid-type-for-array-element (%type elemT)))) + +(def: array::read + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC idxC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer varT) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (check.read var-id)) + [elemT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC))] + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA arrayA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: array::write + Handler + (function (_ extension-name analyse args) + (case args + (^ (list arrayC idxC valueC)) + (do ////.monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Array varT))) + arrayA (typeA.with-type (type (Array varT)) + (analyse arrayC)) + ?elemT (typeA.with-env + (check.read var-id)) + [valueT elem-class] (box-array-element-type (maybe.default varT ?elemT)) + idxA (typeA.with-type Nat + (analyse idxC)) + valueA (typeA.with-type valueT + (analyse valueC))] + (wrap (#analysis.Extension extension-name (list (analysis.text elem-class) idxA valueA arrayA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: bundle::array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "length" array::length) + (bundle.install "new" array::new) + (bundle.install "read" array::read) + (bundle.install "write" array::write) + ))) + +(def: object::null + Handler + (function (_ extension-name analyse args) + (case args + (^ (list)) + (do ////.monad + [expectedT (///.lift macro.expected-type) + _ (check-object expectedT)] + (wrap (#analysis.Extension extension-name (list)))) + + _ + (////.throw ///.incorrect-arity [extension-name 0 (list.size args)])))) + +(def: object::null? + Handler + (function (_ extension-name analyse args) + (case args + (^ (list objectC)) + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (check-object objectT)] + (wrap (#analysis.Extension extension-name (list objectA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::synchronized + Handler + (function (_ extension-name analyse args) + (case args + (^ (list monitorC exprC)) + (do ////.monad + [[monitorT monitorA] (typeA.with-inference + (analyse monitorC)) + _ (check-object monitorT) + exprA (analyse exprC)] + (wrap (#analysis.Extension extension-name (list monitorA exprA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(import: java/lang/Object + (equals [Object] boolean)) + +(import: java/lang/ClassLoader) + +(import: java/lang/reflect/GenericArrayType + (getGenericComponentType [] java/lang/reflect/Type)) + +(import: java/lang/reflect/ParameterizedType + (getRawType [] java/lang/reflect/Type) + (getActualTypeArguments [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/TypeVariable d) + (getName [] String) + (getBounds [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/WildcardType d) + (getLowerBounds [] (Array java/lang/reflect/Type)) + (getUpperBounds [] (Array java/lang/reflect/Type))) + +(import: java/lang/reflect/Modifier + (#static isStatic [int] boolean) + (#static isFinal [int] boolean) + (#static isInterface [int] boolean) + (#static isAbstract [int] boolean)) + +(import: java/lang/reflect/Field + (getDeclaringClass [] (java/lang/Class Object)) + (getModifiers [] int) + (getGenericType [] java/lang/reflect/Type)) + +(import: java/lang/reflect/Method + (getName [] String) + (getModifiers [] int) + (getDeclaringClass [] (Class Object)) + (getTypeParameters [] (Array (TypeVariable Method))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericReturnType [] java/lang/reflect/Type) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(import: (java/lang/reflect/Constructor c) + (getModifiers [] int) + (getDeclaringClass [] (Class c)) + (getTypeParameters [] (Array (TypeVariable (Constructor c)))) + (getGenericParameterTypes [] (Array java/lang/reflect/Type)) + (getGenericExceptionTypes [] (Array java/lang/reflect/Type))) + +(import: (java/lang/Class c) + (getName [] String) + (getModifiers [] int) + (#static forName [String] #try (Class Object)) + (isAssignableFrom [(Class Object)] boolean) + (getTypeParameters [] (Array (TypeVariable (Class c)))) + (getGenericInterfaces [] (Array java/lang/reflect/Type)) + (getGenericSuperclass [] java/lang/reflect/Type) + (getDeclaredField [String] #try Field) + (getConstructors [] (Array (Constructor Object))) + (getDeclaredMethods [] (Array Method))) + +(def: (load-class name) + (-> Text (Operation (Class Object))) + (do ////.monad + [] + (case (Class::forName name) + (#error.Success [class]) + (wrap class) + + (#error.Failure error) + (////.throw unknown-class name)))) + +(def: (sub-class? super sub) + (-> Text Text (Operation Bit)) + (do ////.monad + [super (load-class super) + sub (load-class sub)] + (wrap (Class::isAssignableFrom sub super)))) + +(def: object::throw + Handler + (function (_ extension-name analyse args) + (case args + (^ (list exceptionC)) + (do ////.monad + [_ (typeA.infer Nothing) + [exceptionT exceptionA] (typeA.with-inference + (analyse exceptionC)) + exception-class (check-object exceptionT) + ? (sub-class? "java.lang.Throwable" exception-class) + _ (: (Operation Any) + (if ? + (wrap []) + (////.throw non-throwable exception-class)))] + (wrap (#analysis.Extension extension-name (list exceptionA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::class + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC)) + (case classC + [_ (#.Text class)] + (do ////.monad + [_ (typeA.infer (#.Primitive "java.lang.Class" (list (#.Primitive class (list))))) + _ (load-class class)] + (wrap (#analysis.Extension extension-name (list (analysis.text class))))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: object::instance? + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC objectC)) + (case classC + [_ (#.Text class)] + (do ////.monad + [_ (typeA.infer Bit) + [objectT objectA] (typeA.with-inference + (analyse objectC)) + object-class (check-object objectT) + ? (sub-class? class object-class)] + (if ? + (wrap (#analysis.Extension extension-name (list (analysis.text class)))) + (////.throw cannot-possibly-be-an-instance (format object-class " !<= " class)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: (java-type-to-class jvm-type) + (-> java/lang/reflect/Type (Operation Text)) + (cond (host.instance? Class jvm-type) + (/////wrap (Class::getName (:coerce Class jvm-type))) + + (host.instance? ParameterizedType jvm-type) + (java-type-to-class (ParameterizedType::getRawType (:coerce ParameterizedType jvm-type))) + + ## else + (////.throw cannot-convert-to-a-class jvm-type))) + +(type: Mappings + (Dictionary Text Type)) + +(def: fresh-mappings Mappings (dictionary.new text.hash)) + +(def: (java-type-to-lux-type mappings java-type) + (-> Mappings java/lang/reflect/Type (Operation Type)) + (cond (host.instance? TypeVariable java-type) + (let [var-name (TypeVariable::getName (:coerce TypeVariable java-type))] + (case (dictionary.get var-name mappings) + (#.Some var-type) + (/////wrap var-type) + + #.None + (////.throw unknown-type-var var-name))) + + (host.instance? WildcardType java-type) + (let [java-type (:coerce WildcardType java-type)] + (case [(array.read 0 (WildcardType::getUpperBounds java-type)) + (array.read 0 (WildcardType::getLowerBounds java-type))] + (^or [(#.Some bound) _] [_ (#.Some bound)]) + (java-type-to-lux-type mappings bound) + + _ + (/////wrap Any))) + + (host.instance? Class java-type) + (let [java-type (:coerce (Class Object) java-type) + class-name (Class::getName java-type)] + (/////wrap (case (array.size (Class::getTypeParameters java-type)) + 0 + (#.Primitive class-name (list)) + + arity + (|> (list.indices arity) + list.reverse + (list/map (|>> (n/* 2) inc #.Parameter)) + (#.Primitive class-name) + (type.univ-q arity))))) + + (host.instance? ParameterizedType java-type) + (let [java-type (:coerce ParameterizedType java-type) + raw (ParameterizedType::getRawType java-type)] + (if (host.instance? Class raw) + (do ////.monad + [paramsT (|> java-type + ParameterizedType::getActualTypeArguments + array.to-list + (monad.map @ (java-type-to-lux-type mappings)))] + (/////wrap (#.Primitive (Class::getName (:coerce (Class Object) raw)) + paramsT))) + (////.throw jvm-type-is-not-a-class raw))) + + (host.instance? GenericArrayType java-type) + (do ////.monad + [innerT (|> (:coerce GenericArrayType java-type) + GenericArrayType::getGenericComponentType + (java-type-to-lux-type mappings))] + (wrap (#.Primitive "#Array" (list innerT)))) + + ## else + (////.throw cannot-convert-to-a-lux-type java-type))) + +(def: (correspond-type-params class type) + (-> (Class Object) Type (Operation Mappings)) + (case type + (#.Primitive name params) + (let [class-name (Class::getName class) + class-params (array.to-list (Class::getTypeParameters class)) + num-class-params (list.size class-params) + num-type-params (list.size params)] + (cond (not (text/= class-name name)) + (////.throw cannot-correspond-type-with-a-class + (format "Class = " class-name text.new-line + "Type = " (%type type))) + + (not (n/= num-class-params num-type-params)) + (////.throw type-parameter-mismatch + (format "Expected: " (%i (.int num-class-params)) text.new-line + " Actual: " (%i (.int num-type-params)) text.new-line + " Class: " class-name text.new-line + " Type: " (%type type))) + + ## else + (/////wrap (|> params + (list.zip2 (list/map (|>> TypeVariable::getName) class-params)) + (dictionary.from-list text.hash))) + )) + + _ + (////.throw non-jvm-type type))) + +(def: object::cast + Handler + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.monad + [toT (///.lift macro.expected-type) + to-name (check-jvm toT) + [valueT valueA] (typeA.with-inference + (analyse valueC)) + from-name (check-jvm valueT) + can-cast? (: (Operation Bit) + (case [from-name to-name] + (^template [ ] + (^or [ ] + [ ]) + (do @ + [_ (typeA.infer (#.Primitive to-name (list)))] + (wrap #1))) + (["boolean" "java.lang.Boolean"] + ["byte" "java.lang.Byte"] + ["short" "java.lang.Short"] + ["int" "java.lang.Integer"] + ["long" "java.lang.Long"] + ["float" "java.lang.Float"] + ["double" "java.lang.Double"] + ["char" "java.lang.Character"]) + + _ + (do @ + [_ (////.assert primitives-are-not-objects from-name + (not (dictionary.contains? from-name boxes))) + _ (////.assert primitives-are-not-objects to-name + (not (dictionary.contains? to-name boxes))) + to-class (load-class to-name)] + (loop [[current-name currentT] [from-name valueT]] + (if (text/= to-name current-name) + (do @ + [_ (typeA.infer toT)] + (wrap #1)) + (do @ + [current-class (load-class current-name) + _ (////.assert cannot-cast (format "From class/primitive: " current-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line) + (Class::isAssignableFrom current-class to-class)) + candiate-parents (monad.map @ + (function (_ java-type) + (do @ + [class-name (java-type-to-class java-type) + class (load-class class-name)] + (wrap [[class-name java-type] (Class::isAssignableFrom class to-class)]))) + (list& (Class::getGenericSuperclass current-class) + (array.to-list (Class::getGenericInterfaces current-class))))] + (case (|> candiate-parents + (list.filter product.right) + (list/map product.left)) + (#.Cons [next-name nextJT] _) + (do @ + [mapping (correspond-type-params current-class currentT) + nextT (java-type-to-lux-type mapping nextJT)] + (recur [next-name nextT])) + + #.Nil + (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line))) + ))))))] + (if can-cast? + (wrap (#analysis.Extension extension-name (list (analysis.text from-name) + (analysis.text to-name) + valueA))) + (////.throw cannot-cast (format "From class/primitive: " from-name text.new-line + " To class/primitive: " to-name text.new-line + " For value: " (%code valueC) text.new-line)))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: bundle::object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "null" object::null) + (bundle.install "null?" object::null?) + (bundle.install "synchronized" object::synchronized) + (bundle.install "throw" object::throw) + (bundle.install "class" object::class) + (bundle.install "instance?" object::instance?) + (bundle.install "cast" object::cast) + ))) + +(def: (find-field class-name field-name) + (-> Text Text (Operation [(Class Object) Field])) + (do ////.monad + [class (load-class class-name)] + (case (Class::getDeclaredField field-name class) + (#error.Success field) + (let [owner (Field::getDeclaringClass field)] + (if (is? owner class) + (wrap [class field]) + (////.throw mistaken-field-owner + (format " Field: " field-name text.new-line + " Owner Class: " (Class::getName owner) text.new-line + "Target Class: " class-name text.new-line)))) + + (#error.Failure _) + (////.throw unknown-field (format class-name "#" field-name))))) + +(def: (static-field class-name field-name) + (-> Text Text (Operation [Type Bit])) + (do ////.monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers fieldJ)]] + (if (Modifier::isStatic modifiers) + (let [fieldJT (Field::getGenericType fieldJ)] + (do @ + [fieldT (java-type-to-lux-type fresh-mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal modifiers)]))) + (////.throw not-a-static-field (format class-name "#" field-name))))) + +(def: (virtual-field class-name field-name objectT) + (-> Text Text Type (Operation [Type Bit])) + (do ////.monad + [[class fieldJ] (find-field class-name field-name) + #let [modifiers (Field::getModifiers fieldJ)]] + (if (not (Modifier::isStatic modifiers)) + (do @ + [#let [fieldJT (Field::getGenericType fieldJ) + var-names (|> class + Class::getTypeParameters + array.to-list + (list/map (|>> TypeVariable::getName)))] + mappings (: (Operation Mappings) + (case objectT + (#.Primitive _class-name _class-params) + (do @ + [#let [num-params (list.size _class-params) + num-vars (list.size var-names)] + _ (////.assert type-parameter-mismatch + (format "Expected: " (%i (.int num-params)) text.new-line + " Actual: " (%i (.int num-vars)) text.new-line + " Class: " _class-name text.new-line + " Type: " (%type objectT)) + (n/= num-params num-vars))] + (wrap (|> (list.zip2 var-names _class-params) + (dictionary.from-list text.hash)))) + + _ + (////.throw non-object objectT))) + fieldT (java-type-to-lux-type mappings fieldJT)] + (wrap [fieldT (Modifier::isFinal modifiers)])) + (////.throw not-a-virtual-field (format class-name "#" field-name))))) + +(def: static::get + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[fieldT final?] (static-field class field)] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field))))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)])))) + +(def: static::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [_ (typeA.infer Any) + [fieldT final?] (static-field class field) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: virtual::get + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + [fieldT final?] (virtual-field class field objectT)] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) objectA)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 3 (list.size args)])))) + +(def: virtual::put + Handler + (function (_ extension-name analyse args) + (case args + (^ (list classC fieldC valueC objectC)) + (case [classC fieldC] + [[_ (#.Text class)] [_ (#.Text field)]] + (do ////.monad + [[objectT objectA] (typeA.with-inference + (analyse objectC)) + _ (typeA.infer objectT) + [fieldT final?] (virtual-field class field objectT) + _ (////.assert cannot-set-a-final-field (format class "#" field) + (not final?)) + valueA (typeA.with-type fieldT + (analyse valueC))] + (wrap (#analysis.Extension extension-name (list (analysis.text class) (analysis.text field) valueA objectA)))) + + _ + (////.throw ///.invalid-syntax extension-name)) + + _ + (////.throw ///.incorrect-arity [extension-name 4 (list.size args)])))) + +(def: (java-type-to-parameter type) + (-> java/lang/reflect/Type (Operation Text)) + (cond (host.instance? Class type) + (/////wrap (Class::getName (:coerce Class type))) + + (host.instance? ParameterizedType type) + (java-type-to-parameter (ParameterizedType::getRawType (:coerce ParameterizedType type))) + + (or (host.instance? TypeVariable type) + (host.instance? WildcardType type)) + (/////wrap "java.lang.Object") + + (host.instance? GenericArrayType type) + (do ////.monad + [componentP (java-type-to-parameter (GenericArrayType::getGenericComponentType (:coerce GenericArrayType type)))] + (wrap (format componentP "[]"))) + + ## else + (////.throw cannot-convert-to-a-parameter type))) + +(type: Method-Style + #Static + #Abstract + #Virtual + #Special + #Interface) + +(def: (check-method class method-name method-style arg-classes method) + (-> (Class Object) Text Method-Style (List Text) Method (Operation Bit)) + (do ////.monad + [parameters (|> (Method::getGenericParameterTypes method) + array.to-list + (monad.map @ java-type-to-parameter)) + #let [modifiers (Method::getModifiers method)]] + (wrap (and (Object::equals class (Method::getDeclaringClass method)) + (text/= method-name (Method::getName method)) + (case #Static + #Special + (Modifier::isStatic modifiers) + + _ + #1) + (case method-style + #Special + (not (or (Modifier::isInterface (Class::getModifiers class)) + (Modifier::isAbstract modifiers))) + + _ + #1) + (n/= (list.size arg-classes) (list.size parameters)) + (list/fold (function (_ [expectedJC actualJC] prev) + (and prev + (text/= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters)))))) + +(def: (check-constructor class arg-classes constructor) + (-> (Class Object) (List Text) (Constructor Object) (Operation Bit)) + (do ////.monad + [parameters (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ java-type-to-parameter))] + (wrap (and (Object::equals class (Constructor::getDeclaringClass constructor)) + (n/= (list.size arg-classes) (list.size parameters)) + (list/fold (function (_ [expectedJC actualJC] prev) + (and prev + (text/= expectedJC actualJC))) + #1 + (list.zip2 arg-classes parameters)))))) + +(def: idx-to-parameter + (-> Nat Type) + (|>> (n/* 2) inc #.Parameter)) + +(def: (type-vars amount offset) + (-> Nat Nat (List Type)) + (if (n/= 0 amount) + (list) + (|> (list.indices amount) + (list/map (|>> (n/+ offset) idx-to-parameter))))) + +(def: (method-signature method-style method) + (-> Method-Style Method (Operation Method-Signature)) + (let [owner (Method::getDeclaringClass method) + owner-name (Class::getName owner) + owner-tvars (case method-style + #Static + (list) + + _ + (|> (Class::getTypeParameters owner) + array.to-list + (list/map (|>> TypeVariable::getName)))) + method-tvars (|> (Method::getTypeParameters method) + array.to-list + (list/map (|>> TypeVariable::getName))) + num-owner-tvars (list.size owner-tvars) + num-method-tvars (list.size method-tvars) + all-tvars (list/compose owner-tvars method-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars 0) + method-tvarsT (type-vars num-method-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT method-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dictionary.from-list text.hash))))] + (do ////.monad + [inputsT (|> (Method::getGenericParameterTypes method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + outputT (java-type-to-lux-type mappings (Method::getGenericReturnType method)) + exceptionsT (|> (Method::getGenericExceptionTypes method) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [methodT (<| (type.univ-q num-all-tvars) + (type.function (case method-style + #Static + inputsT + + _ + (list& (#.Primitive owner-name (list.reverse owner-tvarsT)) + inputsT))) + outputT)]] + (wrap [methodT exceptionsT])))) + +(type: Evaluation + (#Pass Method-Signature) + (#Hint Method-Signature) + #Fail) + +(do-template [ ] + [(def: + (-> Evaluation (Maybe Method-Signature)) + (|>> (case> ( output) + (#.Some output) + + _ + #.None)))] + + [pass! #Pass] + [hint! #Hint] + ) + +(def: (method-candidate class-name method-name method-style arg-classes) + (-> Text Text Method-Style (List Text) (Operation Method-Signature)) + (do ////.monad + [class (load-class class-name) + candidates (|> class + Class::getDeclaredMethods + array.to-list + (monad.map @ (: (-> Method (Operation Evaluation)) + (function (_ method) + (do @ + [passes? (check-method class method-name method-style arg-classes method)] + (cond passes? + (:: @ map (|>> #Pass) (method-signature method-style method)) + + (text/= method-name (Method::getName method)) + (:: @ map (|>> #Hint) (method-signature method-style method)) + + ## else + (wrap #Fail)))))))] + (case (list.search-all pass! candidates) + (#.Cons method #.Nil) + (wrap method) + + #.Nil + (////.throw no-candidates [class-name method-name (list.search-all hint! candidates)]) + + candidates + (////.throw too-many-candidates [class-name method-name candidates])))) + +(def: (constructor-signature constructor) + (-> (Constructor Object) (Operation Method-Signature)) + (let [owner (Constructor::getDeclaringClass constructor) + owner-name (Class::getName owner) + owner-tvars (|> (Class::getTypeParameters owner) + array.to-list + (list/map (|>> TypeVariable::getName))) + constructor-tvars (|> (Constructor::getTypeParameters constructor) + array.to-list + (list/map (|>> TypeVariable::getName))) + num-owner-tvars (list.size owner-tvars) + all-tvars (list/compose owner-tvars constructor-tvars) + num-all-tvars (list.size all-tvars) + owner-tvarsT (type-vars num-owner-tvars 0) + constructor-tvarsT (type-vars num-all-tvars num-owner-tvars) + mappings (: Mappings + (if (list.empty? all-tvars) + fresh-mappings + (|> (list/compose owner-tvarsT constructor-tvarsT) + list.reverse + (list.zip2 all-tvars) + (dictionary.from-list text.hash))))] + (do ////.monad + [inputsT (|> (Constructor::getGenericParameterTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + exceptionsT (|> (Constructor::getGenericExceptionTypes constructor) + array.to-list + (monad.map @ (java-type-to-lux-type mappings))) + #let [objectT (#.Primitive owner-name (list.reverse owner-tvarsT)) + constructorT (<| (type.univ-q num-all-tvars) + (type.function inputsT) + objectT)]] + (wrap [constructorT exceptionsT])))) + +(def: constructor-method "") + +(def: (constructor-candidate class-name arg-classes) + (-> Text (List Text) (Operation Method-Signature)) + (do ////.monad + [class (load-class class-name) + candidates (|> class + Class::getConstructors + array.to-list + (monad.map @ (function (_ constructor) + (do @ + [passes? (check-constructor class arg-classes constructor)] + (:: @ map + (if passes? (|>> #Pass) (|>> #Hint)) + (constructor-signature constructor))))))] + (case (list.search-all pass! candidates) + (#.Cons constructor #.Nil) + (wrap constructor) + + #.Nil + (////.throw no-candidates [class-name ..constructor-method (list.search-all hint! candidates)]) + + candidates + (////.throw too-many-candidates [class-name ..constructor-method candidates])))) + +(def: (decorate-inputs typesT inputsA) + (-> (List Text) (List Analysis) (List Analysis)) + (|> inputsA + (list.zip2 (list/map analysis.text typesT)) + (list/map (function (_ [type value]) + (analysis.tuple (list type value)))))) + +(def: invoke::static + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text (List [Text Code])]) + (s.run args ($_ p.and s.text s.text (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class method argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Static argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC)) + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::virtual + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class method objectC argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Virtual argsT) + [outputT allA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + #let [[objectA argsA] (case allA + (#.Cons objectA argsA) + [objectA argsA] + + _ + (undefined))] + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) objectA (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::special + Handler + (function (_ extension-name analyse args) + (case (: (Error [(List Code) [Text Text Code (List [Text Code]) Any]]) + (p.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any))) s.end!))) + (#error.Success [_ [class method objectC argsTC _]]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (method-candidate class method #Special argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (analysis.text method) + (analysis.text outputJC) (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::interface + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text Text Code (List [Text Code])]) + (s.run args ($_ p.and s.text s.text s.any (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class-name method objectC argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + class (load-class class-name) + _ (////.assert non-interface class-name + (Modifier::isInterface (Class::getModifiers class))) + [methodT exceptionsT] (method-candidate class-name method #Interface argsT) + [outputT argsA] (inferenceA.general analyse methodT (list& objectC (list/map product.right argsTC))) + outputJC (check-jvm outputT)] + (wrap (#analysis.Extension extension-name + (list& (analysis.text class-name) (analysis.text method) (analysis.text outputJC) + (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: invoke::constructor + Handler + (function (_ extension-name analyse args) + (case (: (Error [Text (List [Text Code])]) + (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) + (#error.Success [class argsTC]) + (do ////.monad + [#let [argsT (list/map product.left argsTC)] + [methodT exceptionsT] (constructor-candidate class argsT) + [outputT argsA] (inferenceA.general analyse methodT (list/map product.right argsTC))] + (wrap (#analysis.Extension extension-name (list& (analysis.text class) (decorate-inputs argsT argsA))))) + + _ + (////.throw ///.invalid-syntax extension-name)))) + +(def: bundle::member + Bundle + (<| (bundle.prefix "member") + (|> bundle.empty + (dictionary.merge (<| (bundle.prefix "static") + (|> bundle.empty + (bundle.install "get" static::get) + (bundle.install "put" static::put)))) + (dictionary.merge (<| (bundle.prefix "virtual") + (|> bundle.empty + (bundle.install "get" virtual::get) + (bundle.install "put" virtual::put)))) + (dictionary.merge (<| (bundle.prefix "invoke") + (|> bundle.empty + (bundle.install "static" invoke::static) + (bundle.install "virtual" invoke::virtual) + (bundle.install "special" invoke::special) + (bundle.install "interface" invoke::interface) + (bundle.install "constructor" invoke::constructor) + ))) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "jvm") + (|> bundle.empty + (dictionary.merge bundle::conversion) + (dictionary.merge bundle::int) + (dictionary.merge bundle::long) + (dictionary.merge bundle::float) + (dictionary.merge bundle::double) + (dictionary.merge bundle::char) + (dictionary.merge bundle::array) + (dictionary.merge bundle::object) + (dictionary.merge bundle::member) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/bundle.lux b/stdlib/source/lux/tool/compiler/phase/extension/bundle.lux new file mode 100644 index 000000000..643e3b38c --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/bundle.lux @@ -0,0 +1,28 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." text + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]]] + [// (#+ Handler Bundle)]) + +(def: #export empty + Bundle + (dictionary.new text.hash)) + +(def: #export (install name anonymous) + (All [s i o] + (-> Text (Handler s i o) + (-> (Bundle s i o) (Bundle s i o)))) + (dictionary.put name anonymous)) + +(def: #export (prefix prefix) + (All [s i o] + (-> Text (-> (Bundle s i o) (Bundle s i o)))) + (|>> dictionary.entries + (list/map (function (_ [key val]) [(format prefix " " key) val])) + (dictionary.from-list text.hash))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux new file mode 100644 index 000000000..c5ae87050 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -0,0 +1,199 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + pipe] + [data + [text + format] + [collection + ["." list ("#/." functor)] + ["." dictionary]]] + ["." macro] + [type (#+ :share) + ["." check]]] + ["." // + ["." bundle] + ["/." // + ["." analysis + ["." module] + ["." type]] + ["." synthesis] + ["." translation] + ["." statement (#+ Operation Handler Bundle)]]]) + +(def: (evaluate! type codeC) + (All [anchor expression statement] + (-> Type Code (Operation anchor expression statement [Type expression Any]))) + (do ///.monad + [state (//.lift ///.get-state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + translate (get@ [#statement.translation #statement.phase] state)] + [_ code//type codeA] (statement.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (type.with-type type + (do @ + [codeA (analyse codeC)] + (wrap [type codeA])))))) + codeS (statement.lift-synthesis + (synthesize codeA))] + (statement.lift-translation + (translation.with-buffer + (do @ + [codeT (translate codeS) + count translation.next + codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] + (wrap [code//type codeT codeV])))))) + +(def: (define! name ?type codeC) + (All [anchor expression statement] + (-> Name (Maybe Type) Code + (Operation anchor expression statement [Type expression Text Any]))) + (do ///.monad + [state (//.lift ///.get-state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + translate (get@ [#statement.translation #statement.phase] state)] + [_ code//type codeA] (statement.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (case ?type + (#.Some type) + (type.with-type type + (do @ + [codeA (analyse codeC)] + (wrap [type codeA]))) + + #.None + (do @ + [[code//type codeA] (type.with-inference (analyse codeC)) + code//type (type.with-env + (check.clean code//type))] + (wrap [code//type codeA])))))) + codeS (statement.lift-synthesis + (synthesize codeA))] + (statement.lift-translation + (translation.with-buffer + (do @ + [codeT (translate codeS) + codeN+V (translation.define! name codeT)] + (wrap [code//type codeT codeN+V])))))) + +(def: lux::def + Handler + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Identifier ["" short-name])] valueC annotationsC)) + (do ///.monad + [current-module (statement.lift-analysis + (//.lift macro.current-module-name)) + #let [full-name [current-module short-name]] + [_ annotationsT annotationsV] (evaluate! Code annotationsC) + #let [annotationsV (:coerce Code annotationsV)] + [value//type valueT valueN valueV] (define! full-name + (if (macro.type? annotationsV) + (#.Some Type) + #.None) + valueC) + _ (statement.lift-analysis + (do @ + [_ (module.define short-name [value//type annotationsV valueV])] + (if (macro.type? annotationsV) + (case (macro.declared-tags annotationsV) + #.Nil + (wrap []) + + tags + (module.declare-tags tags (macro.export? annotationsV) (:coerce Type valueV))) + (wrap [])))) + #let [_ (log! (format "Definition " (%name full-name)))]] + (statement.lift-translation + (translation.learn full-name valueN))) + + _ + (///.throw //.invalid-syntax [extension-name])))) + +(def: (alias! alias def-name) + (-> Text Name (analysis.Operation Any)) + (do ///.monad + [definition (//.lift (macro.find-def def-name))] + (module.define alias definition))) + +(def: def::module + Handler + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list annotationsC)) + (do ///.monad + [[_ annotationsT annotationsV] (evaluate! Code annotationsC) + _ (statement.lift-analysis + (module.set-annotations (:coerce Code annotationsV)))] + (wrap [])) + + _ + (///.throw //.invalid-syntax [extension-name])))) + +(def: def::alias + Handler + (function (_ extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Identifier ["" alias])] [_ (#.Identifier def-name)])) + (//.lift + (///.sub [(get@ [#statement.analysis #statement.state]) + (set@ [#statement.analysis #statement.state])] + (alias! alias def-name))) + + _ + (///.throw //.invalid-syntax [extension-name])))) + +(do-template [ ] + [(def: + (All [anchor expression statement] + (Handler anchor expression statement)) + (function (handler extension-name phase inputsC+) + (case inputsC+ + (^ (list [_ (#.Text name)] valueC)) + (do ///.monad + [[_ handlerT handlerV] (evaluate! (:of (:share [anchor expression statement] + {(Handler anchor expression statement) + handler} + { + (:assume [])})) + valueC)] + (<| + (//.install name) + (:share [anchor expression statement] + {(Handler anchor expression statement) + handler} + { + (:assume handlerV)}))) + + _ + (///.throw //.invalid-syntax [extension-name]))))] + + [def::analysis analysis.Handler statement.lift-analysis] + [def::synthesis synthesis.Handler statement.lift-synthesis] + [def::translation (translation.Handler anchor expression statement) statement.lift-translation] + [def::statement (statement.Handler anchor expression statement) (<|)] + ) + +(def: bundle::def + Bundle + (<| (bundle.prefix "def") + (|> bundle.empty + (dictionary.put "module" def::module) + (dictionary.put "alias" def::alias) + (dictionary.put "analysis" def::analysis) + (dictionary.put "synthesis" def::synthesis) + (dictionary.put "translation" def::translation) + (dictionary.put "statement" def::statement) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle.empty + (dictionary.put "def" lux::def) + (dictionary.merge ..bundle::def)))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux b/stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux new file mode 100644 index 000000000..1a2e44f6f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/synthesis.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [synthesis (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/translation.lux b/stdlib/source/lux/tool/compiler/phase/extension/translation.lux new file mode 100644 index 000000000..232c8c168 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/translation.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [translation (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/statement.lux b/stdlib/source/lux/tool/compiler/phase/statement.lux new file mode 100644 index 000000000..c7ff3719f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/statement.lux @@ -0,0 +1,45 @@ +(.module: + [lux #*] + ["." // + ["." analysis] + ["." synthesis] + ["." translation] + ["." extension]]) + +(type: #export (Component state phase) + {#state state + #phase phase}) + +(type: #export (State anchor expression statement) + {#analysis (Component analysis.State+ + analysis.Phase) + #synthesis (Component synthesis.State+ + synthesis.Phase) + #translation (Component (translation.State+ anchor expression statement) + (translation.Phase anchor expression statement))}) + +(do-template [ ] + [(type: #export ( anchor expression statement) + ( (..State anchor expression statement) Code Any))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(do-template [ ] + [(def: #export ( operation) + (All [anchor expression statement output] + (-> ( output) + (Operation anchor expression statement output))) + (extension.lift + (//.sub [(get@ [ #..state]) + (set@ [ #..state])] + operation)))] + + [lift-analysis #..analysis analysis.Operation] + [lift-synthesis #..synthesis synthesis.Operation] + [lift-translation #..translation (translation.Operation anchor expression statement)] + ) diff --git a/stdlib/source/lux/tool/compiler/phase/statement/total.lux b/stdlib/source/lux/tool/compiler/phase/statement/total.lux new file mode 100644 index 000000000..c494b01c6 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/statement/total.lux @@ -0,0 +1,56 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + [text + format]] + ["." macro]] + ["." // (#+ Phase) + ["/." // + ["." analysis + ["." expression] + ["." type] + ["///." macro]] + ["." extension]]]) + +(exception: #export (not-a-statement {code Code}) + (ex.report ["Statement" (%code code)])) + +(exception: #export (not-a-macro {code Code}) + (ex.report ["Code" (%code code)])) + +(exception: #export (macro-was-not-found {name Name}) + (ex.report ["Name" (%name name)])) + +(def: #export (phase code) + Phase + (case code + (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) + (extension.apply "Statement" phase [name inputs]) + + (^ [_ (#.Form (list& macro inputs))]) + (do ///.monad + [expansion (//.lift-analysis + (do @ + [macroA (type.with-type Macro + (expression.compile macro))] + (case macroA + (^ (analysis.constant macro-name)) + (do @ + [?macro (extension.lift (macro.find-macro macro-name)) + macro (case ?macro + (#.Some macro) + (wrap macro) + + #.None + (///.throw macro-was-not-found macro-name))] + (extension.lift (///macro.expand macro-name macro inputs))) + + _ + (///.throw not-a-macro code))))] + (monad.map @ phase expansion)) + + _ + (///.throw not-a-statement code))) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis.lux b/stdlib/source/lux/tool/compiler/phase/synthesis.lux new file mode 100644 index 000000000..4cc9c7336 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis.lux @@ -0,0 +1,468 @@ +(.module: + [lux (#- i64 Scope) + [control + [monad (#+ do)] + [equivalence (#+ Equivalence)] + ["ex" exception (#+ exception:)]] + [data + ["." bit ("#/." equivalence)] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]]] + ["." // + ["." analysis (#+ Environment Arity Composite Analysis)] + ["." extension (#+ Extension)] + [// + ["." reference (#+ Register Variable Reference)]]]) + +(type: #export Resolver (Dictionary Variable Variable)) + +(type: #export State + {#locals Nat}) + +(def: #export fresh-resolver + Resolver + (dictionary.new reference.hash)) + +(def: #export init + State + {#locals 0}) + +(type: #export Primitive + (#Bit Bit) + (#I64 (I64 Any)) + (#F64 Frac) + (#Text Text)) + +(type: #export Side + (Either Nat Nat)) + +(type: #export Member + (Either Nat Nat)) + +(type: #export Access + (#Side Side) + (#Member Member)) + +(type: #export (Path' s) + #Pop + (#Test Primitive) + (#Access Access) + (#Bind Register) + (#Alt (Path' s) (Path' s)) + (#Seq (Path' s) (Path' s)) + (#Then s)) + +(type: #export (Abstraction' s) + {#environment Environment + #arity Arity + #body s}) + +(type: #export (Apply' s) + {#function s + #arguments (List s)}) + +(type: #export (Branch s) + (#Let s Register s) + (#If s s s) + (#Case s (Path' s))) + +(type: #export (Scope s) + {#start Register + #inits (List s) + #iteration s}) + +(type: #export (Loop s) + (#Scope (Scope s)) + (#Recur (List s))) + +(type: #export (Function s) + (#Abstraction (Abstraction' s)) + (#Apply s (List s))) + +(type: #export (Control s) + (#Branch (Branch s)) + (#Loop (Loop s)) + (#Function (Function s))) + +(type: #export #rec Synthesis + (#Primitive Primitive) + (#Structure (Composite Synthesis)) + (#Reference Reference) + (#Control (Control Synthesis)) + (#Extension (Extension Synthesis))) + +(do-template [ ] + [(type: #export + ( ..State Analysis Synthesis))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(type: #export Path + (Path' Synthesis)) + +(def: #export path/pop + Path + #Pop) + +(do-template [ ] + [(template: #export ( content) + (#..Test ( content)))] + + [path/bit #..Bit] + [path/i64 #..I64] + [path/f64 #..F64] + [path/text #..Text] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Access + + content))] + + [path/side #..Side] + [path/member #..Member] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Access + + + content))] + + [side/left #..Side #.Left] + [side/right #..Side #.Right] + [member/left #..Member #.Left] + [member/right #..Member #.Right] + ) + +(do-template [ ] + [(template: #export ( content) + ( content))] + + [path/bind #..Bind] + [path/then #..Then] + ) + +(do-template [ ] + [(template: #export ( left right) + ( [left right]))] + + [path/alt #..Alt] + [path/seq #..Seq] + ) + +(type: #export Abstraction + (Abstraction' Synthesis)) + +(type: #export Apply + (Apply' Synthesis)) + +(def: #export unit Text "") + +(do-template [ ] + [(def: #export ( value) + (-> (All [a] (-> (Operation a) (Operation a)))) + (extension.temporary (set@ value)))] + + [with-locals Nat #locals] + ) + +(def: #export (with-abstraction arity resolver) + (-> Arity Resolver + (All [a] (-> (Operation a) (Operation a)))) + (extension.with-state {#locals arity})) + +(do-template [ ] + [(def: #export + (Operation ) + (extension.read (get@ )))] + + [locals #locals Nat] + ) + +(def: #export with-new-local + (All [a] (-> (Operation a) (Operation a))) + (<<| (do //.monad + [locals ..locals]) + (..with-locals (inc locals)))) + +(do-template [ ] + [(template: #export ( content) + (#..Primitive ( content)))] + + [bit #..Bit] + [i64 #..I64] + [f64 #..F64] + [text #..Text] + ) + +(do-template [ ] + [(template: #export ( content) + (<| #..Structure + + content))] + + [variant #analysis.Variant] + [tuple #analysis.Tuple] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Reference + + content))] + + [variable/local reference.local] + [variable/foreign reference.foreign] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Reference + + content))] + + [variable reference.variable] + [constant reference.constant] + ) + +(do-template [ ] + [(template: #export ( content) + (.<| #..Control + + + content))] + + [branch/case #..Branch #..Case] + [branch/let #..Branch #..Let] + [branch/if #..Branch #..If] + + [loop/recur #..Loop #..Recur] + [loop/scope #..Loop #..Scope] + + [function/abstraction #..Function #..Abstraction] + [function/apply #..Function #..Apply] + ) + +(def: #export (%path' %then value) + (All [a] (-> (Format a) (Format (Path' a)))) + (case value + #Pop + "_" + + (#Test primitive) + (format "(? " + (case primitive + (#Bit value) + (%b value) + + (#I64 value) + (%i (.int value)) + + (#F64 value) + (%f value) + + (#Text value) + (%t value)) + ")") + + (#Access access) + (case access + (#Side side) + (case side + (#.Left lefts) + (format "(" (%n lefts) " #0" ")") + + (#.Right lefts) + (format "(" (%n lefts) " #1" ")")) + + (#Member member) + (case member + (#.Left lefts) + (format "[" (%n lefts) " #0" "]") + + (#.Right lefts) + (format "[" (%n lefts) " #1" "]"))) + + (#Bind register) + (format "(@ " (%n register) ")") + + (#Alt left right) + (format "(| " (%path' %then left) " " (%path' %then right) ")") + + (#Seq left right) + (format "(& " (%path' %then left) " " (%path' %then right) ")") + + (#Then then) + (|> (%then then) + (text.enclose ["(! " ")"])))) + +(def: #export (%synthesis value) + (Format Synthesis) + (case value + (#Primitive primitive) + (case primitive + (^template [ ] + ( value) + ( value)) + ([#Bit %b] + [#F64 %f] + [#Text %t]) + + (#I64 value) + (%i (.int value))) + + (#Structure structure) + (case structure + (#analysis.Variant [lefts right? content]) + (|> (%synthesis content) + (format (%n lefts) " " (%b right?) " ") + (text.enclose ["(" ")"])) + + (#analysis.Tuple members) + (|> members + (list/map %synthesis) + (text.join-with " ") + (text.enclose ["[" "]"]))) + + (#Reference reference) + (|> reference + reference.%reference + (text.enclose ["(#@ " ")"])) + + (#Control control) + (case control + (#Function function) + (case function + (#Abstraction [environment arity body]) + (|> (%synthesis body) + (format (%n arity) " ") + (format (|> environment + (list/map reference.%variable) + (text.join-with " ") + (text.enclose ["[" "]"])) + " ") + (text.enclose ["(" ")"])) + + (#Apply func args) + (|> (list/map %synthesis args) + (text.join-with " ") + (format (%synthesis func) " ") + (text.enclose ["(" ")"]))) + + (#Branch branch) + (case branch + (#Let input register body) + (|> (format (%synthesis input) " " (%n register) " " (%synthesis body)) + (text.enclose ["(#let " ")"])) + + (#If test then else) + (|> (format (%synthesis test) " " (%synthesis then) " " (%synthesis else)) + (text.enclose ["(#if " ")"])) + + (#Case input path) + (|> (format (%synthesis input) " " (%path' %synthesis path)) + (text.enclose ["(#case " ")"]))) + + ## (#Loop loop) + _ + "???") + + (#Extension [name args]) + (|> (list/map %synthesis args) + (text.join-with " ") + (format (%t name)) + (text.enclose ["(" ")"])))) + +(def: #export %path + (Format Path) + (%path' %synthesis)) + +(structure: #export primitive-equivalence (Equivalence Primitive) + (def: (= reference sample) + (case [reference sample] + (^template [ ] + [( reference') ( sample')] + ( reference' sample')) + ([#Bit bit/= %b] + [#F64 f/= %f] + [#Text text/= %t]) + + [(#I64 reference') (#I64 sample')] + (i/= (.int reference') (.int sample')) + + _ + false))) + +(structure: #export access-equivalence (Equivalence Access) + (def: (= reference sample) + (case [reference sample] + (^template [] + [( reference') ( sample')] + (case [reference' sample'] + (^template [] + [( reference'') ( sample'')] + (n/= reference'' sample'')) + ([#.Left] + [#.Right]) + + _ + false)) + ([#Side] + [#Member]) + + _ + false))) + +(structure: #export (path'-equivalence Equivalence) + (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) + + (def: (= reference sample) + (case [reference sample] + [#Pop #Pop] + true + + (^template [ ] + [( reference') ( sample')] + (:: = reference' sample')) + ([#Test primitive-equivalence] + [#Access access-equivalence] + [#Then Equivalence]) + + [(#Bind reference') (#Bind sample')] + (n/= reference' sample') + + (^template [] + [( leftR rightR) ( leftS rightS)] + (and (= leftR leftS) + (= rightR rightS))) + ([#Alt] + [#Seq]) + + _ + false))) + +(structure: #export equivalence (Equivalence Synthesis) + (def: (= reference sample) + (case [reference sample] + (^template [ ] + [( reference') ( sample')] + (:: = reference' sample')) + ([#Primitive primitive-equivalence]) + + _ + false))) + +(def: #export path-equivalence + (Equivalence Path) + (path'-equivalence equivalence)) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux new file mode 100644 index 000000000..b1890688d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/case.lux @@ -0,0 +1,170 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + pipe + ["." monad (#+ do)]] + [data + ["." product] + ["." bit ("#/." equivalence)] + ["." text ("#/." equivalence) + format] + [number + ["." frac ("#/." equivalence)]] + [collection + ["." list ("#/." fold monoid)]]]] + ["." // (#+ Path Synthesis Operation Phase) + ["." function] + ["/." // ("#/." monad) + ["." analysis (#+ Pattern Match Analysis)] + [// + ["." reference]]]]) + +(def: clean-up + (-> Path Path) + (|>> (#//.Seq #//.Pop))) + +(def: (path' pattern end? thenC) + (-> Pattern Bit (Operation Path) (Operation Path)) + (case pattern + (#analysis.Simple simple) + (case simple + #analysis.Unit + thenC + + (^template [ ] + ( value) + (///map (|>> (#//.Seq (#//.Test (|> value )))) + thenC)) + ([#analysis.Bit #//.Bit] + [#analysis.Nat (<| #//.I64 .i64)] + [#analysis.Int (<| #//.I64 .i64)] + [#analysis.Rev (<| #//.I64 .i64)] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text])) + + (#analysis.Bind register) + (<| (:: ///.monad map (|>> (#//.Seq (#//.Bind register)))) + //.with-new-local + thenC) + + (#analysis.Complex (#analysis.Variant [lefts right? value-pattern])) + (<| (///map (|>> (#//.Seq (#//.Access (#//.Side (if right? + (#.Right lefts) + (#.Left lefts))))))) + (path' value-pattern end?) + (when (not end?) (///map ..clean-up)) + thenC) + + (#analysis.Complex (#analysis.Tuple tuple)) + (let [tuple::last (dec (list.size tuple))] + (list/fold (function (_ [tuple::lefts tuple::member] nextC) + (let [right? (n/= tuple::last tuple::lefts) + end?' (and end? right?)] + (<| (///map (|>> (#//.Seq (#//.Access (#//.Member (if right? + (#.Right (dec tuple::lefts)) + (#.Left tuple::lefts))))))) + (path' tuple::member end?') + (when (not end?') (///map ..clean-up)) + nextC))) + thenC + (list.reverse (list.enumerate tuple)))))) + +(def: #export (path synthesize pattern bodyA) + (-> Phase Pattern Analysis (Operation Path)) + (path' pattern true (///map (|>> #//.Then) (synthesize bodyA)))) + +(def: #export (weave leftP rightP) + (-> Path Path Path) + (with-expansions [ (as-is (#//.Alt leftP rightP))] + (case [leftP rightP] + [(#//.Seq preL postL) + (#//.Seq preR postR)] + (case (weave preL preR) + (#//.Alt _) + + + weavedP + (#//.Seq weavedP (weave postL postR))) + + [#//.Pop #//.Pop] + rightP + + (^template [ ] + [(#//.Test ( leftV)) + (#//.Test ( rightV))] + (if ( leftV rightV) + rightP + )) + ([#//.Bit bit/=] + [#//.I64 "lux i64 ="] + [#//.F64 frac/=] + [#//.Text text/=]) + + (^template [ ] + [(#//.Access ( ( leftL))) + (#//.Access ( ( rightL)))] + (if (n/= leftL rightL) + rightP + )) + ([#//.Side #.Left] + [#//.Side #.Right] + [#//.Member #.Left] + [#//.Member #.Right]) + + [(#//.Bind leftR) (#//.Bind rightR)] + (if (n/= leftR rightR) + rightP + ) + + _ + ))) + +(def: #export (synthesize synthesize^ inputA [headB tailB+]) + (-> Phase Analysis Match (Operation Synthesis)) + (do ///.monad + [inputS (synthesize^ inputA)] + (with-expansions [ + (as-is (^multi (^ (#analysis.Reference (reference.local outputR))) + (n/= inputR outputR)) + (wrap inputS)) + + + (as-is [[(#analysis.Bind inputR) headB/bodyA] + #.Nil] + (case headB/bodyA + + + _ + (do @ + [headB/bodyS (//.with-new-local + (synthesize^ headB/bodyA))] + (wrap (//.branch/let [inputS inputR headB/bodyS]))))) + + + (as-is (^or (^ [[(analysis.pattern/bit #1) thenA] + (list [(analysis.pattern/bit #0) elseA])]) + (^ [[(analysis.pattern/bit #0) elseA] + (list [(analysis.pattern/bit #1) thenA])])) + (do @ + [thenS (synthesize^ thenA) + elseS (synthesize^ elseA)] + (wrap (//.branch/if [inputS thenS elseS])))) + + + (as-is _ + (let [[[lastP lastA] prevsPA] (|> (#.Cons headB tailB+) + list.reverse + (case> (#.Cons [lastP lastA] prevsPA) + [[lastP lastA] prevsPA] + + _ + (undefined)))] + (do @ + [lastSP (path synthesize^ lastP lastA) + prevsSP+ (monad.map @ (product.uncurry (path synthesize^)) prevsPA)] + (wrap (//.branch/case [inputS (list/fold weave lastSP prevsSP+)])))))] + (case [headB tailB+] + + + )))) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux new file mode 100644 index 000000000..ac6a82ab8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/expression.lux @@ -0,0 +1,86 @@ +(.module: + [lux (#- primitive) + [control + ["." monad (#+ do)] + pipe] + [data + ["." maybe] + ["." error] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]]] + ["." // (#+ Synthesis Phase) + ["." function] + ["." case] + ["/." // ("#/." monad) + ["." analysis (#+ Analysis)] + ["." extension] + [// + ["." reference]]]]) + +(def: (primitive analysis) + (-> analysis.Primitive //.Primitive) + (case analysis + #analysis.Unit + (#//.Text //.unit) + + (^template [ ] + ( value) + ( value)) + ([#analysis.Bit #//.Bit] + [#analysis.Frac #//.F64] + [#analysis.Text #//.Text]) + + (^template [ ] + ( value) + ( (.i64 value))) + ([#analysis.Nat #//.I64] + [#analysis.Int #//.I64] + [#analysis.Rev #//.I64]))) + +(def: #export (phase analysis) + Phase + (case analysis + (#analysis.Primitive analysis') + (///wrap (#//.Primitive (..primitive analysis'))) + + (#analysis.Structure structure) + (case structure + (#analysis.Variant variant) + (do ///.monad + [valueS (phase (get@ #analysis.value variant))] + (wrap (//.variant (set@ #analysis.value valueS variant)))) + + (#analysis.Tuple tuple) + (|> tuple + (monad.map ///.monad phase) + (:: ///.monad map (|>> //.tuple)))) + + (#analysis.Reference reference) + (///wrap (#//.Reference reference)) + + (#analysis.Case inputA branchesAB+) + (case.synthesize phase inputA branchesAB+) + + (^ (analysis.no-op value)) + (phase value) + + (#analysis.Apply _) + (function.apply phase analysis) + + (#analysis.Function environmentA bodyA) + (function.abstraction phase environmentA bodyA) + + (#analysis.Extension name args) + (function (_ state) + (|> (extension.apply "Synthesis" phase [name args]) + (///.run' state) + (case> (#error.Success output) + (#error.Success output) + + (#error.Failure error) + (<| (///.run' state) + (do ///.monad + [argsS+ (monad.map @ phase args)] + (wrap (#//.Extension [name argsS+]))))))) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux new file mode 100644 index 000000000..ce9efe59b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/function.lux @@ -0,0 +1,211 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." maybe] + ["." text + format] + [collection + ["." list ("#/." functor monoid fold)] + ["dict" dictionary (#+ Dictionary)]]]] + ["." // (#+ Path Synthesis Operation Phase) + ["." loop (#+ Transform)] + ["/." // ("#/." monad) + ["." analysis (#+ Environment Arity Analysis)] + [// + ["." reference (#+ Register Variable)]]]]) + +(exception: #export (cannot-find-foreign-variable-in-environment {foreign Register} {environment Environment}) + (ex.report ["Foreign" (%n foreign)] + ["Environment" (|> environment + (list/map reference.%variable) + (text.join-with " "))])) + +(def: arity-arguments + (-> Arity (List Synthesis)) + (|>> dec + (list.n/range 1) + (list/map (|>> //.variable/local)))) + +(template: #export (self-reference) + (//.variable/local 0)) + +(def: (expanded-nested-self-reference arity) + (-> Arity Synthesis) + (//.function/apply [(..self-reference) (arity-arguments arity)])) + +(def: #export (apply phase) + (-> Phase Phase) + (function (_ exprA) + (let [[funcA argsA] (analysis.application exprA)] + (do ///.monad + [funcS (phase funcA) + argsS (monad.map @ phase argsA) + ## locals //.locals + ] + (with-expansions [ (as-is (//.function/apply [funcS argsS]))] + (case funcS + ## (^ (//.function/abstraction functionS)) + ## (wrap (|> functionS + ## (loop.loop (get@ #//.environment functionS) locals argsS) + ## (maybe.default ))) + + (^ (//.function/apply [funcS' argsS'])) + (wrap (//.function/apply [funcS' (list/compose argsS' argsS)])) + + _ + (wrap ))))))) + +(def: (find-foreign environment register) + (-> Environment Register (Operation Variable)) + (case (list.nth register environment) + (#.Some aliased) + (///wrap aliased) + + #.None + (///.throw cannot-find-foreign-variable-in-environment [register environment]))) + +(def: (grow-path grow path) + (-> (-> Synthesis (Operation Synthesis)) Path (Operation Path)) + (case path + (#//.Bind register) + (///wrap (#//.Bind (inc register))) + + (^template [] + ( left right) + (do ///.monad + [left' (grow-path grow left) + right' (grow-path grow right)] + (wrap ( left' right')))) + ([#//.Alt] [#//.Seq]) + + (#//.Then thenS) + (|> thenS + grow + (///map (|>> #//.Then))) + + _ + (///wrap path))) + +(def: (grow-sub-environment super sub) + (-> Environment Environment (Operation Environment)) + (monad.map ///.monad + (function (_ variable) + (case variable + (#reference.Local register) + (///wrap (#reference.Local (inc register))) + + (#reference.Foreign register) + (find-foreign super register))) + sub)) + +(def: (grow environment expression) + (-> Environment Synthesis (Operation Synthesis)) + (case expression + (#//.Structure structure) + (case structure + (#analysis.Variant [lefts right? subS]) + (|> subS + (grow environment) + (///map (|>> [lefts right?] //.variant))) + + (#analysis.Tuple membersS+) + (|> membersS+ + (monad.map ///.monad (grow environment)) + (///map (|>> //.tuple)))) + + (^ (..self-reference)) + (///wrap (//.function/apply [expression (list (//.variable/local 1))])) + + (#//.Reference reference) + (case reference + (#reference.Variable variable) + (case variable + (#reference.Local register) + (///wrap (//.variable/local (inc register))) + + (#reference.Foreign register) + (|> register + (find-foreign environment) + (///map (|>> //.variable)))) + + (#reference.Constant constant) + (///wrap expression)) + + (#//.Control control) + (case control + (#//.Branch branch) + (case branch + (#//.Let [inputS register bodyS]) + (do ///.monad + [inputS' (grow environment inputS) + bodyS' (grow environment bodyS)] + (wrap (//.branch/let [inputS' (inc register) bodyS']))) + + (#//.If [testS thenS elseS]) + (do ///.monad + [testS' (grow environment testS) + thenS' (grow environment thenS) + elseS' (grow environment elseS)] + (wrap (//.branch/if [testS' thenS' elseS']))) + + (#//.Case [inputS pathS]) + (do ///.monad + [inputS' (grow environment inputS) + pathS' (grow-path (grow environment) pathS)] + (wrap (//.branch/case [inputS' pathS'])))) + + (#//.Loop loop) + (case loop + (#//.Scope [start initsS+ iterationS]) + (do ///.monad + [initsS+' (monad.map @ (grow environment) initsS+) + iterationS' (grow environment iterationS)] + (wrap (//.loop/scope [start initsS+' iterationS']))) + + (#//.Recur argumentsS+) + (|> argumentsS+ + (monad.map ///.monad (grow environment)) + (///map (|>> //.loop/recur)))) + + (#//.Function function) + (case function + (#//.Abstraction [_env _arity _body]) + (do ///.monad + [_env' (grow-sub-environment environment _env)] + (wrap (//.function/abstraction [_env' _arity _body]))) + + (#//.Apply funcS argsS+) + (case funcS + (^ (//.function/apply [(..self-reference) pre-argsS+])) + (///wrap (//.function/apply [(..self-reference) + (list/compose pre-argsS+ argsS+)])) + + _ + (do ///.monad + [funcS' (grow environment funcS) + argsS+' (monad.map @ (grow environment) argsS+)] + (wrap (//.function/apply [funcS' argsS+'])))))) + + (#//.Extension name argumentsS+) + (|> argumentsS+ + (monad.map ///.monad (grow environment)) + (///map (|>> (#//.Extension name)))) + + _ + (///wrap expression))) + +(def: #export (abstraction phase environment bodyA) + (-> Phase Environment Analysis (Operation Synthesis)) + (do ///.monad + [bodyS (phase bodyA)] + (case bodyS + (^ (//.function/abstraction [env' down-arity' bodyS'])) + (|> bodyS' + (grow env') + (:: @ map (|>> [environment (inc down-arity')] //.function/abstraction))) + + _ + (wrap (//.function/abstraction [environment 1 bodyS]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux b/stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux new file mode 100644 index 000000000..28517bd42 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/synthesis/loop.lux @@ -0,0 +1,291 @@ +(.module: + [lux (#- loop) + [control + ["." monad (#+ do)] + ["p" parser]] + [data + ["." maybe ("#/." monad)] + [collection + ["." list ("#/." functor)]]] + [macro + ["." code] + ["." syntax]]] + ["." // (#+ Path Abstraction Synthesis) + [// + ["." analysis (#+ Environment)] + ["." extension] + [// + ["." reference (#+ Register Variable)]]]]) + +(type: #export (Transform a) + (-> a (Maybe a))) + +(def: (some? maybe) + (All [a] (-> (Maybe a) Bit)) + (case maybe + (#.Some _) #1 + #.None #0)) + +(template: #export (self) + (#//.Reference (reference.local 0))) + +(template: (recursive-apply args) + (#//.Apply (self) args)) + +(def: improper #0) +(def: proper #1) + +(def: (proper? exprS) + (-> Synthesis Bit) + (case exprS + (^ (self)) + improper + + (#//.Structure structure) + (case structure + (#analysis.Variant variantS) + (proper? (get@ #analysis.value variantS)) + + (#analysis.Tuple membersS+) + (list.every? proper? membersS+)) + + (#//.Control controlS) + (case controlS + (#//.Branch branchS) + (case branchS + (#//.Case inputS pathS) + (and (proper? inputS) + (.loop [pathS pathS] + (case pathS + (^or (#//.Alt leftS rightS) (#//.Seq leftS rightS)) + (and (recur leftS) (recur rightS)) + + (#//.Then bodyS) + (proper? bodyS) + + _ + proper))) + + (#//.Let inputS register bodyS) + (and (proper? inputS) + (proper? bodyS)) + + (#//.If inputS thenS elseS) + (and (proper? inputS) + (proper? thenS) + (proper? elseS))) + + (#//.Loop loopS) + (case loopS + (#//.Scope scopeS) + (and (list.every? proper? (get@ #//.inits scopeS)) + (proper? (get@ #//.iteration scopeS))) + + (#//.Recur argsS) + (list.every? proper? argsS)) + + (#//.Function functionS) + (case functionS + (#//.Abstraction environment arity bodyS) + (list.every? reference.self? environment) + + (#//.Apply funcS argsS) + (and (proper? funcS) + (list.every? proper? argsS)))) + + (#//.Extension [name argsS]) + (list.every? proper? argsS) + + _ + proper)) + +(def: (path-recursion synthesis-recursion) + (-> (Transform Synthesis) (Transform Path)) + (function (recur pathS) + (case pathS + (#//.Alt leftS rightS) + (let [leftS' (recur leftS) + rightS' (recur rightS)] + (if (or (some? leftS') + (some? rightS')) + (#.Some (#//.Alt (maybe.default leftS leftS') + (maybe.default rightS rightS'))) + #.None)) + + (#//.Seq leftS rightS) + (maybe/map (|>> (#//.Seq leftS)) (recur rightS)) + + (#//.Then bodyS) + (maybe/map (|>> #//.Then) (synthesis-recursion bodyS)) + + _ + #.None))) + +(def: #export (recursion arity) + (-> Nat (Transform Synthesis)) + (function (recur exprS) + (case exprS + (#//.Control controlS) + (case controlS + (#//.Branch branchS) + (case branchS + (#//.Case inputS pathS) + (|> pathS + (path-recursion recur) + (maybe/map (|>> (#//.Case inputS) #//.Branch #//.Control))) + + (#//.Let inputS register bodyS) + (maybe/map (|>> (#//.Let inputS register) #//.Branch #//.Control) + (recur bodyS)) + + (#//.If inputS thenS elseS) + (let [thenS' (recur thenS) + elseS' (recur elseS)] + (if (or (some? thenS') + (some? elseS')) + (#.Some (|> (#//.If inputS + (maybe.default thenS thenS') + (maybe.default elseS elseS')) + #//.Branch #//.Control)) + #.None))) + + (^ (#//.Function (recursive-apply argsS))) + (if (n/= arity (list.size argsS)) + (#.Some (|> argsS #//.Recur #//.Loop #//.Control)) + #.None) + + _ + #.None) + + _ + #.None))) + +(def: (resolve environment) + (-> Environment (Transform Variable)) + (function (_ variable) + (case variable + (#reference.Foreign register) + (list.nth register environment) + + _ + (#.Some variable)))) + +(def: (adjust-path adjust-synthesis offset) + (-> (Transform Synthesis) Register (Transform Path)) + (function (recur pathS) + (case pathS + (#//.Bind register) + (#.Some (#//.Bind (n/+ offset register))) + + (^template [] + ( leftS rightS) + (do maybe.monad + [leftS' (recur leftS) + rightS' (recur rightS)] + (wrap ( leftS' rightS')))) + ([#//.Alt] [#//.Seq]) + + (#//.Then bodyS) + (|> bodyS adjust-synthesis (maybe/map (|>> #//.Then))) + + _ + (#.Some pathS)))) + +(def: (adjust scope-environment offset) + (-> Environment Register (Transform Synthesis)) + (function (recur exprS) + (case exprS + (#//.Structure structureS) + (case structureS + (#analysis.Variant variantS) + (do maybe.monad + [valueS' (|> variantS (get@ #analysis.value) recur)] + (wrap (|> variantS + (set@ #analysis.value valueS') + #analysis.Variant + #//.Structure))) + + (#analysis.Tuple membersS+) + (|> membersS+ + (monad.map maybe.monad recur) + (maybe/map (|>> #analysis.Tuple #//.Structure)))) + + (#//.Reference reference) + (case reference + (^ (reference.constant constant)) + (#.Some exprS) + + (^ (reference.local register)) + (#.Some (#//.Reference (reference.local (n/+ offset register)))) + + (^ (reference.foreign register)) + (|> scope-environment + (list.nth register) + (maybe/map (|>> #reference.Variable #//.Reference)))) + + (^ (//.branch/case [inputS pathS])) + (do maybe.monad + [inputS' (recur inputS) + pathS' (adjust-path recur offset pathS)] + (wrap (|> pathS' [inputS'] //.branch/case))) + + (^ (//.branch/let [inputS register bodyS])) + (do maybe.monad + [inputS' (recur inputS) + bodyS' (recur bodyS)] + (wrap (//.branch/let [inputS' register bodyS']))) + + (^ (//.branch/if [inputS thenS elseS])) + (do maybe.monad + [inputS' (recur inputS) + thenS' (recur thenS) + elseS' (recur elseS)] + (wrap (//.branch/if [inputS' thenS' elseS']))) + + (^ (//.loop/scope scopeS)) + (do maybe.monad + [inits' (|> scopeS + (get@ #//.inits) + (monad.map maybe.monad recur)) + iteration' (recur (get@ #//.iteration scopeS))] + (wrap (//.loop/scope {#//.start (|> scopeS (get@ #//.start) (n/+ offset)) + #//.inits inits' + #//.iteration iteration'}))) + + (^ (//.loop/recur argsS)) + (|> argsS + (monad.map maybe.monad recur) + (maybe/map (|>> //.loop/recur))) + + + (^ (//.function/abstraction [environment arity bodyS])) + (do maybe.monad + [environment' (monad.map maybe.monad + (resolve scope-environment) + environment)] + (wrap (//.function/abstraction [environment' arity bodyS]))) + + (^ (//.function/apply [function arguments])) + (do maybe.monad + [function' (recur function) + arguments' (monad.map maybe.monad recur arguments)] + (wrap (//.function/apply [function' arguments']))) + + (#//.Extension [name argsS]) + (|> argsS + (monad.map maybe.monad recur) + (maybe/map (|>> [name] #//.Extension))) + + _ + (#.Some exprS)))) + +(def: #export (loop environment num-locals inits functionS) + (-> Environment Nat (List Synthesis) Abstraction (Maybe Synthesis)) + (let [bodyS (get@ #//.body functionS)] + (if (and (n/= (list.size inits) + (get@ #//.arity functionS)) + (proper? bodyS)) + (|> bodyS + (adjust environment num-locals) + (maybe/map (|>> [(inc num-locals) inits] //.loop/scope))) + #.None))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation.lux b/stdlib/source/lux/tool/compiler/phase/translation.lux new file mode 100644 index 000000000..d8522adcd --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation.lux @@ -0,0 +1,250 @@ +(.module: + [lux #* + [control + ["ex" exception (#+ exception:)] + [monad (#+ do)]] + [data + ["." product] + ["." error (#+ Error)] + ["." name ("#/." equivalence)] + ["." text + format] + [collection + ["." row (#+ Row)] + ["." dictionary (#+ Dictionary)]]] + [world + [file (#+ File)]]] + ["." // + ["." extension]] + [//synthesis (#+ Synthesis)]) + +(do-template [] + [(exception: #export () + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {error Text}) + (ex.report ["Error" error])) + +(exception: #export (unknown-lux-name {name Name}) + (ex.report ["Name" (%name name)])) + +(exception: #export (cannot-overwrite-lux-name {lux-name Name} + {old-host-name Text} + {new-host-name Text}) + (ex.report ["Lux Name" (%name lux-name)] + ["Old Host Name" old-host-name] + ["New Host Name" new-host-name])) + +(do-template [] + [(exception: #export ( {name Name}) + (ex.report ["Output" (%name name)]))] + + [cannot-overwrite-output] + [no-buffer-for-saving-code] + ) + +(type: #export Context + {#scope-name Text + #inner-functions Nat}) + +(signature: #export (Host expression statement) + (: (-> Text expression (Error Any)) + evaluate!) + (: (-> Text statement (Error Any)) + execute!) + (: (-> Name expression (Error [Text Any])) + define!)) + +(type: #export (Buffer statement) (Row [Name statement])) + +(type: #export (Outputs statement) (Dictionary File (Buffer statement))) + +(type: #export (State anchor expression statement) + {#context Context + #anchor (Maybe anchor) + #host (Host expression statement) + #buffer (Maybe (Buffer statement)) + #outputs (Outputs statement) + #counter Nat + #name-cache (Dictionary Name Text)}) + +(do-template [ ] + [(type: #export ( anchor expression statement) + ( (State anchor expression statement) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (state host) + (All [anchor expression statement] + (-> (Host expression statement) + (..State anchor expression statement))) + {#context {#scope-name "" + #inner-functions 0} + #anchor #.None + #host host + #buffer #.None + #outputs (dictionary.new text.hash) + #counter 0 + #name-cache (dictionary.new name.hash)}) + +(def: #export (with-context expr) + (All [anchor expression statement output] + (-> (Operation anchor expression statement output) + (Operation anchor expression statement [Text output]))) + (function (_ [bundle state]) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c" (%n old-inner))] + (case (expr [bundle (set@ #context [new-scope 0] state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] + [new-scope output]]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: #export context + (All [anchor expression statement] + (Operation anchor expression statement Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) + +(do-template [ + + ] + [(def: #export + (All [anchor expression statement output] ) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ (#.Some ) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ (get@ state) state')] + output]) + + (#error.Failure error) + (#error.Failure error))))) + + (def: #export + (All [anchor expression statement] + (Operation anchor expression statement )) + (function (_ (^@ stateE [bundle state])) + (case (get@ state) + (#.Some output) + (#error.Success [stateE output]) + + #.None + (ex.throw []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation anchor expression statement output) + (Operation anchor expression statement output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation anchor expression statement output) + (Operation anchor expression statement output)) + row.empty + buffer (Buffer statement) no-active-buffer] + ) + +(def: #export outputs + (All [anchor expression statement] + (Operation anchor expression statement (Outputs statement))) + (extension.read (get@ #outputs))) + +(def: #export next + (All [anchor expression statement] + (Operation anchor expression statement Nat)) + (do //.monad + [count (extension.read (get@ #counter)) + _ (extension.update (update@ #counter inc))] + (wrap count))) + +(do-template [ ] + [(def: #export ( label code) + (All [anchor expression statement] + (-> Text (Operation anchor expression statement Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) label code) + (#error.Success output) + (#error.Success [state+ output]) + + (#error.Failure error) + (ex.throw cannot-interpret error))))] + + [evaluate! expression] + [execute! statement] + ) + +(def: #export (define! name code) + (All [anchor expression statement] + (-> Name expression (Operation anchor expression statement [Text Any]))) + (function (_ (^@ stateE [bundle state])) + (case (:: (get@ #host state) define! name code) + (#error.Success output) + (#error.Success [stateE output]) + + (#error.Failure error) + (ex.throw cannot-interpret error)))) + +(def: #export (save! name code) + (All [anchor expression statement] + (-> Name statement (Operation anchor expression statement Any))) + (do //.monad + [count ..next + _ (execute! (format "save" (%n count)) code) + ?buffer (extension.read (get@ #buffer))] + (case ?buffer + (#.Some buffer) + (if (row.any? (|>> product.left (name/= name)) buffer) + (//.throw cannot-overwrite-output name) + (extension.update (set@ #buffer (#.Some (row.add [name code] buffer))))) + + #.None + (//.throw no-buffer-for-saving-code name)))) + +(def: #export (save-buffer! target) + (All [anchor expression statement] + (-> File (Operation anchor expression statement Any))) + (do //.monad + [buffer ..buffer] + (extension.update (update@ #outputs (dictionary.put target buffer))))) + +(def: #export (remember lux-name) + (All [anchor expression statement] + (-> Name (Operation anchor expression statement Text))) + (function (_ (^@ stateE [_ state])) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + (#.Some host-name) + (#error.Success [stateE host-name]) + + #.None + (ex.throw unknown-lux-name lux-name))))) + +(def: #export (learn lux-name host-name) + (All [anchor expression statement] + (-> Name Text (Operation anchor expression statement Any))) + (function (_ [bundle state]) + (let [cache (get@ #name-cache state)] + (case (dictionary.get lux-name cache) + #.None + (#error.Success [[bundle + (update@ #name-cache + (dictionary.put lux-name host-name) + state)] + []]) + + (#.Some old-host-name) + (ex.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..92b55cb80 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux @@ -0,0 +1,177 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + ["." list ("#/." functor fold)] + [set (#+ Set)]]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["/." /// ("#/." monad) + ["." synthesis (#+ Synthesis Path)] + [// + [reference (#+ Register)] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]) + +(def: #export (let translate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation Computation)) + (do ////.monad + [valueO (translate valueS) + bodyO (translate bodyS)] + (wrap (_.let (list [(reference.local' register) valueO]) + bodyO)))) + +(def: #export (record-get translate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation Expression)) + (do ////.monad + [valueO (translate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + runtime.product//right + runtime.product//left)] + (method source (_.int (:coerce Int idx))))) + valueO + pathP)))) + +(def: #export (if translate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do ////.monad + [testO (translate testS) + thenO (translate thenS) + elseO (translate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) + +(def: @cursor (_.var "lux_pm_cursor")) + +(def: top _.length/1) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(def: @temp (_.var "lux_pm_temp")) + +(exception: #export (unrecognized-path) + "") + +(def: $alt_error (_.var "alt_error")) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list $alt_error) #.None] + (_.if (|> $alt_error (_.eqv?/2 pm-error)) + handler + (_.raise/1 $alt_error)))) + +(def: (pattern-matching' translate pathP) + (-> Phase Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (translate bodyS) + + #synthesis.Pop + (/////wrap pop-cursor!) + + (#synthesis.Bind register) + (/////wrap (_.define (reference.local' register) [(list) #.None] + cursor-top)) + + (^template [ <=>] + (^ ( value)) + (/////wrap (_.when (|> value (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bit _.bool _.eqv?/2] + [synthesis.path/i64 (<| _.int .int) _.=/2] + [synthesis.path/f64 _.float _.=/2] + [synthesis.path/text _.string _.eqv?/2]) + + (^template [ ] + (^ ( idx)) + (/////wrap (_.let (list [@temp (|> idx .int _.int (runtime.sum//get cursor-top ))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.nil (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [ ] + (^ ( idx)) + (/////wrap (|> idx .int _.int ( cursor-top) push-cursor!))) + ([synthesis.member/left runtime.product//left (<|)] + [synthesis.member/right runtime.product//right inc]) + + (^template [ ] + (^ ( leftP rightP)) + (do ////.monad + [leftO (pattern-matching' translate leftP) + rightO (pattern-matching' translate rightP)] + (wrap ))) + ([synthesis.path/seq (_.begin (list leftO + rightO))] + [synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching translate pathP) + (-> Phase Path (Operation Computation)) + (do ////.monad + [pattern-matching! (pattern-matching' translate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case translate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation Computation)) + (do ////.monad + [valueO (translate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..53d7bbbcb --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + [control + [monad (#+ do)]]] + [// + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference] + ["." function] + ["." case] + ["." loop] + ["." /// + ["." synthesis] + ["." extension]]]) + +(def: #export (translate synthesis) + Phase + (case synthesis + (^template [ ] + (^ ( value)) + ( value)) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant translate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple translate members) + + (#synthesis.Reference reference) + (reference.reference reference) + + (^ (synthesis.branch/case case)) + (case.case translate case) + + (^ (synthesis.branch/let let)) + (case.let translate let) + + (^ (synthesis.branch/if if)) + (case.if translate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope translate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur translate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function translate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply translate application) + + (#synthesis.Extension extension) + (extension.apply translate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..1c55abf83 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux @@ -0,0 +1,245 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["e" error] + ["." product] + ["." text + format] + [number (#+ hex)] + [collection + ["." list ("#/." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:)]] + [/// + ["." runtime (#+ Operation Phase Handler Bundle)] + ["//." /// + ["." synthesis (#+ Synthesis)] + ["." extension + ["." bundle]] + [/// + [host + ["_" scheme (#+ Expression Computation)]]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do /////.monad + [inputsI (monad.map @ phase inputsS)] + (wrap (extension inputsI)))))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is?" (binary (product.uncurry _.eq?/2))) + (bundle.install "try" (unary runtime.lux//try)))) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [bit::and _.bit-and/2] + [bit::or _.bit-or/2] + [bit::xor _.bit-xor/2] + ) + +(def: (bit::left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) + subjectO)) + +(def: (bit::arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit::logical-right-shift [subjectO paramO]) + Binary + (runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) + +(def: bundle::bit + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (bundle.install "and" (binary bit::and)) + (bundle.install "or" (binary bit::or)) + (bundle.install "xor" (binary bit::xor)) + (bundle.install "left-shift" (binary bit::left-shift)) + (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) + ))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [ ] + [(def: ( _) + Nullary + ( ))] + + [frac::smallest (Double::MIN_VALUE) _.float] + [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] + [frac::max (Double::MAX_VALUE) _.float] + ) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + (|> subjectO ( paramO)))] + + [int::+ _.+/2] + [int::- _.-/2] + [int::* _.*/2] + [int::/ _.quotient/2] + [int::% _.remainder/2] + ) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [frac::+ _.+/2] + [frac::- _.-/2] + [frac::* _.*/2] + [frac::/ _.//2] + [frac::% _.mod/2] + [frac::= _.=/2] + [frac::< _. ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [int::= _.=/2] + [int::< _.> _.integer->char/1 _.string/1)) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "+" (binary int::+)) + (bundle.install "-" (binary int::-)) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "=" (binary int::=)) + (bundle.install "<" (binary int::<)) + (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary int::char))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary frac::+)) + (bundle.install "-" (binary frac::-)) + (bundle.install "*" (binary frac::*)) + (bundle.install "/" (binary frac::/)) + (bundle.install "%" (binary frac::%)) + (bundle.install "=" (binary frac::=)) + (bundle.install "<" (binary frac::<)) + (bundle.install "smallest" (nullary frac::smallest)) + (bundle.install "min" (nullary frac::min)) + (bundle.install "max" (nullary frac::max)) + (bundle.install "to-int" (unary _.exact/1)) + (bundle.install "encode" (unary _.number->string/1)) + (bundle.install "decode" (unary runtime.frac//decode))))) + +(def: (text::char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text::clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary (product.uncurry _.string-append/2))) + (bundle.install "size" (unary _.string-length/1)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: (io::log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> io::log ..void))) + (bundle.install "error" (unary _.raise/1)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dict.merge bundle::bit) + (dict.merge bundle::int) + (dict.merge bundle::frac) + (dict.merge bundle::text) + (dict.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux new file mode 100644 index 000000000..b8b2b7612 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux @@ -0,0 +1,11 @@ +(.module: + [lux #*] + [/// + [runtime (#+ Bundle)] + [/// + [extension + ["." bundle]]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..fe08b6a50 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux @@ -0,0 +1,92 @@ +(.module: + [lux (#- function) + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#/." functor)]]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["/." // + ["//." // ("#/." monad) + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + [// + [reference (#+ Register Variable)] + ["." name] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]]) + +(def: #export (apply translate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.monad + [functionO (translate functionS) + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (let [@closure (_.var (format function-name "___CLOSURE"))] + (/////wrap + (case inits + #.Nil + function-definition + + _ + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left reference.foreign'))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc reference.local')) + +(def: #export (function translate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (translate bodyS)))) + closureO+ (monad.map @ reference.variable environment) + #let [arityO (|> arity .int _.int) + @num-args (_.var "num_args") + @function (_.var function-name) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args))]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(reference.local' 0) @function])) + (_.let-values (list [[(|> (list.indices arity) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (runtime.slice (_.int +0) arityO @curried) + output-func-args (runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_. @function + (apply-poly (_.append/2 @curried @missing)))))))]) + @function)) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..0d85654c1 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux @@ -0,0 +1,41 @@ +(.module: + [lux (#- Scope) + [control + ["." monad (#+ do)]] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#/." functor)]]]] + [// + [runtime (#+ Operation Phase)] + ["." reference] + ["/." // + ["//." // + [synthesis (#+ Scope Synthesis)] + [/// + [host + ["_" scheme (#+ Computation Var)]]]]]]) + +(def: @scope (_.var "scope")) + +(def: #export (scope translate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation Computation)) + (do ////.monad + [initsO+ (monad.map @ translate initsS+) + bodyO (///.with-anchor @scope + (translate bodyS))] + (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ start) reference.local'))) + #.None] + bodyO)]) + (_.apply/* @scope initsO+))))) + +(def: #export (recur translate argsS+) + (-> Phase (List Synthesis) (Operation Computation)) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ translate argsS+)] + (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..dc643bcbc --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux @@ -0,0 +1,25 @@ +(.module: + [lux (#- i64)] + [// + [runtime (#+ Operation)] + [// (#+ State) + ["//." // ("#/." monad) + [/// + [host + ["_" scheme (#+ Expression)]]]]]]) + +(def: #export bit + (-> Bit (Operation Expression)) + (|>> _.bool /////wrap)) + +(def: #export i64 + (-> (I64 Any) (Operation Expression)) + (|>> .int _.int /////wrap)) + +(def: #export f64 + (-> Frac (Operation Expression)) + (|>> _.float /////wrap)) + +(def: #export text + (-> Text (Operation Expression)) + (|>> _.string /////wrap)) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..161d2adea --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux @@ -0,0 +1,48 @@ +(.module: + [lux #* + [control + pipe] + [data + [text + format]]] + [// + [runtime (#+ Operation)] + ["/." // + ["//." // ("#/." monad) + [analysis (#+ Variant Tuple)] + [synthesis (#+ Synthesis)] + [// + ["." reference (#+ Register Variable Reference)] + [// + [host + ["_" scheme (#+ Expression Global Var)]]]]]]]) + +(do-template [ ] + [(def: #export + (-> Register Var) + (|>> .int %i (format ) _.var))] + + [local' "l"] + [foreign' "f"] + ) + +(def: #export variable + (-> Variable (Operation Var)) + (|>> (case> (#reference.Local register) + (local' register) + + (#reference.Foreign register) + (foreign' register)) + /////wrap)) + +(def: #export constant + (-> Name (Operation Global)) + (|>> ///.remember (/////map _.global))) + +(def: #export reference + (-> Reference (Operation Expression)) + (|>> (case> (#reference.Constant value) + (..constant value) + + (#reference.Variable value) + (..variable value)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..d254e8c7d --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux @@ -0,0 +1,322 @@ +(.module: + [lux #* + [control + ["p" parser ("#/." monad)] + [monad (#+ do)]] + [data + [number (#+ hex)] + [text + format] + [collection + ["." list ("#/." monad)]]] + ["." function] + [macro + ["." code] + ["s" syntax (#+ syntax:)]]] + ["." /// + ["//." // + [analysis (#+ Variant)] + ["." synthesis] + [// + ["." name] + [// + [host + ["_" scheme (#+ Expression Computation Var)]]]]]]) + +(do-template [ ] + [(type: #export + ( Var Expression Expression))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [0 #0 ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.and s.local-identifier (p/wrap (list))) + (s.form (p.and s.local-identifier (p.some s.local-identifier))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-identifier (format "@@" name)) + runtime (format prefix "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-identifier args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-identifier name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int +0))) + (slice (|> offset (_.-/2 (_.int +1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int +0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int +1))) + (_.cdr/1 list)))) + _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int +1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## Needs recursion + (product//left (product-tail product) + (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) + (let [@index_min_length (_.var "index_min_length") + @product_length (_.var "product_length") + @slice (_.var "slice") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int +0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int +0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [@temp] + (<| (check-index-out-of-bounds array idx) + (_.let (list [@temp (_.vector-ref/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int +0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int +1_000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//box + runtime//io + ))) + +(def: #export translate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..dc1b88591 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux @@ -0,0 +1,33 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." primitive] + ["." /// + [analysis (#+ Variant Tuple)] + ["." synthesis (#+ Synthesis)] + [/// + [host + ["_" scheme (#+ Expression)]]]]]) + +(def: #export (tuple translate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do ///.monad + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (do ///.monad + [valueT (translate valueS)] + (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/tool/compiler/reference.lux b/stdlib/source/lux/tool/compiler/reference.lux new file mode 100644 index 000000000..a20691986 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/reference.lux @@ -0,0 +1,88 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + pipe] + [data + [text + format]]]) + +(type: #export Register Nat) + +(type: #export Variable + (#Local Register) + (#Foreign Register)) + +(type: #export Reference + (#Variable Variable) + (#Constant Name)) + +(structure: #export equivalence (Equivalence Variable) + (def: (= reference sample) + (case [reference sample] + (^template [] + [( reference') ( sample')] + (n/= reference' sample')) + ([#Local] [#Foreign]) + + _ + #0))) + +(structure: #export hash (Hash Variable) + (def: &equivalence ..equivalence) + (def: (hash var) + (case var + (#Local register) + (n/* 1 register) + + (#Foreign register) + (n/* 2 register)))) + +(do-template [ ] + [(template: #export ( content) + (<| + + content))] + + [local #..Variable #..Local] + [foreign #..Variable #..Foreign] + ) + +(do-template [ ] + [(template: #export ( content) + (<| + content))] + + [variable #..Variable] + [constant #..Constant] + ) + +(def: #export self Reference (..local 0)) + +(def: #export self? + (-> Variable Bit) + (|>> ..variable + (case> (^ (..local 0)) + #1 + + _ + #0))) + +(def: #export (%variable variable) + (Format Variable) + (case variable + (#Local local) + (format "+" (%n local)) + + (#Foreign foreign) + (format "-" (%n foreign)))) + +(def: #export (%reference reference) + (Format Reference) + (case reference + (#Variable variable) + (%variable variable) + + (#Constant constant) + (%name constant))) diff --git a/stdlib/source/lux/tool/interpreter.lux b/stdlib/source/lux/tool/interpreter.lux new file mode 100644 index 000000000..d2fbccfdc --- /dev/null +++ b/stdlib/source/lux/tool/interpreter.lux @@ -0,0 +1,221 @@ +(.module: + [lux #* + [control + [monad (#+ Monad do)] + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + ["." text ("#/." equivalence) + format]] + [type (#+ :share) + ["." check]] + [compiler + ["." phase + ["." analysis + ["." module] + ["." type]] + ["." translation] + ["." statement (#+ State+ Operation) + ["." total]] + ["." extension]] + ["." default + ["." syntax] + ["." platform (#+ Platform)] + ["." init]] + ["." cli (#+ Configuration)]] + [world + ["." file (#+ File)] + ["." console (#+ Console)]]] + ["." /type]) + +(exception: #export (error {message Text}) + message) + +(def: #export module "") + +(def: fresh-source Source [[..module 1 0] 0 ""]) + +(def: (add-line line [where offset input]) + (-> Text Source Source) + [where offset (format input text.new-line line)]) + +(def: exit-command Text "exit") + +(def: welcome-message + Text + (format text.new-line + "Welcome to the interpreter!" text.new-line + "Type '" ..exit-command "' to leave." text.new-line + text.new-line)) + +(def: farewell-message + Text + "Till next time...") + +(def: enter-module + (All [anchor expression statement] + (Operation anchor expression statement Any)) + (statement.lift-analysis + (do phase.monad + [_ (module.create 0 ..module)] + (analysis.set-current-module ..module)))) + +(def: (initialize Monad Console platform configuration translation-bundle) + (All [! anchor expression statement] + (-> (Monad !) + (Console !) (Platform ! anchor expression statement) + Configuration + (translation.Bundle anchor expression statement) + (! (State+ anchor expression statement)))) + (do Monad + [state (platform.initialize platform translation-bundle) + state (platform.compile platform + (set@ #cli.module syntax.prelude configuration) + (set@ [#extension.state + #statement.analysis #statement.state + #extension.state + #.info #.mode] + #.Interpreter + state)) + [state _] (:: (get@ #platform.file-system platform) + lift (phase.run' state enter-module)) + _ (:: Console write ..welcome-message)] + (wrap state))) + +(with-expansions [ (as-is (Operation anchor expression statement [Type Any]))] + + (def: (interpret-statement code) + (All [anchor expression statement] + (-> Code )) + (do phase.monad + [_ (total.phase code) + _ init.refresh] + (wrap [Any []]))) + + (def: (interpret-expression code) + (All [anchor expression statement] + (-> Code )) + (do phase.monad + [state (extension.lift phase.get-state) + #let [analyse (get@ [#statement.analysis #statement.phase] state) + synthesize (get@ [#statement.synthesis #statement.phase] state) + translate (get@ [#statement.translation #statement.phase] state)] + [_ codeT codeA] (statement.lift-analysis + (analysis.with-scope + (type.with-fresh-env + (do @ + [[codeT codeA] (type.with-inference + (analyse code)) + codeT (type.with-env + (check.clean codeT))] + (wrap [codeT codeA]))))) + codeS (statement.lift-synthesis + (synthesize codeA))] + (statement.lift-translation + (translation.with-buffer + (do @ + [codeH (translate codeS) + count translation.next + codeV (translation.evaluate! (format "interpretation_" (%n count)) codeH)] + (wrap [codeT codeV])))))) + + (def: (interpret configuration code) + (All [anchor expression statement] + (-> Configuration Code )) + (function (_ state) + (case (<| (phase.run' state) + (:share [anchor expression statement] + {(State+ anchor expression statement) + state} + { + (interpret-statement code)})) + (#error.Success [state' output]) + (#error.Success [state' output]) + + (#error.Failure error) + (if (ex.match? total.not-a-statement error) + (<| (phase.run' state) + (:share [anchor expression statement] + {(State+ anchor expression statement) + state} + { + (interpret-expression code)})) + (#error.Failure error))))) + ) + +(def: (execute configuration code) + (All [anchor expression statement] + (-> Configuration Code (Operation anchor expression statement Text))) + (do phase.monad + [[codeT codeV] (interpret configuration code) + state phase.get-state] + (wrap (/type.represent (get@ [#extension.state + #statement.analysis #statement.state + #extension.state] + state) + codeT + codeV)))) + +(type: (Context anchor expression statement) + {#configuration Configuration + #state (State+ anchor expression statement) + #source Source}) + +(with-expansions [ (as-is (Context anchor expression statement))] + (def: (read-eval-print context) + (All [anchor expression statement] + (-> (Error [ Text]))) + (do error.monad + [#let [[_where _offset _code] (get@ #source context)] + [source' input] (syntax.parse ..module syntax.no-aliases (text.size _code) (get@ #source context)) + [state' representation] (let [## TODO: Simplify ASAP + state (:share [anchor expression statement] + { + context} + {(State+ anchor expression statement) + (get@ #state context)})] + (<| (phase.run' state) + ## TODO: Simplify ASAP + (:share [anchor expression statement] + { + context} + {(Operation anchor expression statement Text) + (execute (get@ #configuration context) input)})))] + (wrap [(|> context + (set@ #state state') + (set@ #source source')) + representation])))) + +(def: #export (run Monad Console platform configuration translation-bundle) + (All [! anchor expression statement] + (-> (Monad !) + (Console !) (Platform ! anchor expression statement) + Configuration + (translation.Bundle anchor expression statement) + (! Any))) + (do Monad + [state (initialize Monad Console platform configuration)] + (loop [context {#configuration configuration + #state state + #source ..fresh-source} + multi-line? #0] + (do @ + [_ (if multi-line? + (:: Console write " ") + (:: Console write "> ")) + line (:: Console read-line)] + (if (and (not multi-line?) + (text/= ..exit-command line)) + (:: Console write ..farewell-message) + (case (read-eval-print (update@ #source (add-line line) context)) + (#error.Success [context' representation]) + (do @ + [_ (:: Console write representation)] + (recur context' #0)) + + (#error.Failure error) + (if (ex.match? syntax.end-of-file error) + (recur context #1) + (exec (log! (ex.construct ..error error)) + (recur (set@ #source ..fresh-source context) #0)))))) + ))) diff --git a/stdlib/source/lux/tool/interpreter/type.lux b/stdlib/source/lux/tool/interpreter/type.lux new file mode 100644 index 000000000..f6a66a76a --- /dev/null +++ b/stdlib/source/lux/tool/interpreter/type.lux @@ -0,0 +1,203 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)] + ["p" parser] + pipe] + [data + ["." error (#+ Error)] + [text + format] + [format + [xml (#+ XML)] + [json (#+ JSON)]] + [collection + ["." list]]] + [time + [instant (#+ Instant)] + [duration (#+ Duration)] + [date (#+ Date)]] + ["." function] + ["." type] + ["." macro + ["." code] + ["." poly (#+ Poly)]]]) + +(exception: #export (cannot-represent-value {type Type}) + (ex.report ["Type" (%type type)])) + +(type: Representation (-> Any Text)) + +(def: primitive-representation + (Poly Representation) + (`` ($_ p.either + (do p.monad + [_ (poly.exactly Any)] + (wrap (function.constant "[]"))) + + (~~ (do-template [ ] + [(do p.monad + [_ (poly.sub )] + (wrap (|>> (:coerce ) )))] + + [Bit %b] + [Nat %n] + [Int %i] + [Rev %r] + [Frac %f] + [Text %t]))))) + +(def: (special-representation representation) + (-> (Poly Representation) (Poly Representation)) + (`` ($_ p.either + (~~ (do-template [ ] + [(do p.monad + [_ (poly.sub )] + (wrap (|>> (:coerce ) )))] + + [Type %type] + [Code %code] + [Instant %instant] + [Duration %duration] + [Date %date] + [JSON %json] + [XML %xml])) + + (do p.monad + [[_ elemT] (poly.apply (p.and (poly.exactly List) poly.any)) + elemR (poly.local (list elemT) representation)] + (wrap (|>> (:coerce (List Any)) (%list elemR)))) + + (do p.monad + [[_ elemT] (poly.apply (p.and (poly.exactly Maybe) poly.any)) + elemR (poly.local (list elemT) representation)] + (wrap (|>> (:coerce (Maybe Any)) + (case> #.None + "#.None" + + (#.Some elemV) + (format "(#.Some " (elemR elemV) ")")))))))) + +(def: (record-representation tags representation) + (-> (List Name) (Poly Representation) (Poly Representation)) + (do p.monad + [membersR+ (poly.tuple (p.many representation)) + _ (p.assert "Number of tags does not match record type size." + (n/= (list.size tags) (list.size membersR+)))] + (wrap (function (_ recordV) + (let [record-body (loop [pairs-left (list.zip2 tags membersR+) + recordV recordV] + (case pairs-left + #.Nil + "" + + (#.Cons [tag repr] #.Nil) + (format (%code (code.tag tag)) " " (repr recordV)) + + (#.Cons [tag repr] tail) + (let [[leftV rightV] (:coerce [Any Any] recordV)] + (format (%code (code.tag tag)) " " (repr leftV) " " + (recur tail rightV)))))] + (format "{" record-body "}")))))) + +(def: (variant-representation tags representation) + (-> (List Name) (Poly Representation) (Poly Representation)) + (do p.monad + [casesR+ (poly.variant (p.many representation)) + #let [num-tags (list.size tags)] + _ (p.assert "Number of tags does not match variant type size." + (n/= num-tags (list.size casesR+)))] + (wrap (function (_ variantV) + (loop [cases-left (list.zip3 tags + (list.indices num-tags) + casesR+) + variantV variantV] + (case cases-left + #.Nil + "" + + (#.Cons [tag-name tag-idx repr] #.Nil) + (let [[_tag _last? _value] (:coerce [Nat Text Any] variantV)] + (if (n/= tag-idx _tag) + (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") + (undefined))) + + (#.Cons [tag-name tag-idx repr] tail) + (let [[_tag _last? _value] (:coerce [Nat Text Any] variantV)] + (if (n/= tag-idx _tag) + (format "(" (%code (code.tag tag-name)) " " (repr _value) ")") + (recur tail variantV))))))))) + +(def: (tagged-representation compiler representation) + (-> Lux (Poly Representation) (Poly Representation)) + (do p.monad + [[name anonymous] poly.named] + (case (macro.run compiler (macro.tags-of name)) + (#error.Success ?tags) + (case ?tags + (#.Some tags) + (poly.local (list anonymous) + (p.either (record-representation tags representation) + (variant-representation tags representation))) + + #.None + representation) + + (#error.Failure error) + (p.fail error)))) + +(def: (tuple-representation representation) + (-> (Poly Representation) (Poly Representation)) + (do p.monad + [membersR+ (poly.tuple (p.many representation))] + (wrap (function (_ tupleV) + (let [tuple-body (loop [representations membersR+ + tupleV tupleV] + (case representations + #.Nil + "" + + (#.Cons lastR #.Nil) + (lastR tupleV) + + (#.Cons headR tailR) + (let [[leftV rightV] (:coerce [Any Any] tupleV)] + (format (headR leftV) " " (recur tailR rightV)))))] + (format "[" tuple-body "]")))))) + +(def: (representation compiler) + (-> Lux (Poly Representation)) + (p.rec + (function (_ representation) + ($_ p.either + primitive-representation + (special-representation representation) + (tagged-representation compiler representation) + (tuple-representation representation) + + (do p.monad + [[funcT inputsT+] (poly.apply (p.and poly.any (p.many poly.any)))] + (case (type.apply inputsT+ funcT) + (#.Some outputT) + (poly.local (list outputT) representation) + + #.None + (p.fail ""))) + + (do p.monad + [[name anonymous] poly.named] + (poly.local (list anonymous) representation)) + + (p.fail "") + )))) + +(def: #export (represent compiler type value) + (-> Lux Type Any Text) + (case (poly.run type (representation compiler)) + (#error.Success representation) + (ex.report ["Type" (%type type)] + ["Value" (representation value)]) + + (#error.Failure error) + (ex.construct cannot-represent-value [type]))) diff --git a/stdlib/source/lux/tool/mediator.lux b/stdlib/source/lux/tool/mediator.lux new file mode 100644 index 000000000..4481b6e2e --- /dev/null +++ b/stdlib/source/lux/tool/mediator.lux @@ -0,0 +1,20 @@ +(.module: + [lux (#- Source Module) + [data + ["." error (#+ Error)]] + [world + ["." binary (#+ Binary)] + ["." file (#+ File)]]] + [// + [compiler (#+ Compiler) + [meta + ["." archive (#+ Archive) + [descriptor (#+ Module)]]]]]) + +(type: #export Source File) + +(type: #export (Mediator !) + (-> Archive Module (! Archive))) + +(type: #export (Instancer ! d o) + (-> (file.System !) (List Source) (Compiler d o) (Mediator !))) diff --git a/stdlib/source/lux/tool/mediator/parallelism.lux b/stdlib/source/lux/tool/mediator/parallelism.lux new file mode 100644 index 000000000..c694f0490 --- /dev/null +++ b/stdlib/source/lux/tool/mediator/parallelism.lux @@ -0,0 +1,169 @@ +(.module: + [lux (#- Source Module) + [control + ["." monad (#+ Monad do)] + ["ex" exception (#+ exception:)]] + [concurrency + ["." promise (#+ Promise) ("#/." functor)] + ["." task (#+ Task)] + ["." stm (#+ Var STM)]] + [data + ["." error (#+ Error) ("#/." monad)] + ["." text ("#/." equivalence) + format] + [collection + ["." list ("#/." functor)] + ["." dictionary (#+ Dictionary)]]] + ["." io]] + ["." // (#+ Source Mediator) + [// + ["." compiler (#+ Input Output Compilation Compiler) + [meta + ["." archive (#+ Archive) + ["." descriptor (#+ Module Descriptor)] + [document (#+ Document)]] + [io + ["." context]]]]]]) + +(exception: #export (self-dependency {module Module}) + (ex.report ["Module" module])) + +(exception: #export (circular-dependency {module Module} {dependency Module}) + (ex.report ["Module" module] + ["Dependency" dependency])) + +(type: Pending-Compilation + (Promise (Error (Ex [d] (Document d))))) + +(type: Active-Compilations + (Dictionary Module [Descriptor Pending-Compilation])) + +(def: (self-dependence? module dependency) + (-> Module Module Bit) + (text/= module dependency)) + +(def: (circular-dependence? active dependency) + (-> Active-Compilations Module Bit) + (case (dictionary.get dependency active) + (#.Some [descriptor pending]) + (case (get@ #descriptor.state descriptor) + #.Active + true + + _ + false) + + #.None + false)) + +(def: (ensure-valid-dependencies! active dependencies module) + (-> Active-Compilations (List Module) Module (Task Any)) + (do task.monad + [_ (: (Task Any) + (if (list.any? (self-dependence? module) dependencies) + (task.throw self-dependency module) + (wrap [])))] + (: (Task Any) + (case (list.find (circular-dependence? active) dependencies) + (#.Some dependency) + (task.throw circular-dependency module dependency) + + #.None + (wrap []))))) + +(def: (share-compilation archive pending) + (-> Active-Compilations Pending-Compilation (Task Archive)) + (promise/map (|>> (error/map (function (_ document) + (archive.add module document archive))) + error/join) + pending)) + +(def: (import Monad mediate archive dependencies) + (All [!] (-> (Monad !) (Mediator !) Active-Compilations (List Module) (! (List Archive)))) + (|> dependencies + (list/map (mediate archive)) + (monad.seq Monad))) + +(def: (step-compilation archive imports [dependencies process]) + (All [d o] (-> Archive (List Archive) (Compilation d o) + [Archive (Either (Compilation d o) + [(Document d) (Output o)])])) + (do error.monad + [archive' (monad.fold error.monad archive.merge archive imports) + outcome (process archive')] + (case outcome + (#.Right [document output]) + (do @ + [archive'' (archive.add module document archive')] + (wrap [archive'' (#.Right [document output])])) + + (#.Left continue) + (wrap [archive' outcome])))) + +(def: (request-compilation file-system sources module compilations) + (All [!] + (-> (file.System Task) (List Source) Module (Var Active-Compilations) + (Task (Either Pending-Compilation + [Pending-Compilation Active-Compilations Input])))) + (do (:: file-system &monad) + [current (|> (stm.read compilations) + stm.commit + task.from-promise)] + (case (dictionary.get module current) + (#.Some [descriptor pending]) + (wrap (#.Left pending)) + + #.None + (do @ + [input (context.read file-system sources module)] + (do stm.monad + [stale (stm.read compilations)] + (case (dictionary.get module stale) + (#.Some [descriptor pending]) + (wrap (#.Left [pending current])) + + #.None + (do @ + [#let [base-descriptor {#descriptor.hash (get@ #compiler.hash input) + #descriptor.name (get@ #compiler.module input) + #descriptor.file (get@ #compiler.file input) + #descriptor.references (list) + #descriptor.state #.Active} + pending (promise.promise (: (Maybe (Error (Ex [d] (Document d)))) + #.None))] + updated (stm.update (dictionary.put (get@ #compiler.module input) + [base-descriptor pending]) + compilations)] + (wrap (is? current stale) + (#.Right [pending updated input]))))))))) + +(def: (mediate-compilation Monad mediate compiler input archive pending) + (All [! d o] (-> (Monad !) (Mediator ! d o) (Compiler d o) Input Archive Pending-Compilation (Task Archive))) + (loop [archive archive + compilation (compiler input)] + (do Monad + [#let [[dependencies process] compilation] + _ (ensure-valid-dependencies! active dependencies (get@ #compiler.module input)) + imports (import @ mediate archive dependencies) + [archive' next] (promise/wrap (step-compilation archive imports compilation))] + (case next + (#.Left continue) + (recur archive' continue) + + (#.Right [document output]) + (exec (io.run (promise.resolve (#error.Success document) pending)) + (wrap archive')))))) + +(def: #export (mediator file-system sources compiler) + (//.Instancer Task) + (let [compilations (: (Var Active-Compilations) + (stm.var (dictionary.new text.hash)))] + (function (mediate archive module) + (do (:: file-system &monad) + [request (request-compilation file-system sources module compilations)] + (case request + (#.Left pending) + (share-compilation archive pending) + + (#.Right [pending active input]) + (mediate-compilation @ mediate compiler input archive pending)))))) diff --git a/stdlib/source/lux/world/console.lux b/stdlib/source/lux/world/console.lux index 8f58b0266..ff54445ed 100644 --- a/stdlib/source/lux/world/console.lux +++ b/stdlib/source/lux/world/console.lux @@ -13,7 +13,7 @@ format]] ["." io (#+ IO Process io)] [host (#+ import:)] - [platform + [tool [compiler ["." host]]]]) diff --git a/stdlib/source/lux/world/file.lux b/stdlib/source/lux/world/file.lux index 0592d41af..55c8a4f8d 100644 --- a/stdlib/source/lux/world/file.lux +++ b/stdlib/source/lux/world/file.lux @@ -24,7 +24,7 @@ ["." binary (#+ Binary)]] ["." io (#+ IO) ("#/." functor)] [host (#+ import:)] - [platform + [tool [compiler ["." host]]]]) diff --git a/stdlib/source/lux/world/net/http/client.lux b/stdlib/source/lux/world/net/http/client.lux index 318a17ef6..af48d8a23 100644 --- a/stdlib/source/lux/world/net/http/client.lux +++ b/stdlib/source/lux/world/net/http/client.lux @@ -11,7 +11,7 @@ ["." context]] [collection ["." dictionary]]] - [platform + [tool [compiler ["." host]]] ["." io (#+ IO)] diff --git a/stdlib/source/lux/world/net/tcp.jvm.lux b/stdlib/source/lux/world/net/tcp.jvm.lux index bd911f95a..3b664d9d8 100644 --- a/stdlib/source/lux/world/net/tcp.jvm.lux +++ b/stdlib/source/lux/world/net/tcp.jvm.lux @@ -12,7 +12,7 @@ ["." binary (#+ Binary)]] ["." io (#+ IO)] [host (#+ import:)] - [platform + [tool [compiler ["." host]]]] ["." // (#+ Can-Read Can-Write Can-Close)]) diff --git a/stdlib/source/lux/world/net/udp.jvm.lux b/stdlib/source/lux/world/net/udp.jvm.lux index 2d4ac82a1..27363956d 100644 --- a/stdlib/source/lux/world/net/udp.jvm.lux +++ b/stdlib/source/lux/world/net/udp.jvm.lux @@ -15,7 +15,7 @@ ["." binary (#+ Binary)]] ["." io (#+ IO)] [host (#+ import:)] - [platform + [tool [compiler ["." host]]]] ["." // (#+ Location Can-Read Can-Write Can-Close)]) -- cgit v1.2.3