From d5e630c8f1db51cb493ad683f06ca9e2dd521478 Mon Sep 17 00:00:00 2001 From: Eduardo Julian Date: Wed, 13 Mar 2019 19:31:53 -0400 Subject: The "translation" phase has been re-named to "generation". --- .../lux/tool/compiler/default/evaluation.lux | 14 +- stdlib/source/lux/tool/compiler/default/init.lux | 22 +- .../source/lux/tool/compiler/default/platform.lux | 18 +- .../tool/compiler/phase/extension/generation.lux | 10 + .../tool/compiler/phase/extension/statement.lux | 50 +- .../tool/compiler/phase/extension/translation.lux | 10 - .../source/lux/tool/compiler/phase/generation.lux | 255 +++++++ .../lux/tool/compiler/phase/generation/js/case.lux | 172 +++++ .../compiler/phase/generation/js/expression.lux | 60 ++ .../compiler/phase/generation/js/extension.lux | 15 + .../phase/generation/js/extension/common.lux | 232 +++++++ .../phase/generation/js/extension/host.lux | 121 ++++ .../tool/compiler/phase/generation/js/function.lux | 108 +++ .../lux/tool/compiler/phase/generation/js/loop.lux | 42 ++ .../compiler/phase/generation/js/primitive.lux | 38 ++ .../compiler/phase/generation/js/reference.lux | 11 + .../tool/compiler/phase/generation/js/runtime.lux | 756 +++++++++++++++++++++ .../compiler/phase/generation/js/structure.lux | 36 + .../tool/compiler/phase/generation/reference.lux | 81 +++ .../compiler/phase/generation/scheme/case.jvm.lux | 175 +++++ .../phase/generation/scheme/expression.jvm.lux | 59 ++ .../phase/generation/scheme/extension.jvm.lux | 15 + .../generation/scheme/extension/common.jvm.lux | 243 +++++++ .../phase/generation/scheme/extension/host.jvm.lux | 11 + .../phase/generation/scheme/function.jvm.lux | 97 +++ .../compiler/phase/generation/scheme/loop.jvm.lux | 41 ++ .../phase/generation/scheme/primitive.jvm.lux | 15 + .../phase/generation/scheme/reference.jvm.lux | 12 + .../phase/generation/scheme/runtime.jvm.lux | 321 +++++++++ .../phase/generation/scheme/structure.jvm.lux | 32 + .../source/lux/tool/compiler/phase/translation.lux | 255 ------- .../tool/compiler/phase/translation/js/case.lux | 172 ----- .../compiler/phase/translation/js/expression.lux | 60 -- .../compiler/phase/translation/js/extension.lux | 15 - .../phase/translation/js/extension/common.lux | 232 ------- .../phase/translation/js/extension/host.lux | 121 ---- .../compiler/phase/translation/js/function.lux | 108 --- .../tool/compiler/phase/translation/js/loop.lux | 42 -- .../compiler/phase/translation/js/primitive.lux | 38 -- .../compiler/phase/translation/js/reference.lux | 11 - .../tool/compiler/phase/translation/js/runtime.lux | 756 --------------------- .../compiler/phase/translation/js/structure.lux | 36 - .../tool/compiler/phase/translation/reference.lux | 81 --- .../compiler/phase/translation/scheme/case.jvm.lux | 175 ----- .../phase/translation/scheme/expression.jvm.lux | 59 -- .../phase/translation/scheme/extension.jvm.lux | 15 - .../translation/scheme/extension/common.jvm.lux | 243 ------- .../translation/scheme/extension/host.jvm.lux | 11 - .../phase/translation/scheme/function.jvm.lux | 97 --- .../compiler/phase/translation/scheme/loop.jvm.lux | 41 -- .../phase/translation/scheme/primitive.jvm.lux | 15 - .../phase/translation/scheme/reference.jvm.lux | 12 - .../phase/translation/scheme/runtime.jvm.lux | 321 --------- .../phase/translation/scheme/structure.jvm.lux | 32 - stdlib/source/lux/tool/compiler/program.lux | 4 +- stdlib/source/lux/tool/compiler/statement.lux | 12 +- stdlib/source/lux/tool/interpreter.lux | 24 +- 57 files changed, 3030 insertions(+), 3030 deletions(-) create mode 100644 stdlib/source/lux/tool/compiler/phase/extension/generation.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/extension/translation.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/case.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/expression.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/function.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/loop.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/js/structure.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/reference.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/expression.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/host.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux create mode 100644 stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/case.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/expression.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/function.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/loop.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/reference.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux delete mode 100644 stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux (limited to 'stdlib/source/lux') diff --git a/stdlib/source/lux/tool/compiler/default/evaluation.lux b/stdlib/source/lux/tool/compiler/default/evaluation.lux index 42bb10ca0..5122237a8 100644 --- a/stdlib/source/lux/tool/compiler/default/evaluation.lux +++ b/stdlib/source/lux/tool/compiler/default/evaluation.lux @@ -12,7 +12,7 @@ [".P" analysis ["." type]] [".P" synthesis] - ["." translation] + ["." generation] [// [analysis (#+ Operation)] ["." synthesis]]]]) @@ -20,12 +20,12 @@ (type: #export Eval (-> Nat Type Code (Operation Any))) -(def: #export (evaluator expander synthesis-state translation-state translate) +(def: #export (evaluator expander synthesis-state generation-state generate) (All [anchor expression statement] (-> Expander synthesis.State+ - (translation.State+ anchor expression statement) - (translation.Phase anchor expression statement) + (generation.State+ anchor expression statement) + (generation.Phase anchor expression statement) Eval)) (let [analyze (analysisP.phase expander)] (function (eval count type exprC) @@ -34,7 +34,7 @@ (analyze exprC))] (phase.lift (do error.monad [exprS (|> exprA synthesisP.phase (phase.run synthesis-state))] - (phase.run translation-state + (phase.run generation-state (do phase.monad - [exprO (translate exprS)] - (translation.evaluate! (format "eval" (%n count)) exprO))))))))) + [exprO (generate exprS)] + (generation.evaluate! (format "eval" (%n count)) exprO))))))))) diff --git a/stdlib/source/lux/tool/compiler/default/init.lux b/stdlib/source/lux/tool/compiler/default/init.lux index 850615b37..aebb74046 100644 --- a/stdlib/source/lux/tool/compiler/default/init.lux +++ b/stdlib/source/lux/tool/compiler/default/init.lux @@ -26,7 +26,7 @@ [".P" analysis ["." module]] [".P" synthesis] - ["." translation] + ["." generation] [".P" statement] ["." extension [".E" analysis] @@ -60,8 +60,8 @@ [[bundle state] phase.get-state #let [eval (evaluation.evaluator expander (get@ [#statement.synthesis #statement.state] state) - (get@ [#statement.translation #statement.state] state) - (get@ [#statement.translation #statement.phase] state))]] + (get@ [#statement.generation #statement.state] state) + (get@ [#statement.generation #statement.phase] state))]] (phase.set-state [bundle (update@ [#statement.analysis #statement.state] (: (-> analysis.State+ analysis.State+) @@ -69,24 +69,24 @@ [(analysisE.bundle eval)])) state)]))) -(def: #export (state expander host translate translation-bundle) +(def: #export (state expander host generate generation-bundle) (All [anchor expression statement] (-> Expander - (translation.Host expression statement) - (translation.Phase anchor expression statement) - (translation.Bundle anchor expression statement) + (generation.Host expression statement) + (generation.Phase anchor expression statement) + (generation.Bundle anchor expression statement) (statement.State+ anchor expression statement))) (let [synthesis-state [synthesisE.bundle synthesis.init] - translation-state [translation-bundle (translation.state host)] - eval (evaluation.evaluator expander synthesis-state translation-state translate) + generation-state [generation-bundle (generation.state host)] + eval (evaluation.evaluator expander synthesis-state generation-state generate) analysis-state [(analysisE.bundle eval) (analysis.state ..info host)]] [statementE.bundle {#statement.analysis {#statement.state analysis-state #statement.phase (analysisP.phase expander)} #statement.synthesis {#statement.state synthesis-state #statement.phase synthesisP.phase} - #statement.translation {#statement.state translation-state - #statement.phase translate}}])) + #statement.generation {#statement.state generation-state + #statement.phase generate}}])) (type: Reader (-> Source (Error [Source Code]))) diff --git a/stdlib/source/lux/tool/compiler/default/platform.lux b/stdlib/source/lux/tool/compiler/default/platform.lux index 73b5d8764..529a4ed79 100644 --- a/stdlib/source/lux/tool/compiler/default/platform.lux +++ b/stdlib/source/lux/tool/compiler/default/platform.lux @@ -21,7 +21,7 @@ [macro (#+ Expander)] ## TODO: Get rid of this import ASAP [extension (#+)] - ["." translation] + ["." generation] [analysis ["." module]]] ["." cli (#+ Configuration)] @@ -34,9 +34,9 @@ (type: #export (Platform ! anchor expression statement) {#&monad (Monad !) #&file-system (file.System !) - #host (translation.Host expression statement) - #phase (translation.Phase anchor expression statement) - #runtime (translation.Operation anchor expression statement Any)}) + #host (generation.Host expression statement) + #phase (generation.Phase anchor expression statement) + #runtime (generation.Operation anchor expression statement Any)}) ## (def: (write-module target-dir file-name module-name module outputs) ## (-> File Text Text Module Outputs (Process Any)) @@ -49,22 +49,22 @@ (with-expansions [ (as-is (Platform ! anchor expression statement)) (as-is (statement.State+ anchor expression statement)) - (as-is (translation.Bundle anchor expression statement))] + (as-is (generation.Bundle anchor expression statement))] - (def: #export (initialize expander platform translation-bundle) + (def: #export (initialize expander platform generation-bundle) (All [! anchor expression statement] (-> Expander (! (Error )))) (|> platform (get@ #runtime) - statement.lift-translation + statement.lift-generation (phase.run' (init.state expander (get@ #host platform) (get@ #phase platform) - translation-bundle)) + generation-bundle)) (:: error.functor map product.left) (:: (get@ #&monad platform) wrap)) - ## (case (runtimeT.translate ## (initL.compiler (io.run js.init)) + ## (case (runtimeT.generate ## (initL.compiler (io.run js.init)) ## (initL.compiler (io.run hostL.init-host)) ## ) ## ## (#error.Success [state disk-write]) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/generation.lux b/stdlib/source/lux/tool/compiler/phase/extension/generation.lux new file mode 100644 index 000000000..467adbf35 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/extension/generation.lux @@ -0,0 +1,10 @@ +(.module: + [lux #*] + [// + ["." bundle] + [// + [generation (#+ Bundle)]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux index 4f5bdb922..83e7320d8 100644 --- a/stdlib/source/lux/tool/compiler/phase/extension/statement.lux +++ b/stdlib/source/lux/tool/compiler/phase/extension/statement.lux @@ -18,25 +18,25 @@ [analysis ["." module] ["." type]] - ["." translation] + ["." generation] [// ["." analysis] ["." synthesis (#+ Synthesis)] ["." statement (#+ Operation Handler Bundle)]]]]) ## TODO: Inline "evaluate!'" into "evaluate!" ASAP -(def: (evaluate!' translate code//type codeS) +(def: (evaluate!' generate code//type codeS) (All [anchor expression statement] - (-> (translation.Phase anchor expression statement) + (-> (generation.Phase anchor expression statement) Type Synthesis (Operation anchor expression statement [Type expression Any]))) - (statement.lift-translation - (translation.with-buffer + (statement.lift-generation + (generation.with-buffer (do ///.monad - [codeT (translate codeS) - count translation.next - codeV (translation.evaluate! (format "evaluate" (%n count)) codeT)] + [codeT (generate codeS) + count generation.next + codeV (generation.evaluate! (format "evaluate" (%n count)) codeT)] (wrap [code//type codeT codeV]))))) (def: (evaluate! type codeC) @@ -46,7 +46,7 @@ [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)] + generate (get@ [#statement.generation #statement.phase] state)] [_ code//type codeA] (statement.lift-analysis (analysis.with-scope (type.with-fresh-env @@ -56,21 +56,21 @@ (wrap [type codeA])))))) codeS (statement.lift-synthesis (synthesize codeA))] - (evaluate!' translate code//type codeS))) + (evaluate!' generate code//type codeS))) ## TODO: Inline "definition'" into "definition" ASAP -(def: (definition' translate name code//type codeS) +(def: (definition' generate name code//type codeS) (All [anchor expression statement] - (-> (translation.Phase anchor expression statement) + (-> (generation.Phase anchor expression statement) Name Type Synthesis (Operation anchor expression statement [Type expression Text Any]))) - (statement.lift-translation - (translation.with-buffer + (statement.lift-generation + (generation.with-buffer (do ///.monad - [codeT (translate codeS) - codeN+V (translation.define! name codeT)] + [codeT (generate codeS) + codeN+V (generation.define! name codeT)] (wrap [code//type codeT codeN+V]))))) (def: (definition name ?type codeC) @@ -81,7 +81,7 @@ [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)] + generate (get@ [#statement.generation #statement.phase] state)] [_ code//type codeA] (statement.lift-analysis (analysis.with-scope (type.with-fresh-env @@ -100,7 +100,7 @@ (wrap [code//type codeA])))))) codeS (statement.lift-synthesis (synthesize codeA))] - (definition' translate name code//type codeS))) + (definition' generate name code//type codeS))) (def: (define short-name type annotations value) (All [anchor expression statement] @@ -136,8 +136,8 @@ valueC) _ (..define short-name value//type annotationsV valueV) #let [_ (log! (format "Definition " (%name full-name)))]] - (statement.lift-translation - (translation.learn full-name valueN))) + (statement.lift-generation + (generation.learn full-name valueN))) _ (///.throw //.invalid-syntax [extension-name])))) @@ -199,10 +199,10 @@ _ (///.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::analysis analysis.Handler statement.lift-analysis] + [def::synthesis synthesis.Handler statement.lift-synthesis] + [def::generation (generation.Handler anchor expression statement) statement.lift-generation] + [def::statement (statement.Handler anchor expression statement) (<|)] ) (def: bundle::def @@ -213,7 +213,7 @@ (dictionary.put "alias" def::alias) (dictionary.put "analysis" def::analysis) (dictionary.put "synthesis" def::synthesis) - (dictionary.put "translation" def::translation) + (dictionary.put "generation" def::generation) (dictionary.put "statement" def::statement) ))) diff --git a/stdlib/source/lux/tool/compiler/phase/extension/translation.lux b/stdlib/source/lux/tool/compiler/phase/extension/translation.lux deleted file mode 100644 index 232c8c168..000000000 --- a/stdlib/source/lux/tool/compiler/phase/extension/translation.lux +++ /dev/null @@ -1,10 +0,0 @@ -(.module: - [lux #*] - [// - ["." bundle] - [// - [translation (#+ Bundle)]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/generation.lux b/stdlib/source/lux/tool/compiler/phase/generation.lux new file mode 100644 index 000000000..99a4c5517 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation.lux @@ -0,0 +1,255 @@ +(.module: + [lux #* + [control + [monad (#+ do)] + ["." exception (#+ exception:)]] + [data + ["." product] + ["." error (#+ Error)] + ["." name ("#/." equivalence)] + ["." text + format] + [collection + ["." row (#+ Row)] + ["." dictionary (#+ Dictionary)]]] + [world + [file (#+ Path)]]] + ["." // + ["." extension] + [// + [synthesis (#+ Synthesis)]]]) + +(do-template [] + [(exception: #export () + "")] + + [no-active-buffer] + [no-anchor] + ) + +(exception: #export (cannot-interpret {error Text}) + (exception.report + ["Error" error])) + +(exception: #export (unknown-lux-name {name Name}) + (exception.report + ["Name" (%name name)])) + +(exception: #export (cannot-overwrite-lux-name {lux-name Name} + {old-host-name Text} + {new-host-name Text}) + (exception.report + ["Lux Name" (%name lux-name)] + ["Old Host Name" old-host-name] + ["New Host Name" new-host-name])) + +(do-template [] + [(exception: #export ( {name Name}) + (exception.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 Path (Buffer statement))) + +(type: #export (State anchor expression statement) + {#context Context + #anchor (Maybe anchor) + #host (Host expression statement) + #buffer (Maybe (Buffer statement)) + #outputs (Outputs statement) + #counter Nat + #name-cache (Dictionary Name Text)}) + +(do-template [ ] + [(type: #export ( anchor expression statement) + ( (State anchor expression statement) Synthesis expression))] + + [State+ extension.State] + [Operation extension.Operation] + [Phase extension.Phase] + [Handler extension.Handler] + [Bundle extension.Bundle] + ) + +(def: #export (state host) + (All [anchor expression statement] + (-> (Host expression statement) + (..State anchor expression statement))) + {#context {#scope-name "" + #inner-functions 0} + #anchor #.None + #host host + #buffer #.None + #outputs (dictionary.new text.hash) + #counter 0 + #name-cache (dictionary.new name.hash)}) + +(def: #export (with-context expr) + (All [anchor expression statement output] + (-> (Operation anchor expression statement output) + (Operation anchor expression statement [Text output]))) + (function (_ [bundle state]) + (let [[old-scope old-inner] (get@ #context state) + new-scope (format old-scope "c" (%n old-inner))] + (case (expr [bundle (set@ #context [new-scope 0] state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] + [new-scope output]]) + + (#error.Failure error) + (#error.Failure error))))) + +(def: #export context + (All [anchor expression statement] + (Operation anchor expression statement Text)) + (extension.read (|>> (get@ #context) + (get@ #scope-name)))) + +(do-template [ + + ] + [(def: #export + (All [anchor expression statement output] ) + (function (_ body) + (function (_ [bundle state]) + (case (body [bundle (set@ (#.Some ) state)]) + (#error.Success [[bundle' state'] output]) + (#error.Success [[bundle' (set@ (get@ state) state')] + output]) + + (#error.Failure error) + (#error.Failure error))))) + + (def: #export + (All [anchor expression statement] + (Operation anchor expression statement )) + (function (_ (^@ stateE [bundle state])) + (case (get@ state) + (#.Some output) + (#error.Success [stateE output]) + + #.None + (exception.throw []))))] + + [#anchor + (with-anchor anchor) + (-> anchor (Operation anchor expression statement output) + (Operation anchor expression statement output)) + anchor + anchor anchor no-anchor] + + [#buffer + with-buffer + (-> (Operation anchor expression statement output) + (Operation anchor expression statement output)) + row.empty + buffer (Buffer statement) no-active-buffer] + ) + +(def: #export outputs + (All [anchor expression statement] + (Operation anchor expression statement (Outputs statement))) + (extension.read (get@ #outputs))) + +(def: #export next + (All [anchor expression statement] + (Operation anchor expression statement Nat)) + (do //.monad + [count (extension.read (get@ #counter)) + _ (extension.update (update@ #counter inc))] + (wrap count))) + +(do-template [ ] + [(def: #export ( label code) + (All [anchor expression statement] + (-> Text (Operation anchor expression statement Any))) + (function (_ (^@ state+ [bundle state])) + (case (:: (get@ #host state) label code) + (#error.Success output) + (#error.Success [state+ output]) + + (#error.Failure error) + (exception.throw cannot-interpret error))))] + + [evaluate! expression] + [execute! statement] + ) + +(def: #export (define! name code) + (All [anchor expression statement] + (-> Name expression (Operation anchor expression statement [Text Any]))) + (function (_ (^@ stateE [bundle state])) + (case (:: (get@ #host state) define! name code) + (#error.Success output) + (#error.Success [stateE output]) + + (#error.Failure error) + (exception.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] + (-> Path (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 + (exception.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) + (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux new file mode 100644 index 000000000..0bafcd3c0 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/case.lux @@ -0,0 +1,172 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + ["." list ("#/." functor fold)]]] + [host + ["_" js (#+ Expression Computation Var Statement)]]] + [// + ["//." runtime (#+ Operation Phase)] + ["//." reference] + ["//." primitive] + [// + ["." reference] + ["//." // ("#/." monad) + [// + [reference (#+ Register)] + ["." synthesis (#+ Synthesis Path)]]]]]) + +(def: #export register + (reference.local _.var)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation Computation)) + (do ////.monad + [valueO (generate valueS) + bodyO (generate bodyS)] + ## TODO: Find some way to do 'let' without paying the price of the closure. + (wrap (_.apply/* (<| (_.closure (list)) + ($_ _.then + (_.define (..register register) valueO) + (_.return bodyO))) + (list))))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation Expression)) + (do ////.monad + [valueO (generate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + //runtime.product//right + //runtime.product//left)] + (method source (_.i32 (.int idx))))) + valueO + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do ////.monad + [testO (generate testS) + thenO (generate thenS) + elseO (generate elseS)] + (wrap (_.? testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @alt-error (_.var "alt_error")) + +(def: (push-cursor! value) + (-> Expression Statement) + (_.statement (|> @cursor (_.do "push" (list value))))) + +(def: pop-cursor! + Statement + (_.statement (|> @cursor (_.do "pop" (list))))) + +(def: peek-cursor + Expression + (.let [idx (|> @cursor (_.the "length") (_.- (_.i32 +1)))] + (|> @cursor (_.at idx)))) + +(def: save-cursor! + Statement + (.let [cursor (|> @cursor (_.do "slice" (list)))] + (_.statement (|> @savepoint (_.do "push" (list cursor)))))) + +(def: restore-cursor! + Statement + (_.set @cursor (|> @savepoint (_.do "pop" (list))))) + +(def: fail-pm! _.break) + +(exception: #export unrecognized-path) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation Statement)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (do ////.monad + [body! (generate bodyS)] + (wrap (_.return body!))) + + #synthesis.Pop + (/////wrap pop-cursor!) + + (#synthesis.Bind register) + (/////wrap (_.define (..register register) ..peek-cursor)) + + (^template [ <=>] + (^ ( value)) + (/////wrap (_.when (|> value (<=> ..peek-cursor) _.not) + fail-pm!))) + ([synthesis.path/bit //primitive.bit _.=] + [synthesis.path/i64 (<| //primitive.i64 .int) //runtime.i64//=] + [synthesis.path/f64 //primitive.f64 _.=] + [synthesis.path/text //primitive.text _.=]) + + (^template [ ] + (^ ( idx)) + (/////wrap ($_ _.then + (_.set @temp (|> idx .int _.i32 (//runtime.sum//get ..peek-cursor ))) + (_.if (_.= _.null @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.null (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [ ] + (^ ( idx)) + (/////wrap (|> idx .int _.i32 ( ..peek-cursor) push-cursor!))) + ([synthesis.member/left //runtime.product//left (<|)] + [synthesis.member/right //runtime.product//right inc]) + + (^template [ ] + (^ ( leftP rightP)) + (do ////.monad + [left! (pattern-matching' generate leftP) + right! (pattern-matching' generate rightP)] + (wrap ))) + ([synthesis.path/seq (_.then left! right!)] + [synthesis.path/alt ($_ _.then + (_.do-while _.false + ($_ _.then + ..save-cursor! + left!)) + ($_ _.then + ..restore-cursor! + right!))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation Statement)) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap ($_ _.then + (_.do-while _.false + pattern-matching!) + (_.throw (_.string "Invalid expression for pattern-matching.")))))) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation Computation)) + (do ////.monad + [stack-init (generate valueS) + path! (pattern-matching generate pathP) + #let [closure (<| (_.closure (list)) + ($_ _.then + (_.declare @temp) + (_.define @cursor (_.array (list stack-init))) + (_.define @savepoint (_.array (list))) + path!))]] + (wrap (_.apply/* closure (list))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/expression.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/expression.lux new file mode 100644 index 000000000..e1d6dbbdb --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/expression.lux @@ -0,0 +1,60 @@ +(.module: + [lux #* + [control + [monad (#+ do)]]] + [// + [runtime (#+ Phase)] + ["." primitive] + ["." structure] + ["." reference] + ["." function] + ["." case] + ["." loop] + ["." /// + ["." extension] + [// + ["." synthesis]]]]) + +(def: #export (generate synthesis) + Phase + (case synthesis + (^template [ ] + (^ ( value)) + (:: ///.monad wrap ( value))) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant generate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple generate members) + + (#synthesis.Reference value) + (:: reference.system reference value) + + (^ (synthesis.branch/case case)) + (case.case generate case) + + (^ (synthesis.branch/let let)) + (case.let generate let) + + (^ (synthesis.branch/if if)) + (case.if generate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope generate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur generate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function generate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply generate application) + + (#synthesis.Extension extension) + (extension.apply generate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux new file mode 100644 index 000000000..98ef827a8 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/common.lux @@ -0,0 +1,232 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["e" error] + ["." product] + [number (#+ hex)] + [collection + ["." list ("#/." functor)] + ["." dictionary]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:) + ["_" js (#+ Expression Computation)]]] + [/// + ["///." runtime (#+ Operation Phase Handler Bundle)] + ["///." primitive] + ["//." /// + ["." extension + ["." bundle]] + [// + ["." synthesis (#+ Synthesis)]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do /////.monad + [inputsI (monad.map @ phase inputsS)] + (wrap (extension inputsI)))))) + +## [Procedures] +## [[Bits]] +(do-template [ ] + [(def: ( [paramJS subjectJS]) + Binary + ( subjectJS (///runtime.i64//to-number paramJS)))] + + [i64//left-shift ///runtime.i64//left-shift] + [i64//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift] + [i64//logical-right-shift ///runtime.i64//logic-right-shift] + ) + +## [[Numbers]] +(import: #long java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [ ] + [(def: ( _) + Nullary + (///primitive.f64 ))] + + [frac//smallest (java/lang/Double::MIN_VALUE)] + [frac//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] + [frac//max (java/lang/Double::MAX_VALUE)] + ) + +(def: frac//decode + Unary + (|>> list + (_.apply/* (_.var "parseFloat")) + _.return + (_.closure (list)) + ///runtime.lux//try)) + +(def: int//char + Unary + (|>> ///runtime.i64//to-number + (list) + (_.apply/* (_.var "String.fromCharCode")))) + +## [[Text]] +(def: (text//concat [subjectJS paramJS]) + Binary + (|> subjectJS (_.do "concat" (list paramJS)))) + +(do-template [ ] + [(def: ( [subjectJS paramJS extraJS]) + Trinary + ( subjectJS paramJS extraJS))] + + [text//clip ///runtime.text//clip] + [text//index ///runtime.text//index] + ) + +## [[IO]] +(def: (io//log messageJS) + Unary + ($_ _., + (///runtime.io//log messageJS) + ///runtime.unit)) + +(def: (io//exit codeJS) + Unary + (let [@@process (_.var "process") + @@window (_.var "window") + @@location (_.var "location")] + ($_ _.or + ($_ _.and + (_.not (_.= _.undefined (_.type-of @@process))) + (_.the "exit" @@process) + (_.do "exit" (list (///runtime.i64//to-number codeJS)) @@process)) + (_.do "close" (list) @@window) + (_.do "reload" (list) @@location)))) + +(def: (io//current-time _) + Nullary + (|> (_.new (_.var "Date") (list)) + (_.do "getTime" (list)) + ///runtime.i64//from-number)) + +## [Bundles] +(def: lux-procs + Bundle + (|> bundle.empty + (bundle.install "is" (binary (product.uncurry _.=))) + (bundle.install "try" (unary ///runtime.lux//try)))) + +(def: i64-procs + Bundle + (<| (bundle.prefix "i64") + (|> bundle.empty + (bundle.install "and" (binary (product.uncurry ///runtime.i64//and))) + (bundle.install "or" (binary (product.uncurry ///runtime.i64//or))) + (bundle.install "xor" (binary (product.uncurry ///runtime.i64//xor))) + (bundle.install "left-shift" (binary i64//left-shift)) + (bundle.install "logical-right-shift" (binary i64//logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) + (bundle.install "=" (binary (product.uncurry ///runtime.i64//=))) + (bundle.install "+" (binary (product.uncurry ///runtime.i64//+))) + (bundle.install "-" (binary (product.uncurry ///runtime.i64//-))) + ))) + +(def: int-procs + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "<" (binary (product.uncurry ///runtime.i64//<))) + (bundle.install "*" (binary (product.uncurry ///runtime.i64//*))) + (bundle.install "/" (binary (product.uncurry ///runtime.i64///))) + (bundle.install "%" (binary (product.uncurry ///runtime.i64//%))) + (bundle.install "frac" (unary ///runtime.i64//to-number)) + (bundle.install "char" (unary int//char))))) + +(def: frac-procs + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary (product.uncurry _.+))) + (bundle.install "-" (binary (product.uncurry _.-))) + (bundle.install "*" (binary (product.uncurry _.*))) + (bundle.install "/" (binary (product.uncurry _./))) + (bundle.install "%" (binary (product.uncurry _.%))) + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "smallest" (nullary frac//smallest)) + (bundle.install "min" (nullary frac//min)) + (bundle.install "max" (nullary frac//max)) + (bundle.install "int" (unary ///runtime.i64//from-number)) + (bundle.install "encode" (unary (_.do "toString" (list)))) + (bundle.install "decode" (unary frac//decode))))) + +(def: text-procs + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary (product.uncurry _.=))) + (bundle.install "<" (binary (product.uncurry _.<))) + (bundle.install "concat" (binary text//concat)) + (bundle.install "index" (trinary text//index)) + (bundle.install "size" (unary (|>> (_.the "length") ///runtime.i64//from-number))) + (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) + (bundle.install "clip" (trinary text//clip)) + ))) + +(def: io-procs + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary io//log)) + (bundle.install "error" (unary ///runtime.io//error)) + (bundle.install "exit" (unary io//exit)) + (bundle.install "current-time" (nullary io//current-time))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> lux-procs + (dictionary.merge i64-procs) + (dictionary.merge int-procs) + (dictionary.merge frac-procs) + (dictionary.merge text-procs) + (dictionary.merge io-procs) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux new file mode 100644 index 000000000..519852967 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/extension/host.lux @@ -0,0 +1,121 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]] + [data + ["." product] + [collection + ["." dictionary]]] + [host + ["_" js]]] + [// + ["." common (#+ Nullary Binary Trinary Variadic)] + [// + ["///." runtime (#+ Handler Bundle)] + ["//." /// + ["." extension + ["." bundle]] + [// + ["." synthesis]]]]]) + +(do-template [ ] + [(def: ( _) Nullary )] + + [js//null _.null] + [js//undefined _.undefined] + [js//object (_.object (list))] + ) + +(def: (js//global name generate inputs) + Handler + (case inputs + (^ (list (synthesis.text global))) + (:: /////.monad wrap (_.var global)) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: (js//call name generate inputs) + Handler + (case inputs + (^ (list& functionS argsS+)) + (do /////.monad + [functionJS (generate functionS) + argsJS+ (monad.map @ generate argsS+)] + (wrap (_.apply/* functionJS argsJS+))) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: js + Bundle + (|> bundle.empty + (bundle.install "null" (common.nullary js//null)) + (bundle.install "undefined" (common.nullary js//undefined)) + (bundle.install "object" (common.nullary js//object)) + (bundle.install "array" (common.variadic _.array)) + (bundle.install "global" js//global) + (bundle.install "call" js//call))) + +(def: (object//new name generate inputs) + Handler + (case inputs + (^ (list& constructorS argsS+)) + (do /////.monad + [constructorJS (generate constructorS) + argsJS+ (monad.map @ generate argsS+)] + (wrap (_.new constructorJS argsJS+))) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: (object//call name generate inputs) + Handler + (case inputs + (^ (list& objectS methodS argsS+)) + (do /////.monad + [objectJS (generate objectS) + methodJS (generate methodS) + argsJS+ (monad.map @ generate argsS+)] + (wrap (|> objectJS + (_.at methodJS) + (_.do "apply" (list& objectJS argsJS+))))) + + _ + (/////.throw extension.incorrect-syntax name))) + +(def: (object//set [fieldJS valueJS objectJS]) + Trinary + (///runtime.js//set objectJS fieldJS valueJS)) + +(def: object + Bundle + (<| (bundle.prefix "object") + (|> bundle.empty + (bundle.install "new" object//new) + (bundle.install "call" object//call) + (bundle.install "read" (common.binary (product.uncurry ///runtime.js//get))) + (bundle.install "write" (common.trinary object//set)) + (bundle.install "delete" (common.binary (product.uncurry ///runtime.js//delete))) + ))) + +(def: (array//write [indexJS valueJS arrayJS]) + Trinary + (///runtime.array//write indexJS valueJS arrayJS)) + +(def: array + Bundle + (<| (bundle.prefix "array") + (|> bundle.empty + (bundle.install "read" (common.binary (product.uncurry ///runtime.array//read))) + (bundle.install "write" (common.trinary array//write)) + (bundle.install "delete" (common.binary (product.uncurry ///runtime.array//delete))) + (bundle.install "length" (common.unary (_.the "length"))) + ))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "js") + (|> ..js + (dictionary.merge ..object) + (dictionary.merge ..array)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/function.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/function.lux new file mode 100644 index 000000000..ca647a81a --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/function.lux @@ -0,0 +1,108 @@ +(.module: + [lux (#- function) + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#/." functor fold)]]] + [host + ["_" js (#+ Expression Computation Var)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["//." case] + ["/." // + ["common-." reference] + ["//." // ("#/." monad) + [// + [reference (#+ Register Variable)] + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + ["." name]]]]]) + +(def: #export (apply generate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.monad + [functionO (generate functionS) + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: #export capture + (common-reference.foreign _.var)) + +(def: (with-closure inits function-definition) + (-> (List Expression) Computation (Operation Computation)) + (/////wrap + (case inits + #.Nil + function-definition + + _ + (let [closure (_.closure (|> (list.enumerate inits) + (list/map (|>> product.left ..capture))) + (_.return function-definition))] + (_.apply/* closure inits))))) + +(def: @curried (_.var "curried")) + +(def: input + (|>> inc //case.register)) + +(def: @@arguments (_.var "arguments")) + +(def: #export (function generate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (generate bodyS)))) + closureO+ (: (Operation (List Expression)) + (monad.map @ (:: reference.system variable) environment)) + #let [arityO (|> arity .int _.i32) + @num-args (_.var "num_args") + @self (_.var function-name) + apply-poly (.function (_ args func) + (|> func (_.do "apply" (list _.null args)))) + initialize-self! (_.define (//case.register 0) @self) + initialize! (list/fold (.function (_ post pre!) + ($_ _.then + pre! + (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) + initialize-self! + (list.indices arity))]] + (with-closure closureO+ + (_.function @self (list) + ($_ _.then + (_.define @num-args (_.the "length" @@arguments)) + (_.cond (list [(|> @num-args (_.= arityO)) + ($_ _.then + initialize! + (_.return bodyO))] + [(|> @num-args (_.> arityO)) + (let [arity-inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments (_.i32 +0) arityO))) + extra-inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments arityO)))] + (_.return (|> @self + (apply-poly arity-inputs) + (apply-poly extra-inputs))))]) + ## (|> @num-args (_.< arityO)) + (let [all-inputs (|> (_.array (list)) + (_.the "slice") + (_.do "call" (list @@arguments)))] + ($_ _.then + (_.define @curried all-inputs) + (_.return (_.closure (list) + (let [@missing all-inputs] + (_.return (apply-poly (_.do "concat" (list @missing) @curried) + @self)))))))) + ))) + )) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/loop.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/loop.lux new file mode 100644 index 000000000..4e3c7d8a9 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/loop.lux @@ -0,0 +1,42 @@ +(.module: + [lux (#- Scope) + [control + ["." monad (#+ do)]] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#/." functor)]]] + [host + ["_" js (#+ Computation Var)]]] + [// + [runtime (#+ Operation Phase)] + ["." reference] + ["//." case] + ["/." // + ["//." // + [// + [synthesis (#+ Scope Synthesis)]]]]]) + +(def: @scope (_.var "scope")) + +(def: #export (scope generate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation Computation)) + (do ////.monad + [initsO+ (monad.map @ generate initsS+) + bodyO (///.with-anchor @scope + (generate bodyS)) + #let [closure (_.function @scope + (|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ start) //case.register))) + (_.return bodyO))]] + (wrap (_.apply/* closure initsO+)))) + +(def: #export (recur generate argsS+) + (-> Phase (List Synthesis) (Operation Computation)) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux new file mode 100644 index 000000000..139fcb191 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/primitive.lux @@ -0,0 +1,38 @@ +(.module: + [lux (#- i64) + [control + [pipe (#+ cond> new>)]] + [data + [number + ["." frac]]] + [host + ["_" js (#+ Computation)]]] + [// + ["//." runtime]]) + +(def: #export bit + (-> Bit Computation) + _.boolean) + +(def: #export (i64 value) + (-> (I64 Any) Computation) + (//runtime.i64//new (|> value //runtime.high .int _.i32) + (|> value //runtime.low .int _.i32))) + +(def: #export f64 + (-> Frac Computation) + (|>> (cond> [(f/= frac.positive-infinity)] + [(new> _.positive-infinity [])] + + [(f/= frac.negative-infinity)] + [(new> _.negative-infinity [])] + + [(f/= frac.not-a-number)] + [(new> _.not-a-number [])] + + ## else + [_.number]))) + +(def: #export text + (-> Text Computation) + _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/reference.lux new file mode 100644 index 000000000..9f8555788 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/reference.lux @@ -0,0 +1,11 @@ +(.module: + [lux #* + [host + ["_" js (#+ Expression)]]] + [// + [// + ["." reference]]]) + +(def: #export system + (reference.system (: (-> Text Expression) _.var) + (: (-> Text Expression) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux new file mode 100644 index 000000000..fe400e403 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/runtime.lux @@ -0,0 +1,756 @@ +(.module: + [lux #* + ["." function] + [control + [monad (#+ do)] + ["p" parser]] + [data + [number (#+ hex) + ["." i64]] + ["." text + format] + [collection + ["." list ("#/." functor)]]] + ["." macro + ["." code] + ["s" syntax (#+ syntax:)]] + [host + ["_" js (#+ Expression Var Computation Statement)]]] + ["." /// + ["//." // + [// + ["/////." name] + ["." synthesis]]]] + ) + +(do-template [ ] + [(type: #export + ( Var Expression Statement))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(type: #export (Generator i) + (-> i Phase (Operation Expression))) + +(def: prefix Text "LuxRuntime") + +(def: #export high + (-> (I64 Any) (I64 Any)) + (i64.logic-right-shift 32)) + +(def: #export low + (-> (I64 Any) (I64 Any)) + (let [mask (dec (i64.left-shift 32 1))] + (|>> (i64.and mask)))) + +(def: #export variant-tag-field "_lux_tag") +(def: #export variant-flag-field "_lux_flag") +(def: #export variant-value-field "_lux_value") + +(def: #export unit Computation (_.string synthesis.unit)) + +(def: #export (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.null)) + +(def: #export (variant tag last? value) + (-> Expression Expression Expression Computation) + (_.object (list [..variant-tag-field tag] + [..variant-flag-field last?] + [..variant-value-field value]))) + +(def: none + Computation + (..variant (_.i32 +0) (flag #0) unit)) + +(def: some + (-> Expression Computation) + (..variant (_.i32 +1) (flag #1))) + +(def: left + (-> Expression Computation) + (..variant (_.i32 +0) (flag #0))) + +(def: right + (-> Expression Computation) + (..variant (_.i32 +1) (flag #1))) + +(def: variable + (-> Text Var) + (|>> /////name.normalize + _.var)) + +(def: runtime-name + (-> Text Var) + (|>> /////name.normalize + (format prefix "$") + _.var)) + +(def: (feature name definition) + (-> Var (-> Var Expression) Statement) + (_.define name (definition name))) + +(syntax: (code-name {definition-name s.local-identifier}) + (wrap (list (code.local-identifier (format "@" definition-name))))) + +(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (/////name.normalize var)))))))) + list.concat))] + (~ body)))))) + +(syntax: (runtime: {declaration (p.or s.local-identifier + (s.form (p.and s.local-identifier + (p.some s.local-identifier))))} + code) + (case declaration + (#.Left name) + (macro.with-gensyms [g!_] + (let [nameC (code.local-identifier name) + code-nameC (code.local-identifier (format "@" name)) + runtime-nameC (` (runtime-name (~ (code.text name))))] + (wrap (list (` (def: #export (~ nameC) Var (~ runtime-nameC))) + (` (def: (~ code-nameC) + Statement + (..feature (~ runtime-nameC) + (function ((~ g!_) (~ nameC)) + (~ code))))))))) + + (#.Right [name inputs]) + (macro.with-gensyms [g!_] + (let [nameC (code.local-identifier name) + code-nameC (code.local-identifier (format "@" name)) + runtime-nameC (` (runtime-name (~ (code.text name)))) + inputsC (list/map code.local-identifier inputs) + inputs-typesC (list/map (function.constant (` _.Expression)) inputs)] + (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) + (-> (~+ inputs-typesC) Computation) + (_.apply/* (~ runtime-nameC) (list (~+ inputsC))))) + (` (def: (~ code-nameC) + Statement + (..feature (~ runtime-nameC) + (function ((~ g!_) (~ g!_)) + (..with-vars [(~+ inputsC)] + (_.function (~ g!_) (list (~+ inputsC)) + (~ code))))))))))))) + +(runtime: (lux//try op) + (with-vars [ex] + (_.try (_.return (_.apply/1 op ..unit)) + [ex (_.return (|> ex (_.do "toString" (list))))]))) + +(def: length + (-> Expression Computation) + (_.the "length")) + +(def: last-index + (-> Expression Computation) + (|>> ..length (_.- (_.i32 +1)))) + +(def: (last-element tuple) + (_.at (..last-index tuple) + tuple)) + +(runtime: (lux//program-args) + (with-vars [process output idx] + (_.if (_.and (|> process _.type-of (_.= _.undefined) _.not) + (|> process (_.the "argv"))) + ($_ _.then + (_.define output ..none) + (_.for idx + (|> process (_.the "argv") ..last-index) + (_.>= (_.i32 +0) idx) + (_.-- idx) + (_.set output (..some (_.array (list (|> process (_.the "argv") (_.at idx)) + output))))) + (_.return output)) + (_.return ..none)))) + +(def: runtime//lux + Statement + ($_ _.then + @lux//try + @lux//program-args + )) + +(runtime: (product//left product index) + (with-vars [index-min-length] + ($_ _.then + (_.define index-min-length (_.+ (_.i32 +1) index)) + (_.if (_.< (..length product) + index-min-length) + ## No need for recursion. + (_.return (_.at index product)) + ## Needs recursion. + (_.return (product//left (last-element product) + (_.- (..length product) + index-min-length))) + )))) + +(runtime: (product//right product index) + (with-vars [index-min-length] + ($_ _.then + (_.define index-min-length (_.+ (_.i32 +1) index)) + (_.cond (list [(_.= index-min-length + (..length product)) + ## Last element. + (_.return (_.at index product))] + [(_.< index-min-length + (..length product)) + ## Needs recursion. + (_.return (product//right (last-element product) + (_.- (..length product) + index-min-length)))]) + ## Must slice + (_.return (_.do "slice" (list index) product)))))) + +(runtime: (sum//get sum wants-last wanted-tag) + (let [no-match! (_.return _.null) + sum-tag (|> sum (_.the ..variant-tag-field)) + sum-flag (|> sum (_.the ..variant-flag-field)) + sum-value (|> sum (_.the ..variant-value-field)) + is-last? (_.= ..unit sum-flag) + extact-match! (_.return sum-value) + test-recursion! (_.if is-last? + ## Must recurse. + (_.return (sum//get sum-value (_.- sum-tag wanted-tag) wants-last)) + no-match!) + extrac-sub-variant! (_.return (..variant (_.- wanted-tag sum-tag) sum-flag sum-value))] + (_.cond (list [(_.= wanted-tag sum-tag) + (_.if (_.= wants-last sum-flag) + extact-match! + test-recursion!)] + [(_.< wanted-tag sum-tag) + test-recursion!] + [(_.and (_.> wanted-tag sum-tag) + (_.= ..unit wants-last)) + extrac-sub-variant!]) + no-match!))) + +(def: runtime//structure + Statement + ($_ _.then + @product//left + @product//right + @sum//get + )) + +(def: #export i64-high-field Text "_lux_high") +(def: #export i64-low-field Text "_lux_low") + +(runtime: (i64//new high low) + (_.return (_.object (list [..i64-high-field high] + [..i64-low-field low])))) + +(runtime: i64//2^16 + (_.left-shift (_.i32 +16) (_.i32 +1))) + +(runtime: i64//2^32 + (_.* i64//2^16 i64//2^16)) + +(runtime: i64//2^64 + (_.* i64//2^32 i64//2^32)) + +(runtime: i64//2^63 + (|> i64//2^64 (_./ (_.i32 +2)))) + +(runtime: (i64//unsigned-low i64) + (_.return (_.? (|> i64 (_.the ..i64-low-field) (_.>= (_.i32 +0))) + (|> i64 (_.the ..i64-low-field)) + (|> i64 (_.the ..i64-low-field) (_.+ i64//2^32))))) + +(runtime: (i64//to-number i64) + (_.return (|> i64 (_.the ..i64-high-field) (_.* i64//2^32) + (_.+ (i64//unsigned-low i64))))) + +(runtime: i64//zero + (i64//new (_.i32 +0) (_.i32 +0))) + +(runtime: i64//min + (i64//new (_.i32 (hex "+80000000")) (_.i32 +0))) + +(runtime: i64//max + (i64//new (_.i32 (hex "+7FFFFFFF")) (_.i32 (hex "+FFFFFFFF")))) + +(runtime: i64//one + (i64//new (_.i32 +0) (_.i32 +1))) + +(runtime: (i64//= left right) + (_.return (_.and (_.= (_.the ..i64-high-field left) + (_.the ..i64-high-field right)) + (_.= (_.the ..i64-low-field left) + (_.the ..i64-low-field right))))) + +(runtime: (i64//+ subject parameter) + (let [up-16 (_.left-shift (_.i32 +16)) + high-16 (_.logic-right-shift (_.i32 +16)) + low-16 (_.bit-and (_.i32 (hex "+FFFF"))) + hh (|>> (_.the ..i64-high-field) high-16) + hl (|>> (_.the ..i64-high-field) low-16) + lh (|>> (_.the ..i64-low-field) high-16) + ll (|>> (_.the ..i64-low-field) low-16)] + (with-vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.define l48 (hh subject)) + (_.define l32 (hl subject)) + (_.define l16 (lh subject)) + (_.define l00 (ll subject)) + + (_.define r48 (hh parameter)) + (_.define r32 (hl parameter)) + (_.define r16 (lh parameter)) + (_.define r00 (ll parameter)) + + (_.define x00 (_.+ l00 r00)) + (_.define x16 (high-16 x00)) + (_.set x00 (low-16 x00)) + (_.set x16 (|> x16 (_.+ l16) (_.+ r16))) + (_.define x32 (high-16 x16)) + (_.set x16 (low-16 x16)) + (_.set x32 (|> x32 (_.+ l32) (_.+ r32))) + (_.define x48 (|> (high-16 x32) (_.+ l48) (_.+ r48) low-16)) + (_.set x32 (low-16 x32)) + + (_.return (i64//new (_.bit-or (up-16 x48) x32) + (_.bit-or (up-16 x16) x00))) + )))) + +(do-template [ ] + [(runtime: ( subject parameter) + (_.return (i64//new ( (_.the ..i64-high-field subject) + (_.the ..i64-high-field parameter)) + ( (_.the ..i64-low-field subject) + (_.the ..i64-low-field parameter)))))] + + [i64//xor _.bit-xor] + [i64//or _.bit-or] + [i64//and _.bit-and] + ) + +(runtime: (i64//not value) + (_.return (i64//new (_.bit-not (_.the ..i64-high-field value)) + (_.bit-not (_.the ..i64-low-field value))))) + +(runtime: (i64//negate value) + (_.if (i64//= i64//min value) + (_.return i64//min) + (_.return (i64//+ (i64//not value) i64//one)))) + +(runtime: i64//-one + (i64//negate i64//one)) + +(runtime: (i64//from-number value) + (_.cond (list [(_.not-a-number? value) + (_.return i64//zero)] + [(_.<= (_.negate i64//2^63) value) + (_.return i64//min)] + [(|> value (_.+ (_.i32 +1)) (_.>= i64//2^63)) + (_.return i64//max)] + [(|> value (_.< (_.i32 +0))) + (_.return (|> value _.negate i64//from-number i64//negate))]) + (_.return (i64//new (_./ i64//2^32 value) + (_.% i64//2^32 value))))) + +(def: (cap-shift! shift) + (-> Var Statement) + (_.set shift (|> shift (_.bit-and (_.i32 +63))))) + +(def: (no-shift! shift input) + (-> Var Var [Expression Statement]) + [(|> shift (_.= (_.i32 +0))) + (_.return input)]) + +(def: small-shift? + (-> Var Expression) + (|>> (_.< (_.i32 +32)))) + +(runtime: (i64//left-shift input shift) + ($_ _.then + (..cap-shift! shift) + (_.cond (list (..no-shift! shift input) + [(..small-shift? shift) + (let [high (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift shift)) + (|> input (_.the ..i64-low-field) (_.logic-right-shift (_.- shift (_.i32 +32))))) + low (|> input (_.the ..i64-low-field) (_.left-shift shift))] + (_.return (i64//new high low)))]) + (let [high (|> input (_.the ..i64-low-field) (_.left-shift (_.- (_.i32 +32) shift)))] + (_.return (i64//new high (_.i32 +0))))))) + +(runtime: (i64//arithmetic-right-shift input shift) + ($_ _.then + (..cap-shift! shift) + (_.cond (list (..no-shift! shift input) + [(..small-shift? shift) + (let [high (|> input (_.the ..i64-high-field) (_.arithmetic-right-shift shift)) + low (|> input (_.the ..i64-low-field) (_.logic-right-shift shift) + (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift (_.- shift (_.i32 +32))))))] + (_.return (i64//new high low)))]) + (let [high (_.? (|> input (_.the ..i64-high-field) (_.>= (_.i32 +0))) + (_.i32 +0) + (_.i32 -1)) + low (|> input (_.the ..i64-high-field) (_.arithmetic-right-shift (_.- (_.i32 +32) shift)))] + (_.return (i64//new high low)))))) + +(runtime: (i64//logic-right-shift input shift) + ($_ _.then + (..cap-shift! shift) + (_.cond (list (..no-shift! shift input) + [(..small-shift? shift) + (let [high (|> input (_.the ..i64-high-field) (_.logic-right-shift shift)) + low (|> input (_.the ..i64-low-field) (_.logic-right-shift shift) + (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift (_.- shift (_.i32 +32))))))] + (_.return (i64//new high low)))] + [(|> shift (_.= (_.i32 +32))) + (_.return (i64//new (_.i32 +0) (|> input (_.the ..i64-high-field))))]) + (_.return (i64//new (_.i32 +0) + (|> input (_.the ..i64-high-field) (_.logic-right-shift (_.- (_.i32 +32) shift)))))))) + +(def: runtime//bit + Statement + ($_ _.then + @i64//and + @i64//or + @i64//xor + @i64//not + @i64//left-shift + @i64//arithmetic-right-shift + @i64//logic-right-shift + )) + +(runtime: (i64//- subject parameter) + (_.return (i64//+ subject (i64//negate parameter)))) + +(runtime: (i64//* subject parameter) + (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))] + (_.cond (list [(negative? subject) + (_.if (negative? parameter) + ## Both are negative + (_.return (i64//* (i64//negate subject) (i64//negate parameter))) + ## Subject is negative + (_.return (i64//negate (i64//* (i64//negate subject) parameter))))] + [(negative? parameter) + ## Parameter is negative + (_.return (i64//negate (i64//* subject (i64//negate parameter))))]) + ## Both are positive + (let [up-16 (_.left-shift (_.i32 +16)) + high-16 (_.logic-right-shift (_.i32 +16)) + low-16 (_.bit-and (_.i32 (hex "+FFFF"))) + hh (|>> (_.the ..i64-high-field) high-16) + hl (|>> (_.the ..i64-high-field) low-16) + lh (|>> (_.the ..i64-low-field) high-16) + ll (|>> (_.the ..i64-low-field) low-16)] + (with-vars [l48 l32 l16 l00 + r48 r32 r16 r00 + x48 x32 x16 x00] + ($_ _.then + (_.define l48 (hh subject)) + (_.define l32 (hl subject)) + (_.define l16 (lh subject)) + (_.define l00 (ll subject)) + + (_.define r48 (hh parameter)) + (_.define r32 (hl parameter)) + (_.define r16 (lh parameter)) + (_.define r00 (ll parameter)) + + (_.define x00 (_.* l00 r00)) + (_.define x16 (high-16 x00)) + (_.set x00 (low-16 x00)) + + (_.set x16 (|> x16 (_.+ (_.* l16 r00)))) + (_.define x32 (high-16 x16)) (_.set x16 (low-16 x16)) + (_.set x16 (|> x16 (_.+ (_.* l00 r16)))) + (_.set x32 (|> x32 (_.+ (high-16 x16)))) (_.set x16 (low-16 x16)) + + (_.set x32 (|> x32 (_.+ (_.* l32 r00)))) + (_.define x48 (high-16 x32)) (_.set x32 (low-16 x32)) + (_.set x32 (|> x32 (_.+ (_.* l16 r16)))) + (_.set x48 (|> x48 (_.+ (high-16 x32)))) (_.set x32 (low-16 x32)) + (_.set x32 (|> x32 (_.+ (_.* l00 r32)))) + (_.set x48 (|> x48 (_.+ (high-16 x32)))) (_.set x32 (low-16 x32)) + + (_.set x48 (|> x48 + (_.+ (_.* l48 r00)) + (_.+ (_.* l32 r16)) + (_.+ (_.* l16 r32)) + (_.+ (_.* l00 r48)) + low-16)) + + (_.return (i64//new (_.bit-or (up-16 x48) x32) + (_.bit-or (up-16 x16) x00))) + )))))) + +(runtime: (i64//< subject parameter) + (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))] + (with-vars [-subject? -parameter?] + ($_ _.then + (_.define -subject? (negative? subject)) + (_.define -parameter? (negative? parameter)) + (_.cond (list [(_.and -subject? (_.not -parameter?)) + (_.return _.true)] + [(_.and (_.not -subject?) -parameter?) + (_.return _.false)]) + (_.return (negative? (i64//- subject parameter)))))))) + +(def: (i64//<= subject param) + (-> Expression Expression Expression) + (_.or (i64//< subject param) + (i64//= subject param))) + +(runtime: (i64/// subject parameter) + (let [negative? (function (_ value) + (i64//< value i64//zero)) + valid-division-check [(i64//= i64//zero parameter) + (_.throw (_.string "Cannot divide by zero!"))] + short-circuit-check [(i64//= i64//zero subject) + (_.return i64//zero)]] + (_.cond (list valid-division-check + short-circuit-check + + [(i64//= i64//min subject) + (_.cond (list [(_.or (i64//= i64//one parameter) + (i64//= i64//-one parameter)) + (_.return i64//min)] + [(i64//= i64//min parameter) + (_.return i64//one)]) + (with-vars [approximation] + (let [subject/2 (i64//arithmetic-right-shift subject (_.i32 +1))] + ($_ _.then + (_.define approximation (i64//left-shift (i64/// subject/2 + parameter) + (_.i32 +1))) + (_.if (i64//= i64//zero approximation) + (_.return (_.? (negative? parameter) + i64//one + i64//-one)) + (let [remainder (i64//- subject + (i64//* parameter + approximation))] + (_.return (i64//+ approximation + (i64/// remainder + parameter)))))))))] + [(i64//= i64//min parameter) + (_.return i64//zero)] + + [(negative? subject) + (_.return (_.? (negative? parameter) + (i64/// (i64//negate subject) + (i64//negate parameter)) + (i64//negate (i64/// (i64//negate subject) + parameter))))] + + [(negative? parameter) + (_.return (i64//negate (i64/// subject (i64//negate parameter))))]) + (with-vars [result remainder] + ($_ _.then + (_.define result i64//zero) + (_.define remainder subject) + (_.while (i64//<= parameter remainder) + (with-vars [approximate approximate-result approximate-remainder log2 delta] + (let [approximate-result' (i64//from-number approximate) + approx-remainder (i64//* approximate-result parameter)] + ($_ _.then + (_.define approximate (|> (i64//to-number remainder) + (_./ (i64//to-number parameter)) + (_.apply/1 (_.var "Math.floor")) + (_.apply/2 (_.var "Math.max") (_.i32 +1)))) + (_.define log2 (|> approximate + (_.apply/1 (_.var "Math.log")) + (_./ (_.var "Math.LN2")) + (_.apply/1 (_.var "Math.ceil")))) + (_.define delta (_.? (_.<= (_.i32 +48) log2) + (_.i32 +1) + (_.apply/2 (_.var "Math.pow") + (_.i32 +2) + (_.- (_.i32 +48) + log2)))) + (_.define approximate-result approximate-result') + (_.define approximate-remainder approx-remainder) + (_.while (_.or (negative? approximate-remainder) + (i64//< remainder + approximate-remainder)) + ($_ _.then + (_.set approximate (_.- delta approximate)) + (_.set approximate-result approximate-result') + (_.set approximate-remainder approx-remainder))) + (_.set result (i64//+ result + (_.? (i64//= i64//zero approximate-result) + i64//one + approximate-result))) + (_.set remainder (i64//- remainder approximate-remainder)))))) + (_.return result))) + ))) + +(runtime: (i64//% subject parameter) + (let [flat (i64//* (i64/// subject parameter) + parameter)] + (_.return (i64//- subject flat)))) + +(def: runtime//i64 + Statement + ($_ _.then + @i64//2^16 + @i64//2^32 + @i64//2^64 + @i64//2^63 + @i64//unsigned-low + @i64//new + @i64//zero + @i64//min + @i64//max + @i64//one + @i64//= + @i64//+ + @i64//negate + @i64//to-number + @i64//from-number + @i64//- + @i64//* + @i64//< + @i64/// + @i64//% + runtime//bit + )) + +(runtime: (text//index text part start) + (with-vars [idx] + ($_ _.then + (_.define idx (|> text (_.do "indexOf" (list part (i64//to-number start))))) + (_.if (_.= (_.i32 -1) idx) + (_.return ..none) + (_.return (..some (i64//from-number idx))))))) + +(runtime: (text//clip text start end) + (_.return (|> text (_.do "substring" (list (_.the ..i64-low-field start) + (_.the ..i64-low-field end)))))) + +(runtime: (text//char text idx) + (with-vars [result] + ($_ _.then + (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64-low-field idx))))) + (_.if (_.not-a-number? result) + (_.return ..none) + (_.return (..some (i64//from-number result))))))) + +(def: runtime//text + Statement + ($_ _.then + @text//index + @text//clip + @text//char + )) + +(runtime: (io//log message) + (let [console (_.var "console") + print (_.var "print") + end! (_.return ..unit)] + (_.cond (list [(|> console _.type-of (_.= (_.string "undefined")) _.not + (_.and (_.the "log" console))) + ($_ _.then + (_.statement (|> console (_.do "log" (list message)))) + end!)] + [(|> print _.type-of (_.= (_.string "undefined")) _.not) + ($_ _.then + (_.statement (_.apply/1 print (_.apply/1 (_.var "JSON.stringify") message))) + end!)]) + end!))) + +(runtime: (io//error message) + (_.throw message)) + +(def: runtime//io + Statement + ($_ _.then + @io//log + @io//error + )) + +(runtime: (js//get object field) + (with-vars [temp] + ($_ _.then + (_.define temp (_.at field object)) + (_.if (_.= _.undefined temp) + (_.return ..none) + (_.return (..some temp)))))) + +(runtime: (js//set object field input) + ($_ _.then + (_.set (_.at field object) input) + (_.return object))) + +(runtime: (js//delete object field) + ($_ _.then + (_.delete (_.at field object)) + (_.return object))) + +(def: runtime//js + Statement + ($_ _.then + @js//get + @js//set + @js//delete + )) + +(runtime: (array//read idx array) + (let [fail! (_.return ..none)] + (_.if (_.< (..length array) idx) + (with-vars [temp] + ($_ _.then + (_.define temp (_.at idx array)) + (_.if (_.= _.undefined temp) + fail! + (_.return (..some temp))))) + fail!))) + +(runtime: (array//write idx value array) + (_.if (_.< (..length array) idx) + ($_ _.then + (_.set (_.at idx array) value) + (_.return (..some array))) + (_.return ..none))) + +(runtime: (array//delete idx array) + (_.if (_.< (..length array) idx) + ($_ _.then + (_.delete (_.at idx array)) + (_.return (..some array))) + (_.return ..none))) + +(def: runtime//array + Statement + ($_ _.then + @array//read + @array//write + @array//delete)) + +(def: runtime + Statement + ($_ _.then + runtime//lux + runtime//structure + runtime//i64 + runtime//text + runtime//io + runtime//js + runtime//array + )) + +(def: #export artifact Text (format prefix ".js")) + +(def: #export generate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/js/structure.lux b/stdlib/source/lux/tool/compiler/phase/generation/js/structure.lux new file mode 100644 index 000000000..623516cdb --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/js/structure.lux @@ -0,0 +1,36 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]] + [host + ["_" js (#+ Expression)]]] + [// + ["//." runtime (#+ Operation Phase)] + ["//." primitive] + ["/." /// + [// + [analysis (#+ Variant Tuple)] + ["." synthesis (#+ Synthesis)]]]]) + +(def: #export (tuple generate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (:: ////.monad wrap (//primitive.text synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate singletonS) + + _ + (do ////.monad + [elemsT+ (monad.map @ generate elemsS+)] + (wrap (_.array elemsT+))))) + +(def: #export (variant generate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (:: ////.monad map + (//runtime.variant (_.i32 (.int (if right? + (inc lefts) + lefts))) + (//runtime.flag right?)) + (generate valueS))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/reference.lux b/stdlib/source/lux/tool/compiler/phase/generation/reference.lux new file mode 100644 index 000000000..878d96e83 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/reference.lux @@ -0,0 +1,81 @@ +(.module: + [lux #* + [control + pipe] + [data + [text + format]] + [type (#+ :share)]] + ["." // + ["/." // ("#/." monad) + [// + [synthesis (#+ Synthesis)] + ["." reference (#+ Register Variable Reference)]]]]) + +(signature: #export (System expression) + (: (-> Register expression) + local) + (: (-> Register expression) + foreign) + (: (All [anchor statement] + (-> Variable (//.Operation anchor expression statement))) + variable) + (: (All [anchor statement] + (-> Name (//.Operation anchor expression statement))) + constant) + (: (All [anchor statement] + (-> Reference (//.Operation anchor expression statement))) + reference)) + +(def: (variable-maker prefix variable) + (All [expression] + (-> Text (-> Text expression) + (-> Register expression))) + (|>> %n (format prefix) variable)) + +(def: #export foreign + (All [expression] + (-> (-> Text expression) + (-> Register expression))) + (variable-maker "f")) + +(def: #export local + (All [expression] + (-> (-> Text expression) + (-> Register expression))) + (variable-maker "l")) + +(def: #export (system constant variable) + (All [expression] + (-> (-> Text expression) (-> Text expression) + (System expression))) + (let [local (..local variable) + foreign (..foreign variable) + variable (:share [expression] + {(-> Text expression) + variable} + {(All [anchor statement] + (-> Variable (//.Operation anchor expression statement))) + (|>> (case> (#reference.Local register) + (local register) + + (#reference.Foreign register) + (foreign register)) + ////wrap)}) + constant (:share [expression] + {(-> Text expression) + constant} + {(All [anchor statement] + (-> Name (//.Operation anchor expression statement))) + (|>> //.remember (////map constant))})] + (structure + (def: local local) + (def: foreign foreign) + (def: variable variable) + (def: constant constant) + (def: reference + (|>> (case> (#reference.Constant value) + (constant value) + + (#reference.Variable value) + (variable value))))))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux new file mode 100644 index 000000000..d0f047c9f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/case.jvm.lux @@ -0,0 +1,175 @@ +(.module: + [lux (#- case let if) + [control + [monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["." number] + ["." text + format] + [collection + ["." list ("#/." functor fold)]]] + [host + ["_" scheme (#+ Expression Computation Var)]]] + [// + ["." runtime (#+ Operation Phase)] + ["//." primitive] + ["." reference] + [// + ["common-." reference] + ["//." // ("#/." monad) + ["." synthesis (#+ Synthesis Path)] + [// + [reference (#+ Register)]]]]]) + +(def: #export register + (common-reference.local _.var)) + +(def: #export (let generate [valueS register bodyS]) + (-> Phase [Synthesis Register Synthesis] + (Operation Computation)) + (do ////.monad + [valueO (generate valueS) + bodyO (generate bodyS)] + (wrap (_.let (list [(..register register) valueO]) + bodyO)))) + +(def: #export (record-get generate valueS pathP) + (-> Phase Synthesis (List [Nat Bit]) + (Operation Expression)) + (do ////.monad + [valueO (generate valueS)] + (wrap (list/fold (function (_ [idx tail?] source) + (.let [method (.if tail? + runtime.product//right + runtime.product//left)] + (method source (_.int (.int idx))))) + valueO + pathP)))) + +(def: #export (if generate [testS thenS elseS]) + (-> Phase [Synthesis Synthesis Synthesis] + (Operation Computation)) + (do ////.monad + [testO (generate testS) + thenO (generate thenS) + elseO (generate elseS)] + (wrap (_.if testO thenO elseO)))) + +(def: @savepoint (_.var "lux_pm_cursor_savepoint")) +(def: @cursor (_.var "lux_pm_cursor")) +(def: @temp (_.var "lux_pm_temp")) +(def: @alt-error (_.var "alt_error")) + +(def: (push! value var) + (-> Expression Var Computation) + (_.set! var (_.cons/2 value var))) + +(def: (push-cursor! value) + (-> Expression Computation) + (push! value @cursor)) + +(def: (pop! var) + (-> Var Computation) + (_.set! var var)) + +(def: save-cursor! + Computation + (push! @cursor @savepoint)) + +(def: restore-cursor! + Computation + (_.set! @cursor (_.car/1 @savepoint))) + +(def: cursor-top + Computation + (_.car/1 @cursor)) + +(def: pop-cursor! + Computation + (pop! @cursor)) + +(def: pm-error (_.string "PM-ERROR")) + +(def: fail-pm! (_.raise/1 pm-error)) + +(exception: #export unrecognized-path) + +(def: (pm-catch handler) + (-> Expression Computation) + (_.lambda [(list @alt-error) #.None] + (_.if (|> @alt-error (_.eqv?/2 pm-error)) + handler + (_.raise/1 @alt-error)))) + +(def: (pattern-matching' generate pathP) + (-> Phase Path (Operation Expression)) + (.case pathP + (^ (synthesis.path/then bodyS)) + (generate bodyS) + + #synthesis.Pop + (/////wrap pop-cursor!) + + (#synthesis.Bind register) + (/////wrap (_.define (..register register) [(list) #.None] + cursor-top)) + + (^template [ <=>] + (^ ( value)) + (/////wrap (_.when (|> value (<=> cursor-top) _.not/1) + fail-pm!))) + ([synthesis.path/bit //primitive.bit _.eqv?/2] + [synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] + [synthesis.path/f64 //primitive.f64 _.=/2] + [synthesis.path/text //primitive.text _.eqv?/2]) + + (^template [ ] + (^ ( idx)) + (/////wrap (_.let (list [@temp (|> idx .int _.int (runtime.sum//get cursor-top ))]) + (_.if (_.null?/1 @temp) + fail-pm! + (push-cursor! @temp))))) + ([synthesis.side/left _.nil (<|)] + [synthesis.side/right (_.string "") inc]) + + (^template [ ] + (^ ( idx)) + (/////wrap (|> idx .int _.int ( cursor-top) push-cursor!))) + ([synthesis.member/left runtime.product//left (<|)] + [synthesis.member/right runtime.product//right inc]) + + (^template [ ] + (^ ( leftP rightP)) + (do ////.monad + [leftO (pattern-matching' generate leftP) + rightO (pattern-matching' generate rightP)] + (wrap ))) + ([synthesis.path/seq (_.begin (list leftO + rightO))] + [synthesis.path/alt (_.with-exception-handler + (pm-catch (_.begin (list restore-cursor! + rightO))) + (_.lambda [(list) #.None] + (_.begin (list save-cursor! + leftO))))]) + + _ + (////.throw unrecognized-path []))) + +(def: (pattern-matching generate pathP) + (-> Phase Path (Operation Computation)) + (do ////.monad + [pattern-matching! (pattern-matching' generate pathP)] + (wrap (_.with-exception-handler + (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) + (_.lambda [(list) #.None] + pattern-matching!))))) + +(def: #export (case generate [valueS pathP]) + (-> Phase [Synthesis Path] (Operation Computation)) + (do ////.monad + [valueO (generate valueS)] + (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] + [@savepoint (_.list/* (list))]))) + (pattern-matching generate pathP)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/expression.jvm.lux new file mode 100644 index 000000000..9b26ba7ab --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/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 (generate synthesis) + Phase + (case synthesis + (^template [ ] + (^ ( value)) + (:: ///.monad wrap ( value))) + ([synthesis.bit primitive.bit] + [synthesis.i64 primitive.i64] + [synthesis.f64 primitive.f64] + [synthesis.text primitive.text]) + + (^ (synthesis.variant variantS)) + (structure.variant generate variantS) + + (^ (synthesis.tuple members)) + (structure.tuple generate members) + + (#synthesis.Reference value) + (:: reference.system reference value) + + (^ (synthesis.branch/case case)) + (case.case generate case) + + (^ (synthesis.branch/let let)) + (case.let generate let) + + (^ (synthesis.branch/if if)) + (case.if generate if) + + (^ (synthesis.loop/scope scope)) + (loop.scope generate scope) + + (^ (synthesis.loop/recur updates)) + (loop.recur generate updates) + + (^ (synthesis.function/abstraction abstraction)) + (function.function generate abstraction) + + (^ (synthesis.function/apply application)) + (function.apply generate application) + + (#synthesis.Extension extension) + (extension.apply generate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux new file mode 100644 index 000000000..a40b4953f --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension.jvm.lux @@ -0,0 +1,15 @@ +(.module: + [lux #* + [data + [collection + ["." dictionary]]]] + [// + [runtime (#+ Bundle)]] + [/ + ["." common] + ["." host]]) + +(def: #export bundle + Bundle + (|> common.bundle + (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux new file mode 100644 index 000000000..d430aba24 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/common.jvm.lux @@ -0,0 +1,243 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)] + ["ex" exception (#+ exception:)]] + [data + ["e" error] + ["." product] + ["." text + format] + [number (#+ hex)] + [collection + ["." list ("#/." functor)] + ["dict" dictionary (#+ Dictionary)]]] + ["." macro (#+ with-gensyms) + ["." code] + ["s" syntax (#+ syntax:)]] + [host (#+ import:) + ["_" scheme (#+ Expression Computation)]]] + [/// + ["." runtime (#+ Operation Phase Handler Bundle)] + ["//." /// + ["." synthesis (#+ Synthesis)] + ["." extension + ["." bundle]]]]) + +(syntax: (Vector {size s.nat} elemT) + (wrap (list (` [(~+ (list.repeat size elemT))])))) + +(type: #export Nullary (-> (Vector 0 Expression) Computation)) +(type: #export Unary (-> (Vector 1 Expression) Computation)) +(type: #export Binary (-> (Vector 2 Expression) Computation)) +(type: #export Trinary (-> (Vector 3 Expression) Computation)) +(type: #export Variadic (-> (List Expression) Computation)) + +(syntax: (arity: {name s.local-identifier} {arity s.nat}) + (with-gensyms [g!_ g!extension g!name g!phase g!inputs] + (do @ + [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] + (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) + (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) + Handler) + (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) + (case (~ g!inputs) + (^ (list (~+ g!input+))) + (do /////.monad + [(~+ (|> g!input+ + (list/map (function (_ g!input) + (list g!input (` ((~ g!phase) (~ g!input)))))) + list.concat))] + ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) + + (~' _) + (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) + +(arity: nullary 0) +(arity: unary 1) +(arity: binary 2) +(arity: trinary 3) + +(def: #export (variadic extension) + (-> Variadic Handler) + (function (_ extension-name) + (function (_ phase inputsS) + (do /////.monad + [inputsI (monad.map @ phase inputsS)] + (wrap (extension inputsI)))))) + +(def: bundle::lux + Bundle + (|> bundle.empty + (bundle.install "is?" (binary (product.uncurry _.eq?/2))) + (bundle.install "try" (unary runtime.lux//try)))) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [bit::and _.bit-and/2] + [bit::or _.bit-or/2] + [bit::xor _.bit-xor/2] + ) + +(def: (bit::left-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) + subjectO)) + +(def: (bit::arithmetic-right-shift [subjectO paramO]) + Binary + (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) + subjectO)) + +(def: (bit::logical-right-shift [subjectO paramO]) + Binary + (runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) + +(def: bundle::bit + Bundle + (<| (bundle.prefix "bit") + (|> bundle.empty + (bundle.install "and" (binary bit::and)) + (bundle.install "or" (binary bit::or)) + (bundle.install "xor" (binary bit::xor)) + (bundle.install "left-shift" (binary bit::left-shift)) + (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) + (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) + ))) + +(import: java/lang/Double + (#static MIN_VALUE Double) + (#static MAX_VALUE Double)) + +(do-template [ ] + [(def: ( _) + Nullary + ( ))] + + [frac::smallest (Double::MIN_VALUE) _.float] + [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] + [frac::max (Double::MAX_VALUE) _.float] + ) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + (|> subjectO ( paramO)))] + + [int::+ _.+/2] + [int::- _.-/2] + [int::* _.*/2] + [int::/ _.quotient/2] + [int::% _.remainder/2] + ) + +(do-template [ ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [frac::+ _.+/2] + [frac::- _.-/2] + [frac::* _.*/2] + [frac::/ _.//2] + [frac::% _.mod/2] + [frac::= _.=/2] + [frac::< _. ] + [(def: ( [subjectO paramO]) + Binary + ( paramO subjectO))] + + [int::= _.=/2] + [int::< _.> _.integer->char/1 _.string/1)) + +(def: bundle::int + Bundle + (<| (bundle.prefix "int") + (|> bundle.empty + (bundle.install "+" (binary int::+)) + (bundle.install "-" (binary int::-)) + (bundle.install "*" (binary int::*)) + (bundle.install "/" (binary int::/)) + (bundle.install "%" (binary int::%)) + (bundle.install "=" (binary int::=)) + (bundle.install "<" (binary int::<)) + (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) + (bundle.install "char" (unary int::char))))) + +(def: bundle::frac + Bundle + (<| (bundle.prefix "frac") + (|> bundle.empty + (bundle.install "+" (binary frac::+)) + (bundle.install "-" (binary frac::-)) + (bundle.install "*" (binary frac::*)) + (bundle.install "/" (binary frac::/)) + (bundle.install "%" (binary frac::%)) + (bundle.install "=" (binary frac::=)) + (bundle.install "<" (binary frac::<)) + (bundle.install "smallest" (nullary frac::smallest)) + (bundle.install "min" (nullary frac::min)) + (bundle.install "max" (nullary frac::max)) + (bundle.install "to-int" (unary _.exact/1)) + (bundle.install "encode" (unary _.number->string/1)) + (bundle.install "decode" (unary runtime.frac//decode))))) + +(def: (text::char [subjectO paramO]) + Binary + (_.string/1 (_.string-ref/2 subjectO paramO))) + +(def: (text::clip [subjectO startO endO]) + Trinary + (_.substring/3 subjectO startO endO)) + +(def: bundle::text + Bundle + (<| (bundle.prefix "text") + (|> bundle.empty + (bundle.install "=" (binary text::=)) + (bundle.install "<" (binary text::<)) + (bundle.install "concat" (binary (product.uncurry _.string-append/2))) + (bundle.install "size" (unary _.string-length/1)) + (bundle.install "char" (binary text::char)) + (bundle.install "clip" (trinary text::clip))))) + +(def: (io::log input) + Unary + (_.begin (list (_.display/1 input) + _.newline/0))) + +(def: (void code) + (-> Expression Computation) + (_.begin (list code (_.string synthesis.unit)))) + +(def: bundle::io + Bundle + (<| (bundle.prefix "io") + (|> bundle.empty + (bundle.install "log" (unary (|>> io::log ..void))) + (bundle.install "error" (unary _.raise/1)) + (bundle.install "exit" (unary _.exit/1)) + (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) + +(def: #export bundle + Bundle + (<| (bundle.prefix "lux") + (|> bundle::lux + (dict.merge bundle::bit) + (dict.merge bundle::int) + (dict.merge bundle::frac) + (dict.merge bundle::text) + (dict.merge bundle::io) + ))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/host.jvm.lux new file mode 100644 index 000000000..b8b2b7612 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/extension/host.jvm.lux @@ -0,0 +1,11 @@ +(.module: + [lux #*] + [/// + [runtime (#+ Bundle)] + [/// + [extension + ["." bundle]]]]) + +(def: #export bundle + Bundle + bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux new file mode 100644 index 000000000..e6069660b --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/function.jvm.lux @@ -0,0 +1,97 @@ +(.module: + [lux (#- function) + [control + ["." monad (#+ do)] + pipe] + [data + ["." product] + [text + format] + [collection + ["." list ("#/." functor)]]] + [host + ["_" scheme (#+ Expression Computation Var)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." reference] + ["//." case] + ["/." // + ["common-." reference] + ["//." // ("#/." monad) + [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] + [synthesis (#+ Synthesis)] + [// + [reference (#+ Register Variable)] + ["." name]]]]]) + +(def: #export (apply generate [functionS argsS+]) + (-> Phase (Application Synthesis) (Operation Computation)) + (do ////.monad + [functionO (generate functionS) + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* functionO argsO+)))) + +(def: #export capture + (common-reference.foreign _.var)) + +(def: (with-closure function-name inits function-definition) + (-> Text (List Expression) Computation (Operation Computation)) + (/////wrap + (case inits + #.Nil + function-definition + + _ + (let [@closure (_.var (format function-name "___CLOSURE"))] + (_.letrec (list [@closure + (_.lambda [(|> (list.enumerate inits) + (list/map (|>> product.left ..capture))) + #.None] + function-definition)]) + (_.apply/* @closure inits)))))) + +(def: @curried (_.var "curried")) +(def: @missing (_.var "missing")) + +(def: input + (|>> inc //case.register)) + +(def: #export (function generate [environment arity bodyS]) + (-> Phase (Abstraction Synthesis) (Operation Computation)) + (do ////.monad + [[function-name bodyO] (///.with-context + (do @ + [function-name ///.context] + (///.with-anchor (_.var function-name) + (generate bodyS)))) + closureO+ (: (Operation (List Expression)) + (monad.map @ (:: reference.system variable) environment)) + #let [arityO (|> arity .int _.int) + apply-poly (.function (_ args func) + (_.apply/2 (_.global "apply") func args)) + @num-args (_.var "num_args") + @function (_.var function-name)]] + (with-closure function-name closureO+ + (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] + (_.let (list [@num-args (_.length/1 @curried)]) + (<| (_.if (|> @num-args (_.=/2 arityO)) + (<| (_.let (list [(//case.register 0) @function])) + (_.let-values (list [[(|> (list.indices arity) + (list/map ..input)) + #.None] + (_.apply/2 (_.global "apply") (_.global "values") @curried)])) + bodyO)) + (_.if (|> @num-args (_.>/2 arityO)) + (let [arity-args (runtime.slice (_.int +0) arityO @curried) + output-func-args (runtime.slice arityO + (|> @num-args (_.-/2 arityO)) + @curried)] + (|> @function + (apply-poly arity-args) + (apply-poly output-func-args)))) + ## (|> @num-args (_. @function + (apply-poly (_.append/2 @curried @missing))))) + ))]) + @function)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux new file mode 100644 index 000000000..0e4adcf03 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/loop.jvm.lux @@ -0,0 +1,41 @@ +(.module: + [lux (#- Scope) + [control + ["." monad (#+ do)]] + [data + ["." product] + ["." text + format] + [collection + ["." list ("#/." functor)]]] + [host + ["_" scheme (#+ Computation Var)]]] + [// + [runtime (#+ Operation Phase)] + ["." reference] + ["//." case] + ["/." // + ["//." // + [synthesis (#+ Scope Synthesis)]]]]) + +(def: @scope (_.var "scope")) + +(def: #export (scope generate [start initsS+ bodyS]) + (-> Phase (Scope Synthesis) (Operation Computation)) + (do ////.monad + [initsO+ (monad.map @ generate initsS+) + bodyO (///.with-anchor @scope + (generate bodyS))] + (wrap (_.letrec (list [@scope (_.lambda [(|> initsS+ + list.enumerate + (list/map (|>> product.left (n/+ start) //case.register))) + #.None] + bodyO)]) + (_.apply/* @scope initsO+))))) + +(def: #export (recur generate argsS+) + (-> Phase (List Synthesis) (Operation Computation)) + (do ////.monad + [@scope ///.anchor + argsO+ (monad.map @ generate argsS+)] + (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux new file mode 100644 index 000000000..d53a0691e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/primitive.jvm.lux @@ -0,0 +1,15 @@ +(.module: + [lux (#- i64) + [host + ["_" scheme (#+ Expression)]]]) + +(do-template [ ] + [(def: #export + (-> Expression) + )] + + [bit Bit _.bool] + [i64 (I64 Any) (|>> .int _.int)] + [f64 Frac _.float] + [text Text _.string] + ) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux new file mode 100644 index 000000000..b28cb1898 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/reference.jvm.lux @@ -0,0 +1,12 @@ +(.module: + [lux #* + [host + ["_" scheme (#+ Expression)]]] + [// + [// + [common + ["." reference]]]]) + +(def: #export system + (reference.system (: (-> Text Expression) _.global) + (: (-> Text Expression) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux new file mode 100644 index 000000000..136e2ff2e --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/runtime.jvm.lux @@ -0,0 +1,321 @@ +(.module: + [lux #* + ["." function] + [control + ["p" parser ("#/." monad)] + [monad (#+ do)]] + [data + [number (#+ hex)] + [text + format] + [collection + ["." list ("#/." monad)]]] + [macro + ["." code] + ["s" syntax (#+ syntax:)]] + [host + ["_" scheme (#+ Expression Computation Var)]]] + ["." /// + ["//." // + [analysis (#+ Variant)] + ["." synthesis] + [// + ["." name]]]]) + +(do-template [ ] + [(type: #export + ( Var Expression Expression))] + + [Operation ///.Operation] + [Phase ///.Phase] + [Handler ///.Handler] + [Bundle ///.Bundle] + ) + +(def: prefix Text "LuxRuntime") + +(def: unit (_.string synthesis.unit)) + +(def: #export variant-tag "lux-variant") + +(def: (flag value) + (-> Bit Computation) + (if value + (_.string "") + _.nil)) + +(def: (variant' tag last? value) + (-> Expression Expression Expression Computation) + (<| (_.cons/2 (_.symbol ..variant-tag)) + (_.cons/2 tag) + (_.cons/2 last?) + value)) + +(def: #export (variant [lefts right? value]) + (-> (Variant Expression) Computation) + (variant' (_.int (.int lefts)) (flag right?) value)) + +(def: #export none + Computation + (variant [0 #0 ..unit])) + +(def: #export some + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: #export left + (-> Expression Computation) + (|>> [0 #0] ..variant)) + +(def: #export right + (-> Expression Computation) + (|>> [0 #1] ..variant)) + +(def: declaration + (s.Syntax [Text (List Text)]) + (p.either (p.and s.local-identifier (p/wrap (list))) + (s.form (p.and s.local-identifier (p.some s.local-identifier))))) + +(syntax: (runtime: {[name args] declaration} + definition) + (let [implementation (code.local-identifier (format "@@" name)) + runtime (format prefix "__" (name.normalize name)) + @runtime (` (_.var (~ (code.text runtime)))) + argsC+ (list/map code.local-identifier args) + argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) + args) + declaration (` ((~ (code.local-identifier name)) + (~+ argsC+))) + type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) + _.Computation))] + (wrap (list (` (def: (~' #export) (~ declaration) + (~ type) + (~ (case argsC+ + #.Nil + @runtime + + _ + (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) + (` (def: (~ implementation) + _.Computation + (~ (case argsC+ + #.Nil + (` (_.define (~ @runtime) [(list) #.None] (~ definition))) + + _ + (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) + (list/map (function (_ [left right]) + (list left right))) + list/join))] + (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] + (~ definition)))))))))))) + +(runtime: (slice offset length list) + (<| (_.if (_.null?/1 list) + list) + (_.if (|> offset (_.>/2 (_.int +0))) + (slice (|> offset (_.-/2 (_.int +1))) + length + (_.cdr/1 list))) + (_.if (|> length (_.>/2 (_.int +0))) + (_.cons/2 (_.car/1 list) + (slice offset + (|> length (_.-/2 (_.int +1))) + (_.cdr/1 list)))) + _.nil)) + +(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} + body) + (wrap (list (` (let [(~+ (|> vars + (list/map (function (_ var) + (list (code.local-identifier var) + (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) + list/join))] + (~ body)))))) + +(runtime: (lux//try op) + (with-vars [error] + (_.with-exception-handler + (_.lambda [(list error) #.None] + (..left error)) + (_.lambda [(list) #.None] + (..right (_.apply/* op (list ..unit))))))) + +(runtime: (lux//program-args program-args) + (with-vars [@loop @input @output] + (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] + (_.if (_.eqv?/2 _.nil @input) + @output + (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) + (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) + +(def: runtime//lux + Computation + (_.begin (list @@lux//try + @@lux//program-args))) + +(def: minimum-index-length + (-> Expression Computation) + (|>> (_.+/2 (_.int +1)))) + +(def: product-element + (-> Expression Expression Computation) + (function.flip _.vector-ref/2)) + +(def: (product-tail product) + (-> Expression Computation) + (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) + +(def: (updated-index min-length product) + (-> Expression Expression Computation) + (|> min-length (_.-/2 (_.length/1 product)))) + +(runtime: (product//left product index) + (let [@index_min_length (_.var "index_min_length")] + (_.begin + (list (_.define @index_min_length [(list) #.None] + (minimum-index-length index)) + (_.if (|> product _.length/1 (_.>/2 @index_min_length)) + ## No need for recursion + (product-element index product) + ## Needs recursion + (product//left (product-tail product) + (updated-index @index_min_length product))))))) + +(runtime: (product//right product index) + (let [@index_min_length (_.var "index_min_length") + @product_length (_.var "product_length") + @slice (_.var "slice") + last-element? (|> @product_length (_.=/2 @index_min_length)) + needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) + (_.vector-copy!/5 @slice (_.int +0) product index @product_length) + @slice))))))) + +(runtime: (sum//get sum last? wanted-tag) + (with-vars [variant-tag sum-tag sum-flag sum-value] + (let [no-match _.nil + is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) + test-recursion (_.if is-last? + ## Must recurse. + (sum//get sum-value + (|> wanted-tag (_.-/2 sum-tag)) + last?) + no-match)] + (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] + (_.apply/* (_.global "apply") (list (_.global "values") sum))])) + (_.if (|> wanted-tag (_.=/2 sum-tag)) + (_.if (|> sum-flag (_.eqv?/2 last?)) + sum-value + test-recursion)) + (_.if (|> wanted-tag (_.>/2 sum-tag)) + test-recursion) + (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) + (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) + no-match)))) + +(def: runtime//adt + Computation + (_.begin (list @@product//left + @@product//right + @@sum//get))) + +(runtime: (bit//logical-right-shift shift input) + (_.if (_.=/2 (_.int +0) shift) + input + (|> input + (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) + (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) + +(def: runtime//bit + Computation + (_.begin (list @@bit//logical-right-shift))) + +(runtime: (frac//decode input) + (with-vars [@output] + (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) + (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) + (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) + ..none + (..some @output))))) + +(def: runtime//frac + Computation + (_.begin + (list @@frac//decode))) + +(def: (check-index-out-of-bounds array idx body) + (-> Expression Expression Expression Computation) + (_.if (|> idx (_.<=/2 (_.length/1 array))) + body + (_.raise/1 (_.string "Array index out of bounds!")))) + +(runtime: (array//get array idx) + (with-vars [@temp] + (<| (check-index-out-of-bounds array idx) + (_.let (list [@temp (_.vector-ref/2 array idx)]) + (_.if (|> @temp (_.eqv?/2 _.nil)) + ..none + (..some @temp)))))) + +(runtime: (array//put array idx value) + (<| (check-index-out-of-bounds array idx) + (_.begin + (list (_.vector-set!/3 array idx value) + array)))) + +(def: runtime//array + Computation + (_.begin + (list @@array//get + @@array//put))) + +(runtime: (box//write value box) + (_.begin + (list + (_.vector-set!/3 box (_.int +0) value) + ..unit))) + +(def: runtime//box + Computation + (_.begin (list @@box//write))) + +(runtime: (io//current-time _) + (|> (_.apply/* (_.global "current-second") (list)) + (_.*/2 (_.int +1_000)) + _.exact/1)) + +(def: runtime//io + (_.begin (list @@io//current-time))) + +(def: runtime + Computation + (_.begin (list @@slice + runtime//lux + runtime//bit + runtime//adt + runtime//frac + runtime//array + runtime//box + runtime//io + ))) + +(def: #export generate + (Operation Any) + (///.with-buffer + (do ////.monad + [_ (///.save! ["" ..prefix] ..runtime)] + (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux new file mode 100644 index 000000000..c586f0706 --- /dev/null +++ b/stdlib/source/lux/tool/compiler/phase/generation/scheme/structure.jvm.lux @@ -0,0 +1,32 @@ +(.module: + [lux #* + [control + ["." monad (#+ do)]] + [host + ["_" scheme (#+ Expression)]]] + [// + ["." runtime (#+ Operation Phase)] + ["." primitive] + ["." /// + [analysis (#+ Variant Tuple)] + ["." synthesis (#+ Synthesis)]]]) + +(def: #export (tuple generate elemsS+) + (-> Phase (Tuple Synthesis) (Operation Expression)) + (case elemsS+ + #.Nil + (:: ///.monad wrap (primitive.text synthesis.unit)) + + (#.Cons singletonS #.Nil) + (generate singletonS) + + _ + (do ///.monad + [elemsT+ (monad.map @ generate elemsS+)] + (wrap (_.vector/* elemsT+))))) + +(def: #export (variant generate [lefts right? valueS]) + (-> Phase (Variant Synthesis) (Operation Expression)) + (do ///.monad + [valueT (generate valueS)] + (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation.lux b/stdlib/source/lux/tool/compiler/phase/translation.lux deleted file mode 100644 index 99a4c5517..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation.lux +++ /dev/null @@ -1,255 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)] - ["." exception (#+ exception:)]] - [data - ["." product] - ["." error (#+ Error)] - ["." name ("#/." equivalence)] - ["." text - format] - [collection - ["." row (#+ Row)] - ["." dictionary (#+ Dictionary)]]] - [world - [file (#+ Path)]]] - ["." // - ["." extension] - [// - [synthesis (#+ Synthesis)]]]) - -(do-template [] - [(exception: #export () - "")] - - [no-active-buffer] - [no-anchor] - ) - -(exception: #export (cannot-interpret {error Text}) - (exception.report - ["Error" error])) - -(exception: #export (unknown-lux-name {name Name}) - (exception.report - ["Name" (%name name)])) - -(exception: #export (cannot-overwrite-lux-name {lux-name Name} - {old-host-name Text} - {new-host-name Text}) - (exception.report - ["Lux Name" (%name lux-name)] - ["Old Host Name" old-host-name] - ["New Host Name" new-host-name])) - -(do-template [] - [(exception: #export ( {name Name}) - (exception.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 Path (Buffer statement))) - -(type: #export (State anchor expression statement) - {#context Context - #anchor (Maybe anchor) - #host (Host expression statement) - #buffer (Maybe (Buffer statement)) - #outputs (Outputs statement) - #counter Nat - #name-cache (Dictionary Name Text)}) - -(do-template [ ] - [(type: #export ( anchor expression statement) - ( (State anchor expression statement) Synthesis expression))] - - [State+ extension.State] - [Operation extension.Operation] - [Phase extension.Phase] - [Handler extension.Handler] - [Bundle extension.Bundle] - ) - -(def: #export (state host) - (All [anchor expression statement] - (-> (Host expression statement) - (..State anchor expression statement))) - {#context {#scope-name "" - #inner-functions 0} - #anchor #.None - #host host - #buffer #.None - #outputs (dictionary.new text.hash) - #counter 0 - #name-cache (dictionary.new name.hash)}) - -(def: #export (with-context expr) - (All [anchor expression statement output] - (-> (Operation anchor expression statement output) - (Operation anchor expression statement [Text output]))) - (function (_ [bundle state]) - (let [[old-scope old-inner] (get@ #context state) - new-scope (format old-scope "c" (%n old-inner))] - (case (expr [bundle (set@ #context [new-scope 0] state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set@ #context [old-scope (inc old-inner)] state')] - [new-scope output]]) - - (#error.Failure error) - (#error.Failure error))))) - -(def: #export context - (All [anchor expression statement] - (Operation anchor expression statement Text)) - (extension.read (|>> (get@ #context) - (get@ #scope-name)))) - -(do-template [ - - ] - [(def: #export - (All [anchor expression statement output] ) - (function (_ body) - (function (_ [bundle state]) - (case (body [bundle (set@ (#.Some ) state)]) - (#error.Success [[bundle' state'] output]) - (#error.Success [[bundle' (set@ (get@ state) state')] - output]) - - (#error.Failure error) - (#error.Failure error))))) - - (def: #export - (All [anchor expression statement] - (Operation anchor expression statement )) - (function (_ (^@ stateE [bundle state])) - (case (get@ state) - (#.Some output) - (#error.Success [stateE output]) - - #.None - (exception.throw []))))] - - [#anchor - (with-anchor anchor) - (-> anchor (Operation anchor expression statement output) - (Operation anchor expression statement output)) - anchor - anchor anchor no-anchor] - - [#buffer - with-buffer - (-> (Operation anchor expression statement output) - (Operation anchor expression statement output)) - row.empty - buffer (Buffer statement) no-active-buffer] - ) - -(def: #export outputs - (All [anchor expression statement] - (Operation anchor expression statement (Outputs statement))) - (extension.read (get@ #outputs))) - -(def: #export next - (All [anchor expression statement] - (Operation anchor expression statement Nat)) - (do //.monad - [count (extension.read (get@ #counter)) - _ (extension.update (update@ #counter inc))] - (wrap count))) - -(do-template [ ] - [(def: #export ( label code) - (All [anchor expression statement] - (-> Text (Operation anchor expression statement Any))) - (function (_ (^@ state+ [bundle state])) - (case (:: (get@ #host state) label code) - (#error.Success output) - (#error.Success [state+ output]) - - (#error.Failure error) - (exception.throw cannot-interpret error))))] - - [evaluate! expression] - [execute! statement] - ) - -(def: #export (define! name code) - (All [anchor expression statement] - (-> Name expression (Operation anchor expression statement [Text Any]))) - (function (_ (^@ stateE [bundle state])) - (case (:: (get@ #host state) define! name code) - (#error.Success output) - (#error.Success [stateE output]) - - (#error.Failure error) - (exception.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] - (-> Path (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 - (exception.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) - (exception.throw cannot-overwrite-lux-name [lux-name old-host-name host-name]))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux deleted file mode 100644 index fc25255df..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/case.lux +++ /dev/null @@ -1,172 +0,0 @@ -(.module: - [lux (#- case let if) - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." number] - ["." text - format] - [collection - ["." list ("#/." functor fold)]]] - [host - ["_" js (#+ Expression Computation Var Statement)]]] - [// - ["//." runtime (#+ Operation Phase)] - ["//." reference] - ["//." primitive] - [// - ["." reference] - ["//." // ("#/." monad) - [// - [reference (#+ Register)] - ["." synthesis (#+ Synthesis Path)]]]]]) - -(def: #export register - (reference.local _.var)) - -(def: #export (let translate [valueS register bodyS]) - (-> Phase [Synthesis Register Synthesis] - (Operation Computation)) - (do ////.monad - [valueO (translate valueS) - bodyO (translate bodyS)] - ## TODO: Find some way to do 'let' without paying the price of the closure. - (wrap (_.apply/* (<| (_.closure (list)) - ($_ _.then - (_.define (..register register) valueO) - (_.return bodyO))) - (list))))) - -(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 (_.i32 (.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 (_.? testO thenO elseO)))) - -(def: @savepoint (_.var "lux_pm_cursor_savepoint")) -(def: @cursor (_.var "lux_pm_cursor")) -(def: @temp (_.var "lux_pm_temp")) -(def: @alt-error (_.var "alt_error")) - -(def: (push-cursor! value) - (-> Expression Statement) - (_.statement (|> @cursor (_.do "push" (list value))))) - -(def: pop-cursor! - Statement - (_.statement (|> @cursor (_.do "pop" (list))))) - -(def: peek-cursor - Expression - (.let [idx (|> @cursor (_.the "length") (_.- (_.i32 +1)))] - (|> @cursor (_.at idx)))) - -(def: save-cursor! - Statement - (.let [cursor (|> @cursor (_.do "slice" (list)))] - (_.statement (|> @savepoint (_.do "push" (list cursor)))))) - -(def: restore-cursor! - Statement - (_.set @cursor (|> @savepoint (_.do "pop" (list))))) - -(def: fail-pm! _.break) - -(exception: #export unrecognized-path) - -(def: (pattern-matching' translate pathP) - (-> Phase Path (Operation Statement)) - (.case pathP - (^ (synthesis.path/then bodyS)) - (do ////.monad - [body! (translate bodyS)] - (wrap (_.return body!))) - - #synthesis.Pop - (/////wrap pop-cursor!) - - (#synthesis.Bind register) - (/////wrap (_.define (..register register) ..peek-cursor)) - - (^template [ <=>] - (^ ( value)) - (/////wrap (_.when (|> value (<=> ..peek-cursor) _.not) - fail-pm!))) - ([synthesis.path/bit //primitive.bit _.=] - [synthesis.path/i64 (<| //primitive.i64 .int) //runtime.i64//=] - [synthesis.path/f64 //primitive.f64 _.=] - [synthesis.path/text //primitive.text _.=]) - - (^template [ ] - (^ ( idx)) - (/////wrap ($_ _.then - (_.set @temp (|> idx .int _.i32 (//runtime.sum//get ..peek-cursor ))) - (_.if (_.= _.null @temp) - fail-pm! - (push-cursor! @temp))))) - ([synthesis.side/left _.null (<|)] - [synthesis.side/right (_.string "") inc]) - - (^template [ ] - (^ ( idx)) - (/////wrap (|> idx .int _.i32 ( ..peek-cursor) push-cursor!))) - ([synthesis.member/left //runtime.product//left (<|)] - [synthesis.member/right //runtime.product//right inc]) - - (^template [ ] - (^ ( leftP rightP)) - (do ////.monad - [left! (pattern-matching' translate leftP) - right! (pattern-matching' translate rightP)] - (wrap ))) - ([synthesis.path/seq (_.then left! right!)] - [synthesis.path/alt ($_ _.then - (_.do-while _.false - ($_ _.then - ..save-cursor! - left!)) - ($_ _.then - ..restore-cursor! - right!))]) - - _ - (////.throw unrecognized-path []))) - -(def: (pattern-matching translate pathP) - (-> Phase Path (Operation Statement)) - (do ////.monad - [pattern-matching! (pattern-matching' translate pathP)] - (wrap ($_ _.then - (_.do-while _.false - pattern-matching!) - (_.throw (_.string "Invalid expression for pattern-matching.")))))) - -(def: #export (case translate [valueS pathP]) - (-> Phase [Synthesis Path] (Operation Computation)) - (do ////.monad - [stack-init (translate valueS) - path! (pattern-matching translate pathP) - #let [closure (<| (_.closure (list)) - ($_ _.then - (_.declare @temp) - (_.define @cursor (_.array (list stack-init))) - (_.define @savepoint (_.array (list))) - path!))]] - (wrap (_.apply/* closure (list))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/expression.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/expression.lux deleted file mode 100644 index 822f51e35..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/expression.lux +++ /dev/null @@ -1,60 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]]] - [// - [runtime (#+ Phase)] - ["." primitive] - ["." structure] - ["." reference] - ["." function] - ["." case] - ["." loop] - ["." /// - ["." extension] - [// - ["." synthesis]]]]) - -(def: #export (translate synthesis) - Phase - (case synthesis - (^template [ ] - (^ ( value)) - (:: ///.monad wrap ( 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 value) - (:: reference.system reference value) - - (^ (synthesis.branch/case case)) - (case.case translate case) - - (^ (synthesis.branch/let let)) - (case.let translate let) - - (^ (synthesis.branch/if if)) - (case.if translate if) - - (^ (synthesis.loop/scope scope)) - (loop.scope translate scope) - - (^ (synthesis.loop/recur updates)) - (loop.recur translate updates) - - (^ (synthesis.function/abstraction abstraction)) - (function.function translate abstraction) - - (^ (synthesis.function/apply application)) - (function.apply translate application) - - (#synthesis.Extension extension) - (extension.apply translate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension.lux deleted file mode 100644 index a40b4953f..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/extension.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/tool/compiler/phase/translation/js/extension/common.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux deleted file mode 100644 index 98ef827a8..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/common.lux +++ /dev/null @@ -1,232 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["e" error] - ["." product] - [number (#+ hex)] - [collection - ["." list ("#/." functor)] - ["." dictionary]]] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax:)]] - [host (#+ import:) - ["_" js (#+ Expression Computation)]]] - [/// - ["///." runtime (#+ Operation Phase Handler Bundle)] - ["///." primitive] - ["//." /// - ["." extension - ["." bundle]] - [// - ["." synthesis (#+ Synthesis)]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Expression) Computation)) -(type: #export Unary (-> (Vector 1 Expression) Computation)) -(type: #export Binary (-> (Vector 2 Expression) Computation)) -(type: #export Trinary (-> (Vector 3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!phase g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - Handler) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do /////.monad - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name) - (function (_ phase inputsS) - (do /////.monad - [inputsI (monad.map @ phase inputsS)] - (wrap (extension inputsI)))))) - -## [Procedures] -## [[Bits]] -(do-template [ ] - [(def: ( [paramJS subjectJS]) - Binary - ( subjectJS (///runtime.i64//to-number paramJS)))] - - [i64//left-shift ///runtime.i64//left-shift] - [i64//arithmetic-right-shift ///runtime.i64//arithmetic-right-shift] - [i64//logical-right-shift ///runtime.i64//logic-right-shift] - ) - -## [[Numbers]] -(import: #long java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [ ] - [(def: ( _) - Nullary - (///primitive.f64 ))] - - [frac//smallest (java/lang/Double::MIN_VALUE)] - [frac//min (f/* -1.0 (java/lang/Double::MAX_VALUE))] - [frac//max (java/lang/Double::MAX_VALUE)] - ) - -(def: frac//decode - Unary - (|>> list - (_.apply/* (_.var "parseFloat")) - _.return - (_.closure (list)) - ///runtime.lux//try)) - -(def: int//char - Unary - (|>> ///runtime.i64//to-number - (list) - (_.apply/* (_.var "String.fromCharCode")))) - -## [[Text]] -(def: (text//concat [subjectJS paramJS]) - Binary - (|> subjectJS (_.do "concat" (list paramJS)))) - -(do-template [ ] - [(def: ( [subjectJS paramJS extraJS]) - Trinary - ( subjectJS paramJS extraJS))] - - [text//clip ///runtime.text//clip] - [text//index ///runtime.text//index] - ) - -## [[IO]] -(def: (io//log messageJS) - Unary - ($_ _., - (///runtime.io//log messageJS) - ///runtime.unit)) - -(def: (io//exit codeJS) - Unary - (let [@@process (_.var "process") - @@window (_.var "window") - @@location (_.var "location")] - ($_ _.or - ($_ _.and - (_.not (_.= _.undefined (_.type-of @@process))) - (_.the "exit" @@process) - (_.do "exit" (list (///runtime.i64//to-number codeJS)) @@process)) - (_.do "close" (list) @@window) - (_.do "reload" (list) @@location)))) - -(def: (io//current-time _) - Nullary - (|> (_.new (_.var "Date") (list)) - (_.do "getTime" (list)) - ///runtime.i64//from-number)) - -## [Bundles] -(def: lux-procs - Bundle - (|> bundle.empty - (bundle.install "is" (binary (product.uncurry _.=))) - (bundle.install "try" (unary ///runtime.lux//try)))) - -(def: i64-procs - Bundle - (<| (bundle.prefix "i64") - (|> bundle.empty - (bundle.install "and" (binary (product.uncurry ///runtime.i64//and))) - (bundle.install "or" (binary (product.uncurry ///runtime.i64//or))) - (bundle.install "xor" (binary (product.uncurry ///runtime.i64//xor))) - (bundle.install "left-shift" (binary i64//left-shift)) - (bundle.install "logical-right-shift" (binary i64//logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary i64//arithmetic-right-shift)) - (bundle.install "=" (binary (product.uncurry ///runtime.i64//=))) - (bundle.install "+" (binary (product.uncurry ///runtime.i64//+))) - (bundle.install "-" (binary (product.uncurry ///runtime.i64//-))) - ))) - -(def: int-procs - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "<" (binary (product.uncurry ///runtime.i64//<))) - (bundle.install "*" (binary (product.uncurry ///runtime.i64//*))) - (bundle.install "/" (binary (product.uncurry ///runtime.i64///))) - (bundle.install "%" (binary (product.uncurry ///runtime.i64//%))) - (bundle.install "frac" (unary ///runtime.i64//to-number)) - (bundle.install "char" (unary int//char))))) - -(def: frac-procs - Bundle - (<| (bundle.prefix "frac") - (|> bundle.empty - (bundle.install "+" (binary (product.uncurry _.+))) - (bundle.install "-" (binary (product.uncurry _.-))) - (bundle.install "*" (binary (product.uncurry _.*))) - (bundle.install "/" (binary (product.uncurry _./))) - (bundle.install "%" (binary (product.uncurry _.%))) - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "smallest" (nullary frac//smallest)) - (bundle.install "min" (nullary frac//min)) - (bundle.install "max" (nullary frac//max)) - (bundle.install "int" (unary ///runtime.i64//from-number)) - (bundle.install "encode" (unary (_.do "toString" (list)))) - (bundle.install "decode" (unary frac//decode))))) - -(def: text-procs - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary (product.uncurry _.=))) - (bundle.install "<" (binary (product.uncurry _.<))) - (bundle.install "concat" (binary text//concat)) - (bundle.install "index" (trinary text//index)) - (bundle.install "size" (unary (|>> (_.the "length") ///runtime.i64//from-number))) - (bundle.install "char" (binary (product.uncurry ///runtime.text//char))) - (bundle.install "clip" (trinary text//clip)) - ))) - -(def: io-procs - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary io//log)) - (bundle.install "error" (unary ///runtime.io//error)) - (bundle.install "exit" (unary io//exit)) - (bundle.install "current-time" (nullary io//current-time))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> lux-procs - (dictionary.merge i64-procs) - (dictionary.merge int-procs) - (dictionary.merge frac-procs) - (dictionary.merge text-procs) - (dictionary.merge io-procs) - ))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux deleted file mode 100644 index 8091f7fee..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/extension/host.lux +++ /dev/null @@ -1,121 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)]] - [data - ["." product] - [collection - ["." dictionary]]] - [host - ["_" js]]] - [// - ["." common (#+ Nullary Binary Trinary Variadic)] - [// - ["///." runtime (#+ Handler Bundle)] - ["//." /// - ["." extension - ["." bundle]] - [// - ["." synthesis]]]]]) - -(do-template [ ] - [(def: ( _) Nullary )] - - [js//null _.null] - [js//undefined _.undefined] - [js//object (_.object (list))] - ) - -(def: (js//global name translate inputs) - Handler - (case inputs - (^ (list (synthesis.text global))) - (:: /////.monad wrap (_.var global)) - - _ - (/////.throw extension.incorrect-syntax name))) - -(def: (js//call name translate inputs) - Handler - (case inputs - (^ (list& functionS argsS+)) - (do /////.monad - [functionJS (translate functionS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (_.apply/* functionJS argsJS+))) - - _ - (/////.throw extension.incorrect-syntax name))) - -(def: js - Bundle - (|> bundle.empty - (bundle.install "null" (common.nullary js//null)) - (bundle.install "undefined" (common.nullary js//undefined)) - (bundle.install "object" (common.nullary js//object)) - (bundle.install "array" (common.variadic _.array)) - (bundle.install "global" js//global) - (bundle.install "call" js//call))) - -(def: (object//new name translate inputs) - Handler - (case inputs - (^ (list& constructorS argsS+)) - (do /////.monad - [constructorJS (translate constructorS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (_.new constructorJS argsJS+))) - - _ - (/////.throw extension.incorrect-syntax name))) - -(def: (object//call name translate inputs) - Handler - (case inputs - (^ (list& objectS methodS argsS+)) - (do /////.monad - [objectJS (translate objectS) - methodJS (translate methodS) - argsJS+ (monad.map @ translate argsS+)] - (wrap (|> objectJS - (_.at methodJS) - (_.do "apply" (list& objectJS argsJS+))))) - - _ - (/////.throw extension.incorrect-syntax name))) - -(def: (object//set [fieldJS valueJS objectJS]) - Trinary - (///runtime.js//set objectJS fieldJS valueJS)) - -(def: object - Bundle - (<| (bundle.prefix "object") - (|> bundle.empty - (bundle.install "new" object//new) - (bundle.install "call" object//call) - (bundle.install "read" (common.binary (product.uncurry ///runtime.js//get))) - (bundle.install "write" (common.trinary object//set)) - (bundle.install "delete" (common.binary (product.uncurry ///runtime.js//delete))) - ))) - -(def: (array//write [indexJS valueJS arrayJS]) - Trinary - (///runtime.array//write indexJS valueJS arrayJS)) - -(def: array - Bundle - (<| (bundle.prefix "array") - (|> bundle.empty - (bundle.install "read" (common.binary (product.uncurry ///runtime.array//read))) - (bundle.install "write" (common.trinary array//write)) - (bundle.install "delete" (common.binary (product.uncurry ///runtime.array//delete))) - (bundle.install "length" (common.unary (_.the "length"))) - ))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "js") - (|> ..js - (dictionary.merge ..object) - (dictionary.merge ..array)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux deleted file mode 100644 index 0d0d659ab..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/function.lux +++ /dev/null @@ -1,108 +0,0 @@ -(.module: - [lux (#- function) - [control - ["." monad (#+ do)] - pipe] - [data - ["." product] - [text - format] - [collection - ["." list ("#/." functor fold)]]] - [host - ["_" js (#+ Expression Computation Var)]]] - [// - ["." runtime (#+ Operation Phase)] - ["." reference] - ["//." case] - ["/." // - ["common-." reference] - ["//." // ("#/." monad) - [// - [reference (#+ Register Variable)] - [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - ["." name]]]]]) - -(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: #export capture - (common-reference.foreign _.var)) - -(def: (with-closure inits function-definition) - (-> (List Expression) Computation (Operation Computation)) - (/////wrap - (case inits - #.Nil - function-definition - - _ - (let [closure (_.closure (|> (list.enumerate inits) - (list/map (|>> product.left ..capture))) - (_.return function-definition))] - (_.apply/* closure inits))))) - -(def: @curried (_.var "curried")) - -(def: input - (|>> inc //case.register)) - -(def: @@arguments (_.var "arguments")) - -(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+ (: (Operation (List Expression)) - (monad.map @ (:: reference.system variable) environment)) - #let [arityO (|> arity .int _.i32) - @num-args (_.var "num_args") - @self (_.var function-name) - apply-poly (.function (_ args func) - (|> func (_.do "apply" (list _.null args)))) - initialize-self! (_.define (//case.register 0) @self) - initialize! (list/fold (.function (_ post pre!) - ($_ _.then - pre! - (_.define (..input post) (_.at (_.i32 (.int post)) @@arguments)))) - initialize-self! - (list.indices arity))]] - (with-closure closureO+ - (_.function @self (list) - ($_ _.then - (_.define @num-args (_.the "length" @@arguments)) - (_.cond (list [(|> @num-args (_.= arityO)) - ($_ _.then - initialize! - (_.return bodyO))] - [(|> @num-args (_.> arityO)) - (let [arity-inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments (_.i32 +0) arityO))) - extra-inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments arityO)))] - (_.return (|> @self - (apply-poly arity-inputs) - (apply-poly extra-inputs))))]) - ## (|> @num-args (_.< arityO)) - (let [all-inputs (|> (_.array (list)) - (_.the "slice") - (_.do "call" (list @@arguments)))] - ($_ _.then - (_.define @curried all-inputs) - (_.return (_.closure (list) - (let [@missing all-inputs] - (_.return (apply-poly (_.do "concat" (list @missing) @curried) - @self)))))))) - ))) - )) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/loop.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/loop.lux deleted file mode 100644 index cbb032153..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/loop.lux +++ /dev/null @@ -1,42 +0,0 @@ -(.module: - [lux (#- Scope) - [control - ["." monad (#+ do)]] - [data - ["." product] - ["." text - format] - [collection - ["." list ("#/." functor)]]] - [host - ["_" js (#+ Computation Var)]]] - [// - [runtime (#+ Operation Phase)] - ["." reference] - ["//." case] - ["/." // - ["//." // - [// - [synthesis (#+ Scope Synthesis)]]]]]) - -(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)) - #let [closure (_.function @scope - (|> initsS+ - list.enumerate - (list/map (|>> product.left (n/+ start) //case.register))) - (_.return bodyO))]] - (wrap (_.apply/* closure initsO+)))) - -(def: #export (recur translate argsS+) - (-> Phase (List Synthesis) (Operation Computation)) - (do ////.monad - [@scope ///.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux deleted file mode 100644 index 139fcb191..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/primitive.lux +++ /dev/null @@ -1,38 +0,0 @@ -(.module: - [lux (#- i64) - [control - [pipe (#+ cond> new>)]] - [data - [number - ["." frac]]] - [host - ["_" js (#+ Computation)]]] - [// - ["//." runtime]]) - -(def: #export bit - (-> Bit Computation) - _.boolean) - -(def: #export (i64 value) - (-> (I64 Any) Computation) - (//runtime.i64//new (|> value //runtime.high .int _.i32) - (|> value //runtime.low .int _.i32))) - -(def: #export f64 - (-> Frac Computation) - (|>> (cond> [(f/= frac.positive-infinity)] - [(new> _.positive-infinity [])] - - [(f/= frac.negative-infinity)] - [(new> _.negative-infinity [])] - - [(f/= frac.not-a-number)] - [(new> _.not-a-number [])] - - ## else - [_.number]))) - -(def: #export text - (-> Text Computation) - _.string) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux deleted file mode 100644 index 9f8555788..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/reference.lux +++ /dev/null @@ -1,11 +0,0 @@ -(.module: - [lux #* - [host - ["_" js (#+ Expression)]]] - [// - [// - ["." reference]]]) - -(def: #export system - (reference.system (: (-> Text Expression) _.var) - (: (-> Text Expression) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux deleted file mode 100644 index 4e95e06b3..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/runtime.lux +++ /dev/null @@ -1,756 +0,0 @@ -(.module: - [lux #* - ["." function] - [control - [monad (#+ do)] - ["p" parser]] - [data - [number (#+ hex) - ["." i64]] - ["." text - format] - [collection - ["." list ("#/." functor)]]] - ["." macro - ["." code] - ["s" syntax (#+ syntax:)]] - [host - ["_" js (#+ Expression Var Computation Statement)]]] - ["." /// - ["//." // - [// - ["/////." name] - ["." synthesis]]]] - ) - -(do-template [ ] - [(type: #export - ( Var Expression Statement))] - - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] - ) - -(type: #export (Generator i) - (-> i Phase (Operation Expression))) - -(def: prefix Text "LuxRuntime") - -(def: #export high - (-> (I64 Any) (I64 Any)) - (i64.logic-right-shift 32)) - -(def: #export low - (-> (I64 Any) (I64 Any)) - (let [mask (dec (i64.left-shift 32 1))] - (|>> (i64.and mask)))) - -(def: #export variant-tag-field "_lux_tag") -(def: #export variant-flag-field "_lux_flag") -(def: #export variant-value-field "_lux_value") - -(def: #export unit Computation (_.string synthesis.unit)) - -(def: #export (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.null)) - -(def: #export (variant tag last? value) - (-> Expression Expression Expression Computation) - (_.object (list [..variant-tag-field tag] - [..variant-flag-field last?] - [..variant-value-field value]))) - -(def: none - Computation - (..variant (_.i32 +0) (flag #0) unit)) - -(def: some - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: left - (-> Expression Computation) - (..variant (_.i32 +0) (flag #0))) - -(def: right - (-> Expression Computation) - (..variant (_.i32 +1) (flag #1))) - -(def: variable - (-> Text Var) - (|>> /////name.normalize - _.var)) - -(def: runtime-name - (-> Text Var) - (|>> /////name.normalize - (format prefix "$") - _.var)) - -(def: (feature name definition) - (-> Var (-> Var Expression) Statement) - (_.define name (definition name))) - -(syntax: (code-name {definition-name s.local-identifier}) - (wrap (list (code.local-identifier (format "@" definition-name))))) - -(syntax: #export (with-vars {vars (s.tuple (p.some s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (/////name.normalize var)))))))) - list.concat))] - (~ body)))))) - -(syntax: (runtime: {declaration (p.or s.local-identifier - (s.form (p.and s.local-identifier - (p.some s.local-identifier))))} - code) - (case declaration - (#.Left name) - (macro.with-gensyms [g!_] - (let [nameC (code.local-identifier name) - code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name))))] - (wrap (list (` (def: #export (~ nameC) Var (~ runtime-nameC))) - (` (def: (~ code-nameC) - Statement - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ nameC)) - (~ code))))))))) - - (#.Right [name inputs]) - (macro.with-gensyms [g!_] - (let [nameC (code.local-identifier name) - code-nameC (code.local-identifier (format "@" name)) - runtime-nameC (` (runtime-name (~ (code.text name)))) - inputsC (list/map code.local-identifier inputs) - inputs-typesC (list/map (function.constant (` _.Expression)) inputs)] - (wrap (list (` (def: #export ((~ nameC) (~+ inputsC)) - (-> (~+ inputs-typesC) Computation) - (_.apply/* (~ runtime-nameC) (list (~+ inputsC))))) - (` (def: (~ code-nameC) - Statement - (..feature (~ runtime-nameC) - (function ((~ g!_) (~ g!_)) - (..with-vars [(~+ inputsC)] - (_.function (~ g!_) (list (~+ inputsC)) - (~ code))))))))))))) - -(runtime: (lux//try op) - (with-vars [ex] - (_.try (_.return (_.apply/1 op ..unit)) - [ex (_.return (|> ex (_.do "toString" (list))))]))) - -(def: length - (-> Expression Computation) - (_.the "length")) - -(def: last-index - (-> Expression Computation) - (|>> ..length (_.- (_.i32 +1)))) - -(def: (last-element tuple) - (_.at (..last-index tuple) - tuple)) - -(runtime: (lux//program-args) - (with-vars [process output idx] - (_.if (_.and (|> process _.type-of (_.= _.undefined) _.not) - (|> process (_.the "argv"))) - ($_ _.then - (_.define output ..none) - (_.for idx - (|> process (_.the "argv") ..last-index) - (_.>= (_.i32 +0) idx) - (_.-- idx) - (_.set output (..some (_.array (list (|> process (_.the "argv") (_.at idx)) - output))))) - (_.return output)) - (_.return ..none)))) - -(def: runtime//lux - Statement - ($_ _.then - @lux//try - @lux//program-args - )) - -(runtime: (product//left product index) - (with-vars [index-min-length] - ($_ _.then - (_.define index-min-length (_.+ (_.i32 +1) index)) - (_.if (_.< (..length product) - index-min-length) - ## No need for recursion. - (_.return (_.at index product)) - ## Needs recursion. - (_.return (product//left (last-element product) - (_.- (..length product) - index-min-length))) - )))) - -(runtime: (product//right product index) - (with-vars [index-min-length] - ($_ _.then - (_.define index-min-length (_.+ (_.i32 +1) index)) - (_.cond (list [(_.= index-min-length - (..length product)) - ## Last element. - (_.return (_.at index product))] - [(_.< index-min-length - (..length product)) - ## Needs recursion. - (_.return (product//right (last-element product) - (_.- (..length product) - index-min-length)))]) - ## Must slice - (_.return (_.do "slice" (list index) product)))))) - -(runtime: (sum//get sum wants-last wanted-tag) - (let [no-match! (_.return _.null) - sum-tag (|> sum (_.the ..variant-tag-field)) - sum-flag (|> sum (_.the ..variant-flag-field)) - sum-value (|> sum (_.the ..variant-value-field)) - is-last? (_.= ..unit sum-flag) - extact-match! (_.return sum-value) - test-recursion! (_.if is-last? - ## Must recurse. - (_.return (sum//get sum-value (_.- sum-tag wanted-tag) wants-last)) - no-match!) - extrac-sub-variant! (_.return (..variant (_.- wanted-tag sum-tag) sum-flag sum-value))] - (_.cond (list [(_.= wanted-tag sum-tag) - (_.if (_.= wants-last sum-flag) - extact-match! - test-recursion!)] - [(_.< wanted-tag sum-tag) - test-recursion!] - [(_.and (_.> wanted-tag sum-tag) - (_.= ..unit wants-last)) - extrac-sub-variant!]) - no-match!))) - -(def: runtime//structure - Statement - ($_ _.then - @product//left - @product//right - @sum//get - )) - -(def: #export i64-high-field Text "_lux_high") -(def: #export i64-low-field Text "_lux_low") - -(runtime: (i64//new high low) - (_.return (_.object (list [..i64-high-field high] - [..i64-low-field low])))) - -(runtime: i64//2^16 - (_.left-shift (_.i32 +16) (_.i32 +1))) - -(runtime: i64//2^32 - (_.* i64//2^16 i64//2^16)) - -(runtime: i64//2^64 - (_.* i64//2^32 i64//2^32)) - -(runtime: i64//2^63 - (|> i64//2^64 (_./ (_.i32 +2)))) - -(runtime: (i64//unsigned-low i64) - (_.return (_.? (|> i64 (_.the ..i64-low-field) (_.>= (_.i32 +0))) - (|> i64 (_.the ..i64-low-field)) - (|> i64 (_.the ..i64-low-field) (_.+ i64//2^32))))) - -(runtime: (i64//to-number i64) - (_.return (|> i64 (_.the ..i64-high-field) (_.* i64//2^32) - (_.+ (i64//unsigned-low i64))))) - -(runtime: i64//zero - (i64//new (_.i32 +0) (_.i32 +0))) - -(runtime: i64//min - (i64//new (_.i32 (hex "+80000000")) (_.i32 +0))) - -(runtime: i64//max - (i64//new (_.i32 (hex "+7FFFFFFF")) (_.i32 (hex "+FFFFFFFF")))) - -(runtime: i64//one - (i64//new (_.i32 +0) (_.i32 +1))) - -(runtime: (i64//= left right) - (_.return (_.and (_.= (_.the ..i64-high-field left) - (_.the ..i64-high-field right)) - (_.= (_.the ..i64-low-field left) - (_.the ..i64-low-field right))))) - -(runtime: (i64//+ subject parameter) - (let [up-16 (_.left-shift (_.i32 +16)) - high-16 (_.logic-right-shift (_.i32 +16)) - low-16 (_.bit-and (_.i32 (hex "+FFFF"))) - hh (|>> (_.the ..i64-high-field) high-16) - hl (|>> (_.the ..i64-high-field) low-16) - lh (|>> (_.the ..i64-low-field) high-16) - ll (|>> (_.the ..i64-low-field) low-16)] - (with-vars [l48 l32 l16 l00 - r48 r32 r16 r00 - x48 x32 x16 x00] - ($_ _.then - (_.define l48 (hh subject)) - (_.define l32 (hl subject)) - (_.define l16 (lh subject)) - (_.define l00 (ll subject)) - - (_.define r48 (hh parameter)) - (_.define r32 (hl parameter)) - (_.define r16 (lh parameter)) - (_.define r00 (ll parameter)) - - (_.define x00 (_.+ l00 r00)) - (_.define x16 (high-16 x00)) - (_.set x00 (low-16 x00)) - (_.set x16 (|> x16 (_.+ l16) (_.+ r16))) - (_.define x32 (high-16 x16)) - (_.set x16 (low-16 x16)) - (_.set x32 (|> x32 (_.+ l32) (_.+ r32))) - (_.define x48 (|> (high-16 x32) (_.+ l48) (_.+ r48) low-16)) - (_.set x32 (low-16 x32)) - - (_.return (i64//new (_.bit-or (up-16 x48) x32) - (_.bit-or (up-16 x16) x00))) - )))) - -(do-template [ ] - [(runtime: ( subject parameter) - (_.return (i64//new ( (_.the ..i64-high-field subject) - (_.the ..i64-high-field parameter)) - ( (_.the ..i64-low-field subject) - (_.the ..i64-low-field parameter)))))] - - [i64//xor _.bit-xor] - [i64//or _.bit-or] - [i64//and _.bit-and] - ) - -(runtime: (i64//not value) - (_.return (i64//new (_.bit-not (_.the ..i64-high-field value)) - (_.bit-not (_.the ..i64-low-field value))))) - -(runtime: (i64//negate value) - (_.if (i64//= i64//min value) - (_.return i64//min) - (_.return (i64//+ (i64//not value) i64//one)))) - -(runtime: i64//-one - (i64//negate i64//one)) - -(runtime: (i64//from-number value) - (_.cond (list [(_.not-a-number? value) - (_.return i64//zero)] - [(_.<= (_.negate i64//2^63) value) - (_.return i64//min)] - [(|> value (_.+ (_.i32 +1)) (_.>= i64//2^63)) - (_.return i64//max)] - [(|> value (_.< (_.i32 +0))) - (_.return (|> value _.negate i64//from-number i64//negate))]) - (_.return (i64//new (_./ i64//2^32 value) - (_.% i64//2^32 value))))) - -(def: (cap-shift! shift) - (-> Var Statement) - (_.set shift (|> shift (_.bit-and (_.i32 +63))))) - -(def: (no-shift! shift input) - (-> Var Var [Expression Statement]) - [(|> shift (_.= (_.i32 +0))) - (_.return input)]) - -(def: small-shift? - (-> Var Expression) - (|>> (_.< (_.i32 +32)))) - -(runtime: (i64//left-shift input shift) - ($_ _.then - (..cap-shift! shift) - (_.cond (list (..no-shift! shift input) - [(..small-shift? shift) - (let [high (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift shift)) - (|> input (_.the ..i64-low-field) (_.logic-right-shift (_.- shift (_.i32 +32))))) - low (|> input (_.the ..i64-low-field) (_.left-shift shift))] - (_.return (i64//new high low)))]) - (let [high (|> input (_.the ..i64-low-field) (_.left-shift (_.- (_.i32 +32) shift)))] - (_.return (i64//new high (_.i32 +0))))))) - -(runtime: (i64//arithmetic-right-shift input shift) - ($_ _.then - (..cap-shift! shift) - (_.cond (list (..no-shift! shift input) - [(..small-shift? shift) - (let [high (|> input (_.the ..i64-high-field) (_.arithmetic-right-shift shift)) - low (|> input (_.the ..i64-low-field) (_.logic-right-shift shift) - (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift (_.- shift (_.i32 +32))))))] - (_.return (i64//new high low)))]) - (let [high (_.? (|> input (_.the ..i64-high-field) (_.>= (_.i32 +0))) - (_.i32 +0) - (_.i32 -1)) - low (|> input (_.the ..i64-high-field) (_.arithmetic-right-shift (_.- (_.i32 +32) shift)))] - (_.return (i64//new high low)))))) - -(runtime: (i64//logic-right-shift input shift) - ($_ _.then - (..cap-shift! shift) - (_.cond (list (..no-shift! shift input) - [(..small-shift? shift) - (let [high (|> input (_.the ..i64-high-field) (_.logic-right-shift shift)) - low (|> input (_.the ..i64-low-field) (_.logic-right-shift shift) - (_.bit-or (|> input (_.the ..i64-high-field) (_.left-shift (_.- shift (_.i32 +32))))))] - (_.return (i64//new high low)))] - [(|> shift (_.= (_.i32 +32))) - (_.return (i64//new (_.i32 +0) (|> input (_.the ..i64-high-field))))]) - (_.return (i64//new (_.i32 +0) - (|> input (_.the ..i64-high-field) (_.logic-right-shift (_.- (_.i32 +32) shift)))))))) - -(def: runtime//bit - Statement - ($_ _.then - @i64//and - @i64//or - @i64//xor - @i64//not - @i64//left-shift - @i64//arithmetic-right-shift - @i64//logic-right-shift - )) - -(runtime: (i64//- subject parameter) - (_.return (i64//+ subject (i64//negate parameter)))) - -(runtime: (i64//* subject parameter) - (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))] - (_.cond (list [(negative? subject) - (_.if (negative? parameter) - ## Both are negative - (_.return (i64//* (i64//negate subject) (i64//negate parameter))) - ## Subject is negative - (_.return (i64//negate (i64//* (i64//negate subject) parameter))))] - [(negative? parameter) - ## Parameter is negative - (_.return (i64//negate (i64//* subject (i64//negate parameter))))]) - ## Both are positive - (let [up-16 (_.left-shift (_.i32 +16)) - high-16 (_.logic-right-shift (_.i32 +16)) - low-16 (_.bit-and (_.i32 (hex "+FFFF"))) - hh (|>> (_.the ..i64-high-field) high-16) - hl (|>> (_.the ..i64-high-field) low-16) - lh (|>> (_.the ..i64-low-field) high-16) - ll (|>> (_.the ..i64-low-field) low-16)] - (with-vars [l48 l32 l16 l00 - r48 r32 r16 r00 - x48 x32 x16 x00] - ($_ _.then - (_.define l48 (hh subject)) - (_.define l32 (hl subject)) - (_.define l16 (lh subject)) - (_.define l00 (ll subject)) - - (_.define r48 (hh parameter)) - (_.define r32 (hl parameter)) - (_.define r16 (lh parameter)) - (_.define r00 (ll parameter)) - - (_.define x00 (_.* l00 r00)) - (_.define x16 (high-16 x00)) - (_.set x00 (low-16 x00)) - - (_.set x16 (|> x16 (_.+ (_.* l16 r00)))) - (_.define x32 (high-16 x16)) (_.set x16 (low-16 x16)) - (_.set x16 (|> x16 (_.+ (_.* l00 r16)))) - (_.set x32 (|> x32 (_.+ (high-16 x16)))) (_.set x16 (low-16 x16)) - - (_.set x32 (|> x32 (_.+ (_.* l32 r00)))) - (_.define x48 (high-16 x32)) (_.set x32 (low-16 x32)) - (_.set x32 (|> x32 (_.+ (_.* l16 r16)))) - (_.set x48 (|> x48 (_.+ (high-16 x32)))) (_.set x32 (low-16 x32)) - (_.set x32 (|> x32 (_.+ (_.* l00 r32)))) - (_.set x48 (|> x48 (_.+ (high-16 x32)))) (_.set x32 (low-16 x32)) - - (_.set x48 (|> x48 - (_.+ (_.* l48 r00)) - (_.+ (_.* l32 r16)) - (_.+ (_.* l16 r32)) - (_.+ (_.* l00 r48)) - low-16)) - - (_.return (i64//new (_.bit-or (up-16 x48) x32) - (_.bit-or (up-16 x16) x00))) - )))))) - -(runtime: (i64//< subject parameter) - (let [negative? (|>> (_.the ..i64-high-field) (_.< (_.i32 +0)))] - (with-vars [-subject? -parameter?] - ($_ _.then - (_.define -subject? (negative? subject)) - (_.define -parameter? (negative? parameter)) - (_.cond (list [(_.and -subject? (_.not -parameter?)) - (_.return _.true)] - [(_.and (_.not -subject?) -parameter?) - (_.return _.false)]) - (_.return (negative? (i64//- subject parameter)))))))) - -(def: (i64//<= subject param) - (-> Expression Expression Expression) - (_.or (i64//< subject param) - (i64//= subject param))) - -(runtime: (i64/// subject parameter) - (let [negative? (function (_ value) - (i64//< value i64//zero)) - valid-division-check [(i64//= i64//zero parameter) - (_.throw (_.string "Cannot divide by zero!"))] - short-circuit-check [(i64//= i64//zero subject) - (_.return i64//zero)]] - (_.cond (list valid-division-check - short-circuit-check - - [(i64//= i64//min subject) - (_.cond (list [(_.or (i64//= i64//one parameter) - (i64//= i64//-one parameter)) - (_.return i64//min)] - [(i64//= i64//min parameter) - (_.return i64//one)]) - (with-vars [approximation] - (let [subject/2 (i64//arithmetic-right-shift subject (_.i32 +1))] - ($_ _.then - (_.define approximation (i64//left-shift (i64/// subject/2 - parameter) - (_.i32 +1))) - (_.if (i64//= i64//zero approximation) - (_.return (_.? (negative? parameter) - i64//one - i64//-one)) - (let [remainder (i64//- subject - (i64//* parameter - approximation))] - (_.return (i64//+ approximation - (i64/// remainder - parameter)))))))))] - [(i64//= i64//min parameter) - (_.return i64//zero)] - - [(negative? subject) - (_.return (_.? (negative? parameter) - (i64/// (i64//negate subject) - (i64//negate parameter)) - (i64//negate (i64/// (i64//negate subject) - parameter))))] - - [(negative? parameter) - (_.return (i64//negate (i64/// subject (i64//negate parameter))))]) - (with-vars [result remainder] - ($_ _.then - (_.define result i64//zero) - (_.define remainder subject) - (_.while (i64//<= parameter remainder) - (with-vars [approximate approximate-result approximate-remainder log2 delta] - (let [approximate-result' (i64//from-number approximate) - approx-remainder (i64//* approximate-result parameter)] - ($_ _.then - (_.define approximate (|> (i64//to-number remainder) - (_./ (i64//to-number parameter)) - (_.apply/1 (_.var "Math.floor")) - (_.apply/2 (_.var "Math.max") (_.i32 +1)))) - (_.define log2 (|> approximate - (_.apply/1 (_.var "Math.log")) - (_./ (_.var "Math.LN2")) - (_.apply/1 (_.var "Math.ceil")))) - (_.define delta (_.? (_.<= (_.i32 +48) log2) - (_.i32 +1) - (_.apply/2 (_.var "Math.pow") - (_.i32 +2) - (_.- (_.i32 +48) - log2)))) - (_.define approximate-result approximate-result') - (_.define approximate-remainder approx-remainder) - (_.while (_.or (negative? approximate-remainder) - (i64//< remainder - approximate-remainder)) - ($_ _.then - (_.set approximate (_.- delta approximate)) - (_.set approximate-result approximate-result') - (_.set approximate-remainder approx-remainder))) - (_.set result (i64//+ result - (_.? (i64//= i64//zero approximate-result) - i64//one - approximate-result))) - (_.set remainder (i64//- remainder approximate-remainder)))))) - (_.return result))) - ))) - -(runtime: (i64//% subject parameter) - (let [flat (i64//* (i64/// subject parameter) - parameter)] - (_.return (i64//- subject flat)))) - -(def: runtime//i64 - Statement - ($_ _.then - @i64//2^16 - @i64//2^32 - @i64//2^64 - @i64//2^63 - @i64//unsigned-low - @i64//new - @i64//zero - @i64//min - @i64//max - @i64//one - @i64//= - @i64//+ - @i64//negate - @i64//to-number - @i64//from-number - @i64//- - @i64//* - @i64//< - @i64/// - @i64//% - runtime//bit - )) - -(runtime: (text//index text part start) - (with-vars [idx] - ($_ _.then - (_.define idx (|> text (_.do "indexOf" (list part (i64//to-number start))))) - (_.if (_.= (_.i32 -1) idx) - (_.return ..none) - (_.return (..some (i64//from-number idx))))))) - -(runtime: (text//clip text start end) - (_.return (|> text (_.do "substring" (list (_.the ..i64-low-field start) - (_.the ..i64-low-field end)))))) - -(runtime: (text//char text idx) - (with-vars [result] - ($_ _.then - (_.define result (|> text (_.do "charCodeAt" (list (_.the ..i64-low-field idx))))) - (_.if (_.not-a-number? result) - (_.return ..none) - (_.return (..some (i64//from-number result))))))) - -(def: runtime//text - Statement - ($_ _.then - @text//index - @text//clip - @text//char - )) - -(runtime: (io//log message) - (let [console (_.var "console") - print (_.var "print") - end! (_.return ..unit)] - (_.cond (list [(|> console _.type-of (_.= (_.string "undefined")) _.not - (_.and (_.the "log" console))) - ($_ _.then - (_.statement (|> console (_.do "log" (list message)))) - end!)] - [(|> print _.type-of (_.= (_.string "undefined")) _.not) - ($_ _.then - (_.statement (_.apply/1 print (_.apply/1 (_.var "JSON.stringify") message))) - end!)]) - end!))) - -(runtime: (io//error message) - (_.throw message)) - -(def: runtime//io - Statement - ($_ _.then - @io//log - @io//error - )) - -(runtime: (js//get object field) - (with-vars [temp] - ($_ _.then - (_.define temp (_.at field object)) - (_.if (_.= _.undefined temp) - (_.return ..none) - (_.return (..some temp)))))) - -(runtime: (js//set object field input) - ($_ _.then - (_.set (_.at field object) input) - (_.return object))) - -(runtime: (js//delete object field) - ($_ _.then - (_.delete (_.at field object)) - (_.return object))) - -(def: runtime//js - Statement - ($_ _.then - @js//get - @js//set - @js//delete - )) - -(runtime: (array//read idx array) - (let [fail! (_.return ..none)] - (_.if (_.< (..length array) idx) - (with-vars [temp] - ($_ _.then - (_.define temp (_.at idx array)) - (_.if (_.= _.undefined temp) - fail! - (_.return (..some temp))))) - fail!))) - -(runtime: (array//write idx value array) - (_.if (_.< (..length array) idx) - ($_ _.then - (_.set (_.at idx array) value) - (_.return (..some array))) - (_.return ..none))) - -(runtime: (array//delete idx array) - (_.if (_.< (..length array) idx) - ($_ _.then - (_.delete (_.at idx array)) - (_.return (..some array))) - (_.return ..none))) - -(def: runtime//array - Statement - ($_ _.then - @array//read - @array//write - @array//delete)) - -(def: runtime - Statement - ($_ _.then - runtime//lux - runtime//structure - runtime//i64 - runtime//text - runtime//io - runtime//js - runtime//array - )) - -(def: #export artifact Text (format prefix ".js")) - -(def: #export translate - (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.save! ["" ..prefix] ..runtime)] - (///.save-buffer! ..artifact)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux b/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux deleted file mode 100644 index 732f48bb9..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/js/structure.lux +++ /dev/null @@ -1,36 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)]] - [host - ["_" js (#+ Expression)]]] - [// - ["//." runtime (#+ Operation Phase)] - ["//." primitive] - ["/." /// - [// - [analysis (#+ Variant Tuple)] - ["." synthesis (#+ Synthesis)]]]]) - -(def: #export (tuple translate elemsS+) - (-> Phase (Tuple Synthesis) (Operation Expression)) - (case elemsS+ - #.Nil - (:: ////.monad wrap (//primitive.text synthesis.unit)) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do ////.monad - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (_.array elemsT+))))) - -(def: #export (variant translate [lefts right? valueS]) - (-> Phase (Variant Synthesis) (Operation Expression)) - (:: ////.monad map - (//runtime.variant (_.i32 (.int (if right? - (inc lefts) - lefts))) - (//runtime.flag right?)) - (translate valueS))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/reference.lux b/stdlib/source/lux/tool/compiler/phase/translation/reference.lux deleted file mode 100644 index 878d96e83..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/reference.lux +++ /dev/null @@ -1,81 +0,0 @@ -(.module: - [lux #* - [control - pipe] - [data - [text - format]] - [type (#+ :share)]] - ["." // - ["/." // ("#/." monad) - [// - [synthesis (#+ Synthesis)] - ["." reference (#+ Register Variable Reference)]]]]) - -(signature: #export (System expression) - (: (-> Register expression) - local) - (: (-> Register expression) - foreign) - (: (All [anchor statement] - (-> Variable (//.Operation anchor expression statement))) - variable) - (: (All [anchor statement] - (-> Name (//.Operation anchor expression statement))) - constant) - (: (All [anchor statement] - (-> Reference (//.Operation anchor expression statement))) - reference)) - -(def: (variable-maker prefix variable) - (All [expression] - (-> Text (-> Text expression) - (-> Register expression))) - (|>> %n (format prefix) variable)) - -(def: #export foreign - (All [expression] - (-> (-> Text expression) - (-> Register expression))) - (variable-maker "f")) - -(def: #export local - (All [expression] - (-> (-> Text expression) - (-> Register expression))) - (variable-maker "l")) - -(def: #export (system constant variable) - (All [expression] - (-> (-> Text expression) (-> Text expression) - (System expression))) - (let [local (..local variable) - foreign (..foreign variable) - variable (:share [expression] - {(-> Text expression) - variable} - {(All [anchor statement] - (-> Variable (//.Operation anchor expression statement))) - (|>> (case> (#reference.Local register) - (local register) - - (#reference.Foreign register) - (foreign register)) - ////wrap)}) - constant (:share [expression] - {(-> Text expression) - constant} - {(All [anchor statement] - (-> Name (//.Operation anchor expression statement))) - (|>> //.remember (////map constant))})] - (structure - (def: local local) - (def: foreign foreign) - (def: variable variable) - (def: constant constant) - (def: reference - (|>> (case> (#reference.Constant value) - (constant value) - - (#reference.Variable value) - (variable value))))))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux deleted file mode 100644 index 6d5cf911b..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/case.jvm.lux +++ /dev/null @@ -1,175 +0,0 @@ -(.module: - [lux (#- case let if) - [control - [monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["." number] - ["." text - format] - [collection - ["." list ("#/." functor fold)]]] - [host - ["_" scheme (#+ Expression Computation Var)]]] - [// - ["." runtime (#+ Operation Phase)] - ["//." primitive] - ["." reference] - [// - ["common-." reference] - ["//." // ("#/." monad) - ["." synthesis (#+ Synthesis Path)] - [// - [reference (#+ Register)]]]]]) - -(def: #export register - (common-reference.local _.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 [(..register 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 (.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: @temp (_.var "lux_pm_temp")) -(def: @alt-error (_.var "alt_error")) - -(def: (push! value var) - (-> Expression Var Computation) - (_.set! var (_.cons/2 value var))) - -(def: (push-cursor! value) - (-> Expression Computation) - (push! value @cursor)) - -(def: (pop! var) - (-> Var Computation) - (_.set! var var)) - -(def: save-cursor! - Computation - (push! @cursor @savepoint)) - -(def: restore-cursor! - Computation - (_.set! @cursor (_.car/1 @savepoint))) - -(def: cursor-top - Computation - (_.car/1 @cursor)) - -(def: pop-cursor! - Computation - (pop! @cursor)) - -(def: pm-error (_.string "PM-ERROR")) - -(def: fail-pm! (_.raise/1 pm-error)) - -(exception: #export unrecognized-path) - -(def: (pm-catch handler) - (-> Expression Computation) - (_.lambda [(list @alt-error) #.None] - (_.if (|> @alt-error (_.eqv?/2 pm-error)) - handler - (_.raise/1 @alt-error)))) - -(def: (pattern-matching' translate pathP) - (-> Phase Path (Operation Expression)) - (.case pathP - (^ (synthesis.path/then bodyS)) - (translate bodyS) - - #synthesis.Pop - (/////wrap pop-cursor!) - - (#synthesis.Bind register) - (/////wrap (_.define (..register register) [(list) #.None] - cursor-top)) - - (^template [ <=>] - (^ ( value)) - (/////wrap (_.when (|> value (<=> cursor-top) _.not/1) - fail-pm!))) - ([synthesis.path/bit //primitive.bit _.eqv?/2] - [synthesis.path/i64 (<| //primitive.i64 .int) _.=/2] - [synthesis.path/f64 //primitive.f64 _.=/2] - [synthesis.path/text //primitive.text _.eqv?/2]) - - (^template [ ] - (^ ( idx)) - (/////wrap (_.let (list [@temp (|> idx .int _.int (runtime.sum//get cursor-top ))]) - (_.if (_.null?/1 @temp) - fail-pm! - (push-cursor! @temp))))) - ([synthesis.side/left _.nil (<|)] - [synthesis.side/right (_.string "") inc]) - - (^template [ ] - (^ ( idx)) - (/////wrap (|> idx .int _.int ( cursor-top) push-cursor!))) - ([synthesis.member/left runtime.product//left (<|)] - [synthesis.member/right runtime.product//right inc]) - - (^template [ ] - (^ ( leftP rightP)) - (do ////.monad - [leftO (pattern-matching' translate leftP) - rightO (pattern-matching' translate rightP)] - (wrap ))) - ([synthesis.path/seq (_.begin (list leftO - rightO))] - [synthesis.path/alt (_.with-exception-handler - (pm-catch (_.begin (list restore-cursor! - rightO))) - (_.lambda [(list) #.None] - (_.begin (list save-cursor! - leftO))))]) - - _ - (////.throw unrecognized-path []))) - -(def: (pattern-matching translate pathP) - (-> Phase Path (Operation Computation)) - (do ////.monad - [pattern-matching! (pattern-matching' translate pathP)] - (wrap (_.with-exception-handler - (pm-catch (_.raise/1 (_.string "Invalid expression for pattern-matching."))) - (_.lambda [(list) #.None] - pattern-matching!))))) - -(def: #export (case translate [valueS pathP]) - (-> Phase [Synthesis Path] (Operation Computation)) - (do ////.monad - [valueO (translate valueS)] - (<| (:: @ map (_.let (list [@cursor (_.list/* (list valueO))] - [@savepoint (_.list/* (list))]))) - (pattern-matching translate pathP)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux deleted file mode 100644 index 76b206124..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/expression.jvm.lux +++ /dev/null @@ -1,59 +0,0 @@ -(.module: - [lux #* - [control - [monad (#+ do)]]] - [// - [runtime (#+ Phase)] - ["." primitive] - ["." structure] - ["." reference] - ["." function] - ["." case] - ["." loop] - ["." /// - ["." synthesis] - ["." extension]]]) - -(def: #export (translate synthesis) - Phase - (case synthesis - (^template [ ] - (^ ( value)) - (:: ///.monad wrap ( 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 value) - (:: reference.system reference value) - - (^ (synthesis.branch/case case)) - (case.case translate case) - - (^ (synthesis.branch/let let)) - (case.let translate let) - - (^ (synthesis.branch/if if)) - (case.if translate if) - - (^ (synthesis.loop/scope scope)) - (loop.scope translate scope) - - (^ (synthesis.loop/recur updates)) - (loop.recur translate updates) - - (^ (synthesis.function/abstraction abstraction)) - (function.function translate abstraction) - - (^ (synthesis.function/apply application)) - (function.apply translate application) - - (#synthesis.Extension extension) - (extension.apply translate extension))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux deleted file mode 100644 index a40b4953f..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension.jvm.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux #* - [data - [collection - ["." dictionary]]]] - [// - [runtime (#+ Bundle)]] - [/ - ["." common] - ["." host]]) - -(def: #export bundle - Bundle - (|> common.bundle - (dictionary.merge host.bundle))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux deleted file mode 100644 index d430aba24..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/common.jvm.lux +++ /dev/null @@ -1,243 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)] - ["ex" exception (#+ exception:)]] - [data - ["e" error] - ["." product] - ["." text - format] - [number (#+ hex)] - [collection - ["." list ("#/." functor)] - ["dict" dictionary (#+ Dictionary)]]] - ["." macro (#+ with-gensyms) - ["." code] - ["s" syntax (#+ syntax:)]] - [host (#+ import:) - ["_" scheme (#+ Expression Computation)]]] - [/// - ["." runtime (#+ Operation Phase Handler Bundle)] - ["//." /// - ["." synthesis (#+ Synthesis)] - ["." extension - ["." bundle]]]]) - -(syntax: (Vector {size s.nat} elemT) - (wrap (list (` [(~+ (list.repeat size elemT))])))) - -(type: #export Nullary (-> (Vector 0 Expression) Computation)) -(type: #export Unary (-> (Vector 1 Expression) Computation)) -(type: #export Binary (-> (Vector 2 Expression) Computation)) -(type: #export Trinary (-> (Vector 3 Expression) Computation)) -(type: #export Variadic (-> (List Expression) Computation)) - -(syntax: (arity: {name s.local-identifier} {arity s.nat}) - (with-gensyms [g!_ g!extension g!name g!phase g!inputs] - (do @ - [g!input+ (monad.seq @ (list.repeat arity (macro.gensym "input")))] - (wrap (list (` (def: #export ((~ (code.local-identifier name)) (~ g!extension)) - (-> (-> (..Vector (~ (code.nat arity)) Expression) Computation) - Handler) - (function ((~ g!_) (~ g!name) (~ g!phase) (~ g!inputs)) - (case (~ g!inputs) - (^ (list (~+ g!input+))) - (do /////.monad - [(~+ (|> g!input+ - (list/map (function (_ g!input) - (list g!input (` ((~ g!phase) (~ g!input)))))) - list.concat))] - ((~' wrap) ((~ g!extension) [(~+ g!input+)]))) - - (~' _) - (/////.throw extension.incorrect-arity [(~ g!name) 1 (list.size (~ g!inputs))])))))))))) - -(arity: nullary 0) -(arity: unary 1) -(arity: binary 2) -(arity: trinary 3) - -(def: #export (variadic extension) - (-> Variadic Handler) - (function (_ extension-name) - (function (_ phase inputsS) - (do /////.monad - [inputsI (monad.map @ phase inputsS)] - (wrap (extension inputsI)))))) - -(def: bundle::lux - Bundle - (|> bundle.empty - (bundle.install "is?" (binary (product.uncurry _.eq?/2))) - (bundle.install "try" (unary runtime.lux//try)))) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [bit::and _.bit-and/2] - [bit::or _.bit-or/2] - [bit::xor _.bit-xor/2] - ) - -(def: (bit::left-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (_.remainder/2 (_.int +64) paramO) - subjectO)) - -(def: (bit::arithmetic-right-shift [subjectO paramO]) - Binary - (_.arithmetic-shift/2 (|> paramO (_.remainder/2 (_.int +64)) (_.*/2 (_.int -1))) - subjectO)) - -(def: (bit::logical-right-shift [subjectO paramO]) - Binary - (runtime.bit//logical-right-shift (_.remainder/2 (_.int +64) paramO) subjectO)) - -(def: bundle::bit - Bundle - (<| (bundle.prefix "bit") - (|> bundle.empty - (bundle.install "and" (binary bit::and)) - (bundle.install "or" (binary bit::or)) - (bundle.install "xor" (binary bit::xor)) - (bundle.install "left-shift" (binary bit::left-shift)) - (bundle.install "logical-right-shift" (binary bit::logical-right-shift)) - (bundle.install "arithmetic-right-shift" (binary bit::arithmetic-right-shift)) - ))) - -(import: java/lang/Double - (#static MIN_VALUE Double) - (#static MAX_VALUE Double)) - -(do-template [ ] - [(def: ( _) - Nullary - ( ))] - - [frac::smallest (Double::MIN_VALUE) _.float] - [frac::min (f/* -1.0 (Double::MAX_VALUE)) _.float] - [frac::max (Double::MAX_VALUE) _.float] - ) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - (|> subjectO ( paramO)))] - - [int::+ _.+/2] - [int::- _.-/2] - [int::* _.*/2] - [int::/ _.quotient/2] - [int::% _.remainder/2] - ) - -(do-template [ ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [frac::+ _.+/2] - [frac::- _.-/2] - [frac::* _.*/2] - [frac::/ _.//2] - [frac::% _.mod/2] - [frac::= _.=/2] - [frac::< _. ] - [(def: ( [subjectO paramO]) - Binary - ( paramO subjectO))] - - [int::= _.=/2] - [int::< _.> _.integer->char/1 _.string/1)) - -(def: bundle::int - Bundle - (<| (bundle.prefix "int") - (|> bundle.empty - (bundle.install "+" (binary int::+)) - (bundle.install "-" (binary int::-)) - (bundle.install "*" (binary int::*)) - (bundle.install "/" (binary int::/)) - (bundle.install "%" (binary int::%)) - (bundle.install "=" (binary int::=)) - (bundle.install "<" (binary int::<)) - (bundle.install "to-frac" (unary (|>> (_.//2 (_.float +1.0))))) - (bundle.install "char" (unary int::char))))) - -(def: bundle::frac - Bundle - (<| (bundle.prefix "frac") - (|> bundle.empty - (bundle.install "+" (binary frac::+)) - (bundle.install "-" (binary frac::-)) - (bundle.install "*" (binary frac::*)) - (bundle.install "/" (binary frac::/)) - (bundle.install "%" (binary frac::%)) - (bundle.install "=" (binary frac::=)) - (bundle.install "<" (binary frac::<)) - (bundle.install "smallest" (nullary frac::smallest)) - (bundle.install "min" (nullary frac::min)) - (bundle.install "max" (nullary frac::max)) - (bundle.install "to-int" (unary _.exact/1)) - (bundle.install "encode" (unary _.number->string/1)) - (bundle.install "decode" (unary runtime.frac//decode))))) - -(def: (text::char [subjectO paramO]) - Binary - (_.string/1 (_.string-ref/2 subjectO paramO))) - -(def: (text::clip [subjectO startO endO]) - Trinary - (_.substring/3 subjectO startO endO)) - -(def: bundle::text - Bundle - (<| (bundle.prefix "text") - (|> bundle.empty - (bundle.install "=" (binary text::=)) - (bundle.install "<" (binary text::<)) - (bundle.install "concat" (binary (product.uncurry _.string-append/2))) - (bundle.install "size" (unary _.string-length/1)) - (bundle.install "char" (binary text::char)) - (bundle.install "clip" (trinary text::clip))))) - -(def: (io::log input) - Unary - (_.begin (list (_.display/1 input) - _.newline/0))) - -(def: (void code) - (-> Expression Computation) - (_.begin (list code (_.string synthesis.unit)))) - -(def: bundle::io - Bundle - (<| (bundle.prefix "io") - (|> bundle.empty - (bundle.install "log" (unary (|>> io::log ..void))) - (bundle.install "error" (unary _.raise/1)) - (bundle.install "exit" (unary _.exit/1)) - (bundle.install "current-time" (nullary (function (_ _) (runtime.io//current-time (_.string synthesis.unit)))))))) - -(def: #export bundle - Bundle - (<| (bundle.prefix "lux") - (|> bundle::lux - (dict.merge bundle::bit) - (dict.merge bundle::int) - (dict.merge bundle::frac) - (dict.merge bundle::text) - (dict.merge bundle::io) - ))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux deleted file mode 100644 index b8b2b7612..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/extension/host.jvm.lux +++ /dev/null @@ -1,11 +0,0 @@ -(.module: - [lux #*] - [/// - [runtime (#+ Bundle)] - [/// - [extension - ["." bundle]]]]) - -(def: #export bundle - Bundle - bundle.empty) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux deleted file mode 100644 index bef6af902..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/function.jvm.lux +++ /dev/null @@ -1,97 +0,0 @@ -(.module: - [lux (#- function) - [control - ["." monad (#+ do)] - pipe] - [data - ["." product] - [text - format] - [collection - ["." list ("#/." functor)]]] - [host - ["_" scheme (#+ Expression Computation Var)]]] - [// - ["." runtime (#+ Operation Phase)] - ["." reference] - ["//." case] - ["/." // - ["common-." reference] - ["//." // ("#/." monad) - [analysis (#+ Variant Tuple Environment Arity Abstraction Application Analysis)] - [synthesis (#+ Synthesis)] - [// - [reference (#+ Register Variable)] - ["." name]]]]]) - -(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: #export capture - (common-reference.foreign _.var)) - -(def: (with-closure function-name inits function-definition) - (-> Text (List Expression) Computation (Operation Computation)) - (/////wrap - (case inits - #.Nil - function-definition - - _ - (let [@closure (_.var (format function-name "___CLOSURE"))] - (_.letrec (list [@closure - (_.lambda [(|> (list.enumerate inits) - (list/map (|>> product.left ..capture))) - #.None] - function-definition)]) - (_.apply/* @closure inits)))))) - -(def: @curried (_.var "curried")) -(def: @missing (_.var "missing")) - -(def: input - (|>> inc //case.register)) - -(def: #export (function 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+ (: (Operation (List Expression)) - (monad.map @ (:: reference.system variable) environment)) - #let [arityO (|> arity .int _.int) - apply-poly (.function (_ args func) - (_.apply/2 (_.global "apply") func args)) - @num-args (_.var "num_args") - @function (_.var function-name)]] - (with-closure function-name closureO+ - (_.letrec (list [@function (_.lambda [(list) (#.Some @curried)] - (_.let (list [@num-args (_.length/1 @curried)]) - (<| (_.if (|> @num-args (_.=/2 arityO)) - (<| (_.let (list [(//case.register 0) @function])) - (_.let-values (list [[(|> (list.indices arity) - (list/map ..input)) - #.None] - (_.apply/2 (_.global "apply") (_.global "values") @curried)])) - bodyO)) - (_.if (|> @num-args (_.>/2 arityO)) - (let [arity-args (runtime.slice (_.int +0) arityO @curried) - output-func-args (runtime.slice arityO - (|> @num-args (_.-/2 arityO)) - @curried)] - (|> @function - (apply-poly arity-args) - (apply-poly output-func-args)))) - ## (|> @num-args (_. @function - (apply-poly (_.append/2 @curried @missing))))) - ))]) - @function)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux deleted file mode 100644 index e1db0477c..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/loop.jvm.lux +++ /dev/null @@ -1,41 +0,0 @@ -(.module: - [lux (#- Scope) - [control - ["." monad (#+ do)]] - [data - ["." product] - ["." text - format] - [collection - ["." list ("#/." functor)]]] - [host - ["_" scheme (#+ Computation Var)]]] - [// - [runtime (#+ Operation Phase)] - ["." reference] - ["//." case] - ["/." // - ["//." // - [synthesis (#+ Scope Synthesis)]]]]) - -(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) //case.register))) - #.None] - bodyO)]) - (_.apply/* @scope initsO+))))) - -(def: #export (recur translate argsS+) - (-> Phase (List Synthesis) (Operation Computation)) - (do ////.monad - [@scope ///.anchor - argsO+ (monad.map @ translate argsS+)] - (wrap (_.apply/* @scope argsO+)))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux deleted file mode 100644 index d53a0691e..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/primitive.jvm.lux +++ /dev/null @@ -1,15 +0,0 @@ -(.module: - [lux (#- i64) - [host - ["_" scheme (#+ Expression)]]]) - -(do-template [ ] - [(def: #export - (-> Expression) - )] - - [bit Bit _.bool] - [i64 (I64 Any) (|>> .int _.int)] - [f64 Frac _.float] - [text Text _.string] - ) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux deleted file mode 100644 index b28cb1898..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/reference.jvm.lux +++ /dev/null @@ -1,12 +0,0 @@ -(.module: - [lux #* - [host - ["_" scheme (#+ Expression)]]] - [// - [// - [common - ["." reference]]]]) - -(def: #export system - (reference.system (: (-> Text Expression) _.global) - (: (-> Text Expression) _.var))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux deleted file mode 100644 index 904f40726..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/runtime.jvm.lux +++ /dev/null @@ -1,321 +0,0 @@ -(.module: - [lux #* - ["." function] - [control - ["p" parser ("#/." monad)] - [monad (#+ do)]] - [data - [number (#+ hex)] - [text - format] - [collection - ["." list ("#/." monad)]]] - [macro - ["." code] - ["s" syntax (#+ syntax:)]] - [host - ["_" scheme (#+ Expression Computation Var)]]] - ["." /// - ["//." // - [analysis (#+ Variant)] - ["." synthesis] - [// - ["." name]]]]) - -(do-template [ ] - [(type: #export - ( Var Expression Expression))] - - [Operation ///.Operation] - [Phase ///.Phase] - [Handler ///.Handler] - [Bundle ///.Bundle] - ) - -(def: prefix Text "LuxRuntime") - -(def: unit (_.string synthesis.unit)) - -(def: #export variant-tag "lux-variant") - -(def: (flag value) - (-> Bit Computation) - (if value - (_.string "") - _.nil)) - -(def: (variant' tag last? value) - (-> Expression Expression Expression Computation) - (<| (_.cons/2 (_.symbol ..variant-tag)) - (_.cons/2 tag) - (_.cons/2 last?) - value)) - -(def: #export (variant [lefts right? value]) - (-> (Variant Expression) Computation) - (variant' (_.int (.int lefts)) (flag right?) value)) - -(def: #export none - Computation - (variant [0 #0 ..unit])) - -(def: #export some - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: #export left - (-> Expression Computation) - (|>> [0 #0] ..variant)) - -(def: #export right - (-> Expression Computation) - (|>> [0 #1] ..variant)) - -(def: declaration - (s.Syntax [Text (List Text)]) - (p.either (p.and s.local-identifier (p/wrap (list))) - (s.form (p.and s.local-identifier (p.some s.local-identifier))))) - -(syntax: (runtime: {[name args] declaration} - definition) - (let [implementation (code.local-identifier (format "@@" name)) - runtime (format prefix "__" (name.normalize name)) - @runtime (` (_.var (~ (code.text runtime)))) - argsC+ (list/map code.local-identifier args) - argsLC+ (list/map (|>> name.normalize (format "LRV__") code.text (~) (_.var) (`)) - args) - declaration (` ((~ (code.local-identifier name)) - (~+ argsC+))) - type (` (-> (~+ (list.repeat (list.size argsC+) (` _.Expression))) - _.Computation))] - (wrap (list (` (def: (~' #export) (~ declaration) - (~ type) - (~ (case argsC+ - #.Nil - @runtime - - _ - (` (_.apply/* (~ @runtime) (list (~+ argsC+)))))))) - (` (def: (~ implementation) - _.Computation - (~ (case argsC+ - #.Nil - (` (_.define (~ @runtime) [(list) #.None] (~ definition))) - - _ - (` (let [(~+ (|> (list.zip2 argsC+ argsLC+) - (list/map (function (_ [left right]) - (list left right))) - list/join))] - (_.define (~ @runtime) [(list (~+ argsLC+)) #.None] - (~ definition)))))))))))) - -(runtime: (slice offset length list) - (<| (_.if (_.null?/1 list) - list) - (_.if (|> offset (_.>/2 (_.int +0))) - (slice (|> offset (_.-/2 (_.int +1))) - length - (_.cdr/1 list))) - (_.if (|> length (_.>/2 (_.int +0))) - (_.cons/2 (_.car/1 list) - (slice offset - (|> length (_.-/2 (_.int +1))) - (_.cdr/1 list)))) - _.nil)) - -(syntax: #export (with-vars {vars (s.tuple (p.many s.local-identifier))} - body) - (wrap (list (` (let [(~+ (|> vars - (list/map (function (_ var) - (list (code.local-identifier var) - (` (_.var (~ (code.text (format "LRV__" (name.normalize var))))))))) - list/join))] - (~ body)))))) - -(runtime: (lux//try op) - (with-vars [error] - (_.with-exception-handler - (_.lambda [(list error) #.None] - (..left error)) - (_.lambda [(list) #.None] - (..right (_.apply/* op (list ..unit))))))) - -(runtime: (lux//program-args program-args) - (with-vars [@loop @input @output] - (_.letrec (list [@loop (_.lambda [(list @input @output) #.None] - (_.if (_.eqv?/2 _.nil @input) - @output - (_.apply/2 @loop (_.cdr/1 @input) (..some (_.vector/* (list (_.car/1 @input) @output))))))]) - (_.apply/2 @loop (_.reverse/1 program-args) ..none)))) - -(def: runtime//lux - Computation - (_.begin (list @@lux//try - @@lux//program-args))) - -(def: minimum-index-length - (-> Expression Computation) - (|>> (_.+/2 (_.int +1)))) - -(def: product-element - (-> Expression Expression Computation) - (function.flip _.vector-ref/2)) - -(def: (product-tail product) - (-> Expression Computation) - (_.vector-ref/2 product (|> (_.length/1 product) (_.-/2 (_.int +1))))) - -(def: (updated-index min-length product) - (-> Expression Expression Computation) - (|> min-length (_.-/2 (_.length/1 product)))) - -(runtime: (product//left product index) - (let [@index_min_length (_.var "index_min_length")] - (_.begin - (list (_.define @index_min_length [(list) #.None] - (minimum-index-length index)) - (_.if (|> product _.length/1 (_.>/2 @index_min_length)) - ## No need for recursion - (product-element index product) - ## Needs recursion - (product//left (product-tail product) - (updated-index @index_min_length product))))))) - -(runtime: (product//right product index) - (let [@index_min_length (_.var "index_min_length") - @product_length (_.var "product_length") - @slice (_.var "slice") - last-element? (|> @product_length (_.=/2 @index_min_length)) - needs-recursion? (|> @product_length (_. @product_length (_.-/2 index)))) - (_.vector-copy!/5 @slice (_.int +0) product index @product_length) - @slice))))))) - -(runtime: (sum//get sum last? wanted-tag) - (with-vars [variant-tag sum-tag sum-flag sum-value] - (let [no-match _.nil - is-last? (|> sum-flag (_.eqv?/2 (_.string ""))) - test-recursion (_.if is-last? - ## Must recurse. - (sum//get sum-value - (|> wanted-tag (_.-/2 sum-tag)) - last?) - no-match)] - (<| (_.let-values (list [[(list variant-tag sum-tag sum-flag sum-value) #.None] - (_.apply/* (_.global "apply") (list (_.global "values") sum))])) - (_.if (|> wanted-tag (_.=/2 sum-tag)) - (_.if (|> sum-flag (_.eqv?/2 last?)) - sum-value - test-recursion)) - (_.if (|> wanted-tag (_.>/2 sum-tag)) - test-recursion) - (_.if (_.and (list (|> last? (_.eqv?/2 (_.string ""))) - (|> wanted-tag (_. sum-tag (_.-/2 wanted-tag)) sum-flag sum-value)) - no-match)))) - -(def: runtime//adt - Computation - (_.begin (list @@product//left - @@product//right - @@sum//get))) - -(runtime: (bit//logical-right-shift shift input) - (_.if (_.=/2 (_.int +0) shift) - input - (|> input - (_.arithmetic-shift/2 (_.*/2 (_.int -1) shift)) - (_.bit-and/2 (_.int (hex "+7FFFFFFFFFFFFFFF")))))) - -(def: runtime//bit - Computation - (_.begin (list @@bit//logical-right-shift))) - -(runtime: (frac//decode input) - (with-vars [@output] - (_.let (list [@output ((_.apply/1 (_.global "string->number")) input)]) - (_.if (_.and (list (_.not/1 (_.=/2 @output @output)) - (_.not/1 (_.eqv?/2 (_.string "+nan.0") input)))) - ..none - (..some @output))))) - -(def: runtime//frac - Computation - (_.begin - (list @@frac//decode))) - -(def: (check-index-out-of-bounds array idx body) - (-> Expression Expression Expression Computation) - (_.if (|> idx (_.<=/2 (_.length/1 array))) - body - (_.raise/1 (_.string "Array index out of bounds!")))) - -(runtime: (array//get array idx) - (with-vars [@temp] - (<| (check-index-out-of-bounds array idx) - (_.let (list [@temp (_.vector-ref/2 array idx)]) - (_.if (|> @temp (_.eqv?/2 _.nil)) - ..none - (..some @temp)))))) - -(runtime: (array//put array idx value) - (<| (check-index-out-of-bounds array idx) - (_.begin - (list (_.vector-set!/3 array idx value) - array)))) - -(def: runtime//array - Computation - (_.begin - (list @@array//get - @@array//put))) - -(runtime: (box//write value box) - (_.begin - (list - (_.vector-set!/3 box (_.int +0) value) - ..unit))) - -(def: runtime//box - Computation - (_.begin (list @@box//write))) - -(runtime: (io//current-time _) - (|> (_.apply/* (_.global "current-second") (list)) - (_.*/2 (_.int +1_000)) - _.exact/1)) - -(def: runtime//io - (_.begin (list @@io//current-time))) - -(def: runtime - Computation - (_.begin (list @@slice - runtime//lux - runtime//bit - runtime//adt - runtime//frac - runtime//array - runtime//box - runtime//io - ))) - -(def: #export translate - (Operation Any) - (///.with-buffer - (do ////.monad - [_ (///.save! ["" ..prefix] ..runtime)] - (///.save-buffer! "")))) diff --git a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux b/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux deleted file mode 100644 index d90569d9c..000000000 --- a/stdlib/source/lux/tool/compiler/phase/translation/scheme/structure.jvm.lux +++ /dev/null @@ -1,32 +0,0 @@ -(.module: - [lux #* - [control - ["." monad (#+ do)]] - [host - ["_" scheme (#+ Expression)]]] - [// - ["." runtime (#+ Operation Phase)] - ["." primitive] - ["." /// - [analysis (#+ Variant Tuple)] - ["." synthesis (#+ Synthesis)]]]) - -(def: #export (tuple translate elemsS+) - (-> Phase (Tuple Synthesis) (Operation Expression)) - (case elemsS+ - #.Nil - (:: ///.monad wrap (primitive.text synthesis.unit)) - - (#.Cons singletonS #.Nil) - (translate singletonS) - - _ - (do ///.monad - [elemsT+ (monad.map @ translate elemsS+)] - (wrap (_.vector/* elemsT+))))) - -(def: #export (variant translate [lefts right? valueS]) - (-> Phase (Variant Synthesis) (Operation Expression)) - (do ///.monad - [valueT (translate valueS)] - (wrap (runtime.variant [lefts right? valueT])))) diff --git a/stdlib/source/lux/tool/compiler/program.lux b/stdlib/source/lux/tool/compiler/program.lux index 9de17b5df..4a079cc0f 100644 --- a/stdlib/source/lux/tool/compiler/program.lux +++ b/stdlib/source/lux/tool/compiler/program.lux @@ -18,7 +18,7 @@ ["." statement] [phase [macro (#+ Expander)] - ["." translation]] + ["." generation]] [default ["." platform (#+ Platform)] ["." syntax]] @@ -62,7 +62,7 @@ (All [anchor expression statement] (-> Expander (IO (Platform IO anchor expression statement)) - (translation.Bundle anchor expression statement) + (generation.Bundle anchor expression statement) Service (IO Any))) (do io.monad diff --git a/stdlib/source/lux/tool/compiler/statement.lux b/stdlib/source/lux/tool/compiler/statement.lux index c4a8b56b1..7f251c42d 100644 --- a/stdlib/source/lux/tool/compiler/statement.lux +++ b/stdlib/source/lux/tool/compiler/statement.lux @@ -4,7 +4,7 @@ ["." analysis] ["." synthesis] ["." phase - ["." translation] + ["." generation] ["." extension]]]) (type: #export (Component state phase) @@ -16,8 +16,8 @@ analysis.Phase) #synthesis (Component synthesis.State+ synthesis.Phase) - #translation (Component (translation.State+ anchor expression statement) - (translation.Phase anchor expression statement))}) + #generation (Component (generation.State+ anchor expression statement) + (generation.Phase anchor expression statement))}) (do-template [ ] [(type: #export ( anchor expression statement) @@ -40,7 +40,7 @@ (set@ [ #..state])] operation)))] - [lift-analysis #..analysis analysis.Operation] - [lift-synthesis #..synthesis synthesis.Operation] - [lift-translation #..translation (translation.Operation anchor expression statement)] + [lift-analysis #..analysis analysis.Operation] + [lift-synthesis #..synthesis synthesis.Operation] + [lift-generation #..generation (generation.Operation anchor expression statement)] ) diff --git a/stdlib/source/lux/tool/interpreter.lux b/stdlib/source/lux/tool/interpreter.lux index d2fbccfdc..4edc6067a 100644 --- a/stdlib/source/lux/tool/interpreter.lux +++ b/stdlib/source/lux/tool/interpreter.lux @@ -14,7 +14,7 @@ ["." analysis ["." module] ["." type]] - ["." translation] + ["." generation] ["." statement (#+ State+ Operation) ["." total]] ["." extension]] @@ -60,15 +60,15 @@ [_ (module.create 0 ..module)] (analysis.set-current-module ..module)))) -(def: (initialize Monad Console platform configuration translation-bundle) +(def: (initialize Monad Console platform configuration generation-bundle) (All [! anchor expression statement] (-> (Monad !) (Console !) (Platform ! anchor expression statement) Configuration - (translation.Bundle anchor expression statement) + (generation.Bundle anchor expression statement) (! (State+ anchor expression statement)))) (do Monad - [state (platform.initialize platform translation-bundle) + [state (platform.initialize platform generation-bundle) state (platform.compile platform (set@ #cli.module syntax.prelude configuration) (set@ [#extension.state @@ -99,7 +99,7 @@ [state (extension.lift phase.get-state) #let [analyse (get@ [#statement.analysis #statement.phase] state) synthesize (get@ [#statement.synthesis #statement.phase] state) - translate (get@ [#statement.translation #statement.phase] state)] + generate (get@ [#statement.generation #statement.phase] state)] [_ codeT codeA] (statement.lift-analysis (analysis.with-scope (type.with-fresh-env @@ -111,12 +111,12 @@ (wrap [codeT codeA]))))) codeS (statement.lift-synthesis (synthesize codeA))] - (statement.lift-translation - (translation.with-buffer + (statement.lift-generation + (generation.with-buffer (do @ - [codeH (translate codeS) - count translation.next - codeV (translation.evaluate! (format "interpretation_" (%n count)) codeH)] + [codeH (generate codeS) + count generation.next + codeV (generation.evaluate! (format "interpretation_" (%n count)) codeH)] (wrap [codeT codeV])))))) (def: (interpret configuration code) @@ -186,12 +186,12 @@ (set@ #source source')) representation])))) -(def: #export (run Monad Console platform configuration translation-bundle) +(def: #export (run Monad Console platform configuration generation-bundle) (All [! anchor expression statement] (-> (Monad !) (Console !) (Platform ! anchor expression statement) Configuration - (translation.Bundle anchor expression statement) + (generation.Bundle anchor expression statement) (! Any))) (do Monad [state (initialize Monad Console platform configuration)] -- cgit v1.2.3