From 5de8734377870637a7757f5aedd13d19cc3c82bb Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 29 Oct 2018 21:15:30 -0400 Subject: Nested the compiler and the interpreter under the lux/platform/* path. --- stdlib/source/lux/compiler.lux | 44 - stdlib/source/lux/compiler/cli.lux | 39 - stdlib/source/lux/compiler/default.lux | 6 - stdlib/source/lux/compiler/default/cache.lux | 35 - stdlib/source/lux/compiler/default/evaluation.lux | 36 - stdlib/source/lux/compiler/default/init.lux | 198 --- stdlib/source/lux/compiler/default/name.lux | 47 - stdlib/source/lux/compiler/default/phase.lux | 115 -- .../source/lux/compiler/default/phase/analysis.lux | 349 ------ .../lux/compiler/default/phase/analysis/case.lux | 300 ----- .../default/phase/analysis/case/coverage.lux | 366 ------ .../compiler/default/phase/analysis/expression.lux | 109 -- .../compiler/default/phase/analysis/function.lux | 102 -- .../compiler/default/phase/analysis/inference.lux | 259 ---- .../lux/compiler/default/phase/analysis/macro.lux | 79 -- .../lux/compiler/default/phase/analysis/module.lux | 255 ---- .../compiler/default/phase/analysis/primitive.lux | 29 - .../compiler/default/phase/analysis/reference.lux | 79 -- .../lux/compiler/default/phase/analysis/scope.lux | 206 ---- .../compiler/default/phase/analysis/structure.lux | 358 ------ .../lux/compiler/default/phase/analysis/type.lux | 52 - .../lux/compiler/default/phase/extension.lux | 140 --- .../compiler/default/phase/extension/analysis.lux | 17 - .../default/phase/extension/analysis/common.lux | 218 ---- .../default/phase/extension/analysis/host.jvm.lux | 1271 -------------------- .../compiler/default/phase/extension/bundle.lux | 28 - .../compiler/default/phase/extension/statement.lux | 199 --- .../compiler/default/phase/extension/synthesis.lux | 10 - .../default/phase/extension/translation.lux | 10 - .../lux/compiler/default/phase/statement.lux | 45 - .../lux/compiler/default/phase/statement/total.lux | 56 - .../lux/compiler/default/phase/synthesis.lux | 468 ------- .../lux/compiler/default/phase/synthesis/case.lux | 169 --- .../default/phase/synthesis/expression.lux | 86 -- .../compiler/default/phase/synthesis/function.lux | 211 ---- .../lux/compiler/default/phase/synthesis/loop.lux | 291 ----- .../lux/compiler/default/phase/translation.lux | 250 ---- .../default/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 | 254 ---- .../translation/scheme/extension/host.jvm.lux | 11 - .../phase/translation/scheme/function.jvm.lux | 92 -- .../default/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/compiler/default/platform.lux | 109 -- stdlib/source/lux/compiler/default/reference.lux | 88 -- stdlib/source/lux/compiler/default/syntax.lux | 557 --------- stdlib/source/lux/compiler/host.lux | 18 - stdlib/source/lux/compiler/host/scheme.lux | 306 ----- stdlib/source/lux/compiler/meta/archive.lux | 75 -- .../lux/compiler/meta/archive/descriptor.lux | 13 - .../source/lux/compiler/meta/archive/document.lux | 53 - stdlib/source/lux/compiler/meta/archive/key.lux | 20 - .../source/lux/compiler/meta/archive/signature.lux | 23 - stdlib/source/lux/compiler/meta/cache.lux | 178 --- .../source/lux/compiler/meta/cache/dependency.lux | 53 - stdlib/source/lux/compiler/meta/io.lux | 16 - stdlib/source/lux/compiler/meta/io/archive.lux | 74 -- stdlib/source/lux/compiler/meta/io/context.lux | 107 -- stdlib/source/lux/interpreter.lux | 221 ---- stdlib/source/lux/interpreter/type.lux | 203 ---- stdlib/source/lux/platform/compiler.lux | 44 + stdlib/source/lux/platform/compiler/cli.lux | 39 + 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 +++ .../source/lux/platform/compiler/default/name.lux | 47 + .../source/lux/platform/compiler/default/phase.lux | 115 ++ .../platform/compiler/default/phase/analysis.lux | 349 ++++++ .../compiler/default/phase/analysis/case.lux | 300 +++++ .../default/phase/analysis/case/coverage.lux | 366 ++++++ .../compiler/default/phase/analysis/expression.lux | 109 ++ .../compiler/default/phase/analysis/function.lux | 102 ++ .../compiler/default/phase/analysis/inference.lux | 259 ++++ .../compiler/default/phase/analysis/macro.lux | 79 ++ .../compiler/default/phase/analysis/module.lux | 255 ++++ .../compiler/default/phase/analysis/primitive.lux | 29 + .../compiler/default/phase/analysis/reference.lux | 79 ++ .../compiler/default/phase/analysis/scope.lux | 206 ++++ .../compiler/default/phase/analysis/structure.lux | 358 ++++++ .../compiler/default/phase/analysis/type.lux | 52 + .../platform/compiler/default/phase/extension.lux | 140 +++ .../compiler/default/phase/extension/analysis.lux | 17 + .../default/phase/extension/analysis/common.lux | 218 ++++ .../default/phase/extension/analysis/host.jvm.lux | 1271 ++++++++++++++++++++ .../compiler/default/phase/extension/bundle.lux | 28 + .../compiler/default/phase/extension/statement.lux | 199 +++ .../compiler/default/phase/extension/synthesis.lux | 10 + .../default/phase/extension/translation.lux | 10 + .../platform/compiler/default/phase/statement.lux | 45 + .../compiler/default/phase/statement/total.lux | 56 + .../platform/compiler/default/phase/synthesis.lux | 468 +++++++ .../compiler/default/phase/synthesis/case.lux | 169 +++ .../default/phase/synthesis/expression.lux | 86 ++ .../compiler/default/phase/synthesis/function.lux | 211 ++++ .../compiler/default/phase/synthesis/loop.lux | 291 +++++ .../compiler/default/phase/translation.lux | 250 ++++ .../default/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 | 254 ++++ .../translation/scheme/extension/host.jvm.lux | 11 + .../phase/translation/scheme/function.jvm.lux | 92 ++ .../default/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 + .../lux/platform/compiler/default/platform.lux | 109 ++ .../lux/platform/compiler/default/reference.lux | 88 ++ .../lux/platform/compiler/default/syntax.lux | 557 +++++++++ stdlib/source/lux/platform/compiler/host.lux | 18 + .../source/lux/platform/compiler/host/scheme.lux | 306 +++++ .../source/lux/platform/compiler/meta/archive.lux | 75 ++ .../platform/compiler/meta/archive/descriptor.lux | 13 + .../platform/compiler/meta/archive/document.lux | 53 + .../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/interpreter.lux | 221 ++++ stdlib/source/lux/platform/interpreter/type.lux | 203 ++++ 130 files changed, 9723 insertions(+), 9723 deletions(-) delete mode 100644 stdlib/source/lux/compiler.lux delete mode 100644 stdlib/source/lux/compiler/cli.lux delete mode 100644 stdlib/source/lux/compiler/default.lux delete mode 100644 stdlib/source/lux/compiler/default/cache.lux delete mode 100644 stdlib/source/lux/compiler/default/evaluation.lux delete mode 100644 stdlib/source/lux/compiler/default/init.lux delete mode 100644 stdlib/source/lux/compiler/default/name.lux delete mode 100644 stdlib/source/lux/compiler/default/phase.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/case.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/expression.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/function.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/inference.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/macro.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/module.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/primitive.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/reference.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/scope.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/structure.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/analysis/type.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/analysis.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/bundle.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/statement.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/synthesis.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/extension/translation.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/statement.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/statement/total.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/synthesis.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/synthesis/case.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/synthesis/expression.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/synthesis/function.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/synthesis/loop.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/expression.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/extension.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/extension/host.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/function.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/loop.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/primitive.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/reference.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/runtime.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/phase/translation/scheme/structure.jvm.lux delete mode 100644 stdlib/source/lux/compiler/default/platform.lux delete mode 100644 stdlib/source/lux/compiler/default/reference.lux delete mode 100644 stdlib/source/lux/compiler/default/syntax.lux delete mode 100644 stdlib/source/lux/compiler/host.lux delete mode 100644 stdlib/source/lux/compiler/host/scheme.lux delete mode 100644 stdlib/source/lux/compiler/meta/archive.lux delete mode 100644 stdlib/source/lux/compiler/meta/archive/descriptor.lux delete mode 100644 stdlib/source/lux/compiler/meta/archive/document.lux delete mode 100644 stdlib/source/lux/compiler/meta/archive/key.lux delete mode 100644 stdlib/source/lux/compiler/meta/archive/signature.lux delete mode 100644 stdlib/source/lux/compiler/meta/cache.lux delete mode 100644 stdlib/source/lux/compiler/meta/cache/dependency.lux delete mode 100644 stdlib/source/lux/compiler/meta/io.lux delete mode 100644 stdlib/source/lux/compiler/meta/io/archive.lux delete mode 100644 stdlib/source/lux/compiler/meta/io/context.lux delete mode 100644 stdlib/source/lux/interpreter.lux delete mode 100644 stdlib/source/lux/interpreter/type.lux create mode 100644 stdlib/source/lux/platform/compiler.lux create mode 100644 stdlib/source/lux/platform/compiler/cli.lux create mode 100644 stdlib/source/lux/platform/compiler/default.lux create mode 100644 stdlib/source/lux/platform/compiler/default/cache.lux create mode 100644 stdlib/source/lux/platform/compiler/default/evaluation.lux create mode 100644 stdlib/source/lux/platform/compiler/default/init.lux create mode 100644 stdlib/source/lux/platform/compiler/default/name.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/case.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/case/coverage.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/expression.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/function.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/inference.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/macro.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/primitive.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/reference.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/scope.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/structure.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/type.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/analysis.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/analysis/common.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/analysis/host.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/bundle.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/statement.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/synthesis.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/translation.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/statement.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/statement/total.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/case.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/expression.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/function.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/loop.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/case.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/expression.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/host.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/function.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/loop.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/primitive.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/reference.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/runtime.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/structure.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/default/platform.lux create mode 100644 stdlib/source/lux/platform/compiler/default/reference.lux create mode 100644 stdlib/source/lux/platform/compiler/default/syntax.lux create mode 100644 stdlib/source/lux/platform/compiler/host.lux create mode 100644 stdlib/source/lux/platform/compiler/host/scheme.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/archive.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/archive/document.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/archive/key.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/archive/signature.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/cache.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/cache/dependency.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/io.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/io/archive.lux create mode 100644 stdlib/source/lux/platform/compiler/meta/io/context.lux create mode 100644 stdlib/source/lux/platform/interpreter.lux create mode 100644 stdlib/source/lux/platform/interpreter/type.lux (limited to 'stdlib') diff --git a/stdlib/source/lux/compiler.lux b/stdlib/source/lux/compiler.lux deleted file mode 100644 index d6c6d82d9..000000000 --- a/stdlib/source/lux/compiler.lux +++ /dev/null @@ -1,44 +0,0 @@ -(.module: - [lux (#- Module Source Code) - [control - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - [collection - ["." dictionary (#+ Dictionary)]]] - [world - ["." binary (#+ Binary)] - ["." 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 - #code Code}) - -(type: #export Output - (Dictionary Text Binary)) - -(type: #export (Compilation d) - {#dependencies (List Module) - #process (-> Archive - (Error (Either (Compilation d) - [(Document d) Output])))}) - -(type: #export (Compiler d) - (-> (Key d) (List Parameter) Input (Compilation d))) - -(type: #export (Importer !) - (-> (file.System !) Module Archive (! (Error Archive)))) - -(exception: #export (cannot-compile {module Module}) - (ex.report ["Module" module])) diff --git a/stdlib/source/lux/compiler/cli.lux b/stdlib/source/lux/compiler/cli.lux deleted file mode 100644 index 55ce35145..000000000 --- a/stdlib/source/lux/compiler/cli.lux +++ /dev/null @@ -1,39 +0,0 @@ -(.module: - [lux #* - [control - ["p" parser]] - ["." cli (#+ CLI)] - [world - [file (#+ File)]]]) - -(type: #export Configuration - {#sources (List File) - #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/compiler/default.lux b/stdlib/source/lux/compiler/default.lux deleted file mode 100644 index 726562cc8..000000000 --- a/stdlib/source/lux/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/compiler/default/cache.lux b/stdlib/source/lux/compiler/default/cache.lux deleted file mode 100644 index 1770b4a82..000000000 --- a/stdlib/source/lux/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/compiler/default/evaluation.lux b/stdlib/source/lux/compiler/default/evaluation.lux deleted file mode 100644 index ea76624df..000000000 --- a/stdlib/source/lux/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/compiler/default/init.lux b/stdlib/source/lux/compiler/default/init.lux deleted file mode 100644 index c50d37705..000000000 --- a/stdlib/source/lux/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 ("text/." Hash)] - [collection - ["." dictionary]]] - ["." macro] - [world - ["." file]]] - ["." // - ["." syntax (#+ Aliases)] - ["." evaluation] - ["." phase - ["." analysis - ["." module] - [".A" expression]] - ["." synthesis - [".S" expression]] - ["." translation] - ["." statement - [".S" total]] - ["." extension - [".E" analysis] - [".E" synthesis] - [".E" statement]]] - ["/." // (#+ Compiler) - ["." host] - [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.Error error) - (#error.Error 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.Error error) - (if (ex.match? syntax.end-of-file error) - (#error.Success [state []]) - (ex.with-stack ///.cannot-compile module (#error.Error 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/compiler/default/name.lux b/stdlib/source/lux/compiler/default/name.lux deleted file mode 100644 index 184b2cab5..000000000 --- a/stdlib/source/lux/compiler/default/name.lux +++ /dev/null @@ -1,47 +0,0 @@ -(.module: - [lux #* - [data - ["." maybe] - ["." text - format]]]) - -(`` (template: (!sanitize char) - ("lux syntax char case!" char - [["*"] "_ASTER_" - ["+"] "_PLUS_" - ["-"] "_DASH_" - ["/"] "_SLASH_" - ["\"] "_BSLASH_" - ["_"] "_UNDERS_" - ["%"] "_PERCENT_" - ["$"] "_DOLLAR_" - ["'"] "_QUOTE_" - ["`"] "_BQUOTE_" - ["@"] "_AT_" - ["^"] "_CARET_" - ["&"] "_AMPERS_" - ["="] "_EQ_" - ["!"] "_BANG_" - ["?"] "_QM_" - [":"] "_COLON_" - ["."] "_PERIOD_" - [","] "_COMMA_" - ["<"] "_LT_" - [">"] "_GT_" - ["~"] "_TILDE_" - ["|"] "_PIPE_"] - (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/compiler/default/phase.lux b/stdlib/source/lux/compiler/default/phase.lux deleted file mode 100644 index a81d5dfa7..000000000 --- a/stdlib/source/lux/compiler/default/phase.lux +++ /dev/null @@ -1,115 +0,0 @@ -(.module: - [lux #* - [control - ["." state] - ["ex" exception (#+ Exception exception:)] - [monad (#+ do)]] - [data - ["." product] - ["." error (#+ 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/compiler/default/phase/analysis.lux b/stdlib/source/lux/compiler/default/phase/analysis.lux deleted file mode 100644 index c69ff8eb2..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis.lux +++ /dev/null @@ -1,349 +0,0 @@ -(.module: - [lux (#- nat int rev) - [control - [monad (#+ do)]] - [data - ["." product] - ["." error] - ["." maybe] - ["." text ("text/." Equivalence) - format] - [collection - ["." list ("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.Error error) - (#error.Error 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.Error "Impossible error: Drained scopes!")) - - (#error.Error error) - (#error.Error 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.Error error) - (#error.Error (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/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/compiler/default/phase/analysis/case.lux deleted file mode 100644 index 5044aed92..000000000 --- a/stdlib/source/lux/compiler/default/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 ("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.Error error) - (///.fail error))] - (wrap (#//.Case inputA [outputH outputT]))) - - #.Nil - (///.throw cannot-have-empty-branches ""))) diff --git a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux deleted file mode 100644 index aff981e09..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis/case/coverage.lux +++ /dev/null @@ -1,366 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)] - equivalence] - [data - [bit ("bit/." Equivalence)] - ["." number] - ["." error (#+ Error) ("error/." Monad)] - ["." maybe] - ["." text - format] - [collection - ["." list ("list/." Functor Fold)] - ["." dictionary (#+ Dictionary)]]]] - ["." //// ("operation/." 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 _)) - (operation/wrap #Exhaustive) - - ## Primitive patterns always have partial coverage because there - ## are too many possibilities as far as values go. - (^template [] - (#///.Simple ( _)) - (operation/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)) - (operation/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.Error 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/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/compiler/default/phase/analysis/expression.lux deleted file mode 100644 index 1da6520a5..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/analysis/function.lux b/stdlib/source/lux/compiler/default/phase/analysis/function.lux deleted file mode 100644 index a996457d9..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis/function.lux +++ /dev/null @@ -1,102 +0,0 @@ -(.module: - [lux (#- function) - [control - monad - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - format] - [collection - ["." list ("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/compiler/default/phase/analysis/inference.lux b/stdlib/source/lux/compiler/default/phase/analysis/inference.lux deleted file mode 100644 index 010bdc437..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis/inference.lux +++ /dev/null @@ -1,259 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - format] - [collection - ["." list ("list/." Functor)]]] - ["." type - ["." check]] - ["." macro]] - ["." /// ("operation/." 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 _) - (operation/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) - (operation/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))] - (operation/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/compiler/default/phase/analysis/macro.lux b/stdlib/source/lux/compiler/default/phase/analysis/macro.lux deleted file mode 100644 index af12c747d..000000000 --- a/stdlib/source/lux/compiler/default/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 ("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.Error 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/compiler/default/phase/analysis/module.lux b/stdlib/source/lux/compiler/default/phase/analysis/module.lux deleted file mode 100644 index a8f6bda03..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis/module.lux +++ /dev/null @@ -1,255 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)] - pipe] - [data - ["." text ("text/." Equivalence) - format] - ["." error] - [collection - ["." list ("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/compiler/default/phase/analysis/primitive.lux b/stdlib/source/lux/compiler/default/phase/analysis/primitive.lux deleted file mode 100644 index bd42825d3..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/analysis/reference.lux b/stdlib/source/lux/compiler/default/phase/analysis/reference.lux deleted file mode 100644 index 30da3e60f..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis/reference.lux +++ /dev/null @@ -1,79 +0,0 @@ -(.module: - [lux #* - [control - monad - ["ex" exception (#+ exception:)]] - ["." macro] - [data - [text ("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/compiler/default/phase/analysis/scope.lux b/stdlib/source/lux/compiler/default/phase/analysis/scope.lux deleted file mode 100644 index 2849e059d..000000000 --- a/stdlib/source/lux/compiler/default/phase/analysis/scope.lux +++ /dev/null @@ -1,206 +0,0 @@ -(.module: - [lux #* - [control - monad - ["ex" exception (#+ exception:)]] - [data - [text ("text/." Equivalence) - format] - ["." maybe ("maybe/." Monad)] - ["." product] - ["e" error] - [collection - ["." list ("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.Error error) - (#e.Error 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.Error error) - (#e.Error 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/compiler/default/phase/analysis/structure.lux b/stdlib/source/lux/compiler/default/phase/analysis/structure.lux deleted file mode 100644 index 43cb8e0d2..000000000 --- a/stdlib/source/lux/compiler/default/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 ("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/compiler/default/phase/analysis/type.lux b/stdlib/source/lux/compiler/default/phase/analysis/type.lux deleted file mode 100644 index 36fee29f8..000000000 --- a/stdlib/source/lux/compiler/default/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.Error 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/compiler/default/phase/extension.lux b/stdlib/source/lux/compiler/default/phase/extension.lux deleted file mode 100644 index 75814ad24..000000000 --- a/stdlib/source/lux/compiler/default/phase/extension.lux +++ /dev/null @@ -1,140 +0,0 @@ -(.module: - [lux (#- Name) - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." error (#+ Error)] - ["." text ("text/." Order) - format] - [collection - ["." list ("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.Error error) - (#error.Error 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.Error error) - (#error.Error 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.Error error) - (#error.Error error)))) diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis.lux deleted file mode 100644 index cc4736ac0..000000000 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis.lux +++ /dev/null @@ -1,17 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [/// - [analysis (#+ Bundle)] - [// - [evaluation (#+ Eval)]]] - [/ - ["." common] - ["." host]]) - -(def: #export (bundle eval) - (-> Eval Bundle) - (dictionary.merge host.bundle - (common.bundle eval))) diff --git a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux deleted file mode 100644 index d599af130..000000000 --- a/stdlib/source/lux/compiler/default/phase/extension/analysis/common.lux +++ /dev/null @@ -1,218 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)]] - [data - ["." text - format] - [collection - ["." list ("list/." Functor)] - ["." dictionary (#+ Dictionary)]]] - [type - ["." check]] - ["." macro] - [io (#+ IO)]] - ["." /// - ["." bundle] - ["//." // - ["." analysis (#+ Analysis Handler Bundle) - [".A" type] - [".A" case] - [".A" function]] - [// - [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/compiler/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/compiler/default/phase/extension/analysis/host.jvm.lux deleted file mode 100644 index a494b0e44..000000000 --- a/stdlib/source/lux/compiler/default/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 - ["e" error] - ["." maybe] - ["." product] - ["." text ("text/." Equivalence) - format] - [collection - ["." list ("list/." Fold Functor Monoid)] - ["." array (#+ Array)] - ["." dictionary (#+ Dictionary)]]] - ["." type - ["." check]] - ["." macro - ["s" syntax]] - ["." host (#+ import:)]] - [// - ["." common] - ["/." // - ["." bundle] - ["//." // ("operation/." 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 _) - (operation/wrap name) - - (#.Named name unnamed) - (check-jvm unnamed) - - (#.Var id) - (operation/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) - (operation/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))] - (operation/wrap [(#.Primitive boxed-name #.Nil) - boxed-name])) - - (#.Primitive name _) - (if (dictionary.contains? name boxes) - (////.throw primitives-cannot-have-type-parameters name) - (operation/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) - (#e.Success [class]) - (wrap class) - - (#e.Error 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) - (operation/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) - (operation/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) - - _ - (operation/wrap Any))) - - (host.instance? Class java-type) - (let [java-type (:coerce (Class Object) java-type) - class-name (Class::getName java-type)] - (operation/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)))] - (operation/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 - (operation/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) - (#e.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)))) - - (#e.Error _) - (////.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) - (operation/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)) - (operation/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 (: (e.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)))))) - (#e.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 (: (e.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)))))) - (#e.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 (: (e.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!))) - (#e.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 (: (e.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)))))) - (#e.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 (: (e.Error [Text (List [Text Code])]) - (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any)))))) - (#e.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/compiler/default/phase/extension/bundle.lux b/stdlib/source/lux/compiler/default/phase/extension/bundle.lux deleted file mode 100644 index 582526694..000000000 --- a/stdlib/source/lux/compiler/default/phase/extension/bundle.lux +++ /dev/null @@ -1,28 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." text - format] - [collection - [list ("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/compiler/default/phase/extension/statement.lux b/stdlib/source/lux/compiler/default/phase/extension/statement.lux deleted file mode 100644 index e5963e96c..000000000 --- a/stdlib/source/lux/compiler/default/phase/extension/statement.lux +++ /dev/null @@ -1,199 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - pipe] - [data - [text - format] - [collection - [list ("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/compiler/default/phase/extension/synthesis.lux b/stdlib/source/lux/compiler/default/phase/extension/synthesis.lux deleted file mode 100644 index 1a2e44f6f..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/extension/translation.lux b/stdlib/source/lux/compiler/default/phase/extension/translation.lux deleted file mode 100644 index 232c8c168..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/statement.lux b/stdlib/source/lux/compiler/default/phase/statement.lux deleted file mode 100644 index c7ff3719f..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/statement/total.lux b/stdlib/source/lux/compiler/default/phase/statement/total.lux deleted file mode 100644 index 15f116aa1..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/synthesis.lux b/stdlib/source/lux/compiler/default/phase/synthesis.lux deleted file mode 100644 index cf29ad74b..000000000 --- a/stdlib/source/lux/compiler/default/phase/synthesis.lux +++ /dev/null @@ -1,468 +0,0 @@ -(.module: - [lux (#- i64 Scope) - [control - [monad (#+ do)] - [equivalence (#+ Equivalence)] - ["ex" exception (#+ exception:)]] - [data - [bit ("bit/." Equivalence)] - ["." text ("text/." Equivalence) - format] - [collection - [list ("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 _ (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 _ (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 (Equivalence Equivalence) - (All [a] (-> (Equivalence a) (Equivalence (Path' a)))) - - (def: (= reference sample) - (case [reference sample] - [#Pop #Pop] - true - - (^template [ ] - [( reference') ( sample')] - (:: = reference' sample')) - ([#Test Equivalence] - [#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 Synthesis) - (def: (= reference sample) - (case [reference sample] - (^template [ ] - [( reference') ( sample')] - (:: = reference' sample')) - ([#Primitive Equivalence]) - - _ - false))) - -(def: #export Equivalence - (Equivalence Path) - (Equivalence Equivalence)) diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/compiler/default/phase/synthesis/case.lux deleted file mode 100644 index e9e941a30..000000000 --- a/stdlib/source/lux/compiler/default/phase/synthesis/case.lux +++ /dev/null @@ -1,169 +0,0 @@ -(.module: - [lux #* - [control - [equivalence (#+ Equivalence)] - pipe - ["." monad (#+ do)]] - [data - ["." product] - [bit ("bit/." Equivalence)] - [text ("text/." Equivalence) - format] - [number ("frac/." Equivalence)] - [collection - ["." list ("list/." Fold Monoid)]]]] - ["." // (#+ Path Synthesis Operation Phase) - ["." function] - ["/." // ("operation/." 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) - (operation/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])) - (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right? - (#.Right lefts) - (#.Left lefts))))))) - (path' value-pattern end?) - (when (not end?) (operation/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?)] - (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if right? - (#.Right (dec tuple::lefts)) - (#.Left tuple::lefts))))))) - (path' tuple::member end?') - (when (not end?') (operation/map ..clean-up)) - nextC))) - thenC - (list.reverse (list.enumerate tuple)))))) - -(def: #export (path synthesize pattern bodyA) - (-> Phase Pattern Analysis (Operation Path)) - (path' pattern true (operation/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/compiler/default/phase/synthesis/expression.lux b/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux deleted file mode 100644 index 0d15ae463..000000000 --- a/stdlib/source/lux/compiler/default/phase/synthesis/expression.lux +++ /dev/null @@ -1,86 +0,0 @@ -(.module: - [lux (#- primitive) - [control - ["." monad (#+ do)] - pipe] - [data - ["." maybe] - ["." error] - [collection - ["." list ("list/." Functor)] - ["." dictionary (#+ Dictionary)]]]] - ["." // (#+ Synthesis Phase) - ["." function] - ["." case] - ["/." // ("operation/." 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') - (operation/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) - (operation/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.Error error) - (<| (///.run' state) - (do ///.Monad - [argsS+ (monad.map @ phase args)] - (wrap (#//.Extension [name argsS+]))))))) - )) diff --git a/stdlib/source/lux/compiler/default/phase/synthesis/function.lux b/stdlib/source/lux/compiler/default/phase/synthesis/function.lux deleted file mode 100644 index 267d941fc..000000000 --- a/stdlib/source/lux/compiler/default/phase/synthesis/function.lux +++ /dev/null @@ -1,211 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." maybe] - ["." text - format] - [collection - ["." list ("list/." Functor Monoid Fold)] - ["dict" dictionary (#+ Dictionary)]]]] - ["." // (#+ Path Synthesis Operation Phase) - ["." loop (#+ Transform)] - ["/." // ("operation/." 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) - (operation/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) - (operation/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 - (operation/map (|>> #//.Then))) - - _ - (operation/wrap path))) - -(def: (grow-sub-environment super sub) - (-> Environment Environment (Operation Environment)) - (monad.map ///.Monad - (function (_ variable) - (case variable - (#reference.Local register) - (operation/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) - (operation/map (|>> [lefts right?] //.variant))) - - (#analysis.Tuple membersS+) - (|> membersS+ - (monad.map ///.Monad (grow environment)) - (operation/map (|>> //.tuple)))) - - (^ (..self-reference)) - (operation/wrap (//.function/apply [expression (list (//.variable/local 1))])) - - (#//.Reference reference) - (case reference - (#reference.Variable variable) - (case variable - (#reference.Local register) - (operation/wrap (//.variable/local (inc register))) - - (#reference.Foreign register) - (|> register - (find-foreign environment) - (operation/map (|>> //.variable)))) - - (#reference.Constant constant) - (operation/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)) - (operation/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+])) - (operation/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)) - (operation/map (|>> (#//.Extension name)))) - - _ - (operation/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/compiler/default/phase/synthesis/loop.lux b/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux deleted file mode 100644 index cd57c1d29..000000000 --- a/stdlib/source/lux/compiler/default/phase/synthesis/loop.lux +++ /dev/null @@ -1,291 +0,0 @@ -(.module: - [lux (#- loop) - [control - ["." monad (#+ do)] - ["p" parser]] - [data - ["." maybe ("maybe/." Monad)] - [collection - ["." list ("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/compiler/default/phase/translation.lux b/stdlib/source/lux/compiler/default/phase/translation.lux deleted file mode 100644 index fb40f4652..000000000 --- a/stdlib/source/lux/compiler/default/phase/translation.lux +++ /dev/null @@ -1,250 +0,0 @@ -(.module: - [lux #* - [control - ["ex" exception (#+ exception:)] - [monad (#+ do)]] - [data - ["." product] - ["." error (#+ Error)] - ["." name ("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.Error error) - (#error.Error 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.Error error) - (#error.Error 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.Error 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.Error 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/compiler/default/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/case.jvm.lux deleted file mode 100644 index 4a963d507..000000000 --- a/stdlib/source/lux/compiler/default/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 ("list/." Functor Fold)] - [set (#+ Set)]]]] - [// - ["." runtime (#+ Operation Phase)] - ["." reference] - ["/." /// ("operation/." 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 - (operation/wrap pop-cursor!) - - (#synthesis.Bind register) - (operation/wrap (_.define (reference.local' register) [(list) #.None] - cursor-top)) - - (^template [ <=>] - (^ ( value)) - (operation/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)) - (operation/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)) - (operation/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/compiler/default/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/expression.jvm.lux deleted file mode 100644 index 53d7bbbcb..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension.jvm.lux deleted file mode 100644 index a40b4953f..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux deleted file mode 100644 index a503949dd..000000000 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/common.jvm.lux +++ /dev/null @@ -1,254 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["e" error] - ["." product] - ["." text - format] - [number (#+ hex)] - [collection - ["." list ("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)]]]]]) - -## [Types] -(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)) - -## [Utils] -(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)))))) - -## [Bundle] -## [[Lux]] -(def: bundle::lux - Bundle - (|> bundle.empty - (bundle.install "is?" (binary (product.uncurry _.eq?/2))) - (bundle.install "try" (unary runtime.lux//try)))) - -## [[Bits]] -(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)) - ))) - -## [[Numbers]] -(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))))) - -## [[Text]] -(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))))) - -## [[IO]] -(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)))))))) - -## [Bundles] -(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/compiler/default/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/extension/host.jvm.lux deleted file mode 100644 index b8b2b7612..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/function.jvm.lux deleted file mode 100644 index 7eeb5a8ed..000000000 --- a/stdlib/source/lux/compiler/default/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 ("list/." Functor)]]]] - [// - ["." runtime (#+ Operation Phase)] - ["." reference] - ["/." // - ["//." // ("operation/." 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"))] - (operation/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/compiler/default/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/loop.jvm.lux deleted file mode 100644 index 91757d291..000000000 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/loop.jvm.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux (#- Scope) - [control - ["." monad (#+ do)]] - [data - ["." product] - ["." text - format] - [collection - ["." list ("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/compiler/default/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/primitive.jvm.lux deleted file mode 100644 index c16c696c4..000000000 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,25 +0,0 @@ -(.module: - [lux (#- i64)] - [// - [runtime (#+ Operation)] - [// (#+ State) - [// ("operation/." Monad) - [/// - [host - ["_" scheme (#+ Expression)]]]]]]) - -(def: #export bit - (-> Bit (Operation Expression)) - (|>> _.bool operation/wrap)) - -(def: #export i64 - (-> (I64 Any) (Operation Expression)) - (|>> .int _.int operation/wrap)) - -(def: #export f64 - (-> Frac (Operation Expression)) - (|>> _.float operation/wrap)) - -(def: #export text - (-> Text (Operation Expression)) - (|>> _.string operation/wrap)) diff --git a/stdlib/source/lux/compiler/default/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/reference.jvm.lux deleted file mode 100644 index 6d4088189..000000000 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/reference.jvm.lux +++ /dev/null @@ -1,48 +0,0 @@ -(.module: - [lux #* - [control - pipe] - [data - [text - format]]] - [// - [runtime (#+ Operation)] - ["/." // - [// ("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)) - operation/wrap)) - -(def: #export constant - (-> Name (Operation Global)) - (|>> ///.remember (operation/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/compiler/default/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/runtime.jvm.lux deleted file mode 100644 index 43748c3b1..000000000 --- a/stdlib/source/lux/compiler/default/phase/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,322 +0,0 @@ -(.module: - [lux #* - [control - ["p" parser ("parser/." Monad)] - [monad (#+ do)]] - [data - [number (#+ hex)] - [text - format] - [collection - ["." list ("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 (parser/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/compiler/default/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/compiler/default/phase/translation/scheme/structure.jvm.lux deleted file mode 100644 index 3991ea281..000000000 --- a/stdlib/source/lux/compiler/default/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/compiler/default/platform.lux b/stdlib/source/lux/compiler/default/platform.lux deleted file mode 100644 index 0c0d72024..000000000 --- a/stdlib/source/lux/compiler/default/platform.lux +++ /dev/null @@ -1,109 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]] - [data - ["." product] - ["." error]] - [world - ["." file (#+ File)]] - ["." compiler - [default - ["." 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 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.Error 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.Error error) - ## (:: (get@ #file-system platform) lift (#error.Error error)) - - ## (#error.Success)) - (let [compiler (init.compiler syntax.prelude state) - compilation (compiler init.key (list) input)] - (case ((get@ #compiler.process compilation) - archive.empty) - (#error.Success more|done) - (case more|done - (#.Left more) - (:: (get@ #file-system platform) lift (#error.Error "NOT DONE!")) - - (#.Right done) - (wrap [])) - - (#error.Error error) - (:: (get@ #file-system platform) lift (#error.Error error)))))) - ) diff --git a/stdlib/source/lux/compiler/default/reference.lux b/stdlib/source/lux/compiler/default/reference.lux deleted file mode 100644 index b945c1327..000000000 --- a/stdlib/source/lux/compiler/default/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 Variable) - (def: (= reference sample) - (case [reference sample] - (^template [] - [( reference') ( sample')] - (n/= reference' sample')) - ([#Local] [#Foreign]) - - _ - #0))) - -(structure: #export _ (Hash Variable) - (def: eq 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/compiler/default/syntax.lux b/stdlib/source/lux/compiler/default/syntax.lux deleted file mode 100644 index 5e1990393..000000000 --- a/stdlib/source/lux/compiler/default/syntax.lux +++ /dev/null @@ -1,557 +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] - ["." 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.Error 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.Error error) - (#error.Error 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.Error error) - (#error.Error error)) - - (#error.Error error) - (let [[where offset _] source] - (<| (!with-char+ source-code//size source-code offset closing-char (#error.Error 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.Error error) - (#error.Error 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.Error error) - (#error.Error error))) - -(def: no-exponent Offset 0) - -(with-expansions [ (as-is (!number-output start end number.Codec #.Int)) - (as-is (!number-output start end number.Codec #.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 number.Codec #.Nat] - [!parse-rev number.Codec #.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.Error 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.Error error) - (#error.Error 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.Error error) - (#error.Error 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.Error error) - (#error.Error error))) - ))) - - (#error.Error error) - (#error.Error 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.Error error) - (#error.Error 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/compiler/host.lux b/stdlib/source/lux/compiler/host.lux deleted file mode 100644 index 218de67a4..000000000 --- a/stdlib/source/lux/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/compiler/host/scheme.lux b/stdlib/source/lux/compiler/host/scheme.lux deleted file mode 100644 index 8d5cbdbcd..000000000 --- a/stdlib/source/lux/compiler/host/scheme.lux +++ /dev/null @@ -1,306 +0,0 @@ -(.module: - [lux (#- Code' Code int or and if function cond when let) - [control - pipe] - [data - ["." number] - ["." text - format] - [collection - ["." list ("list/." Functor Fold)]]] - [type - abstract]]) - -(abstract: Global' {} Any) -(abstract: Var' {} Any) -(abstract: Computation' {} Any) -(abstract: (Expression' k) {} Any) - -(abstract: (Code' k) - {} - - Text - - (type: #export Code (Ex [k] (Code' k))) - (type: #export Expression (Code' (Ex [k] (Expression' k)))) - (type: #export Global (Code' (Expression' Global'))) - (type: #export Computation (Code' (Expression' Computation'))) - (type: #export Var (Code' (Expression' Var'))) - - (type: #export Arguments - {#mandatory (List Var) - #rest (Maybe Var)}) - - (def: #export code (-> Code Text) (|>> :representation)) - - (def: #export var (-> Text Var) (|>> :abstraction)) - - (def: (arguments [vars rest]) - (-> Arguments Code) - (case rest - (#.Some rest) - (case vars - #.Nil - rest - - _ - (|> (format " . " (:representation rest)) - (format (|> vars - (list/map ..code) - (text.join-with " "))) - (text.enclose ["(" ")"]) - :abstraction)) - - #.None - (|> vars - (list/map ..code) - (text.join-with " ") - (text.enclose ["(" ")"]) - :abstraction))) - - (def: #export nil - Computation - (:abstraction "'()")) - - (def: #export bool - (-> Bit Computation) - (|>> (case> #0 "#f" - #1 "#t") - :abstraction)) - - (def: #export int - (-> Int Computation) - (|>> %i :abstraction)) - - (def: #export float - (-> Frac Computation) - (|>> (cond> [(f/= number.positive-infinity)] - [(new> "+inf.0")] - - [(f/= number.negative-infinity)] - [(new> "-inf.0")] - - [number.not-a-number?] - [(new> "+nan.0")] - - ## else - [%f]) - :abstraction)) - - (def: #export positive-infinity Computation (..float number.positive-infinity)) - (def: #export negative-infinity Computation (..float number.negative-infinity)) - (def: #export not-a-number Computation (..float number.not-a-number)) - - (def: #export string - (-> Text Computation) - (|>> %t :abstraction)) - - (def: #export symbol - (-> Text Computation) - (|>> (format "'") :abstraction)) - - (def: #export global - (-> Text Global) - (|>> :abstraction)) - - (def: form - (-> (List Code) Text) - (|>> (list/map ..code) - (text.join-with " ") - (text.enclose ["(" ")"]))) - - (def: #export (apply/* func args) - (-> Expression (List Expression) Computation) - (:abstraction (..form (#.Cons func args)))) - - (do-template [ ] - [(def: #export - (-> (List Expression) Computation) - (apply/* (..global )))] - - [vector/* "vector"] - [list/* "list"] - ) - - (def: #export (apply/0 func) - (-> Expression Computation) - (..apply/* func (list))) - - (do-template [ ] - [(def: #export (apply/0 (..global )))] - - [newline/0 "newline"] - ) - - (def: #export (apply/1 func) - (-> Expression (-> Expression Computation)) - (|>> (list) (..apply/* func))) - - (do-template [ ] - [(def: #export (apply/1 (..global )))] - - [exact/1 "exact"] - [integer->char/1 "integer->char"] - [number->string/1 "number->string"] - [string/1 "string"] - [length/1 "length"] - [values/1 "values"] - [null?/1 "null?"] - [car/1 "car"] - [cdr/1 "cdr"] - [raise/1 "raise"] - [error-object-message/1 "error-object-message"] - [make-vector/1 "make-vector"] - [vector-length/1 "vector-length"] - [not/1 "not"] - [string-length/1 "string-length"] - [string-hash/1 "string-hash"] - [reverse/1 "reverse"] - [display/1 "display"] - [exit/1 "exit"] - ) - - (def: #export (apply/2 func) - (-> Expression (-> Expression Expression Computation)) - (.function (_ _0 _1) - (..apply/* func (list _0 _1)))) - - (do-template [ ] - [(def: #export (apply/2 (..global )))] - - [append/2 "append"] - [cons/2 "cons"] - [make-vector/2 "make-vector"] - [vector-ref/2 "vector-ref"] - [list-tail/2 "list-tail"] - [map/2 "map"] - [string-ref/2 "string-ref"] - [string-append/2 "string-append"] - ) - - (do-template [ ] - [(def: #export ( param subject) - (-> Expression Expression Computation) - (..apply/2 (..global ) subject param))] - - [=/2 "="] - [eq?/2 "eq?"] - [eqv?/2 "eqv?"] - [/2 ">"] - [>=/2 ">="] - [string=?/2 "string=?"] - [string Expression (-> Expression Expression Expression Computation)) - (.function (_ _0 _1 _2) - (..apply/* func (list _0 _1 _2)))) - - (do-template [ ] - [(def: #export (apply/3 (..global )))] - - [substring/3 "substring"] - [vector-set!/3 "vector-set!"] - ) - - (def: #export (vector-copy!/5 _0 _1 _2 _3 _4) - (-> Expression Expression Expression Expression Expression - Computation) - (..apply/* (..global "vector-copy!") - (list _0 _1 _2 _3 _4))) - - (do-template [ ] - [(def: #export - (-> (List Expression) Computation) - (|>> (list& (..global )) ..form :abstraction))] - - [or "or"] - [and "and"] - ) - - (do-template [ 
]
-    [(def: #export ( bindings body)
-       (-> (List [ Expression]) Expression Computation)
-       (:abstraction
-        (..form (list (..global )
-                      (|> bindings
-                          (list/map (.function (_ [binding/name binding/value])
-                                      (:abstraction
-                                       (..form (list (
 binding/name)
-                                                     binding/value)))))
-                          ..form
-                          :abstraction)
-                      body))))]
-
-    [let           "let"           Var       .id]
-    [let*          "let*"          Var       .id]
-    [letrec        "letrec"        Var       .id]
-    [let-values    "let-values"    Arguments ..arguments]
-    [let*-values   "let*-values"   Arguments ..arguments]
-    [letrec-values "letrec-values" Arguments ..arguments]
-    )
-
-  (def: #export (if test then else)
-    (-> Expression Expression Expression Computation)
-    (:abstraction
-     (..form (list (..global "if") test then else))))
-
-  (def: #export (when test then)
-    (-> Expression Expression Computation)
-    (:abstraction
-     (..form (list (..global "when") test then))))
-
-  (def: #export (cond clauses else)
-    (-> (List [Expression Expression]) Expression Computation)
-    (|> (list/fold (.function (_ [test then] next)
-                     (if test then next))
-                   else
-                   (list.reverse clauses))
-        :representation
-        :abstraction))
-
-  (def: #export (lambda arguments body)
-    (-> Arguments Expression Computation)
-    (:abstraction
-     (..form (list (..global "lambda")
-                   (..arguments arguments)
-                   body))))
-
-  (def: #export (define name arguments body)
-    (-> Var Arguments Expression Computation)
-    (:abstraction
-     (..form (list (..global "define")
-                   (|> arguments
-                       (update@ #mandatory (|>> (#.Cons name)))
-                       ..arguments)
-                   body))))
-
-  (def: #export begin
-    (-> (List Expression) Computation)
-    (|>> (#.Cons (..global "begin")) ..form :abstraction))
-
-  (def: #export (set! name value)
-    (-> Var Expression Computation)
-    (:abstraction
-     (..form (list (..global "set!") name value))))
-
-  (def: #export (with-exception-handler handler body)
-    (-> Expression Expression Computation)
-    (:abstraction
-     (..form (list (..global "with-exception-handler") handler body))))
-  )
diff --git a/stdlib/source/lux/compiler/meta/archive.lux b/stdlib/source/lux/compiler/meta/archive.lux
deleted file mode 100644
index f36a0b754..000000000
--- a/stdlib/source/lux/compiler/meta/archive.lux
+++ /dev/null
@@ -1,75 +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 )
-
-    (def: #export empty
-      Archive
-      (:abstraction (dictionary.new text.Hash)))
-
-    (def: #export (add name document archive)
-      (-> Module  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 (:abstraction (dictionary.put name document
-                                                      (:representation archive))))))
-
-    (def: #export (find name archive)
-      (-> Module Archive (Error ))
-      (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' document'] archive')
-                    (..add name' document' archive'))
-                  archive
-                  (dictionary.entries (:representation additions))))
-    ))
diff --git a/stdlib/source/lux/compiler/meta/archive/descriptor.lux b/stdlib/source/lux/compiler/meta/archive/descriptor.lux
deleted file mode 100644
index 6c7e6744e..000000000
--- a/stdlib/source/lux/compiler/meta/archive/descriptor.lux
+++ /dev/null
@@ -1,13 +0,0 @@
-(.module:
-  [lux (#- Module)
-   [world
-    [file (#+ File)]]])
-
-(type: #export Module Text)
-
-(type: #export Descriptor
-  {#hash Nat
-   #name Module
-   #file File
-   #references (List Module)
-   #state Module-State})
diff --git a/stdlib/source/lux/compiler/meta/archive/document.lux b/stdlib/source/lux/compiler/meta/archive/document.lux
deleted file mode 100644
index b99ff9b72..000000000
--- a/stdlib/source/lux/compiler/meta/archive/document.lux
+++ /dev/null
@@ -1,53 +0,0 @@
-(.module:
-  [lux (#- Module)
-   [control
-    ["ex" exception (#+ exception:)]]
-   [data
-    ["." error (#+ Error)]
-    [collection
-     ["." dictionary (#+ Dictionary)]]]
-   [type (#+ :share)
-    abstract]]
-  [//
-   ["." signature (#+ Signature)]
-   ["." key (#+ Key)]
-   ["." descriptor (#+ Module Descriptor)]])
-
-## Document
-(exception: #export (invalid-signature {module Module} {expected Signature} {actual Signature})
-  (ex.report ["Module" module]
-             ["Expected" (signature.description expected)]
-             ["Actual" (signature.description actual)]))
-
-(abstract: #export (Document d)
-  {}
-  
-  {#signature Signature
-   #descriptor Descriptor
-   #content d}
-
-  (def: #export (read key document)
-    (All [d] (-> (Key d) (Document Any) (Error d)))
-    (let [[document//signature document//descriptor 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 [(get@ #descriptor.name document//descriptor)
-                                     (key.signature key)
-                                     document//signature]))))
-
-  (def: #export (write key descriptor content)
-    (All [d] (-> (Key d) Descriptor d (Document d)))
-    (:abstraction {#signature (key.signature key)
-                   #descriptor descriptor
-                   #content content}))
-
-  (def: #export signature
-    (-> (Document Any) Signature)
-    (|>> :representation (get@ #signature)))
-  )
diff --git a/stdlib/source/lux/compiler/meta/archive/key.lux b/stdlib/source/lux/compiler/meta/archive/key.lux
deleted file mode 100644
index 50c10ac01..000000000
--- a/stdlib/source/lux/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/compiler/meta/archive/signature.lux b/stdlib/source/lux/compiler/meta/archive/signature.lux
deleted file mode 100644
index 5332b79c3..000000000
--- a/stdlib/source/lux/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/compiler/meta/cache.lux b/stdlib/source/lux/compiler/meta/cache.lux
deleted file mode 100644
index bcb7c98f0..000000000
--- a/stdlib/source/lux/compiler/meta/cache.lux
+++ /dev/null
@@ -1,178 +0,0 @@
-(.module:
-  [lux (#- Module)
-   [control
-    ["." monad (#+ Monad do)]
-    ["ex" exception (#+ exception:)]
-    pipe]
-   [data
-    ["." bit ("bit/." Equivalence)]
-    ["." maybe]
-    ["." error]
-    ["." product]
-    [format
-     ["." binary (#+ Format)]]
-    ["." text
-     [format (#- Format)]]
-    [collection
-     ["." list ("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.Error 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/compiler/meta/cache/dependency.lux b/stdlib/source/lux/compiler/meta/cache/dependency.lux
deleted file mode 100644
index e63fa192b..000000000
--- a/stdlib/source/lux/compiler/meta/cache/dependency.lux
+++ /dev/null
@@ -1,53 +0,0 @@
-(.module:
-  [lux (#- Module)
-   [data
-    ["." text]
-    [collection
-     [list ("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/compiler/meta/io.lux b/stdlib/source/lux/compiler/meta/io.lux
deleted file mode 100644
index dd261a539..000000000
--- a/stdlib/source/lux/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/compiler/meta/io/archive.lux b/stdlib/source/lux/compiler/meta/io/archive.lux
deleted file mode 100644
index 1f0714b25..000000000
--- a/stdlib/source/lux/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.Error _)
-          (:: 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/compiler/meta/io/context.lux b/stdlib/source/lux/compiler/meta/io/context.lux
deleted file mode 100644
index 32e05c219..000000000
--- a/stdlib/source/lux/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.Error _)
-        (:: System throw ..cannot-read-module [module])))))
diff --git a/stdlib/source/lux/interpreter.lux b/stdlib/source/lux/interpreter.lux
deleted file mode 100644
index 8a6d00578..000000000
--- a/stdlib/source/lux/interpreter.lux
+++ /dev/null
@@ -1,221 +0,0 @@
-(.module:
-  [lux #*
-   [control
-    [monad (#+ Monad do)]
-    ["ex" exception (#+ exception:)]]
-   [data
-    ["." error (#+ Error)]
-    ["." text ("text/." Equivalence)
-     format]]
-   [type (#+ :share)
-    ["." check]]
-   [compiler
-    ["." cli (#+ Configuration)]
-    ["." default
-     ["." syntax]
-     ["." platform (#+ Platform)]
-     ["." init]
-     ["." phase
-      ["." analysis
-       ["." module]
-       ["." type]]
-      ["." translation]
-      ["." statement (#+ State+ Operation)
-       ["." total]]
-      ["." extension]]]]
-   [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.Error 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.Error 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.Error 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/interpreter/type.lux b/stdlib/source/lux/interpreter/type.lux
deleted file mode 100644
index 7d3ac0d9c..000000000
--- a/stdlib/source/lux/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.Error 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.Error error)
-    (ex.construct cannot-represent-value [type])))
diff --git a/stdlib/source/lux/platform/compiler.lux b/stdlib/source/lux/platform/compiler.lux
new file mode 100644
index 000000000..d6c6d82d9
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler.lux
@@ -0,0 +1,44 @@
+(.module:
+  [lux (#- Module Source Code)
+   [control
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." error (#+ Error)]
+    [collection
+     ["." dictionary (#+ Dictionary)]]]
+   [world
+    ["." binary (#+ Binary)]
+    ["." 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
+   #code Code})
+
+(type: #export Output
+  (Dictionary Text Binary))
+
+(type: #export (Compilation d)
+  {#dependencies (List Module)
+   #process (-> Archive
+                (Error (Either (Compilation d)
+                               [(Document d) Output])))})
+
+(type: #export (Compiler d)
+  (-> (Key d) (List Parameter) Input (Compilation d)))
+
+(type: #export (Importer !)
+  (-> (file.System !) Module Archive (! (Error Archive))))
+
+(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
new file mode 100644
index 000000000..55ce35145
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/cli.lux
@@ -0,0 +1,39 @@
+(.module:
+  [lux #*
+   [control
+    ["p" parser]]
+   ["." cli (#+ CLI)]
+   [world
+    [file (#+ File)]]])
+
+(type: #export Configuration
+  {#sources (List File)
+   #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
new file mode 100644
index 000000000..726562cc8
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/default/cache.lux b/stdlib/source/lux/platform/compiler/default/cache.lux
new file mode 100644
index 000000000..1770b4a82
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/default/evaluation.lux b/stdlib/source/lux/platform/compiler/default/evaluation.lux
new file mode 100644
index 000000000..ea76624df
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/default/init.lux b/stdlib/source/lux/platform/compiler/default/init.lux
new file mode 100644
index 000000000..c50d37705
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/init.lux
@@ -0,0 +1,198 @@
+(.module:
+  [lux (#- Module loop)
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." product]
+    ["." error (#+ Error)]
+    ["." text ("text/." Hash)]
+    [collection
+     ["." dictionary]]]
+   ["." macro]
+   [world
+    ["." file]]]
+  ["." //
+   ["." syntax (#+ Aliases)]
+   ["." evaluation]
+   ["." phase
+    ["." analysis
+     ["." module]
+     [".A" expression]]
+    ["." synthesis
+     [".S" expression]]
+    ["." translation]
+    ["." statement
+     [".S" total]]
+    ["." extension
+     [".E" analysis]
+     [".E" synthesis]
+     [".E" statement]]]
+   ["/." // (#+ Compiler)
+    ["." host]
+    [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.Error error)
+      (#error.Error 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.Error error)
+            (if (ex.match? syntax.end-of-file error)
+              (#error.Success [state []])
+              (ex.with-stack ///.cannot-compile module (#error.Error 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/name.lux b/stdlib/source/lux/platform/compiler/default/name.lux
new file mode 100644
index 000000000..184b2cab5
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/name.lux
@@ -0,0 +1,47 @@
+(.module:
+  [lux #*
+   [data
+    ["." maybe]
+    ["." text
+     format]]])
+
+(`` (template: (!sanitize char)
+      ("lux syntax char case!" char
+       [["*"] "_ASTER_"
+        ["+"] "_PLUS_"
+        ["-"] "_DASH_"
+        ["/"] "_SLASH_"
+        ["\"] "_BSLASH_"
+        ["_"] "_UNDERS_"
+        ["%"] "_PERCENT_"
+        ["$"] "_DOLLAR_"
+        ["'"] "_QUOTE_"
+        ["`"] "_BQUOTE_"
+        ["@"] "_AT_"
+        ["^"] "_CARET_"
+        ["&"] "_AMPERS_"
+        ["="] "_EQ_"
+        ["!"] "_BANG_"
+        ["?"] "_QM_"
+        [":"] "_COLON_"
+        ["."] "_PERIOD_"
+        [","] "_COMMA_"
+        ["<"] "_LT_"
+        [">"] "_GT_"
+        ["~"] "_TILDE_"
+        ["|"] "_PIPE_"]
+       (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/default/phase.lux b/stdlib/source/lux/platform/compiler/default/phase.lux
new file mode 100644
index 000000000..a81d5dfa7
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase.lux
@@ -0,0 +1,115 @@
+(.module:
+  [lux #*
+   [control
+    ["." state]
+    ["ex" exception (#+ Exception exception:)]
+    [monad (#+ do)]]
+   [data
+    ["." product]
+    ["." error (#+ 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/default/phase/analysis.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis.lux
new file mode 100644
index 000000000..c69ff8eb2
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis.lux
@@ -0,0 +1,349 @@
+(.module:
+  [lux (#- nat int rev)
+   [control
+    [monad (#+ do)]]
+   [data
+    ["." product]
+    ["." error]
+    ["." maybe]
+    ["." text ("text/." Equivalence)
+     format]
+    [collection
+     ["." list ("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.Error error)
+        (#error.Error 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.Error "Impossible error: Drained scopes!"))
+
+      (#error.Error error)
+      (#error.Error 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.Error error)
+          (#error.Error (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/default/phase/analysis/case.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/case.lux
new file mode 100644
index 000000000..5044aed92
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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 ("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.Error error)
+           (///.fail error))]
+      (wrap (#//.Case inputA [outputH outputT])))
+
+    #.Nil
+    (///.throw cannot-have-empty-branches "")))
diff --git a/stdlib/source/lux/platform/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/case/coverage.lux
new file mode 100644
index 000000000..aff981e09
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/case/coverage.lux
@@ -0,0 +1,366 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]
+    equivalence]
+   [data
+    [bit ("bit/." Equivalence)]
+    ["." number]
+    ["." error (#+ Error) ("error/." Monad)]
+    ["." maybe]
+    ["." text
+     format]
+    [collection
+     ["." list ("list/." Functor Fold)]
+     ["." dictionary (#+ Dictionary)]]]]
+  ["." //// ("operation/." 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 _))
+    (operation/wrap #Exhaustive)
+
+    ## Primitive patterns always have partial coverage because there
+    ## are too many possibilities as far as values go.
+    (^template []
+      (#///.Simple ( _))
+      (operation/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))
+    (operation/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.Error 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/default/phase/analysis/expression.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/expression.lux
new file mode 100644
index 000000000..1da6520a5
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/analysis/function.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/function.lux
new file mode 100644
index 000000000..a996457d9
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/function.lux
@@ -0,0 +1,102 @@
+(.module:
+  [lux (#- function)
+   [control
+    monad
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." maybe]
+    ["." text
+     format]
+    [collection
+     ["." list ("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/default/phase/analysis/inference.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/inference.lux
new file mode 100644
index 000000000..010bdc437
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/inference.lux
@@ -0,0 +1,259 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." maybe]
+    ["." text
+     format]
+    [collection
+     ["." list ("list/." Functor)]]]
+   ["." type
+    ["." check]]
+   ["." macro]]
+  ["." /// ("operation/." 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 _)
+    (operation/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)
+                (operation/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))]
+                (operation/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/default/phase/analysis/macro.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/macro.lux
new file mode 100644
index 000000000..af12c747d
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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 ("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.Error 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/default/phase/analysis/module.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux
new file mode 100644
index 000000000..a8f6bda03
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux
@@ -0,0 +1,255 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]
+    pipe]
+   [data
+    ["." text ("text/." Equivalence)
+     format]
+    ["." error]
+    [collection
+     ["." list ("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/default/phase/analysis/primitive.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/primitive.lux
new file mode 100644
index 000000000..bd42825d3
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/analysis/reference.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/reference.lux
new file mode 100644
index 000000000..30da3e60f
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/reference.lux
@@ -0,0 +1,79 @@
+(.module:
+  [lux #*
+   [control
+    monad
+    ["ex" exception (#+ exception:)]]
+   ["." macro]
+   [data
+    [text ("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/default/phase/analysis/scope.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/scope.lux
new file mode 100644
index 000000000..2849e059d
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/analysis/scope.lux
@@ -0,0 +1,206 @@
+(.module:
+  [lux #*
+   [control
+    monad
+    ["ex" exception (#+ exception:)]]
+   [data
+    [text ("text/." Equivalence)
+     format]
+    ["." maybe ("maybe/." Monad)]
+    ["." product]
+    ["e" error]
+    [collection
+     ["." list ("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.Error error)
+          (#e.Error 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.Error error)
+        (#e.Error 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/default/phase/analysis/structure.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/structure.lux
new file mode 100644
index 000000000..43cb8e0d2
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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 ("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/default/phase/analysis/type.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/type.lux
new file mode 100644
index 000000000..36fee29f8
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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.Error 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/default/phase/extension.lux b/stdlib/source/lux/platform/compiler/default/phase/extension.lux
new file mode 100644
index 000000000..75814ad24
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/extension.lux
@@ -0,0 +1,140 @@
+(.module:
+  [lux (#- Name)
+   [control
+    [monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." error (#+ Error)]
+    ["." text ("text/." Order)
+     format]
+    [collection
+     ["." list ("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.Error error)
+          (#error.Error 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.Error error)
+        (#error.Error 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.Error error)
+      (#error.Error error))))
diff --git a/stdlib/source/lux/platform/compiler/default/phase/extension/analysis.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis.lux
new file mode 100644
index 000000000..cc4736ac0
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis.lux
@@ -0,0 +1,17 @@
+(.module:
+  [lux #*
+   [data
+    [collection
+     ["." dictionary]]]]
+  [///
+   [analysis (#+ Bundle)]
+   [//
+    [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/default/phase/extension/analysis/common.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis/common.lux
new file mode 100644
index 000000000..d599af130
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis/common.lux
@@ -0,0 +1,218 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]]
+   [data
+    ["." text
+     format]
+    [collection
+     ["." list ("list/." Functor)]
+     ["." dictionary (#+ Dictionary)]]]
+   [type
+    ["." check]]
+   ["." macro]
+   [io (#+ IO)]]
+  ["." ///
+   ["." bundle]
+   ["//." //
+    ["." analysis (#+ Analysis Handler Bundle)
+     [".A" type]
+     [".A" case]
+     [".A" function]]
+    [//
+     [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/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis/host.jvm.lux
new file mode 100644
index 000000000..a494b0e44
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis/host.jvm.lux
@@ -0,0 +1,1271 @@
+(.module:
+  [lux (#- char int)
+   [control
+    ["." monad (#+ do)]
+    ["p" parser]
+    ["ex" exception (#+ exception:)]
+    pipe]
+   [data
+    ["e" error]
+    ["." maybe]
+    ["." product]
+    ["." text ("text/." Equivalence)
+     format]
+    [collection
+     ["." list ("list/." Fold Functor Monoid)]
+     ["." array (#+ Array)]
+     ["." dictionary (#+ Dictionary)]]]
+   ["." type
+    ["." check]]
+   ["." macro
+    ["s" syntax]]
+   ["." host (#+ import:)]]
+  [//
+   ["." common]
+   ["/." //
+    ["." bundle]
+    ["//." // ("operation/." 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 _)
+    (operation/wrap name)
+
+    (#.Named name unnamed)
+    (check-jvm unnamed)
+
+    (#.Var id)
+    (operation/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)
+      (operation/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))]
+      (operation/wrap [(#.Primitive boxed-name #.Nil)
+                       boxed-name]))
+
+    (#.Primitive name _)
+    (if (dictionary.contains? name boxes)
+      (////.throw primitives-cannot-have-type-parameters name)
+      (operation/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)
+      (#e.Success [class])
+      (wrap class)
+
+      (#e.Error 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)
+        (operation/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)
+            (operation/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)
+            
+            _
+            (operation/wrap Any)))
+
+        (host.instance? Class java-type)
+        (let [java-type (:coerce (Class Object) java-type)
+              class-name (Class::getName java-type)]
+          (operation/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)))]
+              (operation/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
+            (operation/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)
+      (#e.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))))
+
+      (#e.Error _)
+      (////.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)
+        (operation/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))
+        (operation/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 (: (e.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))))))
+      (#e.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 (: (e.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))))))
+      (#e.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 (: (e.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!)))
+      (#e.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 (: (e.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))))))
+      (#e.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 (: (e.Error [Text (List [Text Code])])
+             (s.run args ($_ p.and s.text (p.some (s.tuple (p.and s.text s.any))))))
+      (#e.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/default/phase/extension/bundle.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/bundle.lux
new file mode 100644
index 000000000..582526694
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/extension/bundle.lux
@@ -0,0 +1,28 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]]
+   [data
+    ["." text
+     format]
+    [collection
+     [list ("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/default/phase/extension/statement.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/statement.lux
new file mode 100644
index 000000000..e5963e96c
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/extension/statement.lux
@@ -0,0 +1,199 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ do)]
+    pipe]
+   [data
+    [text
+     format]
+    [collection
+     [list ("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/default/phase/extension/synthesis.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/synthesis.lux
new file mode 100644
index 000000000..1a2e44f6f
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/extension/translation.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/translation.lux
new file mode 100644
index 000000000..232c8c168
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/statement.lux b/stdlib/source/lux/platform/compiler/default/phase/statement.lux
new file mode 100644
index 000000000..c7ff3719f
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/statement/total.lux b/stdlib/source/lux/platform/compiler/default/phase/statement/total.lux
new file mode 100644
index 000000000..15f116aa1
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/synthesis.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis.lux
new file mode 100644
index 000000000..cf29ad74b
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/synthesis.lux
@@ -0,0 +1,468 @@
+(.module:
+  [lux (#- i64 Scope)
+   [control
+    [monad (#+ do)]
+    [equivalence (#+ Equivalence)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    [bit ("bit/." Equivalence)]
+    ["." text ("text/." Equivalence)
+     format]
+    [collection
+     [list ("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 _ (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 _ (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 (Equivalence Equivalence)
+  (All [a] (-> (Equivalence a) (Equivalence (Path' a))))
+
+  (def: (= reference sample)
+    (case [reference sample]
+      [#Pop #Pop]
+      true
+
+      (^template [ ]
+        [( reference') ( sample')]
+        (::  = reference' sample'))
+      ([#Test   Equivalence]
+       [#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 Synthesis)
+  (def: (= reference sample)
+    (case [reference sample]
+      (^template [ ]
+        [( reference') ( sample')]
+        (::  = reference' sample'))
+      ([#Primitive Equivalence])
+
+      _
+      false)))
+
+(def: #export Equivalence
+  (Equivalence Path)
+  (Equivalence Equivalence))
diff --git a/stdlib/source/lux/platform/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/case.lux
new file mode 100644
index 000000000..e9e941a30
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/synthesis/case.lux
@@ -0,0 +1,169 @@
+(.module:
+  [lux #*
+   [control
+    [equivalence (#+ Equivalence)]
+    pipe
+    ["." monad (#+ do)]]
+   [data
+    ["." product]
+    [bit ("bit/." Equivalence)]
+    [text ("text/." Equivalence)
+     format]
+    [number ("frac/." Equivalence)]
+    [collection
+     ["." list ("list/." Fold Monoid)]]]]
+  ["." // (#+ Path Synthesis Operation Phase)
+   ["." function]
+   ["/." // ("operation/." 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)
+        (operation/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]))
+    (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Side (if right?
+                                                             (#.Right lefts)
+                                                             (#.Left lefts)))))))
+        (path' value-pattern end?)
+        (when (not end?) (operation/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?)]
+                     (<| (operation/map (|>> (#//.Seq (#//.Access (#//.Member (if right?
+                                                                                (#.Right (dec tuple::lefts))
+                                                                                (#.Left tuple::lefts)))))))
+                         (path' tuple::member end?')
+                         (when (not end?') (operation/map ..clean-up))
+                         nextC)))
+                 thenC
+                 (list.reverse (list.enumerate tuple))))))
+
+(def: #export (path synthesize pattern bodyA)
+  (-> Phase Pattern Analysis (Operation Path))
+  (path' pattern true (operation/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/default/phase/synthesis/expression.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/expression.lux
new file mode 100644
index 000000000..0d15ae463
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/synthesis/expression.lux
@@ -0,0 +1,86 @@
+(.module:
+  [lux (#- primitive)
+   [control
+    ["." monad (#+ do)]
+    pipe]
+   [data
+    ["." maybe]
+    ["." error]
+    [collection
+     ["." list ("list/." Functor)]
+     ["." dictionary (#+ Dictionary)]]]]
+  ["." // (#+ Synthesis Phase)
+   ["." function]
+   ["." case]
+   ["/." // ("operation/." 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')
+    (operation/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)
+    (operation/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.Error error)
+                 (<| (///.run' state)
+                     (do ///.Monad
+                       [argsS+ (monad.map @ phase args)]
+                       (wrap (#//.Extension [name argsS+])))))))
+    ))
diff --git a/stdlib/source/lux/platform/compiler/default/phase/synthesis/function.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/function.lux
new file mode 100644
index 000000000..267d941fc
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/synthesis/function.lux
@@ -0,0 +1,211 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." maybe]
+    ["." text
+     format]
+    [collection
+     ["." list ("list/." Functor Monoid Fold)]
+     ["dict" dictionary (#+ Dictionary)]]]]
+  ["." // (#+ Path Synthesis Operation Phase)
+   ["." loop (#+ Transform)]
+   ["/." // ("operation/." 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)
+    (operation/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)
+    (operation/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
+        (operation/map (|>> #//.Then)))
+
+    _
+    (operation/wrap path)))
+
+(def: (grow-sub-environment super sub)
+  (-> Environment Environment (Operation Environment))
+  (monad.map ///.Monad
+             (function (_ variable)
+               (case variable
+                 (#reference.Local register)
+                 (operation/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)
+          (operation/map (|>> [lefts right?] //.variant)))
+      
+      (#analysis.Tuple membersS+)
+      (|> membersS+
+          (monad.map ///.Monad (grow environment))
+          (operation/map (|>> //.tuple))))
+
+    (^ (..self-reference))
+    (operation/wrap (//.function/apply [expression (list (//.variable/local 1))]))
+    
+    (#//.Reference reference)
+    (case reference
+      (#reference.Variable variable)
+      (case variable
+        (#reference.Local register)
+        (operation/wrap (//.variable/local (inc register)))
+        
+        (#reference.Foreign register)
+        (|> register
+            (find-foreign environment)
+            (operation/map (|>> //.variable))))
+      
+      (#reference.Constant constant)
+      (operation/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))
+            (operation/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+]))
+          (operation/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))
+        (operation/map (|>> (#//.Extension name))))
+
+    _
+    (operation/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/default/phase/synthesis/loop.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/loop.lux
new file mode 100644
index 000000000..cd57c1d29
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/synthesis/loop.lux
@@ -0,0 +1,291 @@
+(.module:
+  [lux (#- loop)
+   [control
+    ["." monad (#+ do)]
+    ["p" parser]]
+   [data
+    ["." maybe ("maybe/." Monad)]
+    [collection
+     ["." list ("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/default/phase/translation.lux b/stdlib/source/lux/platform/compiler/default/phase/translation.lux
new file mode 100644
index 000000000..fb40f4652
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation.lux
@@ -0,0 +1,250 @@
+(.module:
+  [lux #*
+   [control
+    ["ex" exception (#+ exception:)]
+    [monad (#+ do)]]
+   [data
+    ["." product]
+    ["." error (#+ Error)]
+    ["." name ("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.Error error)
+        (#error.Error 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.Error error)
+           (#error.Error 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.Error 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.Error 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/default/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/case.jvm.lux
new file mode 100644
index 000000000..4a963d507
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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 ("list/." Functor Fold)]
+     [set (#+ Set)]]]]
+  [//
+   ["." runtime (#+ Operation Phase)]
+   ["." reference]
+   ["/." /// ("operation/." 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
+    (operation/wrap pop-cursor!)
+
+    (#synthesis.Bind register)
+    (operation/wrap (_.define (reference.local' register) [(list) #.None]
+                              cursor-top))
+
+    (^template [  <=>]
+      (^ ( value))
+      (operation/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))
+      (operation/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))
+      (operation/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/default/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/expression.jvm.lux
new file mode 100644
index 000000000..53d7bbbcb
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension.jvm.lux
new file mode 100644
index 000000000..a40b4953f
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux
new file mode 100644
index 000000000..a503949dd
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux
@@ -0,0 +1,254 @@
+(.module:
+  [lux #*
+   [control
+    ["." monad (#+ do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["e" error]
+    ["." product]
+    ["." text
+     format]
+    [number (#+ hex)]
+    [collection
+     ["." list ("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)]]]]])
+
+## [Types]
+(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))
+
+## [Utils]
+(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))))))
+
+## [Bundle]
+## [[Lux]]
+(def: bundle::lux
+  Bundle
+  (|> bundle.empty
+      (bundle.install "is?" (binary (product.uncurry _.eq?/2)))
+      (bundle.install "try" (unary runtime.lux//try))))
+
+## [[Bits]]
+(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))
+          )))
+
+## [[Numbers]]
+(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)))))
+
+## [[Text]]
+(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)))))
+
+## [[IO]]
+(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))))))))
+
+## [Bundles]
+(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/default/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/host.jvm.lux
new file mode 100644
index 000000000..b8b2b7612
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/function.jvm.lux
new file mode 100644
index 000000000..7eeb5a8ed
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/function.jvm.lux
@@ -0,0 +1,92 @@
+(.module:
+  [lux (#- function)
+   [control
+    ["." monad (#+ do)]
+    pipe]
+   [data
+    ["." product]
+    [text
+     format]
+    [collection
+     ["." list ("list/." Functor)]]]]
+  [//
+   ["." runtime (#+ Operation Phase)]
+   ["." reference]
+   ["/." //
+    ["//." // ("operation/." 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"))]
+    (operation/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/default/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/loop.jvm.lux
new file mode 100644
index 000000000..91757d291
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/loop.jvm.lux
@@ -0,0 +1,41 @@
+(.module:
+  [lux (#- Scope)
+   [control
+    ["." monad (#+ do)]]
+   [data
+    ["." product]
+    ["." text
+     format]
+    [collection
+     ["." list ("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/default/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/primitive.jvm.lux
new file mode 100644
index 000000000..c16c696c4
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/primitive.jvm.lux
@@ -0,0 +1,25 @@
+(.module:
+  [lux (#- i64)]
+  [//
+   [runtime (#+ Operation)]
+   [// (#+ State)
+    [// ("operation/." Monad)
+     [///
+      [host
+       ["_" scheme (#+ Expression)]]]]]])
+
+(def: #export bit
+  (-> Bit (Operation Expression))
+  (|>> _.bool operation/wrap))
+
+(def: #export i64
+  (-> (I64 Any) (Operation Expression))
+  (|>> .int _.int operation/wrap))
+
+(def: #export f64
+  (-> Frac (Operation Expression))
+  (|>> _.float operation/wrap))
+
+(def: #export text
+  (-> Text (Operation Expression))
+  (|>> _.string operation/wrap))
diff --git a/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/reference.jvm.lux
new file mode 100644
index 000000000..6d4088189
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/reference.jvm.lux
@@ -0,0 +1,48 @@
+(.module:
+  [lux #*
+   [control
+    pipe]
+   [data
+    [text
+     format]]]
+  [//
+   [runtime (#+ Operation)]
+   ["/." //
+    [// ("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))
+       operation/wrap))
+
+(def: #export constant
+  (-> Name (Operation Global))
+  (|>> ///.remember (operation/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/default/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/runtime.jvm.lux
new file mode 100644
index 000000000..43748c3b1
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/runtime.jvm.lux
@@ -0,0 +1,322 @@
+(.module:
+  [lux #*
+   [control
+    ["p" parser ("parser/." Monad)]
+    [monad (#+ do)]]
+   [data
+    [number (#+ hex)]
+    [text
+     format]
+    [collection
+     ["." list ("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 (parser/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/default/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/structure.jvm.lux
new file mode 100644
index 000000000..3991ea281
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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/platform/compiler/default/platform.lux b/stdlib/source/lux/platform/compiler/default/platform.lux
new file mode 100644
index 000000000..e5d881833
--- /dev/null
+++ b/stdlib/source/lux/platform/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 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.Error 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.Error error)
+      ##   (:: (get@ #file-system platform) lift (#error.Error 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.Error "NOT DONE!"))
+            
+            (#.Right done)
+            (wrap []))
+          
+          (#error.Error error)
+          (:: (get@ #file-system platform) lift (#error.Error error))))))
+  )
diff --git a/stdlib/source/lux/platform/compiler/default/reference.lux b/stdlib/source/lux/platform/compiler/default/reference.lux
new file mode 100644
index 000000000..b945c1327
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/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 Variable)
+  (def: (= reference sample)
+    (case [reference sample]
+      (^template []
+        [( reference') ( sample')]
+        (n/= reference' sample'))
+      ([#Local] [#Foreign])
+
+      _
+      #0)))
+
+(structure: #export _ (Hash Variable)
+  (def: eq 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/compiler/default/syntax.lux b/stdlib/source/lux/platform/compiler/default/syntax.lux
new file mode 100644
index 000000000..5e1990393
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/default/syntax.lux
@@ -0,0 +1,557 @@
+## 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]
+    ["." 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.Error 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.Error error)
+                   (#error.Error 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.Error error)
+          (#error.Error error))
+
+        (#error.Error error)
+        (let [[where offset _] source]
+          (<| (!with-char+ source-code//size source-code offset closing-char (#error.Error 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.Error error)
+                (#error.Error 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.Error error)
+    (#error.Error error)))
+
+(def: no-exponent Offset 0)
+
+(with-expansions [ (as-is (!number-output start end number.Codec #.Int))
+                   (as-is (!number-output start end number.Codec #.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 number.Codec #.Nat]
+  [!parse-rev number.Codec #.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.Error 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.Error error)
+            (#error.Error 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.Error error)
+      (#error.Error 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.Error error)
+                        (#error.Error error)))
+                    )))
+            
+            (#error.Error error)
+            (#error.Error 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.Error error)
+      (#error.Error 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
new file mode 100644
index 000000000..218de67a4
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/host/scheme.lux b/stdlib/source/lux/platform/compiler/host/scheme.lux
new file mode 100644
index 000000000..8d5cbdbcd
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/host/scheme.lux
@@ -0,0 +1,306 @@
+(.module:
+  [lux (#- Code' Code int or and if function cond when let)
+   [control
+    pipe]
+   [data
+    ["." number]
+    ["." text
+     format]
+    [collection
+     ["." list ("list/." Functor Fold)]]]
+   [type
+    abstract]])
+
+(abstract: Global' {} Any)
+(abstract: Var' {} Any)
+(abstract: Computation' {} Any)
+(abstract: (Expression' k) {} Any)
+
+(abstract: (Code' k)
+  {}
+  
+  Text
+
+  (type: #export Code (Ex [k] (Code' k)))
+  (type: #export Expression (Code' (Ex [k] (Expression' k))))
+  (type: #export Global (Code' (Expression' Global')))
+  (type: #export Computation (Code' (Expression' Computation')))
+  (type: #export Var (Code' (Expression' Var')))
+
+  (type: #export Arguments
+    {#mandatory (List Var)
+     #rest (Maybe Var)})
+
+  (def: #export code (-> Code Text) (|>> :representation))
+
+  (def: #export var (-> Text Var) (|>> :abstraction))
+
+  (def: (arguments [vars rest])
+    (-> Arguments Code)
+    (case rest
+      (#.Some rest)
+      (case vars
+        #.Nil
+        rest
+
+        _
+        (|> (format " . " (:representation rest))
+            (format (|> vars
+                        (list/map ..code)
+                        (text.join-with " ")))
+            (text.enclose ["(" ")"])
+            :abstraction))
+      
+      #.None
+      (|> vars
+          (list/map ..code)
+          (text.join-with " ")
+          (text.enclose ["(" ")"])
+          :abstraction)))
+
+  (def: #export nil
+    Computation
+    (:abstraction "'()"))
+
+  (def: #export bool
+    (-> Bit Computation)
+    (|>> (case> #0 "#f"
+                #1 "#t")
+         :abstraction))
+
+  (def: #export int
+    (-> Int Computation)
+    (|>> %i :abstraction))
+
+  (def: #export float
+    (-> Frac Computation)
+    (|>> (cond> [(f/= number.positive-infinity)]
+                [(new> "+inf.0")]
+                
+                [(f/= number.negative-infinity)]
+                [(new> "-inf.0")]
+                
+                [number.not-a-number?]
+                [(new> "+nan.0")]
+                
+                ## else
+                [%f])
+         :abstraction))
+
+  (def: #export positive-infinity Computation (..float number.positive-infinity))
+  (def: #export negative-infinity Computation (..float number.negative-infinity))
+  (def: #export not-a-number Computation (..float number.not-a-number))
+
+  (def: #export string
+    (-> Text Computation)
+    (|>> %t :abstraction))
+
+  (def: #export symbol
+    (-> Text Computation)
+    (|>> (format "'") :abstraction))
+
+  (def: #export global
+    (-> Text Global)
+    (|>> :abstraction))
+
+  (def: form
+    (-> (List Code) Text)
+    (|>> (list/map ..code)
+         (text.join-with " ")
+         (text.enclose ["(" ")"])))
+  
+  (def: #export (apply/* func args)
+    (-> Expression (List Expression) Computation)
+    (:abstraction (..form (#.Cons func args))))
+  
+  (do-template [ ]
+    [(def: #export 
+       (-> (List Expression) Computation)
+       (apply/* (..global )))]
+
+    [vector/* "vector"]
+    [list/*   "list"]
+    )
+
+  (def: #export (apply/0 func)
+    (-> Expression Computation)
+    (..apply/* func (list)))
+
+  (do-template [ ]
+    [(def: #export  (apply/0 (..global )))]
+
+    [newline/0 "newline"]
+    )
+
+  (def: #export (apply/1 func)
+    (-> Expression (-> Expression Computation))
+    (|>> (list) (..apply/* func)))
+
+  (do-template [ ]
+    [(def: #export  (apply/1 (..global )))]
+
+    [exact/1 "exact"]
+    [integer->char/1 "integer->char"]
+    [number->string/1 "number->string"]
+    [string/1 "string"]
+    [length/1 "length"]
+    [values/1 "values"]
+    [null?/1 "null?"]
+    [car/1 "car"]
+    [cdr/1 "cdr"]
+    [raise/1 "raise"]
+    [error-object-message/1 "error-object-message"]
+    [make-vector/1 "make-vector"]
+    [vector-length/1 "vector-length"]
+    [not/1 "not"]
+    [string-length/1 "string-length"]
+    [string-hash/1 "string-hash"]
+    [reverse/1 "reverse"]
+    [display/1 "display"]
+    [exit/1 "exit"]
+    )
+  
+  (def: #export (apply/2 func)
+    (-> Expression (-> Expression Expression Computation))
+    (.function (_ _0 _1)
+      (..apply/* func (list _0 _1))))
+
+  (do-template [ ]
+    [(def: #export  (apply/2 (..global )))]
+
+    [append/2 "append"]
+    [cons/2 "cons"]
+    [make-vector/2 "make-vector"]
+    [vector-ref/2 "vector-ref"]
+    [list-tail/2 "list-tail"]
+    [map/2 "map"]
+    [string-ref/2 "string-ref"]
+    [string-append/2 "string-append"]
+    )
+
+  (do-template [ ]
+    [(def: #export ( param subject)
+       (-> Expression Expression Computation)
+       (..apply/2 (..global ) subject param))]
+
+    [=/2   "="]
+    [eq?/2 "eq?"]
+    [eqv?/2 "eqv?"]
+    [/2   ">"]
+    [>=/2  ">="]
+    [string=?/2 "string=?"]
+    [string Expression (-> Expression Expression Expression Computation))
+    (.function (_ _0 _1 _2)
+      (..apply/* func (list _0 _1 _2))))
+
+  (do-template [ ]
+    [(def: #export  (apply/3 (..global )))]
+
+    [substring/3 "substring"]
+    [vector-set!/3 "vector-set!"]
+    )
+
+  (def: #export (vector-copy!/5 _0 _1 _2 _3 _4)
+    (-> Expression Expression Expression Expression Expression
+        Computation)
+    (..apply/* (..global "vector-copy!")
+               (list _0 _1 _2 _3 _4)))
+  
+  (do-template [ ]
+    [(def: #export 
+       (-> (List Expression) Computation)
+       (|>> (list& (..global )) ..form :abstraction))]
+
+    [or "or"]
+    [and "and"]
+    )
+
+  (do-template [   
]
+    [(def: #export ( bindings body)
+       (-> (List [ Expression]) Expression Computation)
+       (:abstraction
+        (..form (list (..global )
+                      (|> bindings
+                          (list/map (.function (_ [binding/name binding/value])
+                                      (:abstraction
+                                       (..form (list (
 binding/name)
+                                                     binding/value)))))
+                          ..form
+                          :abstraction)
+                      body))))]
+
+    [let           "let"           Var       .id]
+    [let*          "let*"          Var       .id]
+    [letrec        "letrec"        Var       .id]
+    [let-values    "let-values"    Arguments ..arguments]
+    [let*-values   "let*-values"   Arguments ..arguments]
+    [letrec-values "letrec-values" Arguments ..arguments]
+    )
+
+  (def: #export (if test then else)
+    (-> Expression Expression Expression Computation)
+    (:abstraction
+     (..form (list (..global "if") test then else))))
+
+  (def: #export (when test then)
+    (-> Expression Expression Computation)
+    (:abstraction
+     (..form (list (..global "when") test then))))
+
+  (def: #export (cond clauses else)
+    (-> (List [Expression Expression]) Expression Computation)
+    (|> (list/fold (.function (_ [test then] next)
+                     (if test then next))
+                   else
+                   (list.reverse clauses))
+        :representation
+        :abstraction))
+
+  (def: #export (lambda arguments body)
+    (-> Arguments Expression Computation)
+    (:abstraction
+     (..form (list (..global "lambda")
+                   (..arguments arguments)
+                   body))))
+
+  (def: #export (define name arguments body)
+    (-> Var Arguments Expression Computation)
+    (:abstraction
+     (..form (list (..global "define")
+                   (|> arguments
+                       (update@ #mandatory (|>> (#.Cons name)))
+                       ..arguments)
+                   body))))
+
+  (def: #export begin
+    (-> (List Expression) Computation)
+    (|>> (#.Cons (..global "begin")) ..form :abstraction))
+
+  (def: #export (set! name value)
+    (-> Var Expression Computation)
+    (:abstraction
+     (..form (list (..global "set!") name value))))
+
+  (def: #export (with-exception-handler handler body)
+    (-> Expression Expression Computation)
+    (:abstraction
+     (..form (list (..global "with-exception-handler") handler body))))
+  )
diff --git a/stdlib/source/lux/platform/compiler/meta/archive.lux b/stdlib/source/lux/platform/compiler/meta/archive.lux
new file mode 100644
index 000000000..f36a0b754
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/meta/archive.lux
@@ -0,0 +1,75 @@
+(.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 )
+
+    (def: #export empty
+      Archive
+      (:abstraction (dictionary.new text.Hash)))
+
+    (def: #export (add name document archive)
+      (-> Module  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 (:abstraction (dictionary.put name document
+                                                      (:representation archive))))))
+
+    (def: #export (find name archive)
+      (-> Module Archive (Error ))
+      (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' document'] archive')
+                    (..add name' 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
new file mode 100644
index 000000000..6c7e6744e
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/meta/archive/descriptor.lux
@@ -0,0 +1,13 @@
+(.module:
+  [lux (#- Module)
+   [world
+    [file (#+ File)]]])
+
+(type: #export Module Text)
+
+(type: #export Descriptor
+  {#hash Nat
+   #name Module
+   #file File
+   #references (List 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
new file mode 100644
index 000000000..b99ff9b72
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/meta/archive/document.lux
@@ -0,0 +1,53 @@
+(.module:
+  [lux (#- Module)
+   [control
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." error (#+ Error)]
+    [collection
+     ["." dictionary (#+ Dictionary)]]]
+   [type (#+ :share)
+    abstract]]
+  [//
+   ["." signature (#+ Signature)]
+   ["." key (#+ Key)]
+   ["." descriptor (#+ Module Descriptor)]])
+
+## Document
+(exception: #export (invalid-signature {module Module} {expected Signature} {actual Signature})
+  (ex.report ["Module" module]
+             ["Expected" (signature.description expected)]
+             ["Actual" (signature.description actual)]))
+
+(abstract: #export (Document d)
+  {}
+  
+  {#signature Signature
+   #descriptor Descriptor
+   #content d}
+
+  (def: #export (read key document)
+    (All [d] (-> (Key d) (Document Any) (Error d)))
+    (let [[document//signature document//descriptor 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 [(get@ #descriptor.name document//descriptor)
+                                     (key.signature key)
+                                     document//signature]))))
+
+  (def: #export (write key descriptor content)
+    (All [d] (-> (Key d) Descriptor d (Document d)))
+    (:abstraction {#signature (key.signature key)
+                   #descriptor descriptor
+                   #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
new file mode 100644
index 000000000..50c10ac01
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/meta/archive/signature.lux b/stdlib/source/lux/platform/compiler/meta/archive/signature.lux
new file mode 100644
index 000000000..5332b79c3
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/meta/cache.lux b/stdlib/source/lux/platform/compiler/meta/cache.lux
new file mode 100644
index 000000000..bcb7c98f0
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/meta/cache.lux
@@ -0,0 +1,178 @@
+(.module:
+  [lux (#- Module)
+   [control
+    ["." monad (#+ Monad do)]
+    ["ex" exception (#+ exception:)]
+    pipe]
+   [data
+    ["." bit ("bit/." Equivalence)]
+    ["." maybe]
+    ["." error]
+    ["." product]
+    [format
+     ["." binary (#+ Format)]]
+    ["." text
+     [format (#- Format)]]
+    [collection
+     ["." list ("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.Error 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
new file mode 100644
index 000000000..e63fa192b
--- /dev/null
+++ b/stdlib/source/lux/platform/compiler/meta/cache/dependency.lux
@@ -0,0 +1,53 @@
+(.module:
+  [lux (#- Module)
+   [data
+    ["." text]
+    [collection
+     [list ("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
new file mode 100644
index 000000000..dd261a539
--- /dev/null
+++ b/stdlib/source/lux/platform/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/platform/compiler/meta/io/archive.lux b/stdlib/source/lux/platform/compiler/meta/io/archive.lux
new file mode 100644
index 000000000..1f0714b25
--- /dev/null
+++ b/stdlib/source/lux/platform/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.Error _)
+          (:: 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
new file mode 100644
index 000000000..32e05c219
--- /dev/null
+++ b/stdlib/source/lux/platform/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.Error _)
+        (:: System throw ..cannot-read-module [module])))))
diff --git a/stdlib/source/lux/platform/interpreter.lux b/stdlib/source/lux/platform/interpreter.lux
new file mode 100644
index 000000000..8a6d00578
--- /dev/null
+++ b/stdlib/source/lux/platform/interpreter.lux
@@ -0,0 +1,221 @@
+(.module:
+  [lux #*
+   [control
+    [monad (#+ Monad do)]
+    ["ex" exception (#+ exception:)]]
+   [data
+    ["." error (#+ Error)]
+    ["." text ("text/." Equivalence)
+     format]]
+   [type (#+ :share)
+    ["." check]]
+   [compiler
+    ["." cli (#+ Configuration)]
+    ["." default
+     ["." syntax]
+     ["." platform (#+ Platform)]
+     ["." init]
+     ["." phase
+      ["." analysis
+       ["." module]
+       ["." type]]
+      ["." translation]
+      ["." statement (#+ State+ Operation)
+       ["." total]]
+      ["." extension]]]]
+   [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.Error 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.Error 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.Error 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
new file mode 100644
index 000000000..7d3ac0d9c
--- /dev/null
+++ b/stdlib/source/lux/platform/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.Error 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.Error error)
+    (ex.construct cannot-represent-value [type])))
-- 
cgit v1.2.3