From 3da30aff80bc8c80e090574887a58c6015ceb694 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Mon, 29 Oct 2018 21:54:10 -0400 Subject: Extracted "phase" from under "lux/platform/compiler/default". --- new-luxc/source/luxc/lang/host/jvm.lux | 4 +- new-luxc/source/luxc/lang/host/jvm/inst.lux | 4 +- new-luxc/source/luxc/lang/translation/jvm.lux | 7 +- .../source/luxc/lang/translation/jvm/case.jvm.lux | 5 +- .../luxc/lang/translation/jvm/common.jvm.lux | 7 +- .../luxc/lang/translation/jvm/expression.jvm.lux | 7 +- .../luxc/lang/translation/jvm/function.jvm.lux | 11 +- .../source/luxc/lang/translation/jvm/loop.jvm.lux | 9 +- .../luxc/lang/translation/jvm/primitive.jvm.lux | 3 +- .../lang/translation/jvm/procedure/common.jvm.lux | 9 +- .../luxc/lang/translation/jvm/reference.jvm.lux | 9 +- .../luxc/lang/translation/jvm/runtime.jvm.lux | 7 +- .../luxc/lang/translation/jvm/structure.jvm.lux | 5 +- new-luxc/source/program.lux | 8 +- .../lux/platform/compiler/default/evaluation.lux | 2 +- .../source/lux/platform/compiler/default/init.lux | 26 +- .../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 | 6 +- .../lux/platform/compiler/default/reference.lux | 88 -- stdlib/source/lux/platform/compiler/name.lux | 47 + stdlib/source/lux/platform/compiler/phase.lux | 115 ++ .../lux/platform/compiler/phase/analysis.lux | 349 ++++++ .../lux/platform/compiler/phase/analysis/case.lux | 300 +++++ .../compiler/phase/analysis/case/coverage.lux | 366 ++++++ .../compiler/phase/analysis/expression.lux | 109 ++ .../platform/compiler/phase/analysis/function.lux | 102 ++ .../platform/compiler/phase/analysis/inference.lux | 259 ++++ .../lux/platform/compiler/phase/analysis/macro.lux | 79 ++ .../platform/compiler/phase/analysis/module.lux | 255 ++++ .../platform/compiler/phase/analysis/primitive.lux | 29 + .../platform/compiler/phase/analysis/reference.lux | 79 ++ .../lux/platform/compiler/phase/analysis/scope.lux | 206 ++++ .../platform/compiler/phase/analysis/structure.lux | 358 ++++++ .../lux/platform/compiler/phase/analysis/type.lux | 52 + .../lux/platform/compiler/phase/extension.lux | 140 +++ .../platform/compiler/phase/extension/analysis.lux | 18 + .../compiler/phase/extension/analysis/common.lux | 219 ++++ .../compiler/phase/extension/analysis/host.jvm.lux | 1271 ++++++++++++++++++++ .../platform/compiler/phase/extension/bundle.lux | 28 + .../compiler/phase/extension/statement.lux | 199 +++ .../compiler/phase/extension/synthesis.lux | 10 + .../compiler/phase/extension/translation.lux | 10 + .../lux/platform/compiler/phase/statement.lux | 45 + .../platform/compiler/phase/statement/total.lux | 56 + .../lux/platform/compiler/phase/synthesis.lux | 468 +++++++ .../lux/platform/compiler/phase/synthesis/case.lux | 169 +++ .../compiler/phase/synthesis/expression.lux | 86 ++ .../platform/compiler/phase/synthesis/function.lux | 211 ++++ .../lux/platform/compiler/phase/synthesis/loop.lux | 291 +++++ .../lux/platform/compiler/phase/translation.lux | 250 ++++ .../compiler/phase/translation/scheme/case.jvm.lux | 177 +++ .../phase/translation/scheme/expression.jvm.lux | 59 + .../phase/translation/scheme/extension.jvm.lux | 15 + .../translation/scheme/extension/common.jvm.lux | 254 ++++ .../translation/scheme/extension/host.jvm.lux | 11 + .../phase/translation/scheme/function.jvm.lux | 92 ++ .../compiler/phase/translation/scheme/loop.jvm.lux | 41 + .../phase/translation/scheme/primitive.jvm.lux | 25 + .../phase/translation/scheme/reference.jvm.lux | 48 + .../phase/translation/scheme/runtime.jvm.lux | 322 +++++ .../phase/translation/scheme/structure.jvm.lux | 33 + stdlib/source/lux/platform/compiler/reference.lux | 88 ++ stdlib/source/lux/platform/interpreter.lux | 20 +- 104 files changed, 7410 insertions(+), 7419 deletions(-) delete mode 100644 stdlib/source/lux/platform/compiler/default/name.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/case.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/case/coverage.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/expression.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/function.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/inference.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/macro.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/primitive.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/reference.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/scope.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/structure.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/analysis/type.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/analysis.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/analysis/common.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/analysis/host.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/bundle.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/statement.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/synthesis.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/extension/translation.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/statement.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/statement/total.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/case.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/expression.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/function.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/synthesis/loop.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/case.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/expression.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/host.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/function.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/loop.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/primitive.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/reference.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/runtime.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/phase/translation/scheme/structure.jvm.lux delete mode 100644 stdlib/source/lux/platform/compiler/default/reference.lux create mode 100644 stdlib/source/lux/platform/compiler/name.lux create mode 100644 stdlib/source/lux/platform/compiler/phase.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/case.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/expression.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/function.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/inference.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/macro.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/module.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/reference.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/scope.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/structure.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/analysis/type.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/analysis.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/bundle.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/statement.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/extension/translation.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/statement.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/statement/total.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/case.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/function.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux create mode 100644 stdlib/source/lux/platform/compiler/reference.lux diff --git a/new-luxc/source/luxc/lang/host/jvm.lux b/new-luxc/source/luxc/lang/host/jvm.lux index 49f02c0f0..656d07d21 100644 --- a/new-luxc/source/luxc/lang/host/jvm.lux +++ b/new-luxc/source/luxc/lang/host/jvm.lux @@ -12,8 +12,8 @@ [host (#+ import:)] [world [binary (#+ Binary)]] - [compiler - [default + [platform + [compiler [reference (#+ Register)] [phase ["." translation]]]]]) diff --git a/new-luxc/source/luxc/lang/host/jvm/inst.lux b/new-luxc/source/luxc/lang/host/jvm/inst.lux index 44ce0839a..9a26f8df0 100644 --- a/new-luxc/source/luxc/lang/host/jvm/inst.lux +++ b/new-luxc/source/luxc/lang/host/jvm/inst.lux @@ -15,8 +15,8 @@ ["." code] ["s" syntax (#+ syntax:)]] ["." function] - [compiler - [default + [platform + [compiler [phase (#+ Operation)]]]] ["." // (#+ Primitive Inst) ["." type]]) diff --git a/new-luxc/source/luxc/lang/translation/jvm.lux b/new-luxc/source/luxc/lang/translation/jvm.lux index 3f9189f4f..47fbbefcf 100644 --- a/new-luxc/source/luxc/lang/translation/jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm.lux @@ -20,10 +20,9 @@ [binary (#+ Binary)]] [platform [compiler - [default - ["." name] - [phase - ["." translation]]]]]] + ["." name] + [phase + ["." translation]]]]] [/// [host ["." jvm (#+ Inst Definition Host State) diff --git a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux index 4b9feebb4..78ef508e8 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/case.jvm.lux @@ -8,9 +8,8 @@ format]] [platform [compiler - [default - ["." phase ("operation/." Monad) - ["." synthesis (#+ Path Synthesis)]]]]]] + ["." phase ("operation/." Monad) + ["." synthesis (#+ Path Synthesis)]]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux index 67721c736..f0b73ac23 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/common.jvm.lux @@ -16,10 +16,9 @@ [binary (#+ Binary)]] [platform [compiler - [default - ["." name] - [reference (#+ Register)] - ["." phase]]]]] + ["." name] + [reference (#+ Register)] + ["." phase]]]] ## [luxc ## [lang ## [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux index 60e873323..7af459900 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/expression.jvm.lux @@ -2,10 +2,9 @@ [lux #* [platform [compiler - [default - [phase - ["." synthesis] - ["." extension]]]]]] + [phase + ["." synthesis] + ["." extension]]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux index 730d45641..8e5fe30b3 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/function.jvm.lux @@ -9,12 +9,11 @@ ["." list ("list/." Functor Monoid)]]] [platform [compiler - [default - ["_." reference (#+ Register Variable)] - ["." phase - [analysis (#+ Arity)] - [synthesis (#+ Synthesis Abstraction Apply)] - ["." translation]]]]]] + ["_." reference (#+ Register Variable)] + ["." phase + [analysis (#+ Arity)] + [synthesis (#+ Synthesis Abstraction Apply)] + ["." translation]]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux index ed40d498f..40f4decd9 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/loop.jvm.lux @@ -9,11 +9,10 @@ ["." list ("list/." Functor Monoid)]]] [platform [compiler - [default - [reference (#+ Register)] - ["." phase - ["." synthesis (#+ Synthesis)] - ["." translation]]]]]] + [reference (#+ Register)] + ["." phase + ["." synthesis (#+ Synthesis)] + ["." translation]]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux index 392de6354..7129a3887 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/primitive.jvm.lux @@ -7,8 +7,7 @@ format]] [platform [compiler - [default - [phase ("operation/." Monad)]]]]] + [phase ("operation/." Monad)]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux index c1d8792d0..154dcbdcf 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/procedure/common.jvm.lux @@ -15,11 +15,10 @@ ["s" syntax (#+ syntax:)]] [platform [compiler - [default - ["." phase - [synthesis (#+ Synthesis)] - ["." extension - ["." bundle]]]]]] + ["." phase + [synthesis (#+ Synthesis)] + ["." extension + ["." bundle]]]]] [host (#+ import:)]] [luxc [lang diff --git a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux index ec9facd2c..175338ba4 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/reference.jvm.lux @@ -7,11 +7,10 @@ format]] [platform [compiler - [default - ["." name] - ["." reference (#+ Register Variable)] - ["." phase ("operation/." Monad) - ["." translation]]]]]] + ["." name] + ["." reference (#+ Register Variable)] + ["." phase ("operation/." Monad) + ["." translation]]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux index eaad9cced..a22ed2b07 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/runtime.jvm.lux @@ -10,10 +10,9 @@ ["." math] [platform [compiler - [default - ["." phase - [analysis (#+ Arity)] - ["." translation]]]]]] + ["." phase + [analysis (#+ Arity)] + ["." translation]]]]] [luxc [lang [host diff --git a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux index f50788c58..9f69b1edd 100644 --- a/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux +++ b/new-luxc/source/luxc/lang/translation/jvm/structure.jvm.lux @@ -10,9 +10,8 @@ ["." list]]] [platform [compiler - [default - ["." phase - [synthesis (#+ Synthesis)]]]]]] + ["." phase + [synthesis (#+ Synthesis)]]]]] [luxc [lang [host diff --git a/new-luxc/source/program.lux b/new-luxc/source/program.lux index f119d9174..4fa032f7f 100644 --- a/new-luxc/source/program.lux +++ b/new-luxc/source/program.lux @@ -20,13 +20,13 @@ ["." archive] [io ["." context]]] + ["." phase + ["." translation] + ["." statement]] [default ["." platform (#+ Platform)] ["." init] - ["." syntax] - ["." phase - ["." translation] - ["." statement]]]]] + ["." syntax]]]] ## ["." interpreter] ] [luxc diff --git a/stdlib/source/lux/platform/compiler/default/evaluation.lux b/stdlib/source/lux/platform/compiler/default/evaluation.lux index ea76624df..157596e84 100644 --- a/stdlib/source/lux/platform/compiler/default/evaluation.lux +++ b/stdlib/source/lux/platform/compiler/default/evaluation.lux @@ -6,7 +6,7 @@ ["." error] [text format]]] - [// + [/// ["." phase [analysis (#+ Operation) [".A" expression] diff --git a/stdlib/source/lux/platform/compiler/default/init.lux b/stdlib/source/lux/platform/compiler/default/init.lux index c50d37705..699ddfb54 100644 --- a/stdlib/source/lux/platform/compiler/default/init.lux +++ b/stdlib/source/lux/platform/compiler/default/init.lux @@ -15,21 +15,21 @@ ["." // ["." syntax (#+ Aliases)] ["." evaluation] - ["." phase - ["." analysis - ["." module] - [".A" expression]] - ["." synthesis - [".S" expression]] - ["." translation] - ["." statement - [".S" total]] - ["." extension - [".E" analysis] - [".E" synthesis] - [".E" statement]]] ["/." // (#+ Compiler) ["." host] + ["." phase + ["." analysis + ["." module] + [".A" expression]] + ["." synthesis + [".S" expression]] + ["." translation] + ["." statement + [".S" total]] + ["." extension + [".E" analysis] + [".E" synthesis] + [".E" statement]]] [meta [archive ["." signature] diff --git a/stdlib/source/lux/platform/compiler/default/name.lux b/stdlib/source/lux/platform/compiler/default/name.lux deleted file mode 100644 index 184b2cab5..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase.lux b/stdlib/source/lux/platform/compiler/default/phase.lux deleted file mode 100644 index a81d5dfa7..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis.lux deleted file mode 100644 index c69ff8eb2..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/case.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/case.lux deleted file mode 100644 index 5044aed92..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/case/coverage.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/case/coverage.lux deleted file mode 100644 index aff981e09..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/expression.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/expression.lux deleted file mode 100644 index 1da6520a5..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/function.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/function.lux deleted file mode 100644 index a996457d9..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/inference.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/inference.lux deleted file mode 100644 index 010bdc437..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/macro.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/macro.lux deleted file mode 100644 index af12c747d..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/module.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/module.lux deleted file mode 100644 index a8f6bda03..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/primitive.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/primitive.lux deleted file mode 100644 index bd42825d3..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/reference.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/reference.lux deleted file mode 100644 index 30da3e60f..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/scope.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/scope.lux deleted file mode 100644 index 2849e059d..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/structure.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/structure.lux deleted file mode 100644 index 43cb8e0d2..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/analysis/type.lux b/stdlib/source/lux/platform/compiler/default/phase/analysis/type.lux deleted file mode 100644 index 36fee29f8..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension.lux b/stdlib/source/lux/platform/compiler/default/phase/extension.lux deleted file mode 100644 index 75814ad24..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/analysis.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis.lux deleted file mode 100644 index cc4736ac0..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/analysis/common.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis/common.lux deleted file mode 100644 index d599af130..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/analysis/host.jvm.lux deleted file mode 100644 index a494b0e44..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/bundle.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/bundle.lux deleted file mode 100644 index 582526694..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/statement.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/statement.lux deleted file mode 100644 index e5963e96c..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/synthesis.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/synthesis.lux deleted file mode 100644 index 1a2e44f6f..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/extension/translation.lux b/stdlib/source/lux/platform/compiler/default/phase/extension/translation.lux deleted file mode 100644 index 232c8c168..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/statement.lux b/stdlib/source/lux/platform/compiler/default/phase/statement.lux deleted file mode 100644 index c7ff3719f..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/statement/total.lux b/stdlib/source/lux/platform/compiler/default/phase/statement/total.lux deleted file mode 100644 index 15f116aa1..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/synthesis.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis.lux deleted file mode 100644 index cf29ad74b..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/synthesis/case.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/case.lux deleted file mode 100644 index e9e941a30..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/synthesis/expression.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/expression.lux deleted file mode 100644 index 0d15ae463..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/synthesis/function.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/function.lux deleted file mode 100644 index 267d941fc..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/synthesis/loop.lux b/stdlib/source/lux/platform/compiler/default/phase/synthesis/loop.lux deleted file mode 100644 index cd57c1d29..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation.lux b/stdlib/source/lux/platform/compiler/default/phase/translation.lux deleted file mode 100644 index fb40f4652..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/case.jvm.lux deleted file mode 100644 index 4a963d507..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/expression.jvm.lux deleted file mode 100644 index 53d7bbbcb..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension.jvm.lux deleted file mode 100644 index a40b4953f..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/common.jvm.lux deleted file mode 100644 index a503949dd..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/extension/host.jvm.lux deleted file mode 100644 index b8b2b7612..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/function.jvm.lux deleted file mode 100644 index 7eeb5a8ed..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/loop.jvm.lux deleted file mode 100644 index 91757d291..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/primitive.jvm.lux deleted file mode 100644 index c16c696c4..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/reference.jvm.lux deleted file mode 100644 index 6d4088189..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/runtime.jvm.lux deleted file mode 100644 index 43748c3b1..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/platform/compiler/default/phase/translation/scheme/structure.jvm.lux deleted file mode 100644 index 3991ea281..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/default/platform.lux b/stdlib/source/lux/platform/compiler/default/platform.lux index e5d881833..9a169fb15 100644 --- a/stdlib/source/lux/platform/compiler/default/platform.lux +++ b/stdlib/source/lux/platform/compiler/default/platform.lux @@ -10,10 +10,10 @@ [// ["." init] ["." syntax] - ["." phase - ["." translation] - ["." statement]] ["/." // + ["." phase + ["." translation] + ["." statement]] ["." cli (#+ Configuration)] [meta ["." archive] diff --git a/stdlib/source/lux/platform/compiler/default/reference.lux b/stdlib/source/lux/platform/compiler/default/reference.lux deleted file mode 100644 index b945c1327..000000000 --- a/stdlib/source/lux/platform/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/platform/compiler/name.lux b/stdlib/source/lux/platform/compiler/name.lux new file mode 100644 index 000000000..184b2cab5 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase.lux b/stdlib/source/lux/platform/compiler/phase.lux new file mode 100644 index 000000000..a81d5dfa7 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis.lux b/stdlib/source/lux/platform/compiler/phase/analysis.lux new file mode 100644 index 000000000..c69ff8eb2 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/case.lux b/stdlib/source/lux/platform/compiler/phase/analysis/case.lux new file mode 100644 index 000000000..5044aed92 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/analysis/case.lux @@ -0,0 +1,300 @@ +(.module: + [lux (#- case) + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." product] + ["." error] + ["." maybe] + [text + format] + [collection + ["." list ("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/phase/analysis/case/coverage.lux b/stdlib/source/lux/platform/compiler/phase/analysis/case/coverage.lux new file mode 100644 index 000000000..aff981e09 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/expression.lux b/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux new file mode 100644 index 000000000..1da6520a5 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/analysis/expression.lux @@ -0,0 +1,109 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error] + [text + format]] + ["." macro]] + ["." // (#+ Analysis Operation Phase) + ["." type] + ["." primitive] + ["." structure] + ["//." reference] + ["." case] + ["." function] + ["//." macro] + ["/." // + ["." extension] + [// + ["." reference]]]]) + +(exception: #export (unrecognized-syntax {code Code}) + (ex.report ["Code" (%code code)])) + +(def: #export (compile code) + Phase + (do ///.Monad + [expectedT (extension.lift macro.expected-type)] + (let [[cursor code'] code] + ## The cursor must be set in the state for the sake + ## of having useful error messages. + (//.with-cursor cursor + (case code' + (^template [ ] + ( value) + ( value)) + ([#.Bit primitive.bit] + [#.Nat primitive.nat] + [#.Int primitive.int] + [#.Rev primitive.rev] + [#.Frac primitive.frac] + [#.Text primitive.text]) + + (^template [ ] + (^ (#.Form (list& [_ ( tag)] + values))) + (case values + (#.Cons value #.Nil) + ( compile tag value) + + _ + ( compile tag (` [(~+ values)])))) + ([#.Nat structure.sum] + [#.Tag structure.tagged-sum]) + + (#.Tag tag) + (structure.tagged-sum compile tag (' [])) + + (^ (#.Tuple (list))) + primitive.unit + + (^ (#.Tuple (list singleton))) + (compile singleton) + + (^ (#.Tuple elems)) + (structure.product compile elems) + + (^ (#.Record pairs)) + (structure.record compile pairs) + + (#.Identifier reference) + (//reference.reference reference) + + (^ (#.Form (list [_ (#.Record branches)] input))) + (case.case compile input branches) + + (^ (#.Form (list& [_ (#.Text extension-name)] extension-args))) + (extension.apply "Analysis" compile [extension-name extension-args]) + + (^ (#.Form (list [_ (#.Tuple (list [_ (#.Identifier ["" function-name])] + [_ (#.Identifier ["" arg-name])]))] + body))) + (function.function compile function-name arg-name body) + + (^ (#.Form (list& functionC argsC+))) + (do @ + [[functionT functionA] (type.with-inference + (compile functionC))] + (case functionA + (#//.Reference (#reference.Constant def-name)) + (do @ + [?macro (extension.lift (macro.find-macro def-name))] + (case ?macro + (#.Some macro) + (do @ + [expansion (extension.lift (//macro.expand-one def-name macro argsC+))] + (compile expansion)) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (function.apply compile functionT functionA argsC+))) + + _ + (///.throw unrecognized-syntax code) + ))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/function.lux b/stdlib/source/lux/platform/compiler/phase/analysis/function.lux new file mode 100644 index 000000000..a996457d9 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/inference.lux b/stdlib/source/lux/platform/compiler/phase/analysis/inference.lux new file mode 100644 index 000000000..010bdc437 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/macro.lux b/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux new file mode 100644 index 000000000..af12c747d --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/analysis/macro.lux @@ -0,0 +1,79 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." error (#+ Error)] + ["." text + format] + [collection + [array (#+ Array)] + [list ("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/phase/analysis/module.lux b/stdlib/source/lux/platform/compiler/phase/analysis/module.lux new file mode 100644 index 000000000..a8f6bda03 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/primitive.lux b/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux new file mode 100644 index 000000000..bd42825d3 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/analysis/primitive.lux @@ -0,0 +1,29 @@ +(.module: + [lux (#- nat int rev) + [control + monad]] + ["." // (#+ Analysis Operation) + [".A" type] + ["/." //]]) + +## [Analysers] +(do-template [ ] + [(def: #export ( value) + (-> (Operation Analysis)) + (do ///.Monad + [_ (typeA.infer )] + (wrap (#//.Primitive ( value)))))] + + [bit Bit #//.Bit] + [nat Nat #//.Nat] + [int Int #//.Int] + [rev Rev #//.Rev] + [frac Frac #//.Frac] + [text Text #//.Text] + ) + +(def: #export unit + (Operation Analysis) + (do ///.Monad + [_ (typeA.infer Any)] + (wrap (#//.Primitive #//.Unit)))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux b/stdlib/source/lux/platform/compiler/phase/analysis/reference.lux new file mode 100644 index 000000000..30da3e60f --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/scope.lux b/stdlib/source/lux/platform/compiler/phase/analysis/scope.lux new file mode 100644 index 000000000..2849e059d --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/analysis/structure.lux b/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux new file mode 100644 index 000000000..43cb8e0d2 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/analysis/structure.lux @@ -0,0 +1,358 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)] + ["." state]] + [data + ["." name] + ["." number] + ["." product] + ["." maybe] + ["." error] + [text + format] + [collection + ["." list ("list/." Functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." type + ["." check]] + ["." macro + ["." code]]] + ["." // (#+ Tag Analysis Operation Phase) + ["//." type] + ["." primitive] + ["." inference] + ["/." // + ["." extension]]]) + +(exception: #export (invalid-variant-type {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)])) + +(do-template [] + [(exception: #export ( {type Type} {members (List Code)}) + (ex.report ["Type" (%type type)] + ["Expression" (%code (` [(~+ members)]))]))] + + [invalid-tuple-type] + [cannot-analyse-tuple] + ) + +(exception: #export (not-a-quantified-type {type Type}) + (%type type)) + +(do-template [] + [(exception: #export ( {type Type} {tag Tag} {code Code}) + (ex.report ["Type" (%type type)] + ["Tag" (%n tag)] + ["Expression" (%code code)]))] + + [cannot-analyse-variant] + [cannot-infer-numeric-tag] + ) + +(exception: #export (record-keys-must-be-tags {key Code} {record (List [Code Code])}) + (ex.report ["Key" (%code key)] + ["Record" (%code (code.record record))])) + +(do-template [] + [(exception: #export ( {key Name} {record (List [Name Code])}) + (ex.report ["Tag" (%code (code.tag key))] + ["Record" (%code (code.record (list/map (function (_ [keyI valC]) + [(code.tag keyI) valC]) + record)))]))] + + [cannot-repeat-tag] + ) + +(exception: #export (tag-does-not-belong-to-record {key Name} {type Type}) + (ex.report ["Tag" (%code (code.tag key))] + ["Type" (%type type)])) + +(exception: #export (record-size-mismatch {expected Nat} {actual Nat} {type Type} {record (List [Name Code])}) + (ex.report ["Expected" (|> expected .int %i)] + ["Actual" (|> actual .int %i)] + ["Type" (%type type)] + ["Expression" (%code (|> record + (list/map (function (_ [keyI valueC]) + [(code.tag keyI) valueC])) + code.record))])) + +(def: #export (sum analyse tag valueC) + (-> Phase Nat Code (Operation Analysis)) + (do ///.Monad + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-variant [expectedT tag valueC] + (case expectedT + (#.Sum _) + (let [flat (type.flatten-variant expectedT) + type-size (list.size flat) + right? (n/= (dec type-size) + tag) + lefts (if right? + (dec tag) + tag)] + (case (list.nth tag flat) + (#.Some variant-type) + (do @ + [valueA (//type.with-type variant-type + (analyse valueC))] + (wrap (//.variant [lefts right? valueA]))) + + #.None + (///.throw inference.variant-tag-out-of-bounds [type-size tag expectedT]))) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (sum analyse tag valueC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (sum analyse tag valueC)) + + _ + ## Cannot do inference when the tag is numeric. + ## This is because there is no way of knowing how many + ## cases the inferred sum type would have. + (///.throw cannot-infer-numeric-tag [expectedT tag valueC]) + )) + + (^template [ ] + ( _) + (do @ + [[instance-id instanceT] (//type.with-env )] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (sum analyse tag valueC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (sum analyse tag valueC)) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (sum analyse tag valueC)) + + #.None + (///.throw not-a-quantified-type funT))) + + _ + (///.throw invalid-variant-type [expectedT tag valueC]))))) + +(def: (typed-product analyse members) + (-> Phase (List Code) (Operation Analysis)) + (do ///.Monad + [expectedT (extension.lift macro.expected-type) + membersA+ (: (Operation (List Analysis)) + (loop [membersT+ (type.flatten-tuple expectedT) + membersC+ members] + (case [membersT+ membersC+] + [(#.Cons memberT #.Nil) _] + (//type.with-type memberT + (:: @ map (|>> list) (analyse (code.tuple membersC+)))) + + [_ (#.Cons memberC #.Nil)] + (//type.with-type (type.tuple membersT+) + (:: @ map (|>> list) (analyse memberC))) + + [(#.Cons memberT membersT+') (#.Cons memberC membersC+')] + (do @ + [memberA (//type.with-type memberT + (analyse memberC)) + memberA+ (recur membersT+' membersC+')] + (wrap (#.Cons memberA memberA+))) + + _ + (///.throw cannot-analyse-tuple [expectedT members]))))] + (wrap (//.tuple membersA+)))) + +(def: #export (product analyse membersC) + (-> Phase (List Code) (Operation Analysis)) + (do ///.Monad + [expectedT (extension.lift macro.expected-type)] + (///.with-stack cannot-analyse-tuple [expectedT membersC] + (case expectedT + (#.Product _) + (..typed-product analyse membersC) + + (#.Named name unnamedT) + (//type.with-type unnamedT + (product analyse membersC)) + + (#.Var id) + (do @ + [?expectedT' (//type.with-env + (check.read id))] + (case ?expectedT' + (#.Some expectedT') + (//type.with-type expectedT' + (product analyse membersC)) + + _ + ## Must do inference... + (do @ + [membersTA (monad.map @ (|>> analyse //type.with-inference) + membersC) + _ (//type.with-env + (check.check expectedT + (type.tuple (list/map product.left membersTA))))] + (wrap (//.tuple (list/map product.right membersTA)))))) + + (^template [ ] + ( _) + (do @ + [[instance-id instanceT] (//type.with-env )] + (//type.with-type (maybe.assume (type.apply (list instanceT) expectedT)) + (product analyse membersC)))) + ([#.UnivQ check.existential] + [#.ExQ check.var]) + + (#.Apply inputT funT) + (case funT + (#.Var funT-id) + (do @ + [?funT' (//type.with-env (check.read funT-id))] + (case ?funT' + (#.Some funT') + (//type.with-type (#.Apply inputT funT') + (product analyse membersC)) + + _ + (///.throw invalid-tuple-type [expectedT membersC]))) + + _ + (case (type.apply (list inputT) funT) + (#.Some outputT) + (//type.with-type outputT + (product analyse membersC)) + + #.None + (///.throw not-a-quantified-type funT))) + + _ + (///.throw invalid-tuple-type [expectedT membersC]) + )))) + +(def: #export (tagged-sum analyse tag valueC) + (-> Phase Name Code (Operation Analysis)) + (do ///.Monad + [tag (extension.lift (macro.normalize tag)) + [idx group variantT] (extension.lift (macro.resolve-tag tag)) + expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [#let [case-size (list.size group)] + inferenceT (inference.variant idx case-size variantT) + [inferredT valueA+] (inference.general analyse inferenceT (list valueC)) + #let [right? (n/= (dec case-size) idx) + lefts (if right? + (dec idx) + idx)]] + (wrap (//.variant [lefts right? (|> valueA+ list.head maybe.assume)]))) + + _ + (..sum analyse idx valueC)))) + +## There cannot be any ambiguity or improper syntax when analysing +## records, so they must be normalized for further analysis. +## Normalization just means that all the tags get resolved to their +## canonical form (with their corresponding module identified). +(def: #export (normalize record) + (-> (List [Code Code]) (Operation (List [Name Code]))) + (monad.map ///.Monad + (function (_ [key val]) + (case key + [_ (#.Tag key)] + (do ///.Monad + [key (extension.lift (macro.normalize key))] + (wrap [key val])) + + _ + (///.throw record-keys-must-be-tags [key record]))) + record)) + +## Lux already possesses the means to analyse tuples, so +## re-implementing the same functionality for records makes no sense. +## Records, thus, get transformed into tuples by ordering the elements. +(def: #export (order record) + (-> (List [Name Code]) (Operation [(List Code) Type])) + (case record + ## empty-record = empty-tuple = unit = [] + #.Nil + (:: ///.Monad wrap [(list) Any]) + + (#.Cons [head-k head-v] _) + (do ///.Monad + [head-k (extension.lift (macro.normalize head-k)) + [_ tag-set recordT] (extension.lift (macro.resolve-tag head-k)) + #let [size-record (list.size record) + size-ts (list.size tag-set)] + _ (if (n/= size-ts size-record) + (wrap []) + (///.throw record-size-mismatch [size-ts size-record recordT record])) + #let [tuple-range (list.indices size-ts) + tag->idx (dict.from-list name.Hash (list.zip2 tag-set tuple-range))] + idx->val (monad.fold @ + (function (_ [key val] idx->val) + (do @ + [key (extension.lift (macro.normalize key))] + (case (dict.get key tag->idx) + (#.Some idx) + (if (dict.contains? idx idx->val) + (///.throw cannot-repeat-tag [key record]) + (wrap (dict.put idx val idx->val))) + + #.None + (///.throw tag-does-not-belong-to-record [key recordT])))) + (: (Dictionary Nat Code) + (dict.new number.Hash)) + record) + #let [ordered-tuple (list/map (function (_ idx) (maybe.assume (dict.get idx idx->val))) + tuple-range)]] + (wrap [ordered-tuple recordT])) + )) + +(def: #export (record analyse members) + (-> Phase (List [Code Code]) (Operation Analysis)) + (do ///.Monad + [members (normalize members) + [membersC recordT] (order members)] + (case membersC + (^ (list)) + primitive.unit + + (^ (list singletonC)) + (analyse singletonC) + + _ + (do @ + [expectedT (extension.lift macro.expected-type)] + (case expectedT + (#.Var _) + (do @ + [inferenceT (inference.record recordT) + [inferredT membersA] (inference.general analyse inferenceT membersC)] + (wrap (//.tuple membersA))) + + _ + (..product analyse membersC)))))) diff --git a/stdlib/source/lux/platform/compiler/phase/analysis/type.lux b/stdlib/source/lux/platform/compiler/phase/analysis/type.lux new file mode 100644 index 000000000..36fee29f8 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/analysis/type.lux @@ -0,0 +1,52 @@ +(.module: + [lux #* + [control + [monad (#+ do)]] + [data + ["." error]] + ["." function] + [type + ["tc" check]] + ["." macro]] + [// (#+ Operation) + ["/." // + ["." extension]]]) + +(def: #export (with-type expected) + (All [a] (-> Type (Operation a) (Operation a))) + (extension.localized (get@ #.expected) (set@ #.expected) + (function.constant (#.Some expected)))) + +(def: #export (with-env action) + (All [a] (-> (tc.Check a) (Operation a))) + (function (_ (^@ stateE [bundle state])) + (case (action (get@ #.type-context state)) + (#error.Success [context' output]) + (#error.Success [[bundle (set@ #.type-context context' state)] + output]) + + (#error.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/phase/extension.lux b/stdlib/source/lux/platform/compiler/phase/extension.lux new file mode 100644 index 000000000..75814ad24 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/extension/analysis.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis.lux new file mode 100644 index 000000000..3b31f3d46 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/extension/analysis.lux @@ -0,0 +1,18 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [/// + [analysis (#+ Bundle)] + [// + [default + [evaluation (#+ Eval)]]]] + [/ + ["." common] + ["." host]]) + +(def: #export (bundle eval) + (-> Eval Bundle) + (dictionary.merge host.bundle + (common.bundle eval))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux new file mode 100644 index 000000000..73f0d6c9d --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/extension/analysis/common.lux @@ -0,0 +1,219 @@ +(.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]] + [// + [default + [evaluation (#+ Eval)]]]]]) + +## [Utils] +(def: (simple inputsT+ outputT) + (-> (List Type) Type Handler) + (let [num-expected (list.size inputsT+)] + (function (_ extension-name analyse args) + (let [num-actual (list.size args)] + (if (n/= num-expected num-actual) + (do ////.Monad + [_ (typeA.infer outputT) + argsA (monad.map @ + (function (_ [argT argC]) + (typeA.with-type argT + (analyse argC))) + (list.zip2 inputsT+ args))] + (wrap (#analysis.Extension extension-name argsA))) + (////.throw ///.incorrect-arity [extension-name num-expected num-actual])))))) + +(def: #export (nullary valueT) + (-> Type Handler) + (simple (list) valueT)) + +(def: #export (unary inputT outputT) + (-> Type Type Handler) + (simple (list inputT) outputT)) + +(def: #export (binary subjectT paramT outputT) + (-> Type Type Type Handler) + (simple (list subjectT paramT) outputT)) + +(def: #export (trinary subjectT param0T param1T outputT) + (-> Type Type Type Type Handler) + (simple (list subjectT param0T param1T) outputT)) + +## [Analysers] +## "lux is" represents reference/pointer equality. +(def: lux::is + Handler + (function (_ extension-name analyse args) + (do ////.Monad + [[var-id varT] (typeA.with-env check.var)] + ((binary varT varT Bit extension-name) + analyse args)))) + +## "lux try" provides a simple way to interact with the host platform's +## error-handling facilities. +(def: lux::try + Handler + (function (_ extension-name analyse args) + (case args + (^ (list opC)) + (do ////.Monad + [[var-id varT] (typeA.with-env check.var) + _ (typeA.infer (type (Either Text varT))) + opA (typeA.with-type (type (IO varT)) + (analyse opC))] + (wrap (#analysis.Extension extension-name (list opA)))) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: lux::in-module + Handler + (function (_ extension-name analyse argsC+) + (case argsC+ + (^ (list [_ (#.Text module-name)] exprC)) + (analysis.with-current-module module-name + (analyse exprC)) + + _ + (////.throw ///.invalid-syntax [extension-name])))) + +(do-template [ ] + [(def: ( eval) + (-> Eval Handler) + (function (_ extension-name analyse args) + (case args + (^ (list typeC valueC)) + (do ////.Monad + [count (///.lift macro.count) + actualT (:: @ map (|>> (:coerce Type)) + (eval count Type typeC)) + _ (typeA.infer actualT)] + (typeA.with-type + (analyse valueC))) + + _ + (////.throw ///.incorrect-arity [extension-name 2 (list.size args)]))))] + + [lux::check actualT] + [lux::coerce Any] + ) + +(def: lux::check::type + Handler + (function (_ extension-name analyse args) + (case args + (^ (list valueC)) + (do ////.Monad + [_ (typeA.infer Type) + valueA (typeA.with-type Type + (analyse valueC))] + (wrap valueA)) + + _ + (////.throw ///.incorrect-arity [extension-name 1 (list.size args)])))) + +(def: (bundle::lux eval) + (-> Eval Bundle) + (|> bundle.empty + (bundle.install "is" lux::is) + (bundle.install "try" lux::try) + (bundle.install "check" (lux::check eval)) + (bundle.install "coerce" (lux::coerce eval)) + (bundle.install "check type" lux::check::type) + (bundle.install "in-module" lux::in-module))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary Text Any)) + (bundle.install "error" (unary Text Nothing)) + (bundle.install "exit" (unary Int Nothing)) + (bundle.install "current-time" (nullary Int))))) + +(def: I64* (type (I64 Any))) + +(def: bundle::i64 + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary I64* I64* I64)) + (bundle.install "or" (binary I64* I64* I64)) + (bundle.install "xor" (binary I64* I64* I64)) + (bundle.install "left-shift" (binary Nat I64* I64)) + (bundle.install "logical-right-shift" (binary Nat I64* I64)) + (bundle.install "arithmetic-right-shift" (binary Nat I64* I64)) + (bundle.install "+" (binary I64* I64* I64)) + (bundle.install "-" (binary I64* I64* I64)) + (bundle.install "=" (binary I64* I64* Bit))))) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "*" (binary Int Int Int)) + (bundle.install "/" (binary Int Int Int)) + (bundle.install "%" (binary Int Int Int)) + (bundle.install "<" (binary Int Int Bit)) + (bundle.install "frac" (unary Int Frac)) + (bundle.install "char" (unary Int Text))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary Frac Frac Frac)) + (bundle.install "-" (binary Frac Frac Frac)) + (bundle.install "*" (binary Frac Frac Frac)) + (bundle.install "/" (binary Frac Frac Frac)) + (bundle.install "%" (binary Frac Frac Frac)) + (bundle.install "=" (binary Frac Frac Bit)) + (bundle.install "<" (binary Frac Frac Bit)) + (bundle.install "smallest" (nullary Frac)) + (bundle.install "min" (nullary Frac)) + (bundle.install "max" (nullary Frac)) + (bundle.install "int" (unary Frac Int)) + (bundle.install "encode" (unary Frac Text)) + (bundle.install "decode" (unary Text (type (Maybe Frac))))))) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary Text Text Bit)) + (bundle.install "<" (binary Text Text Bit)) + (bundle.install "concat" (binary Text Text Text)) + (bundle.install "index" (trinary Text Text Nat (type (Maybe Nat)))) + (bundle.install "size" (unary Text Nat)) + (bundle.install "char" (binary Text Nat Nat)) + (bundle.install "clip" (trinary Text Nat Nat Text)) + ))) + +(def: #export (bundle eval) + (-> Eval Bundle) + (<| (bundle.prefix "lux") + (|> bundle.empty + (dictionary.merge (bundle::lux eval)) + (dictionary.merge bundle::i64) + (dictionary.merge bundle::int) + (dictionary.merge bundle::frac) + (dictionary.merge bundle::text) + (dictionary.merge bundle::io) + ))) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux b/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux new file mode 100644 index 000000000..a494b0e44 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/extension/analysis/host.jvm.lux @@ -0,0 +1,1271 @@ +(.module: + [lux (#- char int) + [control + ["." monad (#+ do)] + ["p" parser] + ["ex" exception (#+ exception:)] + pipe] + [data + ["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/phase/extension/bundle.lux b/stdlib/source/lux/platform/compiler/phase/extension/bundle.lux new file mode 100644 index 000000000..582526694 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/extension/statement.lux b/stdlib/source/lux/platform/compiler/phase/extension/statement.lux new file mode 100644 index 000000000..e5963e96c --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/extension/synthesis.lux b/stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux new file mode 100644 index 000000000..1a2e44f6f --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/extension/synthesis.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [synthesis (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/platform/compiler/phase/extension/translation.lux b/stdlib/source/lux/platform/compiler/phase/extension/translation.lux new file mode 100644 index 000000000..232c8c168 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/extension/translation.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [translation (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/platform/compiler/phase/statement.lux b/stdlib/source/lux/platform/compiler/phase/statement.lux new file mode 100644 index 000000000..c7ff3719f --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/statement.lux @@ -0,0 +1,45 @@ +(.module: + [lux #*] + ["." // + ["." analysis] + ["." synthesis] + ["." translation] + ["." extension]]) + +(type: #export (Component state phase) + {#state state + #phase phase}) + +(type: #export (State anchor expression statement) + {#analysis (Component analysis.State+ + analysis.Phase) + #synthesis (Component synthesis.State+ + synthesis.Phase) + #translation (Component (translation.State+ anchor expression statement) + (translation.Phase anchor expression statement))}) + +(do-template [ ] + [(type: #export ( anchor expression statement) + ( (..State anchor expression statement) Code Any))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(do-template [ ] + [(def: #export ( operation) + (All [anchor expression statement output] + (-> ( output) + (Operation anchor expression statement output))) + (extension.lift + (//.sub [(get@ [ #..state]) + (set@ [ #..state])] + operation)))] + + [lift-analysis #..analysis analysis.Operation] + [lift-synthesis #..synthesis synthesis.Operation] + [lift-translation #..translation (translation.Operation anchor expression statement)] + ) diff --git a/stdlib/source/lux/platform/compiler/phase/statement/total.lux b/stdlib/source/lux/platform/compiler/phase/statement/total.lux new file mode 100644 index 000000000..15f116aa1 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/statement/total.lux @@ -0,0 +1,56 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + [text + format]] + ["." macro]] + ["." // (#+ Phase) + ["/." // + ["." analysis + ["." expression] + ["." type] + ["///." macro]] + ["." extension]]]) + +(exception: #export (not-a-statement {code Code}) + (ex.report ["Statement" (%code code)])) + +(exception: #export (not-a-macro {code Code}) + (ex.report ["Code" (%code code)])) + +(exception: #export (macro-was-not-found {name Name}) + (ex.report ["Name" (%name name)])) + +(def: #export (phase code) + Phase + (case code + (^ [_ (#.Form (list& [_ (#.Text name)] inputs))]) + (extension.apply "Statement" phase [name inputs]) + + (^ [_ (#.Form (list& macro inputs))]) + (do ///.Monad + [expansion (//.lift-analysis + (do @ + [macroA (type.with-type Macro + (expression.compile macro))] + (case macroA + (^ (analysis.constant macro-name)) + (do @ + [?macro (extension.lift (macro.find-macro macro-name)) + macro (case ?macro + (#.Some macro) + (wrap macro) + + #.None + (///.throw macro-was-not-found macro-name))] + (extension.lift (///macro.expand macro-name macro inputs))) + + _ + (///.throw not-a-macro code))))] + (monad.map @ phase expansion)) + + _ + (///.throw not-a-statement code))) diff --git a/stdlib/source/lux/platform/compiler/phase/synthesis.lux b/stdlib/source/lux/platform/compiler/phase/synthesis.lux new file mode 100644 index 000000000..cf29ad74b --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/synthesis/case.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/case.lux new file mode 100644 index 000000000..e9e941a30 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/synthesis/expression.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/expression.lux new file mode 100644 index 000000000..0d15ae463 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/synthesis/function.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/function.lux new file mode 100644 index 000000000..267d941fc --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/synthesis/loop.lux b/stdlib/source/lux/platform/compiler/phase/synthesis/loop.lux new file mode 100644 index 000000000..cd57c1d29 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation.lux b/stdlib/source/lux/platform/compiler/phase/translation.lux new file mode 100644 index 000000000..fb40f4652 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux new file mode 100644 index 000000000..4a963d507 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/case.jvm.lux @@ -0,0 +1,177 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + [list ("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/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux new file mode 100644 index 000000000..53d7bbbcb --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/expression.jvm.lux @@ -0,0 +1,59 @@ +(.module: + [lux #* + [control + [monad (#+ do)]]] + [// + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference] + ["." function] + ["." case] + ["." loop] + ["." /// + ["." synthesis] + ["." extension]]]) + +(def: #export (translate synthesis) + Phase + (case synthesis + (^template [ ] + (^ ( value)) + ( value)) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant translate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple translate members) + + (#synthesis.Reference reference) + (reference.reference reference) + + (^ (synthesis.branch/case case)) + (case.case translate case) + + (^ (synthesis.branch/let let)) + (case.let translate let) + + (^ (synthesis.branch/if if)) + (case.if translate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope translate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur translate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function translate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply translate application) + + (#synthesis.Extension extension) + (extension.apply translate extension))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension.jvm.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..a503949dd --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux new file mode 100644 index 000000000..b8b2b7612 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/extension/host.jvm.lux @@ -0,0 +1,11 @@ +(.module: + [lux #*] + [/// + [runtime (#+ Bundle)] + [/// + [extension + ["." bundle]]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/function.jvm.lux new file mode 100644 index 000000000..7eeb5a8ed --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/loop.jvm.lux new file mode 100644 index 000000000..91757d291 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..c16c696c4 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/reference.jvm.lux new file mode 100644 index 000000000..6d4088189 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..43748c3b1 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/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/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux new file mode 100644 index 000000000..3991ea281 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/phase/translation/scheme/structure.jvm.lux @@ -0,0 +1,33 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." primitive] + ["." /// + [analysis (#+ Variant Tuple)] + ["." synthesis (#+ Synthesis)] + [/// + [host + ["_" scheme (#+ Expression)]]]]]) + +(def: #export (tuple translate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (primitive.text synthesis.unit) + + (#.Cons singletonS #.Nil) + (translate singletonS) + + _ + (do ///.Monad + [elemsT+ (monad.map @ translate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant translate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (do ///.Monad + [valueT (translate valueS)] + (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/platform/compiler/reference.lux b/stdlib/source/lux/platform/compiler/reference.lux new file mode 100644 index 000000000..b945c1327 --- /dev/null +++ b/stdlib/source/lux/platform/compiler/reference.lux @@ -0,0 +1,88 @@ +(.module: + [lux #* + [control + [equivalence (#+ Equivalence)] + [hash (#+ Hash)] + pipe] + [data + [text + format]]]) + +(type: #export Register Nat) + +(type: #export Variable + (#Local Register) + (#Foreign Register)) + +(type: #export Reference + (#Variable Variable) + (#Constant Name)) + +(structure: #export _ (Equivalence 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/interpreter.lux b/stdlib/source/lux/platform/interpreter.lux index 8a6d00578..b73f72bc6 100644 --- a/stdlib/source/lux/platform/interpreter.lux +++ b/stdlib/source/lux/platform/interpreter.lux @@ -10,19 +10,19 @@ [type (#+ :share) ["." check]] [compiler - ["." cli (#+ Configuration)] + ["." phase + ["." analysis + ["." module] + ["." type]] + ["." translation] + ["." statement (#+ State+ Operation) + ["." total]] + ["." extension]] ["." default ["." syntax] ["." platform (#+ Platform)] - ["." init] - ["." phase - ["." analysis - ["." module] - ["." type]] - ["." translation] - ["." statement (#+ State+ Operation) - ["." total]] - ["." extension]]]] + ["." init]] + ["." cli (#+ Configuration)]] [world ["." file (#+ File)] ["." console (#+ Console)]]] -- cgit v1.2.3